'******************************************************************************
'Subject: Cyclic cellular automata:
' wave activity in the primordial soup
'Author : Sjoerd.J.Schaper
'Date : 01-21-2006
'Code : all QBasic's, FreeBasic extendable
'Keys : [Esc] quit program
' [Enter] input parameters
' [Tab] draw an island
' [Backspc] frame a pond
' [Space] freeze
' press any key to seed with random states
'******************************************************************************
'This program is copyright (c) 2006 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 populate (t)
'display the automaton at time t
DECLARE SUB evaluate ()
'apply the range/shape/threshold/states rule
DECLARE FUNCTION params ()
'input CCA parameters
DECLARE SUB colours ()
'read state colour wheel
DECLARE SUB island ()
'draw an island to flood
DECLARE SUB pond ()
'leave a square pond
CONST MODE = 12, dW = 640, dH = 480
' set screenmode, width, height
'CONST MODE = 20, dW = 1024, dH = 768 ' FreeBasic only
CONST MAX = 128 ' Must be a power-of-two!
' maximum grid size 128 for Q-Basic's
'CONST MAX = 1024 ' FreeBasic only
DIM SHARED tl(15), c(MAX - 1, MAX - 1, 1)
' state counters, cell indices
DIM SHARED DR, L1, TH, CS, sw
'neighbourhood, metric, threshold,
' cell states, generation switch
DR = 1: L1 = 0: TH = 3: CS = 4 ' defaults
RANDOMIZE TIMER
t = 0
DO
populate t
t = t + 1
evaluate
g$ = INKEY$
IF g$ <> "" THEN
SELECT CASE ASC(g$)
CASE 8
pond
CASE 9
island
CASE 13
IF params THEN t = 0 ' change parameters
CASE 27
EXIT DO
CASE 32
LOCATE 4, 3: PRINT t; " "
LOCATE 8, 4: PRINT "0 "
SLEEP ' freeze
CASE ELSE
t = 0 ' reset
END SELECT
WHILE INKEY$ <> "": WEND
END IF
LOOP
SYSTEM
DATA "57", "147", "1433", "14232", "122233", "3231212", "11222212"
DATA "411221111", "1211212112", "11213111112", "111221111112"
DATA "1111121111111", "11111111111111", "111111111111111"
' Adaptable palette steps for colour wheels
DATA &H000014, &H00051B, &H000A1F, &H00121E, &H001821
' carmine vermilion orange deep yellow lemon yellow
DATA &H001514, &H001300, &H070F00, &H0A0C00, &H0C0800
' gr.yellow l.green turquoise blue green cobalt blue
DATA &H100000, &H0A0004, &H0A0009, &H05000E, &H040406
' ultramarine blue violet violet mauve sepia
SUB colours
DIM pa(15) AS STRING, co(255) AS LONG
FOR l = 2 TO 15
READ pa(l)
NEXT l
co(0) = &H242424
co(15) = &H40406
FOR l = 1 TO CS
d = VAL(MID$(pa(CS), l, 1))
FOR i = 1 TO d
READ co(l)
NEXT i
NEXT l
RESTORE
PALETTE USING co(0)
END SUB
SUB evaluate
n1 = MAX - 1
FOR r = 0 TO n1
FOR s = 0 TO n1
FOR i = 0 TO CS ' clear
tl(i) = 0
NEXT i
FOR rn = r - DR TO r + DR
IF L1 THEN
ds = DR - ABS(rn - r) ' von Neumann
ELSE
ds = DR ' Moore
END IF
FOR sn = s - ds TO s + ds
x = (sn + MAX) AND n1 ' toroidal neighbours
y = (rn + MAX) AND n1
i = c(x, y, sw)
tl(i) = tl(i) + 1 ' count cell states
NEXT sn
NEXT rn
i = c(s, r, sw)
j = 1 + i MOD CS ' next colour
IF tl(j) < TH THEN
c(s, r, 1 - sw) = i
ELSE
c(s, r, 1 - sw) = j ' update cell
END IF
NEXT s
NEXT r
sw = 1 - sw ' switch generations
END SUB
SUB island
n1 = MAX - 1
dc! = n1 * .5: d! = .491
r! = dc! * dc! * .64
FOR y = 0 TO n1
dy! = (y - dc!) * (y - dc!)
FOR x = 0 TO n1
dx! = (x - dc!) * (x - dc!)
IF dx! + dy! < r! THEN ' paint void
LINE (x - d!, y - d!)-(x + d!, y + d!), 0, BF
c(x, y, sw) = 0
END IF
NEXT x
NEXT y
END SUB
FUNCTION params
params = 0
LOCATE 11, 1: PRINT " range "; DR;
LOCATE 11, 8: INPUT "", t
IF t > 0 THEN
DR = t: IF t > 7 THEN DR = 7
END IF
g$ = "b": IF L1 THEN g$ = "d"
LOCATE 11, 1: PRINT " dmd/box "; g$;
LOCATE 11, 10: INPUT "", g$ ' metric
IF g$ <> "" THEN
L1 = 0: IF INSTR(g$, "d") THEN L1 = -1
END IF
LOCATE 11, 1: PRINT " thresh. "; TH;
LOCATE 11, 10: INPUT "", t
IF t > 0 THEN
s = 2 * DR + 1: a = s * s ' box area
IF L1 THEN a = (s * s + 1) \ 2 ' diamond area
TH = t: IF t >= a THEN TH = a - 1
END IF
LOCATE 11, 1: PRINT " cstates "; CS;
LOCATE 11, 10: INPUT "", t
IF t > 1 THEN
CS = t: IF t > 15 THEN CS = 15
params = -1: colours ' set palette
END IF
LOCATE 11, 1: PRINT SPACE$(12)
END FUNCTION
SUB pond
n1 = MAX - 1
dc! = n1 * .5: d! = .491
r! = dc! / 7
FOR y = 0 TO n1
FOR x = 0 TO n1
dx! = ABS(x - dc!): dy! = ABS(y - dc!)
m! = dx!: IF dy! > dx! THEN m! = dy! ' max(x, y)
IF m! > r! THEN
LINE (x - d!, y - d!)-(x + d!, y + d!), 0, BF
c(x, y, sw) = 0
END IF
NEXT x
NEXT y
END SUB
SUB populate (gen)
STATIC fl, g0, t0!
IF gen = 0 THEN
IF NOT fl THEN
SCREEN MODE ' 4 bpp
PALETTE 0, &H242424
PALETTE 15, &H40406: COLOR 15
r = 1 + dW * .25 * .618
s = r + dW * .75 - 1: fl = -1
VIEW (r, 1)-(s, dH - 2), 15, 15
LOCATE 3, 2: PRINT "generation"
LOCATE 7, 2: PRINT "speed * 10"
sw = 0: colours ' initialize
END IF
g0 = 0: t0! = TIMER: d! = -.5
WINDOW SCREEN (d!, d!)-(MAX + d!, MAX + d!)
FOR y = 0 TO MAX - 1 ' primordial soup
FOR x = 0 TO MAX - 1
c(x, y, sw) = 1 + INT(RND * CS)
c(x, y, 1 - sw) = 0
NEXT x
NEXT y
END IF
d! = .491
FOR y = 0 TO MAX - 1 ' update CCA
FOR x = 0 TO MAX - 1
IF c(x, y, sw) XOR c(x, y, 1 - sw) THEN
LINE (x - d!, y - d!)-(x + d!, y + d!), c(x, y, sw), BF
END IF
NEXT x
NEXT y
dt! = TIMER - t0!
IF dt! > 1 THEN
LOCATE 4, 3: PRINT gen; " ";
LOCATE 8, 3: PRINT CINT(10 * (gen - g0) / dt!); " ";
g0 = gen: t0! = TIMER
END IF
END SUB