'******************************************************************************
'Subject: Rudy Rucker's Laplacian rug rule:
'         purple hazed bubbling lava.
'Author : Sjoerd.J.Schaper
'Date   : 02-11-2006
'Code   : all QBasic's, FreeBasic extendable
'Keys   : [Esc] quit program
'         [Enter] for a unicolor grid
'         [Tab] break four-fold symmetry
'         [Backspc] seed with random states
'         [Space] freeze
'         press any other key to shake the grid
'******************************************************************************
'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 rug rule
DECLARE FUNCTION mix ()
'mix 8-bit colours
DECLARE FUNCTION unigrid ()
'set a unicolor grid
DECLARE SUB mutate ()
'change a single cell
DECLARE FUNCTION rndstat ()
'seed with random states

CONST MODE = 13, dW = 320, dH = 200
' set screenmode, width, height
'CONST MODE = 18, dW = 640, dH = 480 ' FreeBasic only

CONST MAX = 127, nn = MAX * MAX - 1 ' Must be odd!
' maximum grid size 127 for QBasic 1.0

DIM SHARED c(0 TO nn, 1) '            cell indices
DIM SHARED LR, sw '   Laplacian/ generation switch
RANDOMIZE TIMER
LR = -1

t = 0
DO
   populate t
   t = t + 1
   evaluate
   LR = -1

   g$ = INKEY$
   IF g$ <> "" THEN
      SELECT CASE ASC(g$)
      CASE 8
         t = rndstat '                scatter
      CASE 9
         mutate '                     flip
      CASE 13
         t = unigrid '                reset
      CASE 27
         EXIT DO '                    quit
      CASE 32
         LOCATE 4, 1: PRINT t;
         LOCATE 8, 2: PRINT "0   ";
         SLEEP '                      freeze
      CASE ELSE
         LR = 0 '                     shake
      END SELECT
      WHILE INKEY$ <> "": WEND
   END IF
LOOP
SYSTEM

SUB evaluate STATIC
IF NOT fl THEN
DIM a(3), b(3): fl = -1
   a(0) = 1: a(2) = -a(0) '           E,W
   a(1) = MAX: a(3) = -a(1) '         S,N
   b(0) = MAX + 1: b(2) = -b(0) '     SE,NW
   b(1) = MAX - 1: b(3) = -b(1) '     SW,NE
END IF

   FOR r = 1 TO MAX - 2
      FOR k = r * MAX + 1 TO (r + 1) * MAX - 2

         sa = 0: sb = 10 '            (round up)
         FOR t = 0 TO 3 '             sum cell states
            sa = sa + c(k + a(t), sw)
            sb = sb + c(k + b(t), sw)
         NEXT t

         IF LR THEN
            t = (sa * 4 + sb) \ 20 '  solution to Laplacian
         ELSE
            t = sa - 4 * c(k, sw) + 1023 ' disturb
         END IF

         c(k, 1 - sw) = (t + 1) AND 255 ' update cell
      NEXT k
   NEXT r

   sw = 1 - sw '                      switch generations
END SUB

FUNCTION mix
DIM col(255) AS LONG
DIM cmp(2, 1), df(2) AS SINGLE

   pi! = 4 * ATN(1)
   wo! = pi! / 255 * 9.618 '          velocity
   'blue                              component ranges
   cmp(0, 0) = 35
   cmp(0, 1) = 45
   df(0) = 0
   'green
   cmp(1, 0) = 0
   cmp(1, 1) = 58
   df(1) = wo! * .66
   'red
   cmp(2, 0) = 20
   cmp(2, 1) = 63
   df(2) = -wo!

   col(0) = &HA0004
   FOR t = 0 TO 2
      c0 = cmp(t, 0)
      dc = cmp(t, 1) - c0
      FOR k = 1 TO 255 '              colour mixer
         s! = SIN(df(t) + k * wo!)
         c1 = c0 + CINT(s! * s! * dc)
         col(k) = col(k) * 256 + c1
      NEXT k
   NEXT t
   PALETTE USING col(0)

mix = CINT(pi! / (2 * wo!))
END FUNCTION

SUB mutate
   x = (MAX - 1) \ 2 '                axial cell
   y = 1 + INT(RND * (MAX - 2))
   k = y * MAX + x
   c(k, sw) = INT(RND * 256)
END SUB

SUB populate (gen)
STATIC fl, g0, t0!
IF gen = 0 THEN
   IF NOT fl THEN
      SCREEN MODE '                   8 bpp
      sw = mix: COLOR sw

      r = 1 + dW * .25 * .618
      s = r + dW * .75 - 1: fl = -1
      VIEW (r, 1)-(s, dH - 2), , sw
      LOCATE 3, 2: PRINT "gen.";
      LOCATE 7, 2: PRINT "v*10";
      sw = unigrid '                  initialize
   END IF
   LOCATE 4, 2: PRINT "    ";

   g0 = 0: t0! = TIMER: d! = .5
   WINDOW SCREEN (d!, d!)-(MAX - 1 - d!, MAX - 1 - d!)
   LINE (0, 0)-(MAX - 1, MAX - 1), 0, BF
END IF

   d! = .491
   WAIT &H3DA, 8
   FOR k = 0 TO nn '                  update CA
      IF c(k, sw) XOR c(k, 1 - sw) THEN
         y = k \ MAX
         x = k - y * MAX
         LINE (x - d!, y - d!)-(x + d!, y + d!), c(k, sw), BF
      END IF
   NEXT k
 
   dt! = TIMER - t0!
   IF dt! > 1 THEN
      LOCATE 4, 1: PRINT gen;
      LOCATE 8, 1: PRINT CINT(10 * (gen - g0) / dt!); " ";
      g0 = gen: t0! = TIMER
   END IF
END SUB

FUNCTION rndstat
   k = unigrid '                      for border bias
   FOR r = 1 TO MAX - 2 '             primordial soup
      FOR s = 1 TO MAX - 2
         k = r * MAX + s
         c(k, sw) = INT(RND * 256)
      NEXT s
   NEXT r
rndstat = 0
END FUNCTION

FUNCTION unigrid
   col = INT(RND * 256)
   FOR k = 0 TO nn '                  clear
      c(k, 0) = col: c(k, 1) = col
   NEXT k
unigrid = 0
END FUNCTION