Paste: Brian’s (Factored) Functional Brain

Author:	pruned
Mode:	factor
Date:	Sat, 17 Oct 2009 10:53:51

Plain Text |

Delete Paste

: mmap ( m quot -- m' ) '[ _ map ] map ; inline
: 2mmap ( m m2 quot -- m' ) '[ _ 2map ] 2map ; inline

: aggregate ( v -- v' )
    dup dup <reversed> [ unclip drop f suffix ] bi@ <reversed>
    [ 2array ] 2map [ swap prefix ] 2map [ sift ] map ;
    
: neighbours ( m -- m ) 
    [ aggregate ] map flip [ aggregate ] map [ concat ] mmap ;
    
SYMBOLS: on off dying ;
    
: step-cell ( state neighbours -- state' )
    [ on = ] filter length swap
    {
        { on [ drop dying ] }
        { dying [ drop off ] }
        { off [ 2 = [ on ] [ off ] if ] }
    } case ;
        
: random-world ( xy -- m ) 
    first2 zero-matrix 
    [ drop { on off dying } random ] mmap ;
    
: step-world ( m -- m' ) dup neighbours [ step-cell ] 2mmap ;

Annotation: opengl part doesn't work yet

Author:	jon
Mode:	factor
Date:	Sat, 17 Oct 2009 10:57:08

Plain Text |

Delete Annotation

! 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 ;
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 nth ] 3keep nth [ swap 1 + swap ] dip set-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 ;
: on-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 on-count '[ [ _ (step-cell) ] curry map-index ] map-index ;


M: cell draw-interior 
nip color gl-color { 0 0 } { 10 10 } gl-fill-rect ;

Annotation: working display

Author:	jon
Mode:	factor
Date:	Sat, 17 Oct 2009 12:31:23

Plain Text |

Delete Annotation

! 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 ;

Annotation: Merge of the two versions for cleaner code

Author:	Jon
Mode:	factor
Date:	Sat, 17 Oct 2009 17:38:06

Plain Text |

Delete Annotation

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

<PRIVATE

! !!!!!!!!!!!!!!!!!!!!!!!!! !
! Helper words for matrices !
! !!!!!!!!!!!!!!!!!!!!!!!!! !
: mmap ( m quot -- m' ) '[ _ map ] map ; inline
: 2mmap ( m m2 quot -- m' ) '[ _ 2map ] 2map ; inline
: meach-index ( m quot -- m' ) '[ _ curry each-index ] each-index ; inline

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !
! Words to generate and step the world !
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !
SYMBOLS: on off dying ;
: random-world ( xy -- m )
    first2 zero-matrix
    [ drop { on off } random ] mmap ;

: aggregate ( v -- v' )
    dup dup <reversed> [ unclip drop f suffix ] bi@ <reversed>
    [ 2array ] 2map [ swap prefix ] 2map [ sift ] map ;
: neighbours ( m -- m )
    [ aggregate ] map flip [ aggregate ] map [ concat ] mmap flip ;
: step-cell ( state neighbours -- state' )
    [ on = ] filter length swap
    {
        { on [ drop dying ] }
        { dying [ drop off ] }
        { off [ 2 = [ on ] [ off ] if ] }
    } case ;
: step-world ( m -- m' ) dup neighbours [ step-cell ] 2mmap ;

! !!!!!!!!!!!!!!!!!!!!!!! !
! Words to draw the world !
! !!!!!!!!!!!!!!!!!!!!!!! !
: color ( cell -- color )
    {
        { on [ COLOR: red ] }
        { off [ COLOR: black ] }
        { dying [ COLOR: blue ] }
    } case ;

: cell-loc ( x y cell-dim -- cell-loc )
    [ 2array ] dip [ * ] 2map ;
:: draw-cell ( cell j i cell-dim -- )
    cell color gl-color
    j i cell-dim [ cell-loc ] keep gl-fill-rect ;
: (draw) ( world cell-dim -- )
    [ draw-cell ] curry meach-index ;
:: draw ( gadget-dim world -- )
    [let* | world-dim [ world [ first length ] [ length ] bi 2array ]
            cell-dim [ gadget-dim world-dim [ / ] 2map ]
          | world cell-dim (draw) ] ;
TUPLE: world-pen world ;
M: world-pen draw-interior
    [ pref-dim>> ] [ world>> ] bi* draw ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!
! Words to open the window !
! !!!!!!!!!!!!!!!!!!!!!!!!!!
: <world-gadget> ( world -- gadget )
    world-pen boa <gadget> swap >>interior { 800 800 } >>pref-dim ;
: open-brian-window ( world -- gadget )
    <world-gadget> dup [ "Brian's Brain" open-window ] curry with-ui ;
: step-window ( gadget -- gadget )
    dup interior>> dup world>> step-world >>world >>interior dup relayout-1 ;
PRIVATE>

! !!!!!!!!!!!! !
! Public words !
! !!!!!!!!!!!! !
! Call cancel-alarm on the alarm to stop the rendering
:: animate ( dim frequency -- alarm )
    dim random-world open-brian-window [ step-window ] curry
    now frequency milliseconds add-alarm ;
: example ( -- alarm ) { 80 80 } 100 animate ;

New Annotation

Summary:
Author:
Mode:	PostgreSQLPowerCenter Parameter Fileactionscriptadaada95ans-forth94antantlrantlr4apacheconfapdlapplescriptaspaspect-jassembly-agcassembly-agsassembly-arm32assembly-m68kassembly-macro32assembly-mcs51assembly-parrotassembly-r2000assembly-x86avroawkbbatchbbjbcelbeanshellbibtexbinsource-agccc#c++cfscriptchillcilclipsclojurecmakecobolcoffeescriptcoldfusioncplex-lpcsscsvcvs-commitddartdjangodockerfiledotdoxygendrawj2ddsssleiffelembperlerlangfactorfhtmlforthfortranfortran90foxprofreemarkergcbasicgettextgherkingnuplotgogradlegroovygsphaskellhaxehexhl7v2hlslhtaccesshtmlhxmli4glicalendariconidlinforminiinno-setupinterlisiojamonjavajava module-infojavaccjavafxjavascriptjcljedit-actionsjflexjhtmljmkjsonjspkotlinlatexlexlilypondlispliterate-haskelllogslogtalklotosluam4macroschedulermailmakefilemaplemarkdownmavenmavscriptmetapostmlmodula3moinmqscmustache-templatemxmlmyghtymysqln3netrexxnqcnsis2objective-cobjectrexxoccamomnimarkopensipsoutlinepascalpatchperlphppikepl-sqlpl-sql9pl1plaintexplantumlpop11postscriptpovraypowerdynamopowershellprogressprologpropertiesprotobufpspptlpurepvwavepyrexpythonrakefilercprdrebolredcoderelax-ng-compactrenderman-ribrestrfcrhtmlroffrpm-specrtfrubyrustrviews#s+sassbtscalaschemesdl/prsgmlshellscriptshtmlsipsippslateslaxsmalltalksmartysmi-mibsql-loadersqrsquidconfstatasvn-commitswiftswigtcltemplate-toolkittextexinfotexttldtransact-sqltsptwikityposcripturluscriptvalavbscriptvelocityverilogvhdlvisualbasicvrml2wellknowntextxmlxqxslyabyamlzpt
Body:

Done