[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:
   * A cell gets a new state (0 or 1) depending on its own state and that of its neighbours.
   * In the case shown the rules are very simple: count the number of "live" neighbours. If it is even, then the new state of the centre cell becomes 0. Otherwise it becomes 1.

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
 #
 main
----
''[DKF]'' - 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:
   blank:   Always remains blank.
   wire:   Becomes a head if-and-only-if next (using 8 neighbours rule) to one or two heads.
   head:   Becomes a tail.
   tail:   Becomes a wire.
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 [http://mathworld.wolfram.com/LangtonsAnt.html].

 #	lants2.tcl	Langton's Other Ants 2
 
 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}]			;# starting position
 	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						;# 0=0 1=90 -1=3=270 -2=2=180 degrees
 	set noofcols [llength $directions]			;# number of colours from palette
 	while {$Config(.lants.startstop)} {			;# until stop button
 		set inserts [list]				;# list of new cells
 		array unset updates				;# array of distinct updated cells
 		for {set t 0} {$t<$cycle} {incr t} {		;# do a lot of lant cycles
 			if {[catch {set col $cells($x,$y)}]} {	;# new cell required
 				set col 0			;# 0=background
 				lappend inserts $x $y		;# list of new cells
 			}
 			set dir [expr {($dir+[lindex $directions $col]+4)%4}]
 			set col [expr {($col+1)%$noofcols}]	;# change direction, update colour
 			set cells($x,$y) $col			;# array of current 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 rectangles for inserts
 			.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 rectangles 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 checkname {} {	;# tidy up the lant name and convert to Config(directions)
 global Config
 	set Config(.lants.name) [string map {" " ""} [string toupper $Config(.lants.name)]]
 	set Config(directions) [string map {L -1 R 1 F 0 B -2} [split $Config(.lants.name) ""]]
 	if {[set l [llength $Config(directions)]]} {
	 	for {set x 0;set i 0} {$i<$l} {incr i} {
	 		if {[catch {incr x [lindex $Config(directions) $i]}]} {
	 			set Config(.lants.name) [string range $Config(.lants.name) 0 [expr {$i-1}]]?[string range $Config(.lants.name) [expr {$i+1}] end]
	 			set Config(directions) [lreplace $Config(directions) $i $i 0]
	 		}
	 	}
	 } else {
	 	set Config(directions) [list 0]
	 }
 }
 
 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)]
 	}
 }
 
 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

 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
  
This is a slightly more readable update on the original version, and accepts the letters "F" for forward and "B" for back (directions +0 and -2) - which introduces whole new classes of ants to be exercised.

Bob Clark
----
[[
[Category mathematics] |
[Category games] |
[Category application]
]]