Paste: Factor - Life Game

! Copyright (C) 2011 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar colors.constants combinators kernel
locals math math.functions namespaces opengl sequences
sequences.generalizations timers tools.continuations ui ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.canvas
ui.gadgets.panes ui.gadgets.tracks ui.gadgets.worlds ui.gestures
ui.render ;
 
IN: life

SYMBOL: started
SYMBOL: paused
SYMBOL: stopped

TUPLE: cell alive? col row ;
TUPLE: board < canvas cells state { timer } ;

CONSTANT: BOARD-SIZE 301
CONSTANT: CELL-SIZE 10 

SYMBOL: game-board

: (board) ( -- board )
    game-board get ;

: max-cell ( -- x )
    BOARD-SIZE CELL-SIZE / truncate ;

:: coor>index ( col row -- index )
    row max-cell * col + ;

:: change-cell ( index -- )
    index (board) cells>> 
    [ [ not ] change-alive? ] change-nth ;

: board-on-click ( gadget -- )
    dup hand-click-rel
    first2 [ CELL-SIZE / truncate ] bi@ 
    coor>index change-cell relayout-1 ;

board H{
    { T{ button-up } [ board-on-click ] }
} set-gestures

: draw-cells ( cells -- )
    [| cell |
        cell alive?>> [ COLOR: red ] [ COLOR: white ] if gl-color
        CELL-SIZE [ cell col>> * 1 + ] [ cell row>> * 1 + ] bi 2array
        CELL-SIZE 1 - dup 2array gl-fill-rect
    ] each ;

M: board draw-gadget* ( gadget -- )
    cells>>
    [ draw-cells ]
    when* ;

! ANCHORS
SYMBOLS: topleft bottomleft topright bottomright left right bottom top normal ;

:: alive-count ( indexes -- count )
    (board) cells>> :> cells
    indexes [ cells nth ] map
    0 [ alive?>> [ 1 + ] when ] reduce ;

:: get-neighbours-indexes ( cell index -- indexes )
    cell col>> :> col
    cell row>> :> row
    max-cell 1 - :> max
    {
        { [ col 0 = row 0 = and ]
          [ 1 max-cell max-cell 1 + 3array ] }
        { [ row max = col max = and ]
          [ index max-cell - index 1 - index max-cell - 1 - 3array ] }
        { [ row max = col 0 = and ]
          [ index 1 + index max-cell - index max-cell - 1 + 3array ] }
        { [ row 0 = col max = and ]
          [ index 1 - index max-cell + index max-cell + 1 - 3array ] }
        { [ col 0 = ]
          [ index 1 + index max-cell - index max-cell - 1 +
            index max-cell + index max-cell + 1 + 5 narray ] }        
        { [ row 0 = ]
          [ index 1 + index 1 - index max-cell + index max-cell + 1 +
            index max-cell + 1 - 5 narray ] }
        { [ col max = ]
          [ index 1 - index max-cell - index max-cell - 1 - index max-cell +
            index max-cell + 1 - 5 narray ] }
        { [ row max = ]
          [ index 1 + index 1 - index max-cell - index max-cell - 1 -
          index max-cell - 1 + 5 narray ] }
        [ index 1 + index 1 - index max-cell - index max-cell - 1 - index max-cell -
          1 + index max-cell + index max-cell + 1 + index max-cell + 1 -
          8 narray ]
    } cond ;

: get-neighbours-alive ( cell index -- alives )
     get-neighbours-indexes alive-count ;
          
:: update-cell ( cell index -- )
    cell index get-neighbours-alive :> alives
    cell alive?>>
    [
        {
            { [ alives 2 < ] [ index change-cell ] }
            { [ alives [ 2 = ] [ 3 = ] bi or ] [ ] }
            { [ alives 3 > ] [ index change-cell ] }
        } cond
    ]
    [ alives 3 = [ index change-cell ] when ] if ;
        
: update-cells ( -- )
    (board) cells>>
    [| cell index |
        cell index update-cell
    ] each-index ;

: tick ( board -- )
    dup state>> started = [
        update-cells relayout-1
    ] [ drop ] if ;

M: board graft* ( gadget -- )
    [ [ tick ] curry 100 milliseconds every ] keep timer<< ;

M: board ungraft* ( gadget -- )
    [ stop-timer f ] change-timer drop ;

:: init-cells ( -- )
    max-cell iota
    [| x row |
        max-cell iota
        [| y col | 
            cell new f >>alive? row >>row col >>col
        ] map-index
    ] map-index concat (board) cells<< ;

:: init-game ( -- )
    board new-canvas
    BOARD-SIZE dup 2array >>dim
    stopped >>state game-board set-global
    init-cells ;

: start-game ( -- ) started (board) state<< ;
: pause-game ( -- ) paused  (board) state<< ;
: stop-game ( -- )  stopped (board) state<< init-cells ;
: step-game ( -- ) update-cells (board) relayout-1 ;

: build-button-bar ( -- gadget )
    horizontal <track> { 5 5 } >>gap
    "Start" [ drop start-game ] <border-button> f track-add
    "Pause" [ drop pause-game ] <border-button> f track-add
    "Step" [ drop step-game ] <border-button> f track-add
    <pane> { 1 1 } <border> 1 track-add
    "Stop"  [ drop stop-game ]  <border-button> f track-add ;

: build-ui ( -- gadget )
    vertical <track> { 5 5 } >>gap
    (board) 1 track-add
    build-button-bar f track-add
    { 5 5 } <border> { 1 1 } >>fill ;

: main ( -- )
    [
        init-game
        build-ui
        world-attributes new
        "Life Game in Factor" >>title
        { close-button minimize-button normal-title-bar }
        >>window-controls open-window
    ] with-ui ;