'******************************************************************************
'Subject: Displays the dynamics of over 3.2 * 10^616
' 1-D cellular automata: order for free.
'Author : Sjoerd.J.Schaper
'Date : 11-21-2005
'Code : all QBasic's, FreeBasic extendable
'Keys : [Esc] quit program
' [Enter] build a random update rule
' [Tab] change a single rule atom
' [c] find the cycle length
' [r] and [w] read / write update rule
' [+] and [-] change display period
' [Space] seed with one random state cell
' press any key to seed with all random states
'******************************************************************************
'This program is copyright (c) 2005 by the author. It is made available as is,
'and no warranty - about the program, its performance, or its conformity to any
'specification - is given or implied. It may be used, modified, and distributed
'freely, as long as the original author is credited as part of the final work.
'******************************************************************************
REM $STATIC
DEFINT A-Z
DECLARE SUB inita (n)
'initialize scale n arrays
DECLARE SUB populate (t, m)
'display the automaton at time t modulo m
DECLARE SUB evaluate (t)
'apply the table of rules
DECLARE SUB rndrule ()
'build a table of random couplings between
'cell context and a particular result
DECLARE SUB mutate ()
'change a single rule atom
DECLARE SUB inrule (n&)
'input a valid rule number
DECLARE SUB rndstat ()
'generate sample random states
DECLARE SUB rndcell ()
'seed with one random state cell <> null
DECLARE SUB prntrule (p&)
'save the update rule to file
DECLARE FUNCTION ingrid ()
'input the next valid CA rule
CONST FILE$ = ".\cellauto.lif"
'valid CA life dialect input file
CONST MODE = 12, dW = 640, dH = 480
' set screenmode, width, height
'CONST MODE = 19, dW = 800, dH = 600 ' FreeBasic only
'CONST MODE = 20, dW = 1024, dH = 768
CONST MAX = 16
DIM SHARED stats, nn, edgs, rlen, sw
'state space, dimension, neighbourhood,
' rule length, generation switch
nn = MAX * MAX - 1
DIM SHARED c(-1 TO nn, 2), a(nn, 3), ru(1023)
' cell states, adjacency list, table of rules
RANDOMIZE TIMER
CLS : LOCATE 2, 1
INPUT " number of local states ", stats
IF stats < 2 THEN stats = 2
IF stats > 4 THEN stats = 4
INPUT " size of the neighbourhood ", edgs
IF edgs < 2 THEN edgs = 2
IF edgs > 4 THEN edgs = 4
INPUT " scale ", n
IF n < 3 OR n > MAX THEN n = 10
p& = 1
inita n
m = nn + (nn AND 1)
'inrule 110
DO
populate t, m
evaluate t
t = 1 + t MOD 32767
'
g$ = INKEY$
IF g$ <> "" THEN
find = 0
LOCATE 19, 2: PRINT SPACE$(6);
LOCATE 20, 3: PRINT SPACE$(6);
'
SELECT CASE ASC(g$)
CASE 9
mutate
CASE 13
rndrule
t = 0: rndstat
CASE 27
EXIT DO
CASE 32
rndcell
t = 0: hold = -1
CASE 43
t = 0: m = m + 1
CASE 45
t = 0: m = m - 1
CASE 99
cy = t: find = -1
FOR k = 0 TO nn
c(k, 2) = c(k, sw) ' store current states
NEXT k
CASE 114
SEEK #1, p&
IF ingrid THEN
t = 0: p& = SEEK(1)
m = nn + (nn AND 1)
END IF
CASE 119
prntrule p&
CASE ELSE
rndstat
END SELECT
WHILE INKEY$ <> "": WEND
END IF
IF find AND t > cy THEN
find = NOT find
FOR k = 0 TO nn
IF c(k, sw) <> c(k, 2) THEN
find = -1: EXIT FOR
END IF
NEXT k
IF NOT find THEN ' cycle length found
LOCATE 19, 2: PRINT "period";
LOCATE 20, 3: PRINT t - cy; " ";
END IF
END IF
IF hold AND t = m THEN
hold = 0: SLEEP
WHILE INKEY$ <> "": WEND ' press any key to continue
END IF
LOOP
CLOSE
SYSTEM
SUB evaluate (gen) STATIC
IF gen = 0 THEN
DIM pw(4)
pw(0) = 1
FOR t = 1 TO 4
pw(t) = pw(t - 1) * stats ' store powers
NEXT t
SWAP pw(2), pw(4) ' rearrange
END IF
FOR k = 0 TO nn
tl = c(k, sw) * pw(4)
FOR t = 0 TO 3 ' compute context(k)
tl = tl + c(a(k, t), sw) * pw(t)
NEXT t
c(k, 1 - sw) = ru(tl) ' look up transition rule
NEXT k
sw = 1 - sw ' switch generations
END SUB
FUNCTION ingrid
ingrid = 0: n = 0
DO
IF EOF(1) THEN
ingrid = n > 0: EXIT DO
END IF
LINE INPUT #1, g$: g$ = RTRIM$(g$)
SELECT CASE LEFT$(g$, 2)
CASE "#C", "#D", "#L" ' comments
IF n THEN
ingrid = -1: EXIT DO ' go!
END IF
CASE "#N", "#R" ' scale
n = VAL(MID$(g$, 3))
IF n < 3 OR n > MAX THEN n = 10
CASE "#P" ' CA parameters
g$ = LTRIM$(RTRIM$(MID$(g$, 3)))
t = INSTR(g$, " ")
stats = VAL(LEFT$(g$, t))
IF stats < 2 THEN stats = 2
IF stats > 4 THEN stats = 4
edgs = VAL(MID$(g$, t + 1))
IF edgs < 2 THEN edgs = 2
IF edgs > 4 THEN edgs = 4
inita n: dt = 1
IF edgs = 2 THEN dt = stats 'hack for double-edged rule
CASE ELSE
IF LEN(g$) > 1 THEN ' read rule
t = 0
FOR k = rlen TO 1 STEP -1
ru(t) = VAL(MID$(g$, k, 1))
t = t + dt
NEXT k
END IF
END SELECT
LOOP
END FUNCTION
SUB inita (n)
sw = 0 ' reset global switch
nn = n * n - 1 ' number of cells
FOR k = 0 TO nn ' clear all edges
FOR t = 0 TO 3: a(k, t) = -1: NEXT
NEXT k
rlen = stats ^ (edgs + 1) ' rule length
IF edgs = 2 THEN
FOR k = 0 TO nn
v = (k - 1 + nn) MOD nn ' circular world
a(k, 1) = v: a(v, 3) = k
NEXT k
ELSE
FOR r = 0 TO n - 1
rp = r AND 1 ' store parity(r)
FOR s = 0 TO n - 1
k = r * n + s ' cell number
x0 = s: y0 = r - 1 ' northern neighbour
FOR t = 0 TO 1
x = (x0 + n) MOD n ' toroidal world
y = (y0 + n) MOD n
v = y * n + x ' build adjacency list
IF edgs = 4 OR t = 1 THEN
a(k, t) = v ' square lattice...
a(v, t + 2) = k
ELSE ' triangular lattice
IF (s AND 1) = rp THEN
a(k, 0) = v: a(v, 0) = k
END IF
END IF
x0 = s - 1: y0 = r ' western neighbour
NEXT t
NEXT s
NEXT r
END IF
rndrule
rndstat
END SUB
SUB inrule (n&)
s& = n&: t = 0: dt = 1
IF edgs = 2 THEN dt = stats
FOR k = 1 TO rlen
ru(t) = s& MOD stats ' convert to base stats
s& = s& \ stats
t = t + dt
NEXT k
END SUB
SUB mutate
fl = nn
evaluate 1
FOR k = 0 TO nn
c(k, 2) = c(k, sw) ' store the next generation
fl = fl + (c(k, sw) = 0)
NEXT k
sw = 1 - sw ' this generation
IF fl < 0 THEN EXIT SUB ' null state
dt = 1: tx = rlen
IF edgs = 2 THEN
dt = stats: tx = tx * dt
END IF
fl = 0
DO
DO
t = INT(RND * tx)
LOOP WHILE t MOD dt
v = ru(t) ' rule atom
DO
w = INT(RND * stats)
LOOP WHILE w = v
ru(t) = w ' minimal change
'
evaluate 1
FOR k = 0 TO nn
IF c(k, sw) <> c(k, 2) THEN
fl = -1: EXIT FOR ' has effect
END IF
NEXT k
sw = 1 - sw
IF fl THEN EXIT DO
ru(t) = v
LOOP
END SUB
SUB populate (gen, m)
STATIC fl
IF gen = 0 THEN
IF NOT fl THEN
SCREEN MODE: fl = -1 ' initialize gfx
PALETTE 0, &H282828
PALETTE 1, &H180000
PALETTE 5, &H0: COLOR 5
r = 1 + dW * .25 * .618
s = r + dW * .75 - 1
VIEW (r, 1)-(s, dH - 2), , 5
LOCATE 3, 2: PRINT "states"
LOCATE 7, 2: PRINT "edges"
LOCATE 11, 2: PRINT "display"
LOCATE 15, 2: PRINT "generation"
OPEN FILE$ FOR INPUT SHARED AS #1
END IF
IF m < 1 THEN m = 1
ds! = nn - .5: dr! = m - .5
WINDOW SCREEN (-.5, -.5)-(ds!, dr!)
LINE (-1, -1)-(nn, m), 0, BF ' clear viewport
u = nn: IF m > nn THEN u = m ' max(m, nn)
FOR t = 0 TO u
dt! = t - .5 ' draw grid
LINE (-.5, dt!)-(ds!, dt!), 5
LINE (dt!, -.5)-(dt!, dr!), 5
NEXT t
SELECT CASE stats
CASE 2
PALETTE 2, &H1A2A
CASE 3
PALETTE 2, &H202A
PALETTE 3, &H80026
CASE ELSE
PALETTE 2, &H1A2B
PALETTE 3, &H100025
PALETTE 4, &H1A10
END SELECT
LOCATE 4, 3: PRINT stats
LOCATE 8, 3: PRINT edgs
END IF
t = gen MOD m ' timestep
FOR k = 0 TO nn
PAINT (k, t), c(k, sw) + 1, 5 ' update all cells
NEXT k ' arranged in one row
LOCATE 12, 3: PRINT m; " ";
LOCATE 16, 3: PRINT gen; " ";
END SUB
SUB prntrule (p&)
CLOSE 1
OPEN FILE$ FOR APPEND AS #1
'
PRINT #1, "#D saved by cellauto.bas"
p& = SEEK(1)
PRINT #1, "#N"; SQR(nn + 1) ' print CA parameters
PRINT #1, "#P"; stats; edgs
t = 0: dt = 1
IF edgs = 2 THEN dt = stats
g$ = STRING$(rlen, "0")
FOR k = rlen TO 1 STEP -1 ' concatenate rule
MID$(g$, k, 1) = LTRIM$(STR$(ru(t)))
t = t + dt
NEXT k
PRINT #1, g$
'
CLOSE 1
OPEN FILE$ FOR INPUT SHARED AS #1
END SUB
SUB rndcell
FOR k = 0 TO nn
c(k, sw) = 0 ' clear all cells
NEXT k
t = stats - 1 ' single alive cell
c(nn \ 2, sw) = 1 + INT(RND * t)
END SUB
SUB rndrule
DIM v(3)
fr! = LOG(rlen) * .125 ' saturation
FOR t = 0 TO stats - 1
v(t) = INT(RND * stats) ' random northern bias for reducing
NEXT t ' the number of chaotic automata
tx = rlen
IF edgs = 2 THEN tx = tx * stats
FOR t = 0 TO tx - 1
IF RND < fr! THEN
w = v(t MOD stats) ' canalyzing rule for edges > 2
ELSE
w = INT(RND * stats) ' random value
END IF
ru(t) = w
NEXT t
END SUB
SUB rndstat
fr! = .15 ' fraction alive cells
t = stats - 1
FOR k = 0 TO nn ' random states
IF RND < fr! THEN
c(k, sw) = 1 + INT(RND * t)
ELSE
c(k, sw) = 0
END IF
NEXT k
END SUB