factor/extra/game-of-life/game-of-life.factor

211 lines
6.0 KiB
Factor
Raw Normal View History

! 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
;
IN: game-of-life
: make-grid ( rows cols -- grid )
'[ _ <bit-array> ] replicate ;
: 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 ;
:: count-neighbors ( grid -- counts )
grid grid-dim { fixnum fixnum } declare :> ( rows cols )
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 |
j 0 eq? [ max-rows ] [ j 1 - ] if
j
j max-rows eq? [ 0 ] [ j 1 + ] if
[ 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 [
i 0 eq? [ max-cols ] [ i 1 - ] if
i
i max-cols eq? [ 0 ] [ i 1 + ] if
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@ ]
3tri
2018-03-11 14:31:20 -04:00
] when
] each-index
] each-index neighbors ;
:: 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
cell [
2 3 between? i row set-nth-unsafe
] [
3 = [ t i row set-nth-unsafe ] when
] if
] each-index
] each-index ;
TUPLE: grid-gadget < gadget grid size timer ;
: <grid-gadget> ( grid -- gadget )
grid-gadget new
swap >>grid
20 >>size
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 ;
:: 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 ;
:: draw-cells ( gadget -- )
COLOR: black gl-color
gadget size>> :> size
2018-03-11 14:31:20 -04:00
gadget grid>> { array } declare [| row j |
row { bit-array } declare [| cell i |
cell [
2018-03-09 17:32:30 -05:00
i j [ size * ] bi@ 2array
{ size size } gl-fill-rect
] when
] each-index
] each-index ;
:: draw-lines ( gadget -- )
gadget size>> :> size
gadget grid>> grid-dim :> ( rows cols )
COLOR: gray gl-color
cols rows [ size * ] bi@ :> ( w h )
rows [0,b] [| j |
j size * :> y
{ 0 y } { w y } gl-line
cols [0,b] [| i |
i size * :> x
{ x 0 } { x h } gl-line
] each
] each ;
M: grid-gadget draw-gadget*
[ update-grid ] [ draw-cells ] [ draw-lines ] tri ;
2018-03-09 17:32:30 -05:00
SYMBOL: last-click
:: on-click ( gadget -- )
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
] when gadget relayout-1 ;
:: on-drag ( gadget -- )
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
] when gadget relayout-1 ;
: on-scroll ( gadget -- )
[
scroll-direction get second {
2018-03-09 19:32:08 -05:00
{ [ dup 0 > ] [ -2 ] }
{ [ dup 0 < ] [ 2 ] }
[ 0 ]
} cond nip + 4 30 clamp
] change-size relayout-1 ;
:: com-play ( gadget -- )
gadget timer>> restart-timer ;
:: com-step ( gadget -- )
gadget grid>> next-step
gadget relayout-1 ;
:: com-stop ( gadget -- )
gadget timer>> stop-timer ;
:: com-clear ( gadget -- )
gadget grid>> [ clear-bits ] each
gadget relayout-1 ;
:: com-random ( gadget -- )
2018-03-11 14:31:20 -04:00
gadget grid>> random-grid! gadget relayout-1 ;
:: com-glider ( gadget -- )
gadget grid>> :> grid
{ { 2 1 } { 3 2 } { 1 3 } { 2 3 } { 3 3 } }
[ first2 grid nth t -rot set-nth ] each
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" [
{
{ T{ key-down f { A+ } "F" } [ toggle-fullscreen ] }
{ T{ button-down { # 1 } } [ on-click ] }
{ T{ drag { # 1 } } [ on-drag ] }
{ mouse-scroll [ on-scroll ] }
} 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 ;