2018-03-09 15:13:07 -05:00
|
|
|
! Copyright (C) 2018 John Benediktsson
|
|
|
|
! See http://factorcode.org/license.txt for BSD license
|
|
|
|
|
2018-03-11 14:31:20 -04:00
|
|
|
USING: accessors arrays assocs bit-arrays byte-arrays calendar
|
2018-03-11 14:59:13 -04:00
|
|
|
colors.constants combinators fry kernel kernel.private locals
|
2018-03-12 11:47:31 -04:00
|
|
|
math math.order math.ranges namespaces opengl random sequences
|
|
|
|
sequences.private timers ui ui.commands ui.gadgets
|
|
|
|
ui.gadgets.toolbar ui.gadgets.tracks ui.gestures ui.render words
|
|
|
|
;
|
2018-03-09 15:13:07 -05:00
|
|
|
|
|
|
|
IN: game-of-life
|
|
|
|
|
|
|
|
: make-grid ( rows cols -- grid )
|
2018-03-09 18:04:23 -05:00
|
|
|
'[ _ <bit-array> ] replicate ;
|
2018-03-09 15:13:07 -05:00
|
|
|
|
|
|
|
: grid-dim ( grid -- rows cols )
|
|
|
|
[ length ] [ first length ] bi ;
|
|
|
|
|
2018-03-11 14:31:20 -04:00
|
|
|
: random-grid! ( grid -- )
|
|
|
|
[
|
|
|
|
[ length>> ] [ underlying>> length random-bytes ] bi
|
|
|
|
bit-array boa
|
|
|
|
] map! drop ;
|
|
|
|
|
2018-03-09 15:13:07 -05:00
|
|
|
:: count-neighbors ( grid -- counts )
|
2018-03-09 18:04:23 -05:00
|
|
|
grid grid-dim { fixnum fixnum } declare :> ( rows cols )
|
2018-03-12 11:43:05 -04:00
|
|
|
rows 1 - { fixnum } declare :> max-rows
|
|
|
|
cols 1 - { fixnum } declare :> max-cols
|
2018-03-11 14:31:20 -04:00
|
|
|
rows [ cols <byte-array> ] replicate :> neighbors
|
|
|
|
grid { array } declare [| row j |
|
2018-03-14 18:44:30 -04:00
|
|
|
j 0 eq? [ max-rows ] [ j 1 - ] if
|
2018-03-11 14:48:35 -04:00
|
|
|
j
|
2018-03-14 18:44:30 -04:00
|
|
|
j max-rows eq? [ 0 ] [ j 1 + ] if
|
2018-03-11 14:48:35 -04:00
|
|
|
[ neighbors nth-unsafe { byte-array } declare ] tri@ :>
|
|
|
|
( above same below )
|
|
|
|
|
2018-03-11 14:31:20 -04:00
|
|
|
row { bit-array } declare [| cell i |
|
|
|
|
cell [
|
2018-03-14 18:44:30 -04:00
|
|
|
i 0 eq? [ max-cols ] [ i 1 - ] if
|
2018-03-11 14:48:35 -04:00
|
|
|
i
|
2018-03-14 18:44:30 -04:00
|
|
|
i max-cols eq? [ 0 ] [ i 1 + ] if
|
2018-03-11 14:48:35 -04:00
|
|
|
|
2018-03-12 11:47:31 -04:00
|
|
|
[ [ above [ 1 + ] change-nth-unsafe ] tri@ ]
|
|
|
|
[ nip [ same [ 1 + ] change-nth-unsafe ] bi@ ]
|
|
|
|
[ [ below [ 1 + ] change-nth-unsafe ] tri@ ]
|
2018-03-11 14:48:35 -04:00
|
|
|
3tri
|
2018-03-11 14:31:20 -04:00
|
|
|
] when
|
|
|
|
] each-index
|
|
|
|
] each-index neighbors ;
|
2018-03-09 15:13:07 -05:00
|
|
|
|
|
|
|
:: next-step ( grid -- )
|
2018-03-11 14:31:20 -04:00
|
|
|
grid count-neighbors { array } declare :> neighbors
|
|
|
|
grid { array } declare [| row j |
|
|
|
|
j neighbors nth-unsafe { byte-array } declare :> neighbor-row
|
|
|
|
row { bit-array } declare [| cell i |
|
|
|
|
i neighbor-row nth-unsafe
|
2018-03-09 15:13:07 -05:00
|
|
|
cell [
|
2018-03-11 20:05:47 -04:00
|
|
|
2 3 between? i row set-nth-unsafe
|
2018-03-09 15:13:07 -05:00
|
|
|
] [
|
2018-03-11 20:05:47 -04:00
|
|
|
3 = [ t i row set-nth-unsafe ] when
|
2018-03-09 15:13:07 -05:00
|
|
|
] if
|
|
|
|
] each-index
|
|
|
|
] each-index ;
|
|
|
|
|
2018-03-09 17:24:50 -05:00
|
|
|
TUPLE: grid-gadget < gadget grid size timer ;
|
2018-03-09 15:13:07 -05:00
|
|
|
|
|
|
|
: <grid-gadget> ( grid -- gadget )
|
|
|
|
grid-gadget new
|
|
|
|
swap >>grid
|
2018-03-09 17:24:50 -05:00
|
|
|
20 >>size
|
2018-03-09 15:13:07 -05:00
|
|
|
dup '[ _ [ grid>> next-step ] [ relayout-1 ] bi ]
|
|
|
|
f 1/5 seconds <timer> >>timer ;
|
|
|
|
|
|
|
|
M: grid-gadget ungraft*
|
|
|
|
[ timer>> stop-timer ] [ call-next-method ] bi ;
|
|
|
|
|
|
|
|
M: grid-gadget pref-dim*
|
2018-03-09 19:32:08 -05:00
|
|
|
[ grid>> grid-dim swap ] [ size>> '[ _ * ] bi@ 1 + 2array ] bi ;
|
2018-03-09 17:24:50 -05:00
|
|
|
|
|
|
|
:: update-grid ( gadget -- )
|
|
|
|
gadget dim>> first2 :> ( w h )
|
|
|
|
gadget size>> :> size
|
|
|
|
h w [ size /i ] bi@ :> ( new-rows new-cols )
|
|
|
|
gadget grid>> :> grid
|
|
|
|
grid grid-dim :> ( rows cols )
|
|
|
|
rows new-rows = not
|
|
|
|
cols new-cols = not or [
|
|
|
|
new-rows new-cols make-grid :> new-grid
|
|
|
|
rows new-rows min <iota> [| j |
|
|
|
|
cols new-cols min <iota> [| i |
|
|
|
|
i j grid nth nth
|
|
|
|
i j new-grid nth set-nth
|
|
|
|
] each
|
|
|
|
] each
|
|
|
|
new-grid gadget grid<<
|
|
|
|
] when ;
|
2018-03-09 15:13:07 -05:00
|
|
|
|
|
|
|
:: draw-cells ( gadget -- )
|
|
|
|
COLOR: black gl-color
|
2018-03-09 17:24:50 -05:00
|
|
|
gadget size>> :> size
|
2018-03-11 14:31:20 -04:00
|
|
|
gadget grid>> { array } declare [| row j |
|
|
|
|
row { bit-array } declare [| cell i |
|
2018-03-09 15:13:07 -05:00
|
|
|
cell [
|
2018-03-09 17:32:30 -05:00
|
|
|
i j [ size * ] bi@ 2array
|
|
|
|
{ size size } gl-fill-rect
|
2018-03-09 15:13:07 -05:00
|
|
|
] when
|
|
|
|
] each-index
|
|
|
|
] each-index ;
|
|
|
|
|
|
|
|
:: draw-lines ( gadget -- )
|
2018-03-09 17:24:50 -05:00
|
|
|
gadget size>> :> size
|
2018-03-09 15:13:07 -05:00
|
|
|
gadget grid>> grid-dim :> ( rows cols )
|
|
|
|
COLOR: gray gl-color
|
2018-03-09 17:24:50 -05:00
|
|
|
cols rows [ size * ] bi@ :> ( w h )
|
|
|
|
rows [0,b] [| j |
|
|
|
|
j size * :> y
|
2018-03-09 15:13:07 -05:00
|
|
|
{ 0 y } { w y } gl-line
|
2018-03-09 17:24:50 -05:00
|
|
|
cols [0,b] [| i |
|
|
|
|
i size * :> x
|
2018-03-09 15:13:07 -05:00
|
|
|
{ x 0 } { x h } gl-line
|
|
|
|
] each
|
|
|
|
] each ;
|
|
|
|
|
|
|
|
M: grid-gadget draw-gadget*
|
2018-03-09 17:24:50 -05:00
|
|
|
[ update-grid ] [ draw-cells ] [ draw-lines ] tri ;
|
2018-03-09 15:13:07 -05:00
|
|
|
|
2018-03-09 17:32:30 -05:00
|
|
|
SYMBOL: last-click
|
|
|
|
|
2018-03-09 15:13:07 -05:00
|
|
|
:: on-click ( gadget -- )
|
2018-03-09 17:24:50 -05:00
|
|
|
gadget size>> :> size
|
|
|
|
gadget grid>> grid-dim :> ( rows cols )
|
|
|
|
gadget hand-rel first2 [ size /i ] bi@ :> ( i j )
|
|
|
|
i 0 cols 1 - between?
|
|
|
|
j 0 rows 1 - between? and [
|
2018-03-09 17:32:30 -05:00
|
|
|
i j gadget grid>> nth
|
|
|
|
[ not dup last-click set ] change-nth
|
2018-03-09 15:13:07 -05:00
|
|
|
] when gadget relayout-1 ;
|
|
|
|
|
|
|
|
:: on-drag ( gadget -- )
|
2018-03-09 17:24:50 -05:00
|
|
|
gadget size>> :> size
|
|
|
|
gadget grid>> grid-dim :> ( rows cols )
|
|
|
|
gadget hand-rel first2 [ size /i ] bi@ :> ( i j )
|
|
|
|
i 0 cols 1 - between?
|
|
|
|
j 0 rows 1 - between? and [
|
2018-03-09 17:32:30 -05:00
|
|
|
last-click get i j gadget grid>> nth set-nth
|
2018-03-09 15:13:07 -05:00
|
|
|
] when gadget relayout-1 ;
|
|
|
|
|
2018-03-09 17:24:50 -05:00
|
|
|
: on-scroll ( gadget -- )
|
|
|
|
[
|
|
|
|
scroll-direction get second {
|
2018-03-09 19:32:08 -05:00
|
|
|
{ [ dup 0 > ] [ -2 ] }
|
|
|
|
{ [ dup 0 < ] [ 2 ] }
|
2018-03-09 17:24:50 -05:00
|
|
|
[ 0 ]
|
|
|
|
} cond nip + 4 30 clamp
|
|
|
|
] change-size relayout-1 ;
|
|
|
|
|
2018-03-09 15:13:07 -05:00
|
|
|
:: com-play ( gadget -- )
|
2018-03-12 11:43:05 -04:00
|
|
|
gadget timer>> restart-timer ;
|
2018-03-09 15:13:07 -05:00
|
|
|
|
|
|
|
:: com-step ( gadget -- )
|
|
|
|
gadget grid>> next-step
|
|
|
|
gadget relayout-1 ;
|
|
|
|
|
|
|
|
:: com-stop ( gadget -- )
|
2018-03-12 11:43:05 -04:00
|
|
|
gadget timer>> stop-timer ;
|
2018-03-09 15:13:07 -05:00
|
|
|
|
|
|
|
:: com-clear ( gadget -- )
|
2018-03-09 18:29:22 -05:00
|
|
|
gadget grid>> [ clear-bits ] each
|
2018-03-09 15:13:07 -05:00
|
|
|
gadget relayout-1 ;
|
|
|
|
|
|
|
|
:: com-random ( gadget -- )
|
2018-03-11 14:31:20 -04:00
|
|
|
gadget grid>> random-grid! gadget relayout-1 ;
|
2018-03-09 15:13:07 -05:00
|
|
|
|
|
|
|
:: com-glider ( gadget -- )
|
2018-03-09 17:24:50 -05:00
|
|
|
gadget grid>> :> grid
|
|
|
|
{ { 2 1 } { 3 2 } { 1 3 } { 2 3 } { 3 3 } }
|
|
|
|
[ first2 grid nth t -rot set-nth ] each
|
2018-03-09 15:13:07 -05:00
|
|
|
gadget relayout-1 ;
|
|
|
|
|
|
|
|
grid-gadget "toolbar" f {
|
|
|
|
{ T{ key-down { sym "1" } } com-play }
|
|
|
|
{ T{ key-down { sym "2" } } com-stop }
|
|
|
|
{ T{ key-down { sym "3" } } com-clear }
|
|
|
|
{ T{ key-down { sym "4" } } com-random }
|
|
|
|
{ T{ key-down { sym "5" } } com-glider }
|
|
|
|
{ T{ key-down { sym "6" } } com-step }
|
|
|
|
} define-command-map
|
|
|
|
|
|
|
|
grid-gadget "gestures" [
|
|
|
|
{
|
2018-03-09 17:24:50 -05:00
|
|
|
{ T{ key-down f { A+ } "F" } [ toggle-fullscreen ] }
|
2018-03-09 15:13:07 -05:00
|
|
|
{ T{ button-down { # 1 } } [ on-click ] }
|
|
|
|
{ T{ drag { # 1 } } [ on-drag ] }
|
2018-03-09 17:24:50 -05:00
|
|
|
{ mouse-scroll [ on-scroll ] }
|
2018-03-09 15:13:07 -05:00
|
|
|
} assoc-union
|
|
|
|
] change-word-prop
|
|
|
|
|
|
|
|
TUPLE: life-gadget < track ;
|
|
|
|
|
|
|
|
: <life-gadget> ( -- gadget )
|
|
|
|
vertical life-gadget new-track
|
|
|
|
20 20 make-grid <grid-gadget>
|
|
|
|
[ <toolbar> format-toolbar f track-add ]
|
|
|
|
[ 1 track-add ] bi ;
|
|
|
|
|
|
|
|
M: life-gadget focusable-child* children>> second ;
|
|
|
|
|
|
|
|
MAIN-WINDOW: life-window {
|
|
|
|
{ title "Game of Life" }
|
|
|
|
} <life-gadget> >>gadgets ;
|