! Copyright (C) 2009 Jon Harper.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel arrays random locals math math.ranges
fry ui.gadgets colors.constants ui.pens opengl accessors ui
threads ;
IN: brian

TUPLE: cell ;
TUPLE: on-cell    < cell ;
TUPLE: dying-cell < cell ;
TUPLE: off-cell   < cell ;
C: <on-cell> on-cell
C: <dying-cell> dying-cell
C: <off-cell> off-cell

GENERIC: step-cell ( surrounding-life cell -- newcell )
GENERIC: color ( cell -- color )

M: on-cell step-cell 2drop <dying-cell> ;
M: dying-cell step-cell 2drop <off-cell> ;
M: off-cell step-cell swap 2 = [ drop <on-cell> ] when ;

M: on-cell color drop COLOR: red ;
M: dying-cell color drop COLOR: blue ;
M: off-cell color drop COLOR: black ;

: <matrix> ( n elem -- matrix ) 2dup <array> [ drop <array> ] with with map  ;
: <world> ( n -- world ) f <matrix> ;
: on|off ( -- random ) { T{ on-cell } T{ off-cell } } random clone ;
: <random-world> ( n -- world ) <world> [ [ drop on|off ] map ] map ;

: inc-matrix ( x y matrix -- ) nth [ 1 + ] change-nth ;
: inc-possible? ( x y matrix -- ? )
    [ length [ < ] curry bi@ ] 3keep
    drop [ 0 >= ] bi@ and and and ;
: inc-if-possible ( x y matrix -- ) 3dup inc-possible? [ inc-matrix ] [ 3drop ] if ;

:: increment-around-index ( x y matrix -- )
    -1 1 [a,b] dup 
    [ [ x y swapd [ + ] 2bi@ matrix inc-if-possible ] with each ] curry each ;

:: increment-on ( cell x y matrix -- ) cell on-cell? [ x y matrix increment-around-index ] when ;
: live-neighbours-count ( world -- matrix ) 
    dup length 0 <matrix> tuck
    '[ [ _ increment-on ] curry each-index ] each-index ;

: (step-cell) ( cell x y matrix -- cell ) nth nth swap step-cell ;
: step-world ( world -- world' )
    dup live-neighbours-count '[ [ _ (step-cell) ] curry map-index ] map-index ;

: draw-cell ( cell x y -- ) [ color gl-color ] 2dip 2array [ 10 * ] map { 10 10 } gl-fill-rect ;
TUPLE: brian cells gadget ;
M: brian draw-interior nip cells>> [ [ draw-cell ] curry each-index ] each-index ;
: brian-gadget ( brian -- gadget ) 
    <gadget>
    over cells>> length dup 2array [ 10 * ] map >>pref-dim
    swap >>interior ;

: finished? ( brian -- ? )
    cells>> [ [ on-cell? ] any? ] map [ ] any? ;
: step-brian ( brian -- brian ) dup cells>> step-world >>cells dup gadget>> relayout-1 ;

:  (new-brian) ( n -- ) 
    <random-world> f brian boa dup brian-gadget [ "brian" open-window ] keep >>gadget
    [ dup finished? ] [ step-brian yield ] while drop ;

:  new-brian ( n -- ) [ (new-brian) ] curry with-ui ;

: example ( -- ) 100 new-brian ;