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

   1 ! Copyright (C) 2018 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays assocs bit-arrays byte-arrays calendar
   5 colors.constants combinators fry kernel kernel.private locals
   6 math math.order 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
   9 ;
  10
  11 IN: game-of-life
  12
  13 : make-grid ( rows cols -- grid )
  14     '[ _ <bit-array> ] replicate ;
  15
  16 : grid-dim ( grid -- rows cols )
  17     [ length ] [ first length ] bi ;
  18
  19 : random-grid! ( grid -- )
  20     [
  21         [ length>> ] [ underlying>> length random-bytes ] bi
  22         bit-array boa
  23     ] map! drop ;
  24
  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
  32         j
  33         j max-rows eq? [ 0 ] [ j 1 + ] if
  34         [ neighbors nth-unsafe { byte-array } declare ] tri@ :>
  35         ( above same below )
  36
  37         row { bit-array } declare [| cell i |
  38             cell [
  39                 i 0 eq? [ max-cols ] [ i 1 - ] if
  40                 i
  41                 i max-cols eq? [ 0 ] [ i 1 + ] if
  42
  43                 [ [ above [ 1 + ] change-nth-unsafe ] tri@ ]
  44                 [ nip [ same [ 1 + ] change-nth-unsafe ] bi@ ]
  45                 [ [ below [ 1 + ] change-nth-unsafe ] tri@ ]
  46                 3tri
  47             ] when
  48         ] each-index
  49     ] each-index neighbors ;
  50
  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
  57             cell [
  58                 2 3 between? i row set-nth-unsafe
  59             ] [
  60                 3 = [ t i row set-nth-unsafe ] when
  61             ] if
  62         ] each-index
  63     ] each-index ;
  64
  65 TUPLE: grid-gadget < gadget grid size timer ;
  66
  67 : <grid-gadget> ( grid -- gadget )
  68     grid-gadget new
  69         swap >>grid
  70         20 >>size
  71         dup '[ _ [ grid>> next-step ] [ relayout-1 ] bi ]
  72         f 1/5 seconds <timer> >>timer ;
  73
  74 M: grid-gadget ungraft*
  75     [ timer>> stop-timer ] [ call-next-method ] bi ;
  76
  77 M: grid-gadget pref-dim*
  78     [ grid>> grid-dim swap ] [ size>> '[ _ * ] bi@ 1 + 2array ] bi ;
  79
  80 :: update-grid ( gadget -- )
  81     gadget dim>> first2 :> ( w h )
  82     gadget size>> :> size
  83     h w [ size /i ] bi@ :> ( new-rows new-cols )
  84     gadget grid>> :> grid
  85     grid grid-dim :> ( rows cols )
  86     rows new-rows = not
  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 |
  91                 i j grid nth nth
  92                 i j new-grid nth set-nth
  93             ] each
  94         ] each
  95         new-grid gadget grid<<
  96     ] when ;
  97
  98 :: draw-cells ( gadget -- )
  99     COLOR: black gl-color
 100     gadget size>> :> size
 101     gadget grid>> { array } declare [| row j |
 102         row { bit-array } declare [| cell i |
 103             cell [
 104                 i j [ size * ] bi@ 2array
 105                 { size size } gl-fill-rect
 106             ] when
 107         ] each-index
 108     ] each-index ;
 109
 110 :: draw-lines ( gadget -- )
 111     gadget size>> :> size
 112     gadget grid>> grid-dim :> ( rows cols )
 113     COLOR: gray gl-color
 114     cols rows [ size * ] bi@ :> ( w h )
 115     rows [0..b] [| j |
 116         j size * :> y
 117         { 0 y } { w y } gl-line
 118         cols [0..b] [| i |
 119             i size * :> x
 120             { x 0 } { x h } gl-line
 121         ] each
 122     ] each ;
 123
 124 M: grid-gadget draw-gadget*
 125     [ update-grid ] [ draw-cells ] [ draw-lines ] tri ;
 126
 127 SYMBOL: last-click
 128
 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 ;
 138
 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 ;
 147
 148 : on-scroll ( gadget -- )
 149     [
 150         scroll-direction get second {
 151             { [ dup 0 > ] [ -2 ] }
 152             { [ dup 0 < ] [ 2 ] }
 153             [ 0 ]
 154         } cond nip + 4 30 clamp
 155     ] change-size relayout-1 ;
 156
 157 :: com-play ( gadget -- )
 158     gadget timer>> restart-timer ;
 159
 160 :: com-step ( gadget -- )
 161     gadget grid>> next-step
 162     gadget relayout-1 ;
 163
 164 :: com-stop ( gadget -- )
 165     gadget timer>> stop-timer ;
 166
 167 :: com-clear ( gadget -- )
 168     gadget grid>> [ clear-bits ] each
 169     gadget relayout-1 ;
 170
 171 :: com-random ( gadget -- )
 172     gadget grid>> random-grid! gadget relayout-1 ;
 173
 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
 178     gadget relayout-1 ;
 179
 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 }
 187 } define-command-map
 188
 189 grid-gadget "gestures" [
 190     {
 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 ] }
 195     } assoc-union
 196 ] change-word-prop
 197
 198 TUPLE: life-gadget < track ;
 199
 200 : <life-gadget> ( -- gadget )
 201     vertical life-gadget new-track
 202     20 20 make-grid <grid-gadget>
 203     [ <toolbar> format-toolbar f track-add ]
 204     [ 1 track-add ] bi ;
 205
 206 M: life-gadget focusable-child* children>> second ;
 207
 208 MAIN-WINDOW: life-window {
 209         { title "Game of Life" }
 210     } <life-gadget> >>gadgets ;