'******************************************************************************
'Subject: Edward Fredkin's parity rule w/3 memory bits:
' a replicator CA kaleidoscope.
'Author : Sjoerd.J.Schaper - vspickelen
'Date : 02-07-2006
'Code : all QBasic's, FreeBasic extendable
'Keys : [Esc] quit program
' [Enter] input parameters
' [Ctrl]+[b] draw a box
' [b] draw a box outline
' [Ctrl]+[c] draw a Greek cross
' [c] draw St.Andrew's cross
' [Ctrl]+[d] draw a diamond
' [d] draw a diamond outline
' [Space] freeze
' press any key to sow a few cells
'******************************************************************************
'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/parity rule
DECLARE FUNCTION params ()
'input CA parameters
DECLARE SUB square (f1, f2)
'draw a (filled) square
DECLARE SUB cross (fl)
'draw a cross
DECLARE SUB rndstat ()
'sow some central cells
DECLARE FUNCTION clac ()
'clear all cells
CONST TMX = .333
' set delay < 1 second
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
DIM SHARED c(MAX - 1, MAX - 1, 1) ' cell indices
DIM SHARED DR, L1, RR, BM, sw
'neighbourhood, metric, reversible rule,
' bit mask, generation switch
DR = 1: L1 = -1: RR = 0: BM = 15 ' defaults
RANDOMIZE TIMER
t = 0
DO
IF TMX THEN dt! = TIMER
populate t
t = t + 1
evaluate
g$ = INKEY$
IF g$ <> "" THEN
SELECT CASE ASC(g$)
CASE 2
t = clac: square 0, 0 ' filled
CASE 3
t = clac: cross 0 ' +
CASE 4
t = clac: square 0, 1
CASE 13
IF params THEN t = 0 ' change
CASE 27
EXIT DO ' quit
CASE 32
LOCATE 4, 3: PRINT t; " "
LOCATE 8, 4: PRINT "0 "
SLEEP ' freeze
CASE 98
t = clac: square 1, 0 ' outline
CASE 99
t = clac: cross 1 ' x
CASE 100
t = clac: square 1, 1
CASE ELSE
t = clac: rndstat ' reset
END SELECT
WHILE INKEY$ <> "": WEND
END IF
IF TMX THEN
WHILE TMX > TIMER - dt!: WEND ' delay
END IF
LOOP
SYSTEM
FUNCTION clac
FOR r = 0 TO MAX - 1 ' clear
FOR s = 0 TO MAX - 1
c(r, s, 0) = 0: c(r, s, 1) = 0
NEXT s
NEXT r
clac = 0
END FUNCTION
SUB cross (fl)
x = (MAX - 1) \ 2
y = 1 + INT(RND * x)
FOR r = x - y TO x + y
IF fl THEN
c(r, r, sw) = 1 ' St.Andrew's,
c(r, 2 * x - r, sw) = 1
ELSE
c(x, r, sw) = 1 ' Greek cross
c(r, x, sw) = 1
END IF
NEXT r
END SUB
SUB evaluate
n1 = MAX - 1
FOR r = 0 TO n1
FOR s = 0 TO n1
tl = 0
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
tl = tl + c(x, y, sw) ' sum cell states
NEXT sn
NEXT rn
IF RR THEN
tl = tl - c(s, r, sw) ' reversible rule
tl = tl XOR c(s, r, 1 - sw)
END IF
i = c(s, r, sw) * 2 AND BM ' shift memory bits
c(s, r, 1 - sw) = i OR (tl AND 1)
' update cell w/parity
NEXT s
NEXT r
sw = 1 - sw ' switch generations
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 > 17 THEN DR = 17
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
g$ = "n": IF RR THEN g$ = "y" ' reversible rule
LOCATE 11, 1: PRINT " rev y/n "; g$;
LOCATE 11, 10: INPUT "", g$
IF g$ <> "" THEN
RR = 0: IF INSTR(g$, "y") THEN RR = -1
END IF
t = LOG(BM + 1) / LOG(2)
LOCATE 11, 1: PRINT " colbits "; t;
LOCATE 11, 10: INPUT "", t
IF t > 0 THEN
IF t > 4 THEN t = 4
BM = 2 ^ t - 1: params = -1
END IF
LOCATE 11, 1: PRINT SPACE$(12);
END FUNCTION
SUB populate (gen)
STATIC fl, g0, t0!
IF gen = 0 THEN
IF NOT fl THEN
SCREEN MODE ' 4 bpp
PALETTE 0, &H40406: PALETTE 1, &H121315
' 0000 sepia 0001 grey
PALETTE 8, &HA0004: PALETTE 4, &H100000
' 1000 blue violet 0100 ultramarine
PALETTE 2, &HC0800: PALETTE 12, &HA0C00
' 0010 cobalt blue 1100 blue green
PALETTE 10, &H70F00: PALETTE 6, &H1300
' 1010 turquoise 0110 light green
PALETTE 14, &H1514: PALETTE 9, &HA0009
' 1110 greenish yl. 1001 violet
PALETTE 5, &H5000E: PALETTE 3, &H14
' 0101 mauve 0011 carmine
PALETTE 13, &H51B: PALETTE 11, &HA1F
' 1101 vermilion 1011 orange
PALETTE 7, &H121E: PALETTE 15, &H1821
' 0111 deep yellow 1111 lemon yellow
COLOR 1
r = 1 + dW * .25 * .618
s = r + dW * .75 - 1: fl = -1
VIEW (r, 1)-(s, dH - 2), , 1
LOCATE 3, 2: PRINT "generation"
LOCATE 7, 2: PRINT "speed * 10"
sw = 0: square 0, 0 ' initialize
END IF
g0 = 0: t0! = TIMER: d! = -.5
WINDOW SCREEN (d!, d!)-(MAX + d!, MAX + d!)
LINE (-1, -1)-(MAX, MAX), 0, BF ' clear viewport
END IF
d! = .491
FOR y = 0 TO MAX - 1 ' update CA
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
SUB rndstat
x = (MAX - 1) \ 2: fl = -1
DO
y = 1 + INT(RND * 3)
fr! = .15 / y
FOR r = x - y TO x + y ' random parity
FOR s = x - y TO x + y
IF RND < fr! THEN
c(s, r, sw) = 1: fl = 0
END IF
NEXT s
NEXT r
LOOP WHILE fl
END SUB
SUB square (f1, f2)
x = (MAX - 1) \ 2
y = 1 + INT(RND * x)
IF f1 THEN f1 = 1
FOR t = 0 TO f1
FOR r = x - y TO x + y
IF f2 THEN
ds = y - ABS(r - x) ' diamond
ELSE
ds = y ' box
END IF
FOR s = x - ds TO x + ds
c(s, r, sw) = 1 - t
NEXT s
NEXT r: y = y - 1 ' outline
NEXT t
END SUB