Arjen Markus (26 August 2002) A few years ago cellular automata were "in vogue": they formed a new type of mathematical objects that had rather interesting properties. Given a few simple rules, they could exhibit a wealth of structures. The most famous one of all: the Game of Life.
I recently came across them again and concocted this little script. If I remember the rules correctly, it is an implementation of the Game of Life.
Remark: as noted below by DKF the rules are definitely not those of Life. However, it is rather dynamic :)
The idea:
The rules are found in the proc newCellState.
Note: I paid little attention to customisation or presentation. Just watch and be fascinated.
# cellular_automata --
# Implement simple two-dimensional cellular automata
#
package require Tk
# displayState --
# Display the current state
# Arguments:
# window Window to update
# cells Cells array
# state State array
# nocols Number of columns
# norows Number of rows
# Result:
# None
# Side effects:
# Display the new state by chnaging the colour of the cells
#
proc displayState { window cells state nocols norows } {
upvar #0 $cells cellId
upvar #0 $state newState
for { set j 0 } { $j < $norows } { incr j } {
for { set i 0 } { $i < $nocols } { incr i } {
$window itemconfigure $cellId($i,$j) \
-fill [lindex {white black} $newState($i,$j)]
}
}
}
# calculateNewState --
# Calculate the new state
# Arguments:
# window Window for display
# cells Cell IDs
# old_state State array holding current state
# new_state State array holding new state
# nocols Number of columns
# norows Number of rows
# Result:
# None
# Side effects:
# Set new values in the array new_state
#
proc calculateNewState { window cells old_state new_state nocols norows } {
upvar #0 $old_state state
upvar #0 $new_state newState
for { set j 0 } { $j < $norows } { incr j } {
for { set i 0 } { $i < $nocols } { incr i } {
set ie [expr {$i+1} ]
set iw [expr {$i-1} ]
set jn [expr {$j+1} ]
set js [expr {$j-1} ]
set ie [expr {($ie >= $nocols) ? 0 : $ie} ]
set iw [expr {($iw < 0 ) ? ($nocols-1) : $iw} ]
set jn [expr {($jn >= $norows) ? 0 : $jn} ]
set js [expr {($js < 0 ) ? ($norows-1) : $js} ]
set newState($i,$j) \
[newCellState $state($i,$j) $state($iw,$j) \
$state($ie,$j) $state($i,$jn) \
$state($i,$js) ]
}
}
displayState $window $cells $new_state $nocols $norows
#
# Schedule this routine again - reversed arrays!
#
after 100 [list \
calculateNewState $window $cells $new_state $old_state $nocols $norows ]
}
# setUpDisplay --
# Initialise the display
# Arguments:
# window The window used to display the result
# cells Array with cell IDs
# nocols Number of columns
# norows Number of rows
# Result:
# None
# Side effects:
# Set new values in the array cells
#
proc setUpDisplay { window cells nocols norows } {
upvar #0 $cells cellId
for { set j 0 } { $j < $norows } { incr j } {
for { set i 0 } { $i < $nocols } { incr i } {
set iw [expr {10*$i} ]
set ie [expr {$iw+9} ]
set js [expr {10*($norows-$j)} ]
set jn [expr {$js-9} ]
set cellId($i,$j) \
[$window create rectangle $iw $jn $ie $js -outline "" -fill white]
}
}
}
# newCellState --
# Determine the new state of a cell
# Arguments:
# state_c State of the current cell
# state_w State of the cell west of the current cell
# state_e State of the cell east of the current cell
# state_n State of the cell north of the current cell
# state_s State of the cell south of the current cell
# Result:
# New state
#
proc newCellState { state_c state_w state_e state_n state_s } {
set sum [expr {$state_w+$state_e+$state_n+$state_s}]
switch -- $sum {
"0" { set result 0 }
"1" { set result 1 }
"2" { set result 0 }
"3" { set result 1 }
"4" { set result 0 }
default { set result 0 ;# Should never happen though }
}
return $result
}
# main --
# Steer the application
# Arguments:
# None
# Result:
# None
# Note:
# It is necessary to use global arrays - because of [after]
#
proc main {} {
canvas .cnv
pack .cnv -fill both
set norows 30
set nocols 29
setUpDisplay .cnv ::cells $nocols $norows
#
# Initial condition
#
for { set j 0 } { $j < $norows } { incr j } {
for { set i 0 } { $i < $nocols } { incr i } {
set ::state($i,$j) 0
}
}
set ::state(5,5) 1
displayState .cnv ::cells ::state $nocols $norows
after 100 [list \
calculateNewState .cnv ::cells ::state newState $nocols $norows ]
}
#
# Start the program
#
mainDKF - This is not the classic rules for Conway's Life. That uses the eight nearest neighbours (diagonal too), and states that a cell will remain in its current state when it is next to two living neighbours, become/remain alive when it is next to three living neighbours, and become/remain dead when it is next to any other number of neighbours ("overcrowding" and "loneliness", if you will.)
There are other interesting categories of cellular automata. One of my favourites is "wires" where each cell can be in one of four states:
This is not quite as dynamic as Life (the rules keep the overall form by-and-large static) but it is computationally complete (note that heads and tails combine to form pulse chains that travel in definite directions):
"3-cycle Pulse Source"
H############ ->
T
"OR Gate"
-> #####
#
############ ->
#
-> #####
"INHIBIT Gate"
-> ########## ####### ->
#
###
#
-> ##########
(The inhibit input)It's possible to build complex "circuits" using this, though layout is tricky because you have to be very careful about the timing.
Langton's Ant
Langton's Ant is an automaton that wanders around blindly for a while, before getting its act together and heading off determinedly in a particular direction.
To make its life marginally more interesting, this Ant lives on a toroid, so it keeps tripping over its own tracks.
There is some background at [L1 ].
# lant.tcl Langton's Ant
set size 400 ;# pixels per canvas side
set side 200 ;# cells per canvas side
set cell [expr $size/$side] ;# pixels per cell
set bgcol yellow
set fgcol red
set adir(0) {1 0};set adir(1) {0 1};set adir(2) {-1 0};set adir(3) {0 -1}
catch {destroy .c}
canvas .c -width [expr $size+1] -height [expr $size+1] -bg $bgcol
bind .c <Button> {set run 0}
pack .c
set x [expr int(rand()*$side)];set y [expr int(rand()*$side)];set dir 0;set run 1
while {$run} {
set col [.c itemcget $x,$y -fill] ;# read cell at ant position
if {![string length $col]} { ;# create new fg cells on demand
.c create rectangle \
[set ax [expr $x*$cell+2]] [set ay [expr $y*$cell+2]] \
[expr $ax+$cell] [expr $ay+$cell] \
-outline $fgcol -fill $fgcol -tag $x,$y
set dir [expr ($dir+1)%4] ;# turn right
} elseif {[string match $col $bgcol]} { ;# invert bg cell
.c itemconfigure $x,$y -outline $fgcol -fill $fgcol
set dir [expr ($dir+1)%4] ;# turn right
} else { ;# invert fg cell
.c itemconfigure $x,$y -outline $bgcol -fill $bgcol
set dir [expr ($dir+3)%4] ;# turn left
}
set x [expr ($x+[lindex $adir($dir) 0])%$side]
set y [expr ($y+[lindex $adir($dir) 1])%$side]
update
}Bob Clark
Langton's Other Ants
I didn't know it until reading more about the earlier ant, but Langton has more than one ant.
Langton first ant (the one above) is called "LR", his second ant is called "RL", and all his other ants have names made from the possible permutations of "L" and "R". So there must be an infinite number of them.
Each name describes the behaviour of its ant - the length of the name gives the number of colours or states it can manage, and the letter gives the direction the ant turns in when it encounters each colour, background colour first.
So type the name of the ant into the entry, and press the Start button to see what it does.
I was particularly impressed with the ant called "LLLLLLLLLLLLRRRRRRRRRRRR" - he looked like a brain having ideas.
# lants.tcl Langton's Other Ants
proc config {} {
global Config
array unset Config
array set Config {
size 400 ;# {pixels per canvas side}
side 200 ;# {cells per canvas side}
directions {-1 1} ;# {initial =LR}
colours {ivory red2 darkorange2 yellow2 chartreuse2 green2 springgreen2
turquoise2 dodgerblue2 blue2 blueviolet magenta2 deeppink2
red3 darkorange3 yellow3 chartreuse3 green3 springgreen3
turquoise3 dodgerblue3 blue3 darkviolet magenta3 deeppink3
red4 darkorange4 gold4 chartreuse4 green4 springgreen4
turquoise4 dodgerblue4 navy purple4 magenta4 deeppink4}
;# {spectral}
.lants.name LR ;# {initial =LR}
.lants.cycle 1000 ;# {cell cycles per canvas refresh}
.lants.startstop 0 ;# {0 when Stopped, 1 when Started}
}
set Config(cell) [expr {$Config(size)/$Config(side)}] ;# pixels per cell
}
proc gui {} { ;# create a magnificent gui
global Config
wm title . "Langton's Other Ants"
catch {destroy .lants}
frame .lants
entry .lants.name -textvariable Config(.lants.name) -width 40
button .lants.startstop -text Start -command startstop
canvas .lants.world
.lants.world configure -width [expr $Config(size)+1] -height [expr $Config(size)+1] -bg [lindex $Config(colours) 0]
pack .lants .lants.name .lants.startstop .lants.world
}
proc checkname {} { ;# tidy up the lant name and convert to Config(directions)
global Config
set Config(directions) [set name [list]]
foreach let [split [string toupper $Config(.lants.name)] ""] {
if {$let=="L"} {set dir -1} elseif {$let=="S"} {set dir 0} elseif {$let=="R"} {set dir 1} else {
set let ?
set dir 0
}
lappend name $let
lappend Config(directions) $dir
}
if {![llength $name]} {
lappend Config(directions) 0
}
set Config(.lants.name) [join $name ""]
}
proc runworld {cell cycle directions colours} { ;# track a lant and update the display
global Config
.lants.world delete all
set x [expr {$Config(side)/2}]
set y [expr {$Config(side)/2}]
array set xdir {0 1 1 0 2 -1 3 0} ;# dx per direction
array set ydir {0 0 1 1 2 0 3 -1} ;# dy per direction
set dir 0
set noofcols [llength $directions]
while {$Config(.lants.startstop)} { ;# until stop button
set inserts [list]
array unset updates
for {set t 0} {$t<$cycle} {incr t} { ;# do a lot of lant cycles
if {[catch {set col $cells($x,$y)}]} {
set col 0
lappend inserts $x $y ;# list of new cells
}
set dir [expr {($dir+[lindex $directions $col]+4)%4}]
set col [expr {($col+1)%$noofcols}]
set cells($x,$y) $col ;# array of cell colour
set updates($x,$y) "" ;# array of distinct updated cells
set x [expr {$x+$xdir($dir)}] ;# new x
set y [expr {$y+$ydir($dir)}] ;# new y
}
foreach {x1 y1} $inserts { ;# create squares for new cells
.lants.world create rectangle \
[set ax [expr {$x1*$cell+2}]] [set ay [expr {$y1*$cell+2}]] \
[expr {$ax+$cell}] [expr {$ay+$cell}] -tag $x1,$y1
}
foreach xy [array names updates] { ;# paint squares for inserts and updates
set col [lindex $colours $cells($xy)]
if {![string length $col]} {set col black}
.lants.world itemconfigure $xy -outline $col -fill $col
}
update
}
}
proc startstop {} { ;# start or stop the lant
global Config
if {$Config(.lants.startstop)} {
.lants.name configure -state normal
.lants.startstop configure -text Start
set Config(.lants.startstop) 0
} else {
checkname
.lants.name configure -state disabled
.lants.startstop configure -text Stop
set Config(.lants.startstop) 1
after 0 [list runworld $Config(cell) $Config(.lants.cycle) $Config(directions) $Config(colours)]
}
}
config
guiActually this version also accepts "S" in a name, meaning "straight on". Forward and Back would have been more sensible...
This runs like lightening on Mac OS X at 1GHz - not so impressive on a 200MHz PC :( Someone tell me how to speed it up please!
Bob Clark
[ Category mathematics | Category games | Category application ]