'******************************************************************************
'Subject: Four-piece linear cellular automata ensemble:
' reveals what the eye can't grasp.
' Play with 65535 generalized k = 2, r = 1.5 automata
' (incl. the elementary and reversible CA subsets)
' c(t+1):= f[c(t-1), c-1(t), c(t), c+1(t)]
'Author : Sjoerd.J.Schaper - vspickelen
'Date : 04-04-2006
'Code : FreeBasic 0.16b
'Keys : [Esc] quit program
' [Tab] input transition rule (Enter)
' append "e" for an elementary CA,
' and "r" for a reversible one
' [Enter] random symmetric rule
' [Ctrl]+[Enter] fully random rule
' [i] invert rule
' [m] mirror reflect
' [Backspc] find cycle length
' [Up] or [Down arrow] change window size
' [Left] or [Right arrow] rotate grid l/r
' [Pg Up] or [Pg Down] change voice spacing
' [F1]...[F8] choose modal scale
' [Space] shuffle scale notes
' [+] or [-] change tempo
' [s] save CA parameters [###] (Enter)
' [l] load CA piece [###] (Enter)
' [Insert] seed with a single alive cell
' press any other key for a random state
'******************************************************************************
'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.
'******************************************************************************
'
#INCLIB "winmm"
DECLARE SUB populate (t AS INTEGER)
'display the automaton at time t
DECLARE SUB evaluate ()
'apply the table of rules
DECLARE SUB inrule (n AS STRING)
'input rule number < 65536
DECLARE FUNCTION decrule () AS STRING
'convert rule to decimal
DECLARE SUB rndcell ()
'sow a single alive cell
DECLARE SUB rndstat ()
'generate sample random state
DECLARE FUNCTION converg (n AS INTEGER) AS INTEGER
'jump forward in time
DECLARE FUNCTION period (n AS INTEGER) AS INTEGER
'find cycle length < n
DECLARE SUB roll (fl AS INTEGER)
'rotate grid left/ right
DECLARE SUB scale (n AS INTEGER)
'rotate tone steps
DECLARE SUB midiout (fl AS INTEGER)
'output CA midi messages
DECLARE SUB savep (n AS INTEGER)
'save CA parameters "piece##n.par"
DECLARE FUNCTION loadp (n AS INTEGER) AS INTEGER
'load & playback CA "piece##n.par"
'winapi prototypes
DECLARE FUNCTION midClose Alias "midiOutClose" (ByVal hMidiOut As Long) As Long
DECLARE FUNCTION midiOpen Alias "midiOutOpen" (ByRef lphMidiOut As Long, _
ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, _
ByVal dwFlags As Long) As Long
DECLARE FUNCTION midiMsg Alias "midiOutShortMsg" (ByVal hMidiOut As Long, _
ByVal dwMsg As Long) As Long
CONST MODE = 12, dW = 640, dH = 480
' set screenmode, width, height
CONST MAX = 160 ' max. grid size
DIM SHARED c(MAX, 1) AS INTEGER, ru(15) AS INTEGER, tn(23) AS INTEGER
' cell states, transition rule, tone numbers
DIM SHARED bpm AS INTEGER, mx AS INTEGER, st AS INTEGER
' tempo, window size, status
DIM SHARED sw AS INTEGER, vsp AS INTEGER
' generation switch, spacer
DIM fh AS INTEGER, m AS INTEGER, n AS INTEGER, sc AS INTEGER
DIM t AS INTEGER, t0 AS SINGLE, g AS STRING, h AS STRING
RANDOMIZE TIMER
bpm = 100
mx = 19
fh = 0
t = 0
DO
t0 = TIMER
populate t
midiout -1
evaluate
t += 1
'
g = INKEY$
IF g <> "" THEN
sc = ASC(RIGHT$(g, 1))
IF LEN(g) > 1 THEN sc = sc + 128
LOCATE 21, 2: PRINT SPACE$(7);
LOCATE 22, 3: PRINT SPACE$(5);
SELECT CASE sc
CASE 8
t += converg(32)
n = period(4096) ' maximum
IF n THEN
LOCATE 21, 2: PRINT "period"
LOCATE 22, 3: PRINT n; " "
ELSE
LOCATE 21, 2: PRINT "fail"
END IF
CASE 9
LOCATE 4, 3: INPUT " ", h
IF h <> "" THEN
t = 0: rndcell
inrule (h) ' read rule
END IF
CASE 10, 13
DO
rndstat
h = STR$(RND * 65536) ' random rule
inrule (h)
IF sc = 13 THEN
ru(0) = 0 ' reflection symmetry
ru(1) = ru(4): ru(9) = ru(12)
ru(3) = ru(6): ru(11) = ru(14)
END IF
t = converg(8)
IF period(4) = 0 THEN EXIT DO
LOOP
CASE 27
EXIT DO ' quit
CASE 32
FOR n = 0 TO 19 ' shuffle scale
m = INT(RND * 20)
SWAP tn(n), tn(m)
NEXT n
st XOR= 1
CASE 43, 45
bpm += 44 - sc ' tempo
IF bpm < 1 THEN bpm = 1
CASE 105
FOR n = 0 TO mx - 1
c(n, 0) XOR= 1: c(n, 1) XOR= 1
NEXT n
FOR n = 0 TO 15 ' invert
ru(n) XOR= 1
NEXT n
FOR n = 0 TO 7
SWAP ru(n), ru(15 - n)
NEXT n
st XOR= 1
CASE 108
LOCATE 21, 2: PRINT "load file#"
LOCATE 22, 3: INPUT " ", n
IF n = 0 THEN n = fh
IF loadp(n) THEN t = 0
CASE 109
FOR n = 4 TO 6 STEP 2 ' reflect
m = n - 3: SWAP ru(n), ru(m)
SWAP ru(n + 8), ru(m + 8)
NEXT n
st XOR= 1
CASE 115
LOCATE 21, 2: PRINT "save file#"
LOCATE 22, 3: INPUT " ", n
IF n = 0 THEN n = fh + 1
fh = n: savep n
CASE 187 TO 196
scale sc - 187 ' mode
CASE 200
mx += 1 ' window size
IF mx > MAX THEN mx = MAX
CASE 201
vsp = (vsp + 1) MOD mx ' voice spacing
st XOR= 1
CASE 203, 205
roll 204 - sc ' rotate grid
CASE 208
mx -= 1
IF mx < 3 THEN mx = 3
CASE 209
vsp = (vsp + mx - 1) MOD mx
st XOR= 1
CASE 210
t = 0: rndcell ' sow
CASE ELSE
t = 0: rndstat ' scatter
END SELECT
LOCATE 4, 4: PRINT decrule$; " ";
LOCATE 10, 3: PRINT vsp; " ";
LOCATE 16, 3: PRINT bpm; " ";
IF sc = 108 OR sc = 119 THEN
LOCATE 21, 2: PRINT SPACE$(10)
LOCATE 22, 3: PRINT SPACE$(5)
END IF
WHILE INKEY$ <> "": WEND
END IF
t0 -= TIMER - 14.9 / bpm
m = CINT(t0 * 1000)
IF m > 1 THEN SLEEP m ' delay
LOOP
st XOR= 1
midiout 0
SYSTEM
'8-note Euler scale
DATA 2,2,1,1,1,2,2,1
'instrument offsets 'F F f f
DATA 29, 41, 53, 53
'bass, cello & two skinny geese
DATA &H0020C0,&H002AC1,&H0045C2,&H0038C3
'channel pan, volume & vibrato
DATA &H370AB0,&H520AB1,&H2C0AB2,&H600AB3
DATA &H5F07B0,&H5507B1,&H4A07B2,&H5007B3
DATA &H0001B0,&H0001B1,&H0B01B2,&H0001B3
FUNCTION converg (n AS INTEGER) AS INTEGER
DIM m AS INTEGER, t AS INTEGER
m = mx * n
FOR t = 0 TO m ' kill transients
evaluate
NEXT t
converg = m
END FUNCTION
FUNCTION decrule AS STRING
DIM r AS INTEGER, s AS INTEGER, t AS INTEGER
DIM v AS INTEGER, g AS STRING
v = ru(15)
FOR t = 14 TO 0 STEP -1 ' convert to decimal
v = v SHL 1 OR ru(t)
NEXT t
r = v AND 255: s = v SHR 8
IF (r XOR s) = 0 THEN
g = STR$(r) + "e"
ELSE
s = (NOT s) AND 255
IF (r XOR s) = 0 THEN
g = STR$(r) + "r"
ELSE
g = STR$(v)
END IF
END IF
decrule = g
END FUNCTION
SUB evaluate
DIM k AS INTEGER, u AS INTEGER
DIM ul AS INTEGER, ur AS INTEGER
ul = c(mx - 1, sw)
c(mx, sw) = c(0, sw) ' wrap edges
FOR k = 0 TO mx - 1
ul OR= c(k, 1 - sw) SHL 1 ' previous(k)
u = c(k, sw)
ur = c(k + 1, sw)
ur OR= (ul SHL 1 OR u) SHL 1 ' compute context(k)
ul = u: c(k, 1 - sw) = ru(ur) ' update CA
NEXT k
sw XOR= 1 ' switch generations
END SUB
SUB inrule (h AS STRING)
DIM s AS INTEGER, t AS INTEGER
s = VALINT(h) AND 65535
IF s < 256 THEN
IF INSTR(h, "e") THEN
s OR= s SHL 8 ' elementary k = 2, r = 1
ELSEIF INSTR(h, "r") THEN
t = (NOT s) AND 255
s OR= t SHL 8 ' second-order rule
END IF
END IF
FOR t = 0 TO 15
ru(t) = s AND 1 ' convert to binary
s SHR= 1
NEXT t
END SUB
FUNCTION loadp (n AS INTEGER) AS INTEGER
DIM g AS STRING, h AS STRING, r AS INTEGER, t AS INTEGER
DIM tx AS INTEGER, u AS INTEGER, v AS INTEGER
IF n < 0 OR n > 999 THEN n = 0
g = ".\piece000.par": h = STR$(n)
MID$(g, 11 - LEN(h)) = h
IF OPEN(g FOR INPUT AS #1) = 0 THEN
sw = 0: DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, g: g = TRIM$(g)
SELECT CASE LEFT$(g, 2)
CASE "#R"
inrule MID$(g, 3)
CASE "#W"
mx = VALINT(MID$(g, 3))
IF mx < 3 OR mx > MAX THEN mx = MAX
CASE "#S"
g = LTRIM$(MID$(g, 3))
tx = LEN(g) \ 2 - 1
FOR t = 0 TO tx
r = t * 8
v = VALINT("&H" + MID$(g, 2 * t + 1, 2))
FOR u = 0 TO 7
c(r + u, sw) = v AND 1
v SHR= 1
NEXT u
NEXT t: sw = 1 ' state
CASE "#V"
vsp = VALINT(MID$(g, 3))
IF vsp < 0 THEN vsp = 0
CASE "#N"
g = LTRIM$(MID$(g, 3)) ' notes
FOR t = 0 TO 3
r = t * 6
v = VALINT("&H" + MID$(g, 8 * t + 1, 8))
FOR u = 0 TO 5
tn(r + u) = v MOD 30
v \= 30
NEXT u
NEXT t
LOCATE 19, 4: PRINT "-"
CASE "#T"
bpm = VALINT(MID$(g, 3))
IF bpm < 1 THEN bpm = 1
END SELECT
LOOP
st XOR= 1
CLOSE 1
loadp = -1
END IF
END FUNCTION
SUB midiout (wr AS INTEGER)
STATIC bi(3) AS INTEGER, msg(3) AS INTEGER
STATIC fl AS INTEGER, hnd AS INTEGER, sta AS INTEGER
DIM chnk AS INTEGER, k AS INTEGER, os AS INTEGER
DIM r AS INTEGER, s AS INTEGER, t AS INTEGER
'
IF NOT fl THEN
scale 0
FOR t = 0 TO 11 ' bias
READ bi(t AND 3)
NEXT t: fl = -1
sta = 0: st = 0
IF midiOpen(hnd, 0, 0, 0, 0) THEN
LOCATE 21, 2
PRINT "error opening MIDI device "
SLEEP: END
ELSE
FOR t = 0 TO 15 ' initialize midi
READ msg(0)
midiMsg hnd, msg(0)
NEXT t
RESTORE
FOR t = 0 TO 3
msg(t) = 160 + t
NEXT t
END IF
END IF
IF sta XOR st THEN ' map change
sta = st
FOR t = 0 TO 3
msg(t) AND= NOT 16
midiMsg hnd, msg(t)
NEXT t
END IF
IF wr THEN
FOR t = 0 TO 3
os = vsp * t ' segment offset
r = (msg(t) AND 16) = 16
s = c(os MOD mx, sw) = 1
IF r XOR s THEN ' flipped statusbit
IF s THEN
chnk = 0
FOR k = os + 11 TO os + 1 STEP -1
chnk = chnk SHL 1 OR c(k MOD mx, sw)
NEXT k
r = bi(t) + tn((chnk AND 31) MOD 20)
s = 44 + chnk SHR 5
msg(t) = 144 + t ' channel(t) on
msg(t) OR= r SHL 8 ' note number
msg(t) OR= s SHL 16 ' velocity
ELSE
msg(t) AND= NOT 16 ' note off
END IF
midiMsg hnd, msg(t)
END IF
NEXT t
ELSE
midClose hnd ' close midi device
END IF
END SUB
FUNCTION period (n AS INTEGER) AS INTEGER
DIM d(mx - 1, 1) AS INTEGER, k AS INTEGER
DIM p AS INTEGER, s AS INTEGER
FOR k = 0 TO mx - 1
d(k, 0) = c(k, 1 - sw) ' store phase space
d(k, 1) = c(k, sw)
NEXT k
p = 0: DO
evaluate ' cycle
p += 1
FOR k = 0 TO mx - 1
s = c(k, 1 - sw) XOR d(k, 0)
s OR= c(k, sw) XOR d(k, 1) ' compare
IF s THEN EXIT FOR
NEXT k
IF p >= n THEN p = 0: s = 0 ' fail
LOOP WHILE s
period = p
END FUNCTION
SUB populate (gen AS INTEGER)
STATIC fl AS INTEGER, m AS INTEGER
DIM k AS INTEGER, r AS INTEGER, s AS INTEGER
DIM t AS INTEGER, d AS SINGLE, dt AS SINGLE
'
IF (gen = 0) OR (m XOR mx) THEN
IF NOT fl THEN
SCREEN MODE: fl = -1 ' initialize gfx
PALETTE 0, &H282828
PALETTE 1, &H140000
PALETTE 2, &H1529
PALETTE 3, &H23000A
PALETTE 4, &H2330
PALETTE 5, &H0: COLOR 5
r = 1 + dW * .25 * .618
s = r + dW * .75 - 1
VIEW (r, 1)-(s, dH - 2), , 5
sw = 0: rndstat
inrule (STR$(RND * 256) + "e") 'random elementary rule
LOCATE 3, 2: PRINT "rule nr."
LOCATE 4, 4: PRINT decrule$
LOCATE 6, 2: PRINT "window"
vsp = INT(mx * .251)
LOCATE 9, 2: PRINT "space"
LOCATE 10, 3: PRINT vsp
LOCATE 12, 2: PRINT "generation"
LOCATE 15, 2: PRINT "tempo"
LOCATE 16, 3: PRINT bpm
LOCATE 18, 2: PRINT "mode"
END IF
m = mx: d = mx - .5
WINDOW SCREEN (-.5, -.5)-(d, d)
LINE (-1, -1)-(mx, mx), 1, BF ' clear viewport
FOR t = 0 TO mx
dt = t - .5 ' draw grid
LINE (-.5, dt)-(d, dt), 5
LINE (dt, -.5)-(dt, d), 5
NEXT t
LOCATE 7, 3: PRINT mx; " "
END IF
LOCATE 13, 3: PRINT gen; " ";
t = gen MOD mx ' timestep
FOR k = 0 TO mx - 1
PAINT (k, t), c(k, sw) + 1, 5 ' paint cells
NEXT k
FOR s = 0 TO 3
k = (vsp * s) MOD mx
PAINT (k, t), c(k, sw) + 3, 5 ' singin' columns
NEXT s
END SUB
SUB rndcell
DIM k AS INTEGER
FOR k = 0 TO mx - 1
c(k, 0) = 0: c(k, 1) = 0 ' clear all
NEXT k
k = mx SHR 1: st XOR= 1
c(k, 0) = 1: c(k, 1) = 1 ' single alive cell
END SUB
SUB rndstat
DIM k AS INTEGER, s AS INTEGER, t AS INTEGER
s = CINT(mx * .4)
FOR k = 0 TO mx - 1
IF k < s THEN
c(k, 0) = 1: c(k, 1) = 1 ' fixed weight,
ELSE
c(k, 0) = 0: c(k, 1) = 0
END IF
NEXT k
FOR s = 0 TO 1
FOR k = 0 TO mx - 1
t = INT(RND * mx) ' random distribution
SWAP c(k, s), c(t, s)
NEXT n
NEXT s
st XOR= 1
END SUB
SUB roll (fl AS INTEGER)
DIM k AS INTEGER, s AS INTEGER, t AS INTEGER
FOR s = 0 TO 1
IF fl < 0 THEN
t = c(mx - 1, s) ' rotate right,
FOR k = mx - 1 TO 1 STEP -1
c(k, s) = c(k - 1, s)
NEXT k
c(0, s) = t
ELSE
t = c(0, s) ' left
FOR k = 0 TO mx - 2
c(k, s) = c(k + 1, s)
NEXT k
c(mx - 1, s) = t
END IF
NEXT s
st XOR= 1
END SUB
SUB savep (n AS INTEGER)
DIM g AS STRING, h AS STRING, fl AS INTEGER, r AS INTEGER, s AS INTEGER
DIM t AS INTEGER, tx AS INTEGER, u AS INTEGER, v AS INTEGER
IF n < 0 OR n > 999 THEN n = 0
g = ".\piece000.par": h = STR$(n)
MID$(g, 11 - LEN(h)) = h
OPEN g FOR OUTPUT AS #1
PRINT #1, "#D saved by CApieces.bas"
PRINT #1, "#R "; decrule$
PRINT #1, "#W"; mx
tx = (mx - 1) SHR 3
fl = sw XOR 1
FOR s = 0 TO 1 ' states t-1 and t
g = STRING$(2 * tx + 2, "0")
FOR t = 0 TO tx
v = 0: r = t SHL 3
FOR u = 7 TO 0 STEP -1
v = v SHL 1 OR c(r + u, fl)
NEXT u
h = HEX$(v)
MID$(g, 2 * t + 3 - LEN(h)) = h
NEXT t: fl XOR= 1
PRINT #1, "#S "; g
NEXT s
PRINT #1, "#V"; vsp
g = STRING$(32, "0")
FOR t = 0 TO 3 ' shuffled notes
v = 0: r = t * 6
FOR u = 5 TO 0 STEP -1
v = v * 30 + tn(r + u)
NEXT u
h = HEX$(v)
MID$(g, 8 * t + 9 - LEN(h)) = h
NEXT t
PRINT #1, "#N "; g
PRINT #1, "#T"; bpm
CLOSE 1
END SUB
SUB scale (n AS INTEGER)
DIM d(7) AS INTEGER, k AS INTEGER
DIM t AS INTEGER, u AS INTEGER
FOR t = 0 TO 7
READ d(t) ' steps
NEXT t
RESTORE
n AND= 7: st XOR= 1
LOCATE 19, 3: PRINT 1 + n
FOR k = 1 TO n ' rotate
u = d(0)
FOR t = 0 TO 6
d(t) = d(t + 1)
NEXT t
d(7) = u
NEXT k
tn(0) = 0
FOR t = 0 TO 18 ' note numbers
tn(t + 1) = tn(t) + d(t AND 7)
NEXT t
END SUB