1 ! Copyright (C) 2018 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: accessors arrays assocs bit-arrays byte-arrays calendar
5 colors.constants combinators fry kernel kernel.private locals
6 math math.order math.ranges namespaces opengl random sequences
7 sequences.private timers ui ui.commands ui.gadgets
8 ui.gadgets.toolbar ui.gadgets.tracks ui.gestures ui.render words
13 : make-grid ( rows cols -- grid )
14 '[ _ <bit-array> ] replicate ;
16 : grid-dim ( grid -- rows cols )
17 [ length ] [ first length ] bi ;
19 : random-grid! ( grid -- )
21 [ length>> ] [ underlying>> length random-bytes ] bi
25 :: count-neighbors ( grid -- counts )
26 grid grid-dim { fixnum fixnum } declare :> ( rows cols )
27 rows 1 - { fixnum } declare :> max-rows
28 cols 1 - { fixnum } declare :> max-cols
29 rows [ cols <byte-array> ] replicate :> neighbors
30 grid { array } declare [| row j |
31 j 0 eq? [ max-rows ] [ j 1 - ] if
33 j max-rows eq? [ 0 ] [ j 1 + ] if
34 [ neighbors nth-unsafe { byte-array } declare ] tri@ :>
37 row { bit-array } declare [| cell i |
39 i 0 eq? [ max-cols ] [ i 1 - ] if
41 i max-cols eq? [ 0 ] [ i 1 + ] if
43 [ [ above [ 1 + ] change-nth-unsafe ] tri@ ]
44 [ nip [ same [ 1 + ] change-nth-unsafe ] bi@ ]
45 [ [ below [ 1 + ] change-nth-unsafe ] tri@ ]
49 ] each-index neighbors ;
51 :: next-step ( grid -- )
52 grid count-neighbors { array } declare :> neighbors
53 grid { array } declare [| row j |
54 j neighbors nth-unsafe { byte-array } declare :> neighbor-row
55 row { bit-array } declare [| cell i |
56 i neighbor-row nth-unsafe
58 2 3 between? i row set-nth-unsafe
60 3 = [ t i row set-nth-unsafe ] when
65 TUPLE: grid-gadget < gadget grid size timer ;
67 : <grid-gadget> ( grid -- gadget )
71 dup '[ _ [ grid>> next-step ] [ relayout-1 ] bi ]
72 f 1/5 seconds <timer> >>timer ;
74 M: grid-gadget ungraft*
75 [ timer>> stop-timer ] [ call-next-method ] bi ;
77 M: grid-gadget pref-dim*
78 [ grid>> grid-dim swap ] [ size>> '[ _ * ] bi@ 1 + 2array ] bi ;
80 :: update-grid ( gadget -- )
81 gadget dim>> first2 :> ( w h )
83 h w [ size /i ] bi@ :> ( new-rows new-cols )
85 grid grid-dim :> ( rows cols )
87 cols new-cols = not or [
88 new-rows new-cols make-grid :> new-grid
89 rows new-rows min <iota> [| j |
90 cols new-cols min <iota> [| i |
92 i j new-grid nth set-nth
95 new-grid gadget grid<<
98 :: draw-cells ( gadget -- )
100 gadget size>> :> size
101 gadget grid>> { array } declare [| row j |
102 row { bit-array } declare [| cell i |
104 i j [ size * ] bi@ 2array
105 { size size } gl-fill-rect
110 :: draw-lines ( gadget -- )
111 gadget size>> :> size
112 gadget grid>> grid-dim :> ( rows cols )
114 cols rows [ size * ] bi@ :> ( w h )
117 { 0 y } { w y } gl-line
120 { x 0 } { x h } gl-line
124 M: grid-gadget draw-gadget*
125 [ update-grid ] [ draw-cells ] [ draw-lines ] tri ;
129 :: on-click ( gadget -- )
130 gadget size>> :> size
131 gadget grid>> grid-dim :> ( rows cols )
132 gadget hand-rel first2 [ size /i ] bi@ :> ( i j )
133 i 0 cols 1 - between?
134 j 0 rows 1 - between? and [
135 i j gadget grid>> nth
136 [ not dup last-click set ] change-nth
137 ] when gadget relayout-1 ;
139 :: on-drag ( gadget -- )
140 gadget size>> :> size
141 gadget grid>> grid-dim :> ( rows cols )
142 gadget hand-rel first2 [ size /i ] bi@ :> ( i j )
143 i 0 cols 1 - between?
144 j 0 rows 1 - between? and [
145 last-click get i j gadget grid>> nth set-nth
146 ] when gadget relayout-1 ;
148 : on-scroll ( gadget -- )
150 scroll-direction get second {
151 { [ dup 0 > ] [ -2 ] }
152 { [ dup 0 < ] [ 2 ] }
154 } cond nip + 4 30 clamp
155 ] change-size relayout-1 ;
157 :: com-play ( gadget -- )
158 gadget timer>> restart-timer ;
160 :: com-step ( gadget -- )
161 gadget grid>> next-step
164 :: com-stop ( gadget -- )
165 gadget timer>> stop-timer ;
167 :: com-clear ( gadget -- )
168 gadget grid>> [ clear-bits ] each
171 :: com-random ( gadget -- )
172 gadget grid>> random-grid! gadget relayout-1 ;
174 :: com-glider ( gadget -- )
175 gadget grid>> :> grid
176 { { 2 1 } { 3 2 } { 1 3 } { 2 3 } { 3 3 } }
177 [ first2 grid nth t -rot set-nth ] each
180 grid-gadget "toolbar" f {
181 { T{ key-down { sym "1" } } com-play }
182 { T{ key-down { sym "2" } } com-stop }
183 { T{ key-down { sym "3" } } com-clear }
184 { T{ key-down { sym "4" } } com-random }
185 { T{ key-down { sym "5" } } com-glider }
186 { T{ key-down { sym "6" } } com-step }
189 grid-gadget "gestures" [
191 { T{ key-down f { A+ } "F" } [ toggle-fullscreen ] }
192 { T{ button-down { # 1 } } [ on-click ] }
193 { T{ drag { # 1 } } [ on-drag ] }
194 { mouse-scroll [ on-scroll ] }
198 TUPLE: life-gadget < track ;
200 : <life-gadget> ( -- gadget )
201 vertical life-gadget new-track
202 20 20 make-grid <grid-gadget>
203 [ <toolbar> format-toolbar f track-add ]
206 M: life-gadget focusable-child* children>> second ;
208 MAIN-WINDOW: life-window {
209 { title "Game of Life" }
210 } <life-gadget> >>gadgets ;