'******************************************************************************
'Subject: 1-D continuous-valued cellular automata:
' model of two complex vibrating strings.
'Author : Sjoerd.J.Schaper - vspickelen
'Date : 03-11-2006
'Code : all QBasic's, FreeBasic extendable
'Keys : [Esc] quit program
' [0]...[3] set thirds stack
' [F1]...[F7] choose scale degree,
' next press [0]...[3] for an inversion
' [Enter] switch to loop mode
' [Space] skip CA updates
' [Backspc] reverse the simulation
' [+] and [-] adjust wave amplitude
' [Tab] choose left/ right string,
' [Up] or [Down arrow] to change wave speed
' press any other key for random noise
'******************************************************************************
'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.
'******************************************************************************
'
DECLARE SUB populate (t AS INTEGER)
'display the automaton at time t
DECLARE SUB evaluate ()
'apply the linear wave rule
DECLARE FUNCTION chords% (fl AS INTEGER)
'seed with diatonic chords
'note: replace qb suffix% with AS INTEGER to compile w/fb 0.17b
DECLARE SUB FMod (f AS SINGLE, fm() AS SINGLE, r AS INTEGER)
'modulate sine wave carrier
DECLARE SUB wryte (fl AS INTEGER)
'create .wav-soundfile
CONST MODE = 12, dW = 640, dH = 480
' set screenmode, width, height
CONST BASF = 48 ' base velocity
CONST SRAT = 16000 ' sample rate
CONST MAX = SRAT * (BASF / 264) ' tuned stringlength
CONST GAIN = 1.26, DWV = 1.07 ' parameter defaults
DIM SHARED c(MAX, 3) AS SINGLE, Wav(1) AS SINGLE
' cell states, wave parameter
DIM SHARED lr(1, 1) AS INTEGER, sw AS INTEGER
' generation switches
DIM SHARED plot AS INTEGER, pile AS INTEGER
' gfx switch, pile o'thirds
DIM SHARED deg AS INTEGER, inv AS INTEGER
' scale degree, inversion
DIM auto AS INTEGER, dt AS INTEGER, fl AS INTEGER
DIM k AS INTEGER, r AS INTEGER, sc AS INTEGER
DIM t AS INTEGER, tmx AS INTEGER, ud AS INTEGER
DIM a AS SINGLE, v AS SINGLE, g AS STRING
RANDOMIZE TIMER
auto = 0: fl = 0: ud = -1
dt = 1: t = 0
DO
IF ud THEN populate t
wryte -1: t = t + dt
IF ud THEN evaluate
IF t = 0 AND dt = -1 THEN
LOCATE 3, 29: PRINT "key..."
SLEEP
LOCATE 3, 29: PRINT " "
WHILE INKEY$ <> "": WEND
sw = 1 - sw
dt = 1: t = 1
END IF
g = INKEY$
IF g <> "" THEN
sc = ASC(RIGHT$(g, 1))
IF LEN(g) > 1 THEN sc = sc + 128
SELECT CASE sc
CASE 8
sw = 1 - sw
dt = -dt: t = t + dt ' reverse time
CASE 9
fl = 1 - fl ' toggle l/ r
CASE 13
auto = -1: tmx = 12 ' largo loop
deg = 0: inv = 0
dt = 1: t = chords(0)
CASE 27
EXIT DO ' quit
CASE 32
ud = NOT ud ' freeze
CASE 43, 45
plot = NOT plot: a = GAIN
IF sc = 45 THEN a = 1 / a
FOR k = 0 TO MAX - 1 ' gain
FOR r = 0 TO 3
v = c(k, r) * a
IF ABS(v) > 1 THEN v = SGN(v)
c(k, r) = v
NEXT r
NEXT k
CASE 48 TO 57
pile = (sc - 48) MOD 4 ' thirds
CASE 187 TO 193
auto = 0
deg = sc - 187 ' degree
WHILE INKEY$ <> "": WEND
DO: g = INKEY$
LOOP WHILE g = ""
inv = ASC(RIGHT$(g, 1)) - 48 ' inversion
dt = 1: t = chords(0)
CASE 200, 208
a = Wav(fl) * DWV ' speed
IF sc = 208 THEN a = Wav(fl) / DWV
IF a < 1 THEN Wav(fl) = a
LOCATE 28, 2: PRINT "speed left:"; Wav(0); " ";
LOCATE 28, 29: PRINT "right:"; Wav(1); " ";
CASE ELSE
auto = 0
deg = -1: inv = -1
dt = 1: t = chords(0) ' reset
END SELECT
WHILE INKEY$ <> "": WEND
END IF
IF auto AND (t > tmx) THEN
dt = 1: t = chords(-1)
END IF
LOOP
wryte 0
SYSTEM
'interval ratios
DATA 1,1, 9,8, 6,5, 5,4, 4,3, 64,45
DATA 3,2, 5,3, 16,9, 9,5, 15,8
'chords table
DATA "I","II","III","IV","V","VI","VII"
'primes
DATA 0, 1, 3, 4, 6, 7, 10
'thirds
DATA 3, 2, 2, 3, 3, 2, 2
'fifths
DATA 6, 6, 6, 6, 6, 6, 5
'sevenths
DATA 10, 8, 9, 10, 8, 8, 8
FUNCTION chords% (auto AS INTEGER)
'note: replace qb suffix% with AS INTEGER to compile w/fb 0.17b
STATIC dep AS INTEGER, fl AS INTEGER
STATIC dd() AS INTEGER, ix() AS INTEGER
STATIC iv() AS SINGLE, sy() AS STRING
DIM a AS SINGLE, ch(3) AS SINGLE, fm(2, 1) AS SINGLE
DIM d(1) AS INTEGER, dr AS INTEGER, k AS INTEGER, r AS INTEGER
DIM r2 AS INTEGER, s AS INTEGER, sg AS INTEGER, t AS INTEGER
'
IF NOT fl THEN
REDIM dd(3) AS INTEGER, ix(3, 6) AS INTEGER
REDIM iv(10) AS SINGLE, sy(6) AS STRING
'
FOR t = 0 TO 10 ' read intervals
READ r, s
iv(t) = r / s
NEXT t
FOR t = 0 TO 6 ' read symbols
READ sy(t)
NEXT t
FOR r = 0 TO 3 ' read indices
FOR t = 0 TO 6
READ ix(r, t)
NEXT t
NEXT r
dd(0) = 3: dd(1) = 1
dd(2) = 5: dd(3) = 6
fl = -1
END IF
'FM parameters left/ right
fm(0, 0) = .5: fm(0, 1) = 1.25 ' modulator 1 & 2 mult's
fm(1, 0) = .5: fm(1, 1) = .75
fm(2, 0) = 6: fm(2, 1) = 4 ' deviation 1 & 2
d(0) = CINT(MAX * .618034)
d(1) = CINT(MAX * .3183099) ' phase shift l/r
LOCATE 2, 2: sg = -1
IF auto THEN
DO
t = INT(RND * 4) ' random progression
r = (deg + dd(t)) MOD 7
LOOP WHILE r = dep
dep = deg: deg = r
inv = 0
IF t = 3 THEN
inv = 1 + INT(RND * 3)
END IF
ELSE
IF inv < 0 THEN
FOR r = 0 TO 2
FOR t = 0 TO 1 ' random noise
s = 3: IF r > 1 THEN s = 9
fm(r, t) = .125 + RND * s
NEXT t
NEXT r: sg = 0
inv = INT(RND * (pile + 1))
END IF
IF deg < 0 THEN ' random degree
deg = INT(RND * 7): sg = 0
END IF
END IF
inv = inv MOD (pile + 1)
IF sg THEN
PRINT sy(deg); inv; " ";
ELSE
PRINT "random";
END IF
ch(0) = BASF * iv(ix(0, deg))
FOR t = 1 TO pile ' stack thirds
ch(t) = ch(0) * iv(ix(t, deg))
NEXT t
deg = (deg + inv * 2) MOD 7
IF inv > 0 THEN ' invert
FOR t = 0 TO inv - 1 ' bass ch(inv)
ch(t) = ch(t) * 2
NEXT t
IF (ch(inv) - .01) > BASF * iv(10) THEN ' b
FOR t = 0 TO pile
ch(t) = ch(t) * .5
NEXT t
END IF
END IF
FOR t = 1 TO pile
r = (inv + t) MOD (pile + 1)
IF (ch(r) + .01) < BASF * iv(8) THEN ' b-flat
ch(r) = ch(r) * 2
END IF
NEXT t
LOCATE 2, 28: PRINT SPACE$(20);
LOCATE 2, 28
FOR t = 0 TO pile
PRINT CINT(ch(t) * SRAT / MAX);
NEXT t
dr = 1
FOR r = 0 TO 1
r2 = r + r
FOR k = 0 TO MAX - 1
c(k, r2) = 0
NEXT k
FOR t = 0 TO pile ' FM timbre
FMod ch(t), fm(), r2
NEXT t
a = 0
FOR k = 0 TO MAX - 1 ' shift
c(k, dr) = c((k + d(r)) MOD MAX, r2)
IF ABS(c(k, dr)) > a THEN a = ABS(c(k, dr))
NEXT k
a = .615 * LOG(pile + 2) / a
FOR k = 0 TO MAX - 1
c(k, dr) = c(k, dr) * a ' normalize
c(k, r2) = c(k, dr) ' copy back
NEXT k
dr = 3
NEXT r
chords = 0
END FUNCTION
SUB evaluate
DIM a AS SINGLE, u AS SINGLE, ul AS SINGLE, ur AS SINGLE
DIM k AS INTEGER, s AS INTEGER, s1 AS INTEGER, t AS INTEGER
'
FOR t = 0 TO 1
s1 = lr(t, 1 - sw)
s = lr(t, sw)
ul = c(MAX - 1, s) ' wrap boundary
c(MAX, s) = c(0, s)
FOR k = 0 TO MAX - 1
u = c(k, s)
ur = c(k + 1, s)
a = ul + ur: ul = u: u = u + u
a = (a - u) * Wav(t) + u - c(k, s1)
IF ABS(a) > 1 THEN a = SGN(a) ' clip
c(k, s1) = a ' update CA
NEXT k
NEXT t
sw = 1 - sw ' switch generations
END SUB
SUB FMod (f AS SINGLE, fm() AS SINGLE, r AS INTEGER)
STATIC fl AS INTEGER, sine() AS SINGLE
DIM i(1) AS SINGLE, v(2) AS LONG
DIM a AS INTEGER, k AS INTEGER, w AS SINGLE
'
IF NOT fl THEN
REDIM sine(MAX - 1) AS SINGLE
'
w = 8 * ATN(1) / MAX
FOR k = 0 TO MAX - 1 ' base oscillator
sine(k) = SIN(k * w)
NEXT k
fl = -1
END IF
v(0) = f * fm(r \ 2, 0) ' modulator ratios,
v(1) = f * fm(r \ 2, 1)
v(2) = CLNG(f)
i(0) = MAX * fm(2, 0) / v(0) ' indices
i(1) = MAX * fm(2, 1) / v(1)
FOR k = 0 TO MAX - 1
a = i(0) * sine(k * v(0) MOD MAX) ' two-into-one
a = a + i(1) * sine(k * v(1) MOD MAX)
c(k, r) = c(k, r) + sine((k * v(2) + a) MOD MAX)
NEXT k
END SUB
SUB populate (gen AS INTEGER)
STATIC fl AS INTEGER, pl AS INTEGER
DIM i AS INTEGER, k AS INTEGER, r AS INTEGER
DIM s AS INTEGER, s1 AS INTEGER, t AS INTEGER
'
IF (gen = 0) OR (pl XOR plot) THEN
IF NOT fl THEN
SCREEN MODE
COLOR 7: fl = -1
VIEW (2, 79)-(dW - 3, dH - 80), , 7
WINDOW (0, -2)-(MAX - 1, 2)
sw = 0 ' initialize
lr(0, sw) = 0: lr(0, 1 - sw) = 1 'left,
lr(1, sw) = 2: lr(1, 1 - sw) = 3 'right string
Wav(0) = .06: Wav(1) = .09 ' wave speed
deg = -1: inv = -1
pile = 3: plot = chords(0)
LOCATE 3, 2: PRINT "genr.";
LOCATE 28, 2: PRINT "speed left:"; Wav(0);
LOCATE 28, 29: PRINT "right:"; Wav(1);
END IF
pl = plot
LOCATE 3, 8: PRINT " ";
LINE (0, -2)-(MAX - 1, 2), 0, BF
LINE (0, 0)-(MAX - 1, 0), 7
END IF
LOCATE 3, 7: PRINT gen; " ";
i = 1
FOR r = 0 TO 1
s1 = lr(r, 1 - sw)
s = lr(r, sw)
FOR k = 1 TO MAX - 1 ' plot curves l/r
t = k - 1
LINE (t, c(t, s1) + i)-(k, c(k, s1) + i), 0
LINE (t, c(t, s) + i)-(k, c(k, s) + i), 7
NEXT k: i = -1
NEXT r
END SUB
SUB wryte (wr AS INTEGER)
STATIC a AS INTEGER, fl AS INTEGER, i AS LONG
DIM g AS STRING, k AS INTEGER, p AS INTEGER
DIM sl AS INTEGER, sr AS INTEGER
DIM word AS STRING * 2
DIM dword AS STRING * 4
'
IF NOT fl THEN
OPEN ".\CAsounds.wav" FOR BINARY AS #1
'RIFF type chunk
i = 1
dword = "RIFF"
PUT #1, i, dword ' chunk ID
dword = "WAVE"
PUT #1, i + 8, dword ' RIFF type
i = i + 12
'Format chunk
dword = "fmt "
PUT #1, i, dword ' chunk ID
dword = MKL$(16)
PUT #1, i + 4, dword ' chunk data size
word = MKI$(1)
PUT #1, i + 8, word ' compression code
word = MKI$(2)
PUT #1, i + 10, word ' number of channels
dword = MKL$(SRAT)
PUT #1, i + 12, dword ' sample rate
p = SRAT * 2: dword = MKL$(p)
PUT #1, i + 16, dword ' average bytes per second
word = MKI$(2)
PUT #1, i + 20, word ' block align
word = MKI$(8)
PUT #1, i + 22, word ' significant bits per sample
i = i + 24
'Data chunk
dword = "data"
PUT #1, i, dword ' chunk ID
i = i + 8: fl = -1
a = 126 ' -.1 dB peak
END IF
IF wr THEN
sl = lr(0, sw)
sr = lr(1, sw): p = 1
g = STRING$(MAX * 2, " ")
FOR k = 0 TO MAX - 1
MID$(g, p, 1) = CHR$(CINT(c(k, sl) * a) + 128)
MID$(g, p + 1, 1) = CHR$(CINT(c(k, sr) * a) + 128)
p = p + 2
NEXT k
PUT #1, i, g
i = i + MAX * 2
ELSE
dword = MKL$(i - 8)
PUT #1, 5, dword ' filelength - 8
dword = MKL$(i - 44)
PUT #1, 41, dword ' data chunk size
CLOSE
END IF
END SUB