Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.

Topics - STxAxTIC

Pages: [1] 2 3 ... 5

QB64 Discussion / TIMER vs SLEEP

« on: March 28, 2022, 07:57:16 am »

What happens when the unstoppable force of TIMER meets the immovable object of SLEEP?

Code: QB64: [Select]

Screen _NewImage(600, 600, 32)
 
Dim t1 As _Unsigned Long
t1 = _FreeTimer
On Timer(t1, .01) moo
Timer(t1) On
 
Do
    PSet (Rnd * _Width, Rnd * _Height), _RGB(255, 255, 255)
    'Sleep
    _Display
Loop
 
 
Sub moo
    'do nothing
End Sub

When there's a Timer at play, SLEEP never fully halts the program - or, it sorta does. It slows the thing down in kindof an interesting way. Not that anybody should ever depend on SLEEP for anything, so it's weird that this question would come up in the first place.... anyway... Thought I'd share.

Programs / Finished Driven Pendulum + Mouse Toy

« on: March 22, 2022, 04:32:01 pm »

REDACTED

Programs / Double Pendulum Studies

« on: March 12, 2022, 03:08:58 pm »

REDACTED

Programs / Oddly satisfying Lissajous Glyphs

« on: March 02, 2022, 12:14:33 am »

REDACTED

Programs / Domain Coloring

« on: February 14, 2022, 01:54:11 pm »

Code: QB64: [Select]

'A = render anti-aliased image
'B = render standard image
 
'MouseButton1 = Re-center
'MouseButton3 = Zoom x2 (in)
'MouseButton2 = Zoom /2 (out)
 
'Leftarrow  = Next example plot
'Rightarrow = Previous example plot
'Uparrow    = Increase iterations (where applicable)
'DownArrow  = Decrease iterations (where applicable)
 
'Num 1 = Shading option (HSV vs RGB vs Average)
'Num 2 = Shading scheme (1, 2, 3)
'Num 3 = Shade near origin
'Num 4 = Shade axes
'Num 5 = Shade integers
'Num 6 = Shade contours
'Num 7 = Greyscale
'Num 8 = Stencil
'Num 9 = Invert
'Num 0 = Bolden
 
OPTION _EXPLICIT
DO UNTIL _SCREENEXISTS: LOOP
_TITLE "Domain Coloring"
 
'SCREEN _NEWIMAGE(250, 250, 32)
SCREEN _NEWIMAGE(800, 800, 32)
'SCREEN _NEWIMAGE(1024, 768, 32)
'SCREEN _NEWIMAGE(1920, 1080, 32)
 
DIM SHARED pi AS DOUBLE
pi = 4 * ATN(1)
 
DIM AS LONG q
DIM AS DOUBLE zoom, xshift, yshift, re, im
DIM AS STRING ExhibitName
DIM SHARED PlotOption(0 TO 10) AS DOUBLE
 
PlotOption(0) = 10
PlotOption(1) = .5
PlotOption(2) = 1
PlotOption(3) = 1
PlotOption(4) = 1
PlotOption(5) = 1
PlotOption(6) = 1
PlotOption(7) = -1
PlotOption(8) = -1
PlotOption(9) = -1
PlotOption(10) = -1
 
' Selector
q = 1
 
Initialize q, ExhibitName, zoom, xshift, yshift
CALL DrawPlot(ExhibitName, zoom, xshift, yshift, -1)
 
' User interaction
DIM kh AS INTEGER
DIM ReDraw AS INTEGER
DO
    DO WHILE _MOUSEINPUT
        re = xshift + (_MOUSEX - _WIDTH / 2) / zoom
        im = yshift - (_MOUSEY - _HEIGHT / 2) / zoom
        Calculate re, im, ExhibitName
        'LOCATE 5, 1: PRINT "re: "; INT(re + .5); "      "
        'LOCATE 6, 1: PRINT "im: "; INT(im + .5); "      "
        IF (_MOUSEBUTTON(1)) THEN
            xshift = xshift + (_MOUSEX - _WIDTH / 2) / zoom
            yshift = yshift - (_MOUSEY - _HEIGHT / 2) / zoom
            ReDraw = -1
            DO WHILE _MOUSEINPUT: LOOP
        END IF
        IF (_MOUSEBUTTON(2)) THEN
            zoom = zoom * 1 / 2
            ReDraw = -1
            DO WHILE _MOUSEINPUT: LOOP
        END IF
        IF (_MOUSEBUTTON(3)) THEN
            zoom = zoom * 2
            ReDraw = -1
            DO WHILE _MOUSEINPUT: LOOP
        END IF
    LOOP
    DO WHILE _MOUSEINPUT: LOOP
    kh = _KEYHIT
    _KEYCLEAR
    IF ((kh = ASC("a")) OR (kh = ASC("A"))) THEN
        ReDraw = 1
    END IF
    IF ((kh = ASC("b")) OR (kh = ASC("B"))) THEN
        ReDraw = -1
    END IF
    IF (kh = ASC("1")) THEN
        PlotOption(1) = PlotOption(1) + .5
        IF ((PlotOption(1) > 1)) THEN PlotOption(1) = 0
        ReDraw = -1
    END IF
    IF (kh = ASC("2")) THEN
        PlotOption(2) = PlotOption(2) + 1
        IF (PlotOption(2) > 4) THEN PlotOption(2) = 1
        ReDraw = -1
    END IF
    IF (kh = ASC("3")) THEN PlotOption(3) = -PlotOption(3): ReDraw = -1
    IF (kh = ASC("4")) THEN PlotOption(4) = -PlotOption(4): ReDraw = -1
    IF (kh = ASC("5")) THEN PlotOption(5) = -PlotOption(5): ReDraw = -1
    IF (kh = ASC("6")) THEN PlotOption(6) = -PlotOption(6): ReDraw = -1
    IF (kh = ASC("7")) THEN PlotOption(7) = -PlotOption(7): ReDraw = -1
    IF (kh = ASC("8")) THEN PlotOption(8) = -PlotOption(8): ReDraw = -1
    IF (kh = ASC("9")) THEN PlotOption(9) = -PlotOption(9): ReDraw = -1
    IF (kh = ASC("0")) THEN PlotOption(10) = -PlotOption(10): ReDraw = -1
    IF ((kh = ASC(" ")) OR (kh = 19712)) THEN
        q = q + 1
        Initialize q, ExhibitName, zoom, xshift, yshift
        ReDraw = -1
    END IF
    IF (kh = 19200) THEN
        q = q - 1
        IF (q = 0) THEN q = 1
        Initialize q, ExhibitName, zoom, xshift, yshift
        ReDraw = -1
    END IF
    IF (kh = 18432) THEN
        PlotOption(0) = PlotOption(0) + 1
        ReDraw = -1
    END IF
    IF (kh = 20480) THEN
        PlotOption(0) = PlotOption(0) - 1
        IF (PlotOption(0) < 0) THEN PlotOption(0) = 0
        ReDraw = -1
    END IF
    IF (ReDraw <> 0) THEN
        CALL DrawPlot(ExhibitName, zoom, xshift, yshift, ReDraw)
        ReDraw = 0
    END IF
LOOP
 
SLEEP
 
SYSTEM
 
SUB Initialize (x AS LONG, ExhibitName AS STRING, zoom AS DOUBLE, xshift AS DOUBLE, yshift AS DOUBLE)
    xshift = 0
    yshift = 0
    zoom = 50 * 2
    SELECT CASE x
        CASE 1
            ExhibitName = "Vanilla"
        CASE 2
            ExhibitName = "Monomial"
        CASE 3
            ExhibitName = "Pole"
        CASE 4
            ExhibitName = "Shifts"
        CASE 5
            ExhibitName = "Geometric Series"
            PlotOption(0) = 5
        CASE 6
            ExhibitName = "Taylor"
            PlotOption(0) = 10
        CASE 7
            ExhibitName = "Exponential"
        CASE 8
            ExhibitName = "Logarithm"
        CASE 9
            ExhibitName = "Sqrt"
        CASE 10
            ExhibitName = "Branch"
        CASE 11
            ExhibitName = "Cosine"
        CASE 12
            ExhibitName = "Sine"
        CASE 13
            ExhibitName = "Gamma"
        CASE 14
            ExhibitName = "Condenser"
        CASE 15
            ExhibitName = "Inductor"
        CASE 16
            ExhibitName = "Mandelbrot"
            xshift = -.5 - .25
            PlotOption(0) = 1
        CASE 17
            ExhibitName = "Julia"
            PlotOption(0) = 8
        CASE 18
            ExhibitName = "CIF1"
            PlotOption(0) = 10
        CASE 19
            ExhibitName = "CIF2"
            PlotOption(0) = 50
        CASE 20
            ExhibitName = "CIF3"
        CASE 21
            ExhibitName = "Canonical Logarithm"
        CASE ELSE
    END SELECT
END SUB
 
SUB Calculate (x AS DOUBLE, y AS DOUBLE, a AS STRING)
    DIM AS INTEGER j, m, n
    DIM AS DOUBLE re, im, u, v, u0, v0, uu, vv, fu, fv, xx, yy, p, q, t
 
    SELECT CASE a
        CASE "Vanilla"
            re = x
            im = y
 
        CASE "Monomial"
            're = x ^ 2 - y ^ 2
            'im = 2 * x * y
            'cexp re, im, x, y, 2, 0
            cexp re, im, x, y, 3, 0
 
        CASE "Pole"
            'cexp re, im, x, y, -1, 0
            cexp re, im, x, y, -2, 0
 
        CASE "Shifts"
            'cdiv u, v, x + 1, y, x - 1, y
            cdiv u, v, x, y, x - 1, y
            re = u
            im = v
 
        CASE "Geometric Series"
            p = 0
            q = 0
            u = 1
            v = 0
            cadd u0, v0, p, q, u, v
            FOR m = 1 TO PlotOption(0)
                cexp uu, vv, x, y, m, 0
                cadd p, q, u0, v0, uu, vv
                u0 = p
                v0 = q
            NEXT
            re = u0
            im = v0
 
        CASE "Taylor"
            p = 0
            q = 0
            u = 1
            v = 0
            cadd u0, v0, p, q, u, v
            FOR m = 1 TO PlotOption(0)
                cexp uu, vv, x, y, m, 0
                cdiv u, v, uu, vv, facto&(m), 0
                cadd p, q, u0, v0, u, v
                u0 = p
                v0 = q
            NEXT
            re = u0
            im = v0
 
        CASE "Exponential"
            cexp re, im, EXP(1), 0, x, y
 
        CASE "Logarithm"
            clog re, im, x, y
 
        CASE "Sqrt"
            cexp re, im, x, y, 1 / 2, 0
 
        CASE "Branch"
            cdiv p, q, x + 2, y + 1, x - 2, y - 1
            clog re, im, p, q
 
        CASE "Cosine"
            cosz re, im, x, y
 
        CASE "Sine"
            sinz re, im, x, y
 
        CASE "Gamma"
            ' Is this right?
            uu = x - y
            vv = x + y
            cgamma uu, vv, x, y
            re = uu
            im = vv
 
        CASE "Condenser"
            re = 1
            im = 0
            FOR j = 0 TO 7
                cmul u, v, 1, 0, -0.1 * (j - 3.5), 0
                cmul re, im, re, im, x - u, y - v - 0.1
                cdiv re, im, re, im, x - u, y - v + 0.1
            NEXT
 
        CASE "Inductor"
            re = 1
            im = 0
            FOR j = 0 TO 5
                cmul u, v, 1, 0, 0, -0.18 * (j - 2.5)
                cmul re, im, re, im, x - u - 0.2, y - v
                cdiv re, im, re, im, x - u + 0.2, y - v + 0.1
            NEXT
 
        CASE "Mandelbrot"
            u = x
            v = y
            FOR m = 0 TO PlotOption(0) '2 '5 '00
                u0 = u
                v0 = v
                u = u0 ^ 2 - v0 ^ 2 + x
                v = 2 * u0 * v0 + y
            NEXT
            re = u
            im = v
 
        CASE "Julia"
            u = x
            v = y
            FOR m = 0 TO PlotOption(0)
                u0 = u
                v0 = v
                u = u0 ^ 2 - v0 ^ 2 + 0.35
                v = 2 * u0 * v0 + 0 '0.5
            NEXT
            re = u
            im = v
 
        CASE "CIF1"
            ' Riemann sum resolution
            n = PlotOption(0) '25
            xx = 0
            yy = 0
 
            FOR j = 0 TO n - 1
 
                ' Integration contour
                ' 1:
                'u = 3 * (2 * COS(j * 2 * pi / n))
                'v = 3 * (2 * SIN(j * 2 * pi / n))
                ' 2:
                u = 4 * (2 * COS(j * 2 * pi / n))
                v = 4 * (2 * SIN(j * 2 * pi / n) * COS(j * 2 * pi / n))
 
                ' f(z)
                fu = u - v 'u ^ 2 - v ^ 2
                fv = u + v '2 * u * v
 
                ' f(z) / (z - z_0)
                cdiv uu, vv, fu, fv, u - x, v - y
 
                ' z'(t) = derivative of integration contour
                ' 1:
                'cmul re, im, uu, vv, 3 * (-2 * SIN(j * 2 * pi / n)), 3 * (2 * COS(j * 2 * pi / n))
                ' 2:
                cmul re, im, uu, vv, 4 * (-2 * SIN(j * 2 * pi / n)), 4 * (2 * COS(j * 4 * pi / n))
 
                ' Integral height calculation
                IF ((j = 0) OR (j = n - 1)) THEN
                    xx = xx + 0.5 * re
                    yy = yy + 0.5 * im
                ELSE
                    xx = xx + re
                    yy = yy + im
                END IF
            NEXT
 
            ' Integral base calculation
            xx = xx * 2 * pi / n
            yy = yy * 2 * pi / n
 
            ' Rescale by 1/(2*pi*i)
            cmul re, im, xx, yy, 0, -1 / (2 * pi)
 
        CASE "CIF2"
            ' Riemann sum resolution
            n = PlotOption(0) '10
            xx = 0
            yy = 0
 
            DIM xr AS DOUBLE
            DIM xi AS DOUBLE
            xr = 2.0
            xi = 0.0
 
            FOR j = 0 TO n - 1
 
                ' Integration contour
                u = 3 * 3 * COS(j * 2 * pi / n)
                v = 3 * 2 * SIN(j * 2 * pi / n)
 
                ' f(z)
                sinz fu, fv, u, v
 
                ' f(z) / (z - z_0)^(xr + i xi)
                p = u - x
                q = v - y
                cexp p, q, p, q, xr, xi
                cdiv uu, vv, fu, fv, p, q
 
                ' z'(t) = derivative of integration contour
                cmul re, im, uu, vv, 3 * -3 * SIN(j * 2 * pi / n), 2 * COS(j * 2 * pi / n)
 
                ' Integral height calculation
                IF ((j = 0) OR (j = n - 1)) THEN
                    xx = xx + 0.5 * re
                    yy = yy + 0.5 * im
                ELSE
                    xx = xx + re
                    yy = yy + im
                END IF
            NEXT
 
            ' Integral base calculation
            xx = xx * 2 * pi / n
            yy = yy * 2 * pi / n
 
            ' rescale by Gamma(xr + i ri)/(2*pi*i)
            cgamma u, v, xr + 1, xi
            cmul re, im, xx, yy, u, v
            cmul re, im, re, im, 0, -1 / (2 * pi)
 
        CASE "CIF3"
            xx = 0
            yy = 0
            FOR t = 0 TO 3 STEP 0.1
                uu = t * COS(5 * t)
                vv = t * SIN(5 * t)
                cexp p, q, EXP(1), 0, uu, vv
                cdiv u0, v0, p, q, uu - x, vv - y
                cmul p, q, u0, v0, COS(5 * t) - 5 * t * SIN(5 * t), SIN(5 * t) + 5 * t * COS(5 * t)
                IF ((t = 0) OR (t = 3)) THEN
                    xx = xx + 0.5 * p
                    yy = yy + 0.5 * q
                ELSE
                    xx = xx + 1 * p
                    yy = yy + 1 * q
                END IF
            NEXT
            xx = xx * 0.01
            yy = yy * 0.01
            cmul re, im, xx, yy, 0, -1 / (2 * pi)
 
        CASE "Canonical Logarithm"
            DIM AS DOUBLE a0, k0, sx0, sy0, tx0, ty0
            a0 = .5
            k0 = 0.09
            sx0 = 2
            sy0 = 1
            tx0 = a0 * EXP(k0 * 16) * COS(16) + sx0
            ty0 = a0 * EXP(k0 * 16) * SIN(16) + sy0
            re = 0
            im = 0
            FOR t = 0 TO 16 STEP .1
                p = a0 * EXP(k0 * t) * COS(t) + sx0 - tx0
                q = a0 * EXP(k0 * t) * SIN(t) + sy0 - ty0
                cdiv uu, vv, 1, 0, p - x, q - y
                cmul xx, yy, uu, vv, a0 * EXP(k0 * t) * (k0 * COS(t) - SIN(t)), a0 * EXP(k0 * t) * (k0 * SIN(t) + COS(t))
                re = re + xx
                im = im + yy
            NEXT
            FOR t = 16 - .1 TO 0 STEP -.1
                p = -a0 * EXP(k0 * t) * COS(t) - sx0 + tx0
                q = -a0 * EXP(k0 * t) * SIN(t) - sy0 + ty0
                cdiv uu, vv, 1, 0, p - x, q - y
                cmul xx, yy, uu, vv, a0 * EXP(k0 * t) * (k0 * COS(t) - SIN(t)), a0 * EXP(k0 * t) * (k0 * SIN(t) + COS(t))
                re = re + xx
                im = im + yy
            NEXT
            re = re * 0.1
            im = im * 0.1
            cmul uu, vv, re, im, 0, -1 / (2 * pi)
            re = uu
            im = vv
 
        CASE ELSE
    END SELECT
 
    x = re
    y = im
END SUB
 
SUB ShadePixel (red AS DOUBLE, grn AS DOUBLE, blu AS DOUBLE, alf AS DOUBLE, re AS DOUBLE, im AS DOUBLE, zoom AS DOUBLE)
    DIM AS _UNSIGNED LONG c0, c1, c2
    DIM AS DOUBLE r, a, h, s, k
 
    r = SQR(re * re + im * im)
 
    ' Color scheme 0
    a = (pi + _ATAN2(im, -re)) / (2 * pi)
    c1~& = hrgb~&(a, r)
 
    ' Color scheme 1
    a = _ATAN2(im, -re) * .99999
    h = 180 + a * 180 / pi
    SELECT CASE PlotOption(2)
        CASE 1
            k = 50 * r
        CASE 2
            k = 50 * LOG(1 + r * zoom)
        CASE 3
            k = 50 * LOG(1 + r) * (1 + r)
        CASE 4
            k = 50 * r / zoom
        CASE ELSE
            'IF (r < 1) THEN
            'ELSE
            'END IF
    END SELECT
    s = 50 + ((k * 1) MOD 50)
    c2~& = HSVtoRGB~&(h, s, 100)
 
    ' Weighted average of color schemes
    c0~& = ShadeBlend(PlotOption(1), c1~&, c2~&)
    c0~& = SetAlpha(c0~&, 255)
 
    'IF ((re > 0) AND (im > 0)) THEN
 
    ' Origin
    IF (PlotOption(3) = 1) THEN c0~& = ShadeOrigin(c0~&, re, im, 0.075, 100)
 
    ' Axes
    IF (PlotOption(4) = 1) THEN c0~& = ShadeAxes(c0~&, re, im, 0.075, 100)
 
    ' Integers
    IF (PlotOption(5) = 1) THEN c0~& = ShadeIntegers(c0~&, re, im, 0.075, 100)
 
    'END IF
 
    ' Contours
    IF (PlotOption(6) = 1) THEN c0~& = ShadeContours(c0~&, k, 50, 2, 100)
 
    ' Greyscale
    IF (PlotOption(7) = 1) THEN c0~& = ShadeGreyscale(c0~&)
 
    ' Stencil
    IF (PlotOption(8) = 1) THEN c0~& = ShadeStencil(c0~&, 100)
 
    ' Invert
    IF (PlotOption(9) = 1) THEN c0~& = ShadeInvert(c0~&)
 
    ' Bolden
    IF (PlotOption(0) = 1) THEN c0~& = ShadeBolden(c0~&, .8)
 
    red = _RED32(c0~&)
    grn = _GREEN32(c0~&)
    blu = _BLUE32(c0~&)
    alf = _ALPHA32(c0~&)
END SUB
 
SUB DrawPlot (TheExhibit AS STRING, zoom AS DOUBLE, xshift AS DOUBLE, yshift AS DOUBLE, AAtoggle AS INTEGER)
    DIM AS DOUBLE j, k, x0, y0, re, im, red, grn, blu, alf, nr, ng, nb, na, d, f, jj, kk
    DIM AS DOUBLE r(99), g(99), b(99), a(99), w(99)
    DIM AS INTEGER ii
 
    CLS
    _TITLE TheExhibit
    FOR j = 0 TO _WIDTH
        FOR k = 0 TO _HEIGHT
 
            IF (AAtoggle = -1) THEN
                x0 = (j) - _WIDTH / 2
                y0 = -(k) + _HEIGHT / 2
                re = x0 / zoom + xshift
                im = y0 / zoom + yshift
                Calculate re, im, TheExhibit
                ShadePixel red, grn, blu, alf, re, im, zoom
 
            ELSE
                f = 2
                d = .25
                ii = 0
                FOR jj = j - f * d TO j + f * d STEP d
                    FOR kk = k - f * d TO k + f * d STEP d
                        ii = ii + 1
                        x0 = (jj - d) - _WIDTH / 2
                        y0 = -(kk - d) + _HEIGHT / 2
                        re = x0 / zoom + xshift
                        im = y0 / zoom + yshift
                        Calculate re, im, TheExhibit
                        ShadePixel red, grn, blu, alf, re, im, zoom
                        r(ii) = red
                        g(ii) = grn
                        b(ii) = blu
                        a(ii) = alf
                        w(ii) = EXP(-1 * ((j - jj) ^ 2 + (k - kk) ^ 2))
                    NEXT
                NEXT
                red = 0
                grn = 0
                blu = 0
                alf = 0
                nr = 0
                ng = 0
                nb = 0
                na = 0
                FOR jj = 1 TO ii
                    red = red + r(jj) * w(ii)
                    grn = grn + g(jj) * w(ii)
                    blu = blu + b(jj) * w(ii)
                    alf = alf + a(jj) * w(ii)
                    nr = nr + w(ii)
                    ng = ng + w(ii)
                    nb = nb + w(ii)
                    na = na + w(ii)
                NEXT
                red = red / nr
                grn = grn / ng
                blu = blu / nb
                alf = alf / na
            END IF
 
            CALL CPset(x0, y0, _RGBA(red, grn, blu, alf))
 
        NEXT
    NEXT
 
    'COLOR _RGB32(255, 255, 255, 255)
    'LOCATE 1, 1: PRINT TheExhibit
    'LOCATE 2, 1: PRINT "zoom: "; zoom
    'LOCATE 3, 1: PRINT "xshift: "; xshift
    'LOCATE 4, 1: PRINT "yshift: "; yshift
END SUB
 
FUNCTION ShadeBlend~& (f AS DOUBLE, x AS _UNSIGNED LONG, y AS _UNSIGNED LONG)
    DIM AS DOUBLE red, grn, blu, alf
    red = (1 - f) * (_RED32(x)) + f * (_RED32(y))
    grn = (1 - f) * (_GREEN32(x)) + f * (_GREEN32(y))
    blu = (1 - f) * (_BLUE32(x)) + f * (_BLUE32(y))
    alf = (1 - f) * (_ALPHA32(x)) + f * (_ALPHA32(y))
    ShadeBlend~& = _RGB32(red, grn, blu, alf)
END FUNCTION
 
FUNCTION SetAlpha~& (x AS _UNSIGNED LONG, y AS DOUBLE)
    SetAlpha~& = _RGB32(_RED32(x), _GREEN32(x), _BLUE32(x), y)
END FUNCTION
 
FUNCTION ShadeContours~& (c AS _UNSIGNED LONG, k AS DOUBLE, x AS DOUBLE, y AS DOUBLE, a AS DOUBLE)
    IF (((k MOD x) < y) OR ((k MOD x) > (x - y))) THEN c = SetAlpha(c, a)
    ShadeContours~& = c
END FUNCTION
 
FUNCTION ShadeIntegers~& (c AS _UNSIGNED LONG, x AS DOUBLE, y AS DOUBLE, z AS DOUBLE, a AS DOUBLE)
    IF (((x - INT(x)) < z) AND (INT(x) <> 0)) THEN c = SetAlpha(c, a)
    IF (((y - INT(y)) < z) AND (INT(y) <> 0)) THEN c = SetAlpha(c, a)
    IF (((INT(x) + 1 - x) < z) AND ((INT(x) + 1) <> 0)) THEN c = SetAlpha(c, a)
    IF (((INT(y) + 1 - y) < z) AND ((INT(y) + 1) <> 0)) THEN c = SetAlpha(c, a)
    ShadeIntegers~& = c
END FUNCTION
 
FUNCTION ShadeAxes~& (c AS _UNSIGNED LONG, x AS DOUBLE, y AS DOUBLE, z AS DOUBLE, a AS DOUBLE)
    IF SQR(x * x + y * y) > 1 THEN
        IF (((x - INT(x)) < z) AND (INT(x) = 0)) THEN c = SetAlpha(c, a)
        IF (((y - INT(y)) < z) AND (INT(y) = 0)) THEN c = SetAlpha(c, a)
        IF (((INT(x) + 1 - x) < z) AND ((INT(x) + 1) = 0)) THEN c = SetAlpha(c, a)
        IF (((INT(y) + 1 - y) < z) AND ((INT(y) + 1) = 0)) THEN c = SetAlpha(c, a)
    END IF
    ShadeAxes~& = c
END FUNCTION
 
FUNCTION ShadeOrigin~& (c AS _UNSIGNED LONG, x AS DOUBLE, y AS DOUBLE, z AS DOUBLE, a AS DOUBLE)
    IF SQR(x * x + y * y) <= 1 THEN
        IF (((x - INT(x)) < z) AND (INT(x) = 0)) THEN c = SetAlpha(c, a)
        IF (((y - INT(y)) < z) AND (INT(y) = 0)) THEN c = SetAlpha(c, a)
        IF (((INT(x) + 1 - x) < z) AND ((INT(x) + 1) = 0)) THEN c = SetAlpha(c, a)
        IF (((INT(y) + 1 - y) < z) AND ((INT(y) + 1) = 0)) THEN c = SetAlpha(c, a)
    END IF
    ShadeOrigin~& = c
END FUNCTION
 
FUNCTION ShadeGreyscale~& (x AS _UNSIGNED LONG)
    DIM AS DOUBLE a
    a = 255 - (1 / 3) * (_RED32(x) + _GREEN32(x) + _BLUE32(x))
    ShadeGreyscale~& = _RGB32(a, a, a, _ALPHA32(x))
END FUNCTION
 
FUNCTION ShadeStencil~& (x AS _UNSIGNED LONG, t AS DOUBLE)
    DIM AS DOUBLE red, grn, blu
    IF (_ALPHA32(x) <> t) THEN
        red = 0
        grn = 0
        blu = 0
    ELSE
        red = _RED32(x)
        grn = _GREEN32(x)
        blu = _BLUE32(x)
    END IF
    ShadeStencil~& = _RGB32(red, grn, blu, 255)
END FUNCTION
 
FUNCTION ShadeInvert~& (x AS _UNSIGNED LONG)
    ShadeInvert~& = _RGB32(255 - _RED32(x), 255 - _GREEN32(x), 255 - _BLUE32(x), _ALPHA32(x))
END FUNCTION
 
FUNCTION ShadeBolden~& (x AS _UNSIGNED LONG, t AS DOUBLE)
    DIM AS DOUBLE red, grn, blu
    red = _RED32(x)
    grn = _GREEN32(x)
    blu = _BLUE32(x)
    IF ((red + grn + blu) < (3 * 255)) THEN
        red = red * t
        grn = grn * t
        blu = blu * t
    END IF
    ShadeBolden~& = _RGB32(red, grn, blu, _ALPHA32(x))
END FUNCTION
 
FUNCTION HSVtoRGB~& (h AS DOUBLE, s AS DOUBLE, v AS DOUBLE)
    DIM AS DOUBLE c, x, m, r, g, b
    IF ((h > 360) OR (h < 0) OR (s > 100) OR (s < 0) OR (v > 100) OR (v < 0)) THEN
        PRINT "Out of range:"; h; s; v
    END IF
    s = s / 100
    v = v / 100
    c = s * v
    x = c * (1 - ABS(fmod(h / 60, 2) - 1))
    m = v - c
    IF ((h >= 0) AND (h < 60)) THEN
        r = c
        g = x
        b = 0
    END IF
    IF ((h >= 60) AND (h < 120)) THEN
        r = x
        g = c
        b = 0
    END IF
    IF ((h >= 120) AND (h < 180)) THEN
        r = 0
        g = c
        b = x
    END IF
    IF ((h >= 180) AND (h < 240)) THEN
        r = 0
        g = x
        b = c
    END IF
    IF ((h >= 240) AND (h < 300)) THEN
        r = x
        g = 0
        b = c
    END IF
    IF ((h >= 300) AND (h < 360)) THEN
        r = c
        g = 0
        b = x
    END IF
    r = (r + m) * 255
    g = (g + m) * 255
    b = (b + m) * 255
    HSVtoRGB~& = _RGB32(r, g, b)
END FUNCTION
 
FUNCTION fmod## (numer AS DOUBLE, denom AS DOUBLE)
    fmod## = numer - INT(numer / denom) * denom
END FUNCTION
 
' a vince original, slightly modified
FUNCTION hrgb~& (h AS DOUBLE, m AS DOUBLE)
    DIM n AS LONG
    DIM AS DOUBLE r, g, b, mm, p, rr, gg, bb
    r = 0.5 - 0.5 * SIN(2 * pi * h - pi / 2)
    g = (0.5 + 0.5 * SIN(2 * pi * h * 1.5 - pi / 2)) * -(h < 0.66)
    b = (0.5 + 0.5 * SIN(2 * pi * h * 1.5 + pi / 2)) * -(h > 0.33)
    mm = 0 * (m * 500 MOD 500)
    n = 16
    p = ABS((h * n) - INT(h * n))
    rr = 255 * r - 0.15 * mm - 35 * p
    gg = 255 * g - 0.15 * mm - 35 * p
    bb = 255 * b - 0.15 * mm - 35 * p
    IF (rr < 0) THEN rr = 0
    IF (gg < 0) THEN gg = 0
    IF (bb < 0) THEN bb = 0
    hrgb~& = _RGB(rr, gg, bb)
END FUNCTION
 
SUB CPset (x0 AS DOUBLE, y0 AS DOUBLE, shade AS _UNSIGNED LONG)
    PSET (_WIDTH / 2 + x0, -y0 + _HEIGHT / 2), shade
END SUB
 
'SUB circlef (x AS LONG, y AS LONG, r AS LONG, c AS LONG)
'    DIM AS LONG xx, yy, e
'    xx = r
'    yy = 0
'    e = -r
'    DO WHILE (yy < xx)
'        IF (e <= 0) THEN
'            yy = yy + 1
'            LINE (x - xx, y + yy)-(x + xx, y + yy), c, BF
'            LINE (x - xx, y - yy)-(x + xx, y - yy), c, BF
'            e = e + 2 * yy
'        ELSE
'            LINE (x - yy, y - xx)-(x + yy, y - xx), c, BF
'            LINE (x - yy, y + xx)-(x + yy, y + xx), c, BF
'            xx = xx - 1
'            e = e - 2 * xx
'        END IF
'    LOOP
'    LINE (x - r, y)-(x + r, y), c, BF
'END SUB
 
SUB cadd (u AS DOUBLE, v AS DOUBLE, xx AS DOUBLE, yy AS DOUBLE, aa AS DOUBLE, bb AS DOUBLE)
    DIM AS DOUBLE x, y, a, b
    x = xx
    y = yy
    a = aa
    b = bb
    u = x + a
    v = y + b
END SUB
 
SUB cmul (u AS DOUBLE, v AS DOUBLE, xx AS DOUBLE, yy AS DOUBLE, aa AS DOUBLE, bb AS DOUBLE)
    DIM AS DOUBLE x, y, a, b
    x = xx
    y = yy
    a = aa
    b = bb
    u = x * a - y * b
    v = x * b + y * a
END SUB
 
SUB cdiv (u AS DOUBLE, v AS DOUBLE, xx AS DOUBLE, yy AS DOUBLE, aa AS DOUBLE, bb AS DOUBLE)
    DIM AS DOUBLE x, y, a, b, d
    x = xx
    y = yy
    a = aa
    b = bb
    d = a * a + b * b
    u = (x * a + y * b) / d
    v = (y * a - x * b) / d
END SUB
 
SUB cexp (u AS DOUBLE, v AS DOUBLE, xx AS DOUBLE, yy AS DOUBLE, aa AS DOUBLE, bb AS DOUBLE)
    DIM AS DOUBLE x, y, a, b, lnz, argz, mag, ang
    x = xx
    y = yy
    a = aa
    b = bb
    lnz = x * x + y * y
    IF (lnz = 0) THEN
        u = 0
        v = 0
    ELSE
        lnz = 0.5 * LOG(lnz)
        argz = _ATAN2(y, x)
        mag = EXP(a * lnz - b * argz)
        ang = a * argz + b * lnz
        u = mag * COS(ang)
        v = mag * SIN(ang)
    END IF
END SUB
 
SUB clog (u AS DOUBLE, v AS DOUBLE, xx AS DOUBLE, yy AS DOUBLE)
    DIM AS DOUBLE x, y, lnz, argz
    x = xx
    y = yy
    lnz = x * x + y * y
    IF (lnz = 0) THEN
        u = 0
        v = 0
    ELSE
        lnz = 0.5 * LOG(lnz)
        argz = _ATAN2(y, x)
        u = lnz
        v = argz
    END IF
END SUB
 
FUNCTION cosh## (x AS DOUBLE)
    cosh## = 0.5## * (EXP(x) + EXP(-x))
END FUNCTION
 
FUNCTION sinh## (x AS DOUBLE)
    sinh## = 0.5## * (EXP(x) - EXP(-x))
END FUNCTION
 
SUB sinz (u AS DOUBLE, v AS DOUBLE, xx AS DOUBLE, yy AS DOUBLE)
    DIM AS DOUBLE x, y
    x = xx
    y = yy
    u = SIN(x) * cosh(y)
    v = COS(x) * sinh(y)
END SUB
 
SUB cosz (u AS DOUBLE, v AS DOUBLE, xx AS DOUBLE, yy AS DOUBLE)
    DIM AS DOUBLE x, y
    x = xx
    y = yy
    u = COS(x) * cosh(y)
    v = -SIN(x) * sinh(y)
END SUB
 
FUNCTION rgamma## (x)
    rgamma = SQR(2 * pi * x) * ((x / EXP(1)) ^ x)
END FUNCTION
 
SUB cgamma (u AS DOUBLE, v AS DOUBLE, xx AS DOUBLE, yy AS DOUBLE)
    DIM AS DOUBLE x, y, uu, vv, p, q
    x = xx
    y = yy
    IF x = 0 AND y = 0 THEN
        u = 1
        v = 0
    ELSE
        cexp uu, vv, x, y, x - 0.5, y
        cexp p, q, EXP(1), 0, -x, -y
        cmul u, v, uu, vv, p, q
        u = u * SQR(2 * pi)
        v = v * SQR(2 * pi)
    END IF
END SUB
 
FUNCTION facto& (x AS LONG)
    IF (x = 1) THEN facto& = 1
    IF (x > 1) THEN facto& = x * facto&(x - 1)
END FUNCTION
 

Programs / Scalar Field

« on: February 14, 2022, 08:13:41 am »

Code: QB64: [Select]

OPTION _EXPLICIT
 
DO UNTIL _SCREENEXISTS: LOOP
_TITLE "Scalar Field"
 
SCREEN _NEWIMAGE(800, 600, 32)
RANDOMIZE TIMER
 
TYPE Vector
    x AS DOUBLE
    y AS DOUBLE
END TYPE
 
DIM SHARED Position(10) AS Vector
DIM SHARED Velocity(10) AS Vector
DIM AS INTEGER j, k
DIM AS DOUBLE f, f1, f3, f7, f9, g
 
FOR j = 1 TO UBOUND(Position)
    Position(j).x = _WIDTH * (RND - .5)
    Position(j).y = _HEIGHT * (RND - .5)
    Velocity(j).x = 5 * (RND - .5)
    Velocity(j).y = 5 * (RND - .5)
NEXT
 
DO
    CLS
 
    FOR j = 1 TO UBOUND(Position)
        Position(j).x = Position(j).x + Velocity(j).x
        Position(j).y = Position(j).y + Velocity(j).y
        IF (Position(j).x < -_WIDTH / 2) THEN Velocity(j).x = -Velocity(j).x
        IF (Position(j).x > _WIDTH / 2) THEN Velocity(j).x = -Velocity(j).x
        IF (Position(j).y < -_HEIGHT / 2) THEN Velocity(j).y = -Velocity(j).y
        IF (Position(j).y > _HEIGHT / 2) THEN Velocity(j).y = -Velocity(j).y
    NEXT
 
    FOR j = -_WIDTH / 2 TO _WIDTH / 2 STEP 10
        FOR k = -_HEIGHT / 2 TO _HEIGHT / 2 STEP 10
            f = 15 * CalcPotential#(j, k)
            CALL CCircle(j, k, 4, _RGB(255 * f, 255 * f / 2, 255 * f / 4))
            'NEXT
            'NEXT
 
            'FOR j = -_WIDTH / 2 TO _WIDTH / 2 STEP 10
            'FOR k = -_HEIGHT / 2 TO _HEIGHT / 2 STEP 10
            f1 = 10 * CalcPotential#(j - 5, k - 5)
            f3 = 10 * CalcPotential#(j + 5, k - 5)
            f7 = 10 * CalcPotential#(j - 5, k + 5)
            f9 = 10 * CalcPotential#(j + 5, k + 5)
            FOR g = .15 TO .65 STEP .1
                f = .5
                IF (f1 > g) AND (f3 > g) AND (f7 > g) AND (f9 > g) THEN f = 1
                IF (f1 < g) AND (f3 < g) AND (f7 < g) AND (f9 < g) THEN f = 0
                IF (f = .5) THEN
                    IF (f1 < g) AND (f3 < g) AND (f7 > g) AND (f9 > g) THEN CALL CLine(j - 5, k, j + 5, k, _RGB(255, 255, 255 / 2))
                    IF (f1 > g) AND (f3 > g) AND (f7 < g) AND (f9 < g) THEN CALL CLine(j - 5, k, j + 5, k, _RGB(255, 255, 255 / 2))
                    IF (f1 > g) AND (f3 < g) AND (f7 > g) AND (f9 < g) THEN CALL CLine(j, k - 5, j, k + 5, _RGB(255, 255, 255 / 2))
                    IF (f1 < g) AND (f3 > g) AND (f7 < g) AND (f9 > g) THEN CALL CLine(j, k - 5, j, k + 5, _RGB(255, 255, 255 / 2))
                    IF (f1 > g) AND (f3 < g) AND (f7 < g) AND (f9 < g) THEN CALL CLine(j - 5, k, j, k - 5, _RGB(255, 255, 255 / 2))
                    IF (f1 < g) AND (f3 > g) AND (f7 < g) AND (f9 < g) THEN CALL CLine(j, k - 5, j + 5, k, _RGB(255, 255, 255 / 2))
                    IF (f1 < g) AND (f3 < g) AND (f7 > g) AND (f9 < g) THEN CALL CLine(j - 5, k, j, k + 5, _RGB(255, 255, 255 / 2))
                    IF (f1 < g) AND (f3 < g) AND (f7 < g) AND (f9 > g) THEN CALL CLine(j, k + 5, j + 5, k, _RGB(255, 255, 255 / 2))
                END IF
            NEXT
        NEXT
    NEXT
 
    _DISPLAY
    _LIMIT 60
LOOP
 
END
 
FUNCTION CalcPotential# (x0 AS DOUBLE, y0 AS DOUBLE)
    DIM TheReturn AS DOUBLE
    DIM AS INTEGER j
    DIM AS DOUBLE dx, dy, r
    TheReturn = 0
    FOR j = 1 TO UBOUND(Position)
        dx = x0 - Position(j).x
        dy = y0 - Position(j).y
        r = SQR(dx * dx + dy * dy)
        TheReturn = TheReturn + 1 / r
    NEXT
    CalcPotential# = TheReturn
END FUNCTION
 
SUB CCircle (x0 AS DOUBLE, y0 AS DOUBLE, rad AS DOUBLE, shade AS _UNSIGNED LONG)
    CIRCLE (_WIDTH / 2 + x0, -y0 + _HEIGHT / 2), rad, shade
END SUB
 
SUB CLine (x0 AS DOUBLE, y0 AS DOUBLE, x1 AS DOUBLE, y1 AS DOUBLE, shade AS _UNSIGNED LONG)
    LINE (_WIDTH / 2 + x0, -y0 + _HEIGHT / 2)-(_WIDTH / 2 + x1, -y1 + _HEIGHT / 2), shade
END SUB
 

Programs / Draw any curve using only circles

« on: February 14, 2022, 08:07:36 am »

REDACTED

Programs / Combinator Calculator: The purest math you'll ever see

« on: January 09, 2022, 11:55:17 pm »

Alright, this post will mostly appeal to the theory-heads out there, but maybe there's some unforseen value in making a general-audience post about this, so here we go.

Today the Science Department of QB64 brings your attention to the oldest, most powerful model of computing ever conceived. Before Turing machines, before lambda calculus - in December 1920, the world was alerted to the S and K combinators. These are abstract functions that you can implement very easily on a computer or another device to make that device become a computer. Here are the functions:

Code: [Select]

s[x][y][z] = x[z][y[z]]
k[x][y] = x

... and that's it. The entirety of computing is in those two functions. All data, all algorithms. Everything you've ever written or will write, whether it be code or it be mathematics, can be compiled to/from those S and K combinators as such. One paper I came across said something like "S and K combinators are the machine language of mathematics". I totally jive with this statement. I got so into this actually, that I had to implement this language in QB64. I'll 'splain you it all.

But first, quiz time. You fall into one of three categories right now:

1)
If you're lost or mostly uninterested, forget about whatever you just read and check out the calculator I made. It does plus, times, and exponents, but only on the integers. Code at the bottom!

2)
If you want to know what's going on so far, and want to hear it *from me*, then I wrote all about this (in Notepad with no spell check and in a hurry, and I still need to add images):
http://barnes.x10host.com/pages/Function-Officium/Function-Officium-One.php
http://barnes.x10host.com/pages/Function-Officium/Function-Officium-Two.php

3)
If you want it straight from the horse's mouth, I suggest you start with this:
https://people.cs.uchicago.edu/~odonnell/Teacher/Lectures/Formal_Organization_of_Knowledge/Examples/combinator_calculus/
https://writings.stephenwolfram.com/2020/12/combinators-a-centennial-view/

To play with this, have it crank out some math for you. You can thumb through the examples in the code I commented out - they will make more sense if read alongside my online notes.

Code: QB64: [Select]

OPTION _EXPLICIT
 
DIM a AS INTEGER
DIM b AS INTEGER
DIM c AS INTEGER
DIM d AS STRING
DIM e AS STRING
 
DO
    _KEYCLEAR
    INPUT "Enter first integer: ", a
    INPUT "Enter second integer: ", b
    c = -1
    DO WHILE ((c < 1) OR (c > 3))
        INPUT "Enter operation. 1 for add, 2 for multiply, 3 for exponent: ", c
    LOOP
    PRINT
 
    SELECT CASE c
        CASE 1
            d = "+"
            e = "s[k[s]][s[k[s[k[s]]]][s[k[k]]]]"
        CASE 2
            d = "*"
            e = "s[k[s]][k]"
        CASE 3
            d = "^"
            e = "s[k[s[s[k][k]]]][k]"
    END SELECT
 
    PRINT "You entered:"
    PRINT a; d; b
    PRINT
    PRINT "Translation of problem: "
    PRINT NumberPrefix$(a); e; NumberPrefix$(b)
    PRINT
    PRINT "Press any key to compute..."
    SLEEP
 
    SELECT CASE c
        CASE 1
            PRINT InterpretInteger&(EvalLoop$(SumPrefix$(a, b) + "[s][k]"))
            PRINT "Result:"; a; d; b; "="; a + b
        CASE 2
            PRINT InterpretInteger&(EvalLoop$(ProductPrefix$(a, b) + "[s][k]"))
            PRINT "Result:"; a; d; b; "="; a * b
        CASE 3
            PRINT InterpretInteger&(EvalLoop$(ExponentPrefix$(a, b) + "[s][k]"))
            PRINT "Result:"; a; d; b; "="; a ^ b
    END SELECT
    PRINT
 
LOOP
 
'' Identity
'PRINT EvalLoop$("s[k][k]" + "[a]")
 
'' Wolfram's example
'PRINT EvalLoop$("s[s[k[s]][s[k[k]][s[k[s]][k]]]][s[k[s[s[k][k]]]][k]]")
'PRINT EvalLoop$("s[s[k[s]][s[k[k]][s[k[s]][k]]]][s[k[s[s[k][k]]]][k]][a][b][c]")
 
'' Zero
'PRINT EvalLoop$("s[k]" + "[s][k]")
'PRINT EvalLoop$(NumberPrefix$(0) + "[s][k]")
 
'' One
'PRINT EvalLoop$("s[s[k[s]][k]][s[k]]" + "[s][k]")
'PRINT EvalLoop$("s[s[k[s]][k]]" + "[s[k]][s][k]")
'PRINT EvalLoop$(NumberPrefix$(1) + "[s][k]")
 
'' Two
'PRINT EvalLoop$("s[s[k[s]][k]][s[s[k[s]][k]][s[k]]]" + "[s][k]")
'PRINT EvalLoop$("s[s[k[s]][k]]" + "[" + "s[s[k[s]][k]]" + "[s[k]]][s][k]")
'PRINT EvalLoop$(NumberPrefix$(2) + "[s][k]")
 
'' Three
'PRINT EvalLoop$("s[s[k[s]][k]][s[s[k[s]][k]][s[s[k[s]][k]][s[k]]]]" + "[s][k]")
'PRINT EvalLoop$("s[s[k[s]][k]]" + "[" + "s[s[k[s]][k]]" + "[" + "s[s[k[s]][k]]" + "[s[k]]]][s][k]")
'PRINT EvalLoop$(NumberPrefix$(3) + "[s][k]")
 
'' Sum
'PRINT EvalLoop$("s[k[s]][s[k[s[k[s]]]][s[k[k]]]][s[s[k[s]][k]][s[k]]][s[s[k[s]][k]][s[s[k[s]][k]][s[k]]]][s][k]")
'PRINT EvalLoop$(SumPrefix$(1, 2) + "[s][k]")
'PRINT EvalLoop$(SumPrefix$(3, 4) + "[s][k]")
'PRINT EvalLoop$(SumPrefix$(30, 40) + "[s][k]")
 
'' Product
'PRINT EvalLoop$("s[k[s]][k][s[s[k[s]][k]][s[s[k[s]][k]][s[k]]]][s[s[k[s]][k]][s[s[k[s]][k]][s[k]]]][s][k]")
'PRINT EvalLoop$(ProductPrefix$(2, 2) + "[s][k]")
'PRINT EvalLoop$(ProductPrefix$(3, 2) + "[s][k]")
'PRINT EvalLoop$(ProductPrefix$(2, 3) + "[s][k]")
 
'' Exponent
'PRINT EvalLoop$(ExponentPrefix$(3, 2) + "[s][k]")
 
'' Self-apply: siix
'PRINT EvalLoop$("s[s[k][k]][s[k][k]][x]")
 
'' Infinite loop: sii(sii)
'PRINT EvalLoop$("s[s[k][k]][s[k][k]][s[s[k][k]][s[k][k]]]")
 
'' Swap: s(k(si))(s(kk)i)ab
'PRINT EvalLoop$("s[k[s[s[k][k]]]][s[k[k]][s[k][k]]][a][b]")
 
'' Self-reference 1:
'PRINT EvalLoop$("s[k[x]][s[s[k][k]][s[k][k]]][y]")
 
'' Self-reference 2: (infinite loop)
'PRINT EvalLoop$("s[k[x]][s[s[k][k]][s[k][k]]][s[k[x]][s[s[k][k]][s[k][k]]]]")
 
END
 
' Human helper fucntion(s)
 
FUNCTION InterpretInteger& (t AS STRING)
    DIM TheReturn AS LONG
    DIM j AS INTEGER
    DIM w AS STRING
    TheReturn = 0
    w = t
    j = INSTR(w, "s")
    DO WHILE (j <> 0)
        TheReturn = TheReturn + 1
        w = RIGHT$(w, LEN(w) - j - 1)
        j = INSTR(w, "s")
    LOOP
    InterpretInteger& = TheReturn
END FUNCTION
 
' Math functions
 
FUNCTION ExponentPrefix$ (a AS INTEGER, b AS INTEGER)
    ExponentPrefix$ = "s[k[s[s[k][k]]]][k]" + "[" + NumberPrefix$(a) + "]" + "[" + NumberPrefix$(b) + "]"
END FUNCTION
 
FUNCTION ProductPrefix$ (a AS INTEGER, b AS INTEGER)
    ProductPrefix$ = "s[k[s]][k]" + "[" + NumberPrefix$(a) + "]" + "[" + NumberPrefix$(b) + "]"
END FUNCTION
 
FUNCTION SumPrefix$ (a AS INTEGER, b AS INTEGER)
    SumPrefix$ = "s[k[s]][s[k[s[k[s]]]][s[k[k]]]]" + "[" + NumberPrefix$(a) + "]" + "[" + NumberPrefix$(b) + "]"
END FUNCTION
 
FUNCTION NumberPrefix$ (n AS LONG)
    NumberPrefix$ = Nest$("s[s[k[s]][k]]", "s[k]", n)
END FUNCTION
 
' Higher-order functions
 
FUNCTION Nest$ (f AS STRING, x AS STRING, n AS LONG)
    DIM TheReturn AS STRING
    DIM AS LONG j
    TheReturn = x
    IF (n > 0) THEN
        FOR j = 1 TO n
            TheReturn = f + "[" + TheReturn + "]"
        NEXT
    END IF
    Nest$ = TheReturn
END FUNCTION
 
' Eval functions
 
FUNCTION EvalLoop$ (TheStringIn AS STRING)
    DIM TheReturn AS STRING
    DIM Tmp AS STRING
    DIM k AS INTEGER
    Tmp = TheStringIn
    TheReturn = TheStringIn
    PRINT TheReturn
    k = 0
    DO
        Tmp = EvalStep$(TheReturn)
        IF (Tmp <> TheReturn) THEN
            k = k + 1
            TheReturn = Tmp
            PRINT "Step "; _TRIM$(STR$(k)); ": "; TheReturn
        ELSE
            EXIT DO
        END IF
        '_DELAY .025
    LOOP
    EvalLoop$ = TheReturn
END FUNCTION
 
FUNCTION EvalStep$ (TheStringIn AS STRING)
    DIM TheReturn AS STRING
    DIM AS STRING ArgListS(3)
    DIM AS STRING ArgListK(2)
    DIM AS LONG s0, k0
    DIM AS STRING t1, t2
    TheReturn = TheStringIn
    s0 = FindValidS(TheStringIn, ArgListS())
    k0 = FindValidK(TheStringIn, ArgListK())
    IF (s0 < k0) THEN
        t1 = "s" + ArgListS(1) + ArgListS(2) + ArgListS(3)
        t2 = Shave$(ArgListS(1)) + "[" + Shave$(ArgListS(3)) + "][" + Shave$(ArgListS(2)) + "[" + Shave$(ArgListS(3)) + "]]"
        TheReturn = Replace$(TheStringIn, t1, t2)
    END IF
    IF (k0 < s0) THEN
        t1 = "k" + ArgListK(1) + ArgListK(2)
        t2 = Shave$(ArgListK(1))
        TheReturn = Replace$(TheStringIn, t1, t2)
    END IF
    EvalStep$ = TheReturn
END FUNCTION
 
' Parsing functions
 
FUNCTION Shave$ (TheStringIn AS STRING)
    DIM TheReturn AS STRING
    TheReturn = TheStringIn
    TheReturn = LEFT$(TheReturn, LEN(TheReturn) - 1)
    TheReturn = RIGHT$(TheReturn, LEN(TheReturn) - 1)
    Shave$ = TheReturn
END FUNCTION
 
FUNCTION Replace$ (TheStringIn AS STRING, TargetSegment AS STRING, NewSegment AS STRING)
    DIM TheReturn AS STRING
    DIM k AS INTEGER
    k = INSTR(TheStringIn, TargetSegment)
    IF (k <> 0) THEN
        TheReturn = LEFT$(TheStringIn, k - 1) + NewSegment + RIGHT$(TheStringIn, LEN(TheStringIn) - k - LEN(TargetSegment) + 1)
    ELSE
        TheReturn = TheStringIn
    END IF
    Replace$ = TheReturn
END FUNCTION
 
SUB FindArgs (TheStringIn AS STRING, StartPos AS LONG, NumArgs AS LONG, arr() AS STRING)
    DIM TheString AS STRING
    DIM AS LONG i, j0, j1, j2, bal
    TheString = TheStringIn
    j0 = 0
    j1 = 0
    j2 = 0
    bal = 0
    i = StartPos
    DO WHILE (i <= LEN(TheString))
        i = i + 1
        IF (MID$(TheString, i, 1) = "[") THEN
            bal = bal + 1
            IF (bal = 1) THEN j1 = i
        END IF
        IF (MID$(TheString, i, 1) = "]") THEN
            bal = bal - 1
            IF (bal = 0) THEN j2 = i
        END IF
        IF ((j1 <> 0) AND (j2 <> 0) AND (bal = 0)) THEN
            j0 = j0 + 1
            arr(j0) = MID$(TheString, j1, j2 - j1 + 1)
            j1 = 0
            j2 = 0
            bal = 0
            IF (j0 = NumArgs) THEN EXIT DO
        END IF
    LOOP
END SUB
 
FUNCTION FindValidS& (TheStringIn AS STRING, arr() AS STRING)
    DIM TheReturn AS LONG
    DIM Tmp AS STRING
    DIM AS LONG j, n
    TheReturn = 2147483647
    Tmp = TheStringIn
    FOR j = 1 TO UBOUND(arr)
        arr(j) = ""
    NEXT
    n = 0
    DO
        j = INSTR(Tmp, "s")
        IF (j > 0) THEN
            CALL FindArgs(Tmp, j, 3, arr())
            IF ((arr(1) <> "") AND (arr(2) <> "") AND (arr(3) <> "")) THEN
                TheReturn = j + n
                EXIT DO
            ELSE
                Tmp = RIGHT$(Tmp, LEN(Tmp) - j)
                n = LEN(TheStringIn) - LEN(Tmp)
            END IF
        ELSE
            EXIT DO
        END IF
    LOOP
    FindValidS& = TheReturn
END FUNCTION
 
FUNCTION FindValidK& (TheStringIn AS STRING, arr() AS STRING)
    DIM TheReturn AS LONG
    DIM Tmp AS STRING
    DIM AS LONG j, n
    TheReturn = 2147483647
    Tmp = TheStringIn
    FOR j = 1 TO UBOUND(arr)
        arr(j) = ""
    NEXT
    n = 0
    DO
        j = INSTR(Tmp, "k")
        IF (j > 0) THEN
            CALL FindArgs(Tmp, j, 2, arr())
            IF ((arr(1) <> "") AND (arr(2) <> "")) THEN
                TheReturn = j + n
                EXIT DO
            ELSE
                Tmp = RIGHT$(Tmp, LEN(Tmp) - j)
                n = LEN(TheStringIn) - LEN(Tmp)
            END IF
        ELSE
            EXIT DO
        END IF
    LOOP
    FindValidK& = TheReturn
END FUNCTION

EDIT:

Here is a screenshot of calculating 4^4. It took almost 3000 steps!

Programs / qXed 2021

« on: December 26, 2021, 02:00:08 am »

Yello all,

Some are aware of this project, some aren't. So playing to both audiences, qXed is a hackable text editor made in qb64. It doesn't behave exactly like notepad or gedit, but its probably a bit more friendly than vim. I won't discuss the controls or address the learning curve here, sorry about that. Today is only for new stuff... Using the word "hackable", I mean qXed does more than let you write text. It can also take commands through Pipecom and receive the results back. For instance, I could be typing along, and then for whatever reason need to see the contents of the directory I'm in, so I can type:

Code: [Select]

>dir
and press Ctrl+Enter. (This would be "ls" in Linux of course.) Then, boom, right in the middle of my document, I get the contents of DIR:

Code: [Select]

>dir
( Volume in drive D is New Volume
 Volume Serial Number is 9E67-C1F1

 Directory of D:\qb64

12/26/2021  01:46 AM    <DIR>          .
12/26/2021  01:46 AM    <DIR>          ..
12/26/2021  01:16 AM                37 animals.txt
12/25/2021  09:53 PM         2,170,368 BinaryAnalyzer-Game.exe
12/25/2021  09:56 PM         2,172,416 BinaryAnalyzer.exe
12/23/2021  06:18 PM         1,611,264 bubblesort.exe

Since Pipecom is so handy, you can also send commands to external programs and get the answer back, supposing you have what I'll call "qXed-compatible" programs. These are defined as "pure text in, pure text out". Watch this example session (try to puzzle out what happens):

Code: [Select]

]save animals.txt 
dog
cat
poodle
zebra
waifu
turtle

(animals.txt)
]

>quicksort animals.txt zoo.txt
()

>list zoo.txt
(cat
dog
poodle
turtle
waifu
zebra)
>

For this example to work, a program called quicksort(.exe) needs to already exist that reads a list from file, sorts it, and spits out a new sorted list. We read the sorted list back with another program called list(.exe).

Alright, so you see what I'm trying to make here. It's a text editor colliding with a terminal. This thing might behave in ways you might not expect, maybe rough ways, but I'm calling everything you see a "feature". I reserve the word "bug" for... well, you'll have to really convince me there's a problem. The grander point here is this aims to be one of those kinds of programs you can always have open. With the right supporting programs, it can do all kinds of work for you that the internet already does 1,000,000 times better, but what the hell right?

This is how it's landing in 2021. We'll see how the future treats this code but I bid you all to mess with it and try to dream up whatever console-friendly qXed-compatible programs can run with it. Full code here, all one file:

Code: QB64: [Select]

Option _Explicit
 
'On Error GoTo BadExit
 
$Console
_Console Off
 
Do Until _ScreenExists: Loop
_Title "qXed"
 
'$ExeIcon:'qXedlogo.ico'
$Resize:On
 
Const KeyboardBksp = 8
Const KeyboardTab = 9
Const KeyboardEnter = 13
Const KeyboardEsc = 27
Const KeyboardF1 = 15104
Const KeyboardF2 = 15360
Const KeyboardF3 = 15616
Const KeyboardF4 = 15872
Const KeyboardF5 = 16128
Const KeyboardF6 = 16384
Const KeyboardF7 = 16640
Const KeyboardF8 = 16896
Const KeyboardF9 = 17152
Const KeyboardF10 = 17408
Const KeyboardF11 = 34048
Const KeyboardF12 = 34304
Const KeyboardHome = 18176
Const KeyboardUpArrow = 18432
Const KeyboardPgUp = 18688
Const KeyboardLeftArrow = 19200
Const KeyboardRightArrow = 19712
Const KeyboardEnd = 20224
Const KeyboardDnArrow = 20480
Const KeyboardPgDn = 20736
Const KeyboardIns = 20992
Const KeyboardDel = 21248
Const KeyboardRightShift = 100304
Const KeyboardLeftShift = 100304
Const KeyboardRightCtrl = 100305
Const KeyboardLeftCtrl = 100306
Const KeyboardRightAlt = 100307
Const KeyboardLeftAlt = 100308
 
Dim Shared LF As String
Dim Shared CR As String
Dim Shared Spacebar As String
LF = Chr$(10)
CR = Chr$(13)
Spacebar = Chr$(32)
 
Dim Shared BackgroundColor
Dim Shared Cursor1Back
Dim Shared Cursor2Back
Dim Shared CursorBlinkFace
Dim Shared CursorMixedBack
Dim Shared CursorStdFace
Dim Shared ScrollbarBack
Dim Shared ScrollbarBase
Dim Shared ScrollbarFace
Dim Shared StatusBarColor
Dim Shared TextBackColor
Dim Shared TextFaceColor
Dim Shared TextHighBack
Dim Shared TextHighFace
Dim Shared TitleColor
Dim Shared WireColor
 
Dim Shared ColorTheme
ColorTheme = 1
 
Dim Shared TheERROR As String
Dim Shared Debug$
 
_AcceptFileDrop
 
_Delay .25
Dim Shared scrHand As Long
Dim Shared oldHand As Long
scrHand = _NewImage(1 * 80, 1 * 24, 0) ' 8, 16, 0
Screen scrHand
Call SetPalette
 
' Define fundamental structures.
Type Vector
    X As Integer
    Y As Integer
End Type
 
Type Cell
    Identity As Long
    Pointer As Long
    Lagger As Long
    Content As String * 1
End Type
 
Dim Shared ChainLimit As Long
Dim Shared BOC As Long ' Beginning of chain.
Dim Shared EOC As Long ' End of chain.
ChainLimit = 1 * 10 ^ 6
BOC = 0
EOC = ChainLimit
 
' Define text window properties.
Dim Shared WindowHeight As Integer
Dim Shared WindowWidth As Integer
Dim Shared VisibleLines As Integer
Dim Shared TopIndent As Integer
Dim Shared LeftIndent As Integer
Dim Shared TextHeight As Integer
Dim Shared TextWidth As Integer
Dim Shared HScroll As Integer
Dim Shared TextWrapping As Integer
Dim Shared TextFormatting As Integer
Dim Shared InsertKey As Integer
 
' Set window properties.
Call InitTextWindow
 
' Set display state.
HScroll = 1
TextWrapping = 1
TextFormatting = -1
InsertKey = -1
 
' Initiate text inside window.
Dim Shared StartIndex
Dim Shared LineAsMapped(TextHeight + 1) As String
Dim Shared Cursor1 As Vector
Dim Shared Cursor2 As Vector
Dim Shared ID1
Dim Shared ID2
 
' Auxiliary 2D text grid.
Dim Shared GOLSwitch
Dim Shared AuxGrid(TextWidth, TextHeight, 2) As String
GOLSwitch = -1
 
' Create memory space for string.
Dim Shared TheChain(ChainLimit) As Cell
 
' File I/O.
Dim Shared WorkingFileName As String
 
Dim Shared Highlight As String
Highlight = "qXed"
 
' Load text file into memory if applicable, use example string if not.
Call InitTextChain(Command$)
 
' Prime main loop.
Call MapText
Call CalibrateCursor(ID1)
Call CalibrateCursor(ID2)
Call PrintEverything
 
' Main loop.
Do
 
    If (StateChange% = 1) Then
        Call PrintEverything
    End If
 
    If (GOLSwitch = 1) Then
        Call ConvertToGrid
        Call GOL
        Call ConvertFromGrid
        Call MapText
        Call PrintEverything
    End If
 
    Do While (_Resize)
        If ((_ResizeWidth / 8 > 18) And (_ResizeHeight / 16 > 6)) Then
            oldHand = scrHand
            scrHand = _NewImage((_ResizeWidth / 8), (_ResizeHeight / 16), 0)
            Screen scrHand
            _FreeImage oldHand
            Call SetPalette
            Call InitTextWindow
            ReDim LineAsMapped(TextHeight)
            ReDim AuxGrid(TextWidth, TextHeight, 2)
            Call MapText
            Call CalibrateCursor(ID1)
            Call CalibrateCursor(ID2)
            Call PrintEverything
        End If
    Loop
 
    If (_TotalDroppedFiles > 0) Then
        If (_FileExists(_DroppedFile$(1))) Then
            Call InitTextChain(_DroppedFile$(1))
            Call MapText
            Call CalibrateCursor(ID1)
            Call CalibrateCursor(ID2)
            Call PrintEverything
        End If
        _FinishDrop
    End If
 
    _Display
    _Limit 240
Loop
 
System
 
BadExit:
_Console On
_Echo (TheERROR)
Sleep
System
 
Sub StringPrint (RequestCode As String, x As Integer, y As Integer, txt As String)
    TheERROR = RequestCode + Str$(x) + Str$(y) + " " + txt
    '_PrintString (x * 8, y * 16), txt
    Locate y, x: Print txt;
End Sub
 
Sub InitTextWindow
    WindowWidth = _Width / 1 - 0 * 1 '8, 1
    WindowHeight = _Height / 1 - 0 * 1 '16, 1
    TopIndent = 1 '0
    LeftIndent = 1 '0
    TextHeight = WindowHeight - (1 + TopIndent)
    TextWidth = WindowWidth - (1 + LeftIndent)
End Sub
 
Sub SetPalette
    BackgroundColor = 0
    Cursor1Back = 3
    Cursor2Back = 7
    CursorBlinkFace = 16 + 6
    CursorMixedBack = 7
    CursorStdFace = 0
    ScrollbarBack = 7
    ScrollbarBase = 8
    ScrollbarFace = 1
    StatusBarColor = 3
    TextBackColor = 1
    TextFaceColor = 11
    TextHighBack = 2
    TextHighFace = 1
    TitleColor = 3
    WireColor = 8
    If (ColorTheme = 1) Then
        _PaletteColor 0, _RGB32(0, 0, 39)
        _PaletteColor 1, _RGB32(0, 49, 78)
        _PaletteColor 3, _RGB32(69, 118, 147)
        _PaletteColor 4, _RGB32(216, 98, 78)
        _PaletteColor 6, _RGB32(255, 167, 0) '''
        _PaletteColor 7, _RGB32(98, 98, 98)
        _PaletteColor 8, _RGB32(48, 48, 48) '''
        _PaletteColor 9, _RGB32(0, 88, 108)
        _PaletteColor 10, _RGB32(85, 206, 85)
        _PaletteColor 11, _RGB32(0, 170, 170) '''
        _PaletteColor 14, _RGB32(255, 167, 0)
        _PaletteColor 15, _RGB32(216, 216, 216)
    Else
        oldHand = scrHand
        scrHand = _NewImage(_Width, _Height, 0)
        Screen scrHand
        _FreeImage oldHand
    End If
End Sub
 
Sub InitTextChain (c As String)
    Dim i As Integer
    Dim j As Integer
    Dim k As Long
    Dim q As String
    Dim r As String
    If (c <> "") Then
        q = ""
        Open c For Input As #1
        Do While Not EOF(1)
            Line Input #1, r
            q = q + r + CR
        Loop
        Close #1
        i = InStr(c, ".")
        If (i <> 0) Then
            j = i - 1
        Else
            j = Len(c)
        End If
        WorkingFileName = Left$(c, j) + "-" + LTrim$(RTrim$(Str$(Int(Timer)))) + ".txt"
    Else
        WorkingFileName = "qXed_file" + "-" + Date$ + "-" + LTrim$(RTrim$(Str$(Int(Timer)))) + ".txt"
        q = ""
        'q = q + "Working file is:" + CR + Chr$(9) + WorkingFileName + CR + CR + "Press F6 to save." + CR
        q = q + "Welcome to qXed" + CR
        q = q + "... a hackable text editor" + CR
        q = q + "... now boosted with Pipecom!" + CR
        q = q + CR
        q = q + "Use Pipecom by starting a line with a bracket '>'." + CR
        q = q + "Press Ctrl+Enter to evaluate that line." + CR
        q = q + CR
        q = q + "For example, place the cursor after 'dir', and press Ctrl+Enter:" + CR
        q = q + "(Or, replace 'dir' with 'ls' for Linux.)" + CR
        q = q + CR
        q = q + ">dir"
        q = q + CR
        q = q + CR
        q = q + "This program has a steeper learning curve than Notepad, so beware." + CR
        q = q + CR
        q = q + "Press F3 to change search term." + CR
        q = q + "Press F10 to toggle high contrast mode." + CR
        q = q + "Press F11 to see break returns and whitespace." + CR
        q = q + "Press F12 to cycle text wrapping modes." + CR
    End If
 
    ' Create character list.
    For k = 1 To ChainLimit
        TheChain(k).Identity = 0
    Next
    ID2 = Assimilate&(q, BOC, EOC)
    'StartIndex = 1
    ID1 = StartIndex
 
    GOLSwitch = -1
End Sub
 
Function Assimilate& (a As String, st As Long, en As Long)
    ' Maps a raw string of text between a set of identities.
    Dim b As String
    Dim c As String
    Dim j As Long
    Dim previousID As Long
    Dim nextID As Long
    Dim n0 As Long
 
    If ((st = BOC) And (en = EOC)) Then
        previousID = st
        nextID = NextOpenIdentity&(1)
    Else
        previousID = TheChain(st).Lagger
        nextID = NextOpenIdentity&(st)
    End If
    n0 = nextID
 
    b = a
    Do
        c = Left$(b, 1)
        b = Right$(b, Len(b) - 1)
        Select Case c
            Case Chr$(9)
                c = " "
                b = "   " + b
            Case CR
                If (Left$(b, 1) = LF) Then
                    b = Right$(b, Len(b) - 1)
                End If
            Case LF
                c = CR
        End Select
        j = nextID
        TheChain(j).Identity = j
        TheChain(j).Content = c
        TheChain(j).Lagger = previousID
        If (previousID <> BOC) Then TheChain(previousID).Pointer = j
        If (Len(b) > 0) Then
            previousID = j
            nextID = NextOpenIdentity&(j)
        Else
            If ((st = BOC) And (en = EOC)) Then
                TheChain(j).Pointer = en
                TheChain(en).Lagger = j
            Else
                TheChain(j).Pointer = st
                TheChain(st).Lagger = j
            End If
            Exit Do
        End If
    Loop
 
    If ((st = BOC) And (en = EOC)) Then
        StartIndex = n0
    End If
 
    If (st <> EOC) Then
        If (st = StartIndex) Then
            StartIndex = BackBreak&(StartIndex)
        End If
    End If
 
    Assimilate& = n0
End Function
 
Function InsertString& (a As String, st As Long)
    InsertString& = Assimilate&(a, st, TheChain(st).Pointer)
End Function
 
Function NthP& (a As Long, b As Long)
    ' Returns the address that is b jumps ahead of address a.
    Dim i As Long
    Dim j As Long
    Dim k As Long
    i = a
    j = 0
    If (i <> EOC) Then
        k = 0
        Do While (k < b)
            k = k + 1
            j = i
            i = TheChain(j).Pointer
            If (i = EOC) Then Exit Do
        Loop
    End If
    '''
    If (j = 0) Then
        j = StartIndex
        Sound 1000, 1
    End If
    '''
    NthP& = j
End Function
 
Function NthL& (a As Long, b As Long)
    ' Returns the address that is b jumps behind address a.
    Dim i As Long
    Dim j As Long
    Dim k As Long
    i = a
    k = 0
    Do While (k < b)
        k = k + 1
        j = i
        i = TheChain(j).Lagger
        If (i = BOC) Then Exit Do
    Loop
    NthL& = j
End Function
 
Function NextOpenIdentity& (a As Long)
    Dim j As Long
    For j = a To ChainLimit
        If (TheChain(j).Identity = 0) Then Exit For
    Next
    If (j > ChainLimit) Then
        Print "Chain limit exceeded."
        Sleep
        System
    End If
    NextOpenIdentity& = j
End Function
 
Function BackBreak& (a As Long)
    ' Function for scrolling up.
    Dim c As String
    Dim d As String
    Dim j As Long
    Dim k As Long
    Dim lastBreak As Long
    j = a
    lastBreak = 0
    c = ""
    Do
        If (j = BOC) Then Exit Do
        k = TheChain(j).Lagger
        If (k = BOC) Then
            lastBreak = j
            Exit Do
        End If
        j = k
        d = TheChain(j).Content
        c = d + c
        If (TextWrapping = 1) Then
            If ((d = " ") Or (d = CR)) Then
                lastBreak = j
            End If
        End If
        If (TextWrapping <> 2) And (Len(c) = TextWidth) Then Exit Do
        If (d = CR) Then
            Exit Do
        End If
    Loop
    If (lastBreak <> 0) Then j = lastBreak
    BackBreak& = j
End Function
 
Function BackBreak2& (a As Long)
    Dim c As String
    Dim d As String
    Dim j As Long
    Dim k As Long
    Dim lastBreak As Long
    j = a
    lastBreak = 0
    c = ""
    Do
        If (j = BOC) Then Exit Do
        k = TheChain(j).Lagger
        If (k = BOC) Then
            lastBreak = j
            Exit Do
        End If
        j = k
        d = TheChain(j).Content
        c = d + c
        If (TextWrapping = 1) Then
            If (d = CR) Then
                If (Mid$(c, 2, 1) = ">") Or (Mid$(c, 2, 1) = "]") Then
                    'If ((d = " ") Or (d = CR)) Then
                    lastBreak = TheChain(j).Pointer
                    'lastBreak = j
                End If
            End If
        End If
        If (TextWrapping <> 2) And (Len(c) = TextWidth) Then Exit Do
        If (d = CR) Then
            If (Mid$(c, 2, 1) = ">") Or (Mid$(c, 2, 1) = "]") Then
                'If (d = CR) Then
                Exit Do
            End If
        End If
    Loop
    If (lastBreak <> 0) Then j = lastBreak
    BackBreak2& = j
End Function
 
 
Sub InsertBefore (a As Long, b As String)
    ' Inserts a single cell before address a in the chain.
    Dim lg As Long
    Dim j As Long
    j = NextOpenIdentity&(a)
    lg = TheChain(a).Lagger
    TheChain(j).Identity = j
    TheChain(j).Pointer = a
    TheChain(j).Lagger = lg
    TheChain(j).Content = b
    TheChain(a).Lagger = j
    If (lg = BOC) Then
        StartIndex = j
    Else
        TheChain(lg).Pointer = j
    End If
End Sub
 
Sub InsertCharacter (k As Integer)
    If (InsertKey = -1) Then
        Call InsertBefore(ID1, LTrim$(RTrim$(Chr$(k))))
    Else
        TheChain(ID1).Content = LTrim$(RTrim$(Chr$(k)))
        ID1 = NthP&(ID1, 2)
    End If
    If (TextWrapping = 2) Then
        If (Cursor1.X - LeftIndent = TextWidth) Then
            HScroll = HScroll + 1
        End If
    End If
End Sub
 
Function InsertAfter& (a As Long, b As String)
    ' Inserts a single cell after address a in the chain.
    Dim j As Long
    Dim p As Long
    j = NextOpenIdentity&(a)
    p = TheChain(a).Pointer
    TheChain(j).Identity = j
    TheChain(j).Pointer = p
    TheChain(j).Lagger = a
    TheChain(j).Content = b
    TheChain(a).Pointer = j
    If (p <> EOC) Then
        TheChain(p).Lagger = j
    End If
    InsertAfter& = j
End Function
 
Function LinearCount& (a As Long, b As Long)
    LinearCount& = LinearCountProto&(a, b, ChainLimit + 1)
End Function
 
Function LinearCountProto& (a As Long, b As Long, c As Long)
    ' Returns number of links between two addresses, with exit condition.
    Dim i As Long
    Dim j As Long
    Dim k As Long
    i = a
    k = 0
    Do While (i <> b)
        k = k + 1
        j = i
        i = TheChain(j).Pointer
        If (i = EOC) Then Exit Do
        If (k = c) Then Exit Do
    Loop
    LinearCountProto& = k
End Function
 
Function Projection$ (a As Long, b As Long)
    ' Returns the linear content for all address between a and b, inclusive.
    Dim TheReturn As String
    Dim j As Long
    Dim k As Long
    Dim c As String
    TheReturn = ""
    If (a = b) Then
        TheReturn = TheChain(a).Content
    Else
        j = a
        Do
            c = TheChain(j).Content
            TheReturn = TheReturn + c
            k = TheChain(j).Pointer
            If (j = b) Then Exit Do
            If (k = EOC) Then Exit Do
            j = k
        Loop
    End If
    Projection$ = TheReturn
End Function
 
Sub MapText
    Dim c1 As Long
    Dim c2 As Long
    Dim i As Integer
    Dim r As Integer
    Dim m As Integer
    Dim j As Long
    Dim k As Long
    Dim k1 As Long
    Dim k2 As Long
    Dim n As Long
    Dim q As String
    Dim d As String
    Dim c As String
    Dim brsymbol As String
    If (TextFormatting = 1) Then
        brsymbol = "~"
    Else
        brsymbol = " "
    End If
    j = StartIndex
    i = 1
    q = ""
    d = ""
    Do ' Begin with any left-over text from previous iteration.
        q = d
        d = ""
        r = TextWidth - Len(q)
 
        '''
        If (TextWrapping = 0) Then
            k1 = NthP&(j, r)
            If (TheChain(k1).Pointer = EOC) Then k1 = EOC
        End If
        If (TextWrapping = 1) Then
            k1 = NthP&(j, r)
            If (TheChain(k1).Pointer = EOC) Then k1 = EOC
        End If
        If (TextWrapping = 2) Then
            k1 = EOC
        End If
        '''
 
        k2 = j
        Do
            If (TheChain(k2).Content = CR) Then Exit Do
            If (TheChain(k2).Pointer = EOC) Then Exit Do
            k2 = TheChain(k2).Pointer
        Loop
 
        If (TextWrapping <> 2) Then
            c1 = LinearCount&(j, k1)
        Else
            c1 = LinearCountProto&(j, k1, TextWidth * TextHeight)
        End If
 
        c2 = LinearCount&(j, k2)
 
        If (c2 = 0) Then ' Line has one character (except in Fluid mode).
            k = k2
            If (TheChain(j).Content = CR) Then
                q = q + brsymbol
            Else
                q = q + TheChain(j).Content
            End If
            j = NthP&(k, 2)
 
        Else
 
            If (c1 = c2) Then ' End of line. (Possible end of chain?)
                '''
                If (TextWrapping = 0) Then
                    k = k1
                    If (TheChain(k).Content = CR) Then
                        q = q + Projection$(j, TheChain(k).Lagger) + brsymbol
                    Else
                        q = q + Projection$(j, k)
                    End If
                    j = NthP&(k, 2)
                End If
                If (TextWrapping = 1) Then
                    k = TheChain(k1).Lagger
                    If (TheChain(k).Content = CR) Then
                        q = q + Projection$(j, TheChain(k).Lagger) + brsymbol
                    Else
                        q = q + Projection$(j, k)
                    End If
                    j = NthP&(k, 2)
                End If
                If (TextWrapping = 2) Then
                    k = k1 ' == EOC
                    q = q + Projection$(j, k)
                    j = NthP&(k, 2)
                End If
                '''
            End If
            If (c1 < c2) Then ' Width limit case (not always maximum).
                k = k1
                q = q + Projection$(j, k)
                j = NthP&(k, 2)
            End If
            If (c1 > c2) Then ' Break return somewhere in line (not first).
                k = k2
                n = TheChain(k).Pointer
                ''' Clean this up if compelled.
                If (n <> EOC) Then
                    q = q + Projection$(j, TheChain(k).Lagger) + brsymbol
                    j = n
                Else ' End of chain.
                    If (TheChain(k).Content = CR) Then
                        q = q + Projection$(j, TheChain(k).Lagger) + brsymbol
                    Else
                        q = q + Projection$(j, k)
                    End If
                End If
                '''
            End If
        End If
 
        If (TextWrapping = 1) Then ' Wrap text at first breaking character from right, send remainder to next line.
            If (Len(q) >= TextWidth) Then
                For m = Len(q) To 1 Step -1
                    c = Mid$(q, m, 1)
                    If ((c = " ") Or (c = "-") Or (c = ".") Or (c = "_") Or (c = brsymbol)) Then
                        q = Left$(q, m)
                        Exit For
                    End If
                    d = c + d
                Next
                If (m = 0) Then ' Text is too long for line and contains no wrapping characters.
                    q = Left$(q, TextWidth)
                    d = ""
                End If
            End If
        End If
 
        LineAsMapped(i) = q
        i = i + 1
 
        If (n = EOC) Then
            If (d <> "") Then
                LineAsMapped(i) = d
                i = i + 1
            End If
            Exit Do
        End If
        If (i = TextHeight) Then
            'IF (d <> "") THEN BEEP
            Exit Do
        End If
        If (j = k) Then
            'IF (d <> "") THEN BEEP
            Exit Do
        End If
    Loop
    VisibleLines = i - 1
End Sub
 
Sub PasteClipboard (a As Long, b As String)
    Dim z As Long
    z = InsertString&(b, a)
End Sub
 
Sub CalibrateCursor (a As Long)
    ' Place Cursor under ID on rendered line.
    Dim s As Long
    Dim c As Long
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim n As Integer
    s = StartIndex
    If ((TextWrapping = 2) And (HScroll > 1)) Then s = NthP&(s, HScroll)
    c = LinearCount&(s, a)
    k = 0
    i = -1
    For j = 1 To VisibleLines
        n = Len(LineAsMapped(j))
        If (k + n < c) Then
            k = k + n
        Else
            i = c - k + 1
            Exit For
        End If
    Next
    If (j < VisibleLines) Then
        If (i >= 1 + Len(LineAsMapped(j))) Then ''' Clean this line up a little.
            i = 1
            j = j + 1
        End If
    End If
    If (a = ID1) Then
        Cursor1.X = LeftIndent + i
        Cursor1.Y = TopIndent + j
    End If
    If (a = ID2) Then
        Cursor2.X = LeftIndent + i
        Cursor2.Y = TopIndent + j
    End If
End Sub
 
Function FindID% (a As Integer, b As Long)
    ' Find identity under a mapped location.
    Dim relx As Integer
    Dim rely As Integer
    Dim k As Integer
    Dim t As Integer
    relx = a - LeftIndent
    rely = b - TopIndent
    For k = 1 To rely - 1
        t = t + Len(LineAsMapped(k))
    Next
    t = t + relx
    FindID% = t
End Function
 
Sub ReassignID1
    ID1 = NthP&(StartIndex, FindID%(Cursor1.X, Cursor1.Y) + (HScroll - 1))
End Sub
 
Sub ReassignID2
    ID2 = NthP&(StartIndex, FindID%(Cursor2.X, Cursor2.Y) + (HScroll - 1))
End Sub
 
Sub PrintEverything
    Color BackgroundColor, BackgroundColor
    Cls
    Call PrintWires
    Call HorizontalScrollbar
    Call PrintStatusBars(VerticalScrollbar#)
    Call PrintCursorInfo
    Call PrintMainText
    Call PrintCursor2
    Call PrintCursor1
End Sub
 
Sub PrintWires
    Dim i As Integer
    Color WireColor, BackgroundColor
    Call StringPrint("PrintWires", WindowWidth, WindowHeight - 1, Chr$(217))
    Call StringPrint("PrintWires", LeftIndent, WindowHeight - 1, Chr$(192))
    For i = 1 + TopIndent To WindowHeight - 2
        Call StringPrint("PrintWires", LeftIndent, i, Chr$(179))
    Next
    Call StringPrint("PrintWires", LeftIndent, TopIndent, Chr$(218))
    Call StringPrint("PrintWires", WindowWidth, TopIndent, Chr$(191))
    For i = 1 + LeftIndent To WindowWidth - 1
        Call StringPrint("PrintWires", i, TopIndent, Chr$(196))
    Next
End Sub
 
Sub HorizontalScrollbar
    Dim i As Integer
    Dim p As Long
    Dim q As Long
    Dim r As Double
    Dim s As Double
    Color ScrollbarBase, BackgroundColor
    For i = (1 + LeftIndent) To (WindowWidth - 1)
        Call StringPrint("HorizontalScrollbar1", i, WindowHeight - 1, Chr$(177))
    Next
    p = LinearCount&(NthP&(StartIndex, FindID%(LeftIndent + 1, Cursor1.Y)), ID1)
    q = Len(LineAsMapped(Cursor1.Y - TopIndent))
    If (q <> 1) Then
        r = p / (q - 1)
        If (r > 1) Then r = 1
    Else
        r = 0
    End If
    s = r * (WindowWidth - LeftIndent - 2)
    i = (1 + LeftIndent) + Int(s)
    Color ScrollbarFace, ScrollbarBack
    Call StringPrint("HorizontalScrollbar2", i, WindowHeight - 1, "^")
End Sub
 
Function VerticalScrollbar#
    Dim i As Integer
    Dim p As Long
    Dim q As Long
    Dim r As Double
    Dim s As Double
    Color ScrollbarBase, BackgroundColor
    For i = (1 + TopIndent) To (WindowHeight - 2)
        Call StringPrint("VerticalScrollbar#", WindowWidth, i, Chr$(177))
    Next
    p = LinearCount&(ID1, NthP&(ID1, ChainLimit + 1))
    q = LinearCount&(NthL&(ID1, ChainLimit + 1), NthP&(ID1, ChainLimit + 1))
    If (q = 0) Then
        r = 1
    Else
        r = Abs(1 - p / q)
    End If
    s = r * (WindowHeight - TopIndent - 3)
    i = (1 + TopIndent) + Int(s)
    Color ScrollbarFace, ScrollbarBack
    Call StringPrint("VerticalScrollbar#", WindowWidth, i, "<")
    VerticalScrollbar# = r
End Function
 
Sub PrintStatusBars (r As Double)
    Dim c As String
    c = ""
    If (TextFormatting = 1) Then c = "[Fmt] " + c
    Select Case TextWrapping
        Case 0: c = c + "[Square]" + " "
        Case 1: c = c + "[Fluid]" + " "
        Case 2: c = c + "[None]" + " "
    End Select
    c = c + "[" + LTrim$(RTrim$(Str$(Int(100 * r)))) + "%]"
    If (Len(c) >= TextWidth) Then c = Left$(c, TextWidth)
    Color StatusBarColor, BackgroundColor
    Call StringPrint("PrintStatusBars", WindowWidth - Len(c), TopIndent, c)
    c = ""
    If (InsertKey = 1) Then c = "[Ins]" + c
    If (Len(c) >= TextWidth) Then c = Left$(c, TextWidth)
    Color StatusBarColor, BackgroundColor
    Call StringPrint("PrintStatusBars", WindowWidth - Len(c), WindowHeight, c)
End Sub
 
Sub PrintCursorInfo
    Dim c As String
    Dim d As String
    Dim c0 As String
    Dim d0 As String
    c = TheChain(ID1).Content
    d = TheChain(ID2).Content
    c0 = c
    d0 = d
    If (c = LF) Then c = "@" ' Should never happen.
    If (d = LF) Then d = "@" ' Should never happen.
    If (c = CR) Then c = "~"
    If (d = CR) Then d = "~"
    If (c = Spacebar) Then c = "_"
    If (d = Spacebar) Then d = "_"
    c = "(" + LTrim$(RTrim$(Str$(Cursor1.X - LeftIndent))) + " " + LTrim$(RTrim$(Str$(Cursor1.Y - TopIndent))) + " " + c + Str$(ID1) + ")"
    Color CursorStdFace, Cursor1Back
    Call StringPrint("PrintCursorInfo", 1 + LeftIndent, WindowHeight, c)
    'IF (LinearCount&(StartIndex, ID2) > LinearCount&(StartIndex, ID1)) THEN
    d = "(" + LTrim$(RTrim$(Str$(Cursor2.X - LeftIndent))) + " " + LTrim$(RTrim$(Str$(Cursor2.Y - TopIndent))) + " " + d + Str$(ID2) + ")"
    Color CursorStdFace, Cursor2Back
    Call StringPrint("PrintCursorInfo", 2 + LeftIndent + Len(c), WindowHeight, d)
    'END IF
    Color TitleColor, BackgroundColor
    Call StringPrint("PrintCursorInfo", 1 + LeftIndent, TopIndent, "[qXed]" + Debug$)
End Sub
 
Sub PrintMainText
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim k0 As Integer
    Dim k00 As Integer
    Dim c As String
    Dim d As String
    For i = 1 To VisibleLines
        c = LineAsMapped(i)
        If (TextFormatting = 1) Then
            For j = 1 To TextWidth - Len(c)
                c = c + "_"
            Next
        End If
        d = Mid$(c, HScroll, TextWidth)
 
        If (Highlight <> "") Then
            k = InStr(d, Highlight)
        End If
        If (k > 0) Then
            k0 = 0
            Do While (k > 0)
                k00 = k0 + k - 1
                Color TextFaceColor, TextBackColor
                Call StringPrint("PrintMainText", k0 + LeftIndent + 1, TopIndent + i, Left$(d, k - 1))
                Color TextHighFace, TextHighBack
                Call StringPrint("PrintMainText", k0 + k - 1 + LeftIndent + 1, TopIndent + i, Mid$(d, k, Len(Highlight)))
                d = Right$(d, Len(d) - k - Len(Highlight) + 1)
                k0 = k0 + k - 1 + Len(Highlight)
                k = InStr(d, Highlight)
            Loop
            Color TextFaceColor, TextBackColor
            Call StringPrint("PrintMainText", k00 + Len(Highlight) + LeftIndent + 1, TopIndent + i, d)
        Else
            Color TextFaceColor, TextBackColor
            Call StringPrint("PrintMainText", LeftIndent + 1, TopIndent + i, d)
        End If
    Next
End Sub
 
Sub PrintCursor1
    Dim c As String
    If ((Cursor1.X > 0 And Cursor1.X < WindowWidth) And ((Cursor1.Y > 0) And (Cursor1.Y < WindowHeight))) Then
        c = TheChain(ID1).Content
        If (c = " ") Then c = "_"
        If (c = CR) Then c = "~"
        If ((Cursor1.X = Cursor2.X) And (Cursor1.Y = Cursor2.Y)) Then
            Color CursorBlinkFace, CursorMixedBack
            Call StringPrint("PrintCursor1", Cursor1.X, Cursor1.Y, c)
        Else
            Color CursorBlinkFace, Cursor1Back
            Call StringPrint("PrintCursor1", Cursor1.X, Cursor1.Y, c)
        End If
    End If
End Sub
 
Sub PrintCursor2
    Dim c As String
    Dim p1 As Long
    Dim p2 As Long
    Dim pe As Long
    If ((Cursor2.X > 0 And Cursor2.X < WindowWidth) And ((Cursor2.Y > 0) And (Cursor2.Y < WindowHeight))) Then
        p1 = LinearCount&(StartIndex, ID1)
        p2 = LinearCount&(StartIndex, ID2)
        pe = LinearCount&(StartIndex, EOC)
        If p2 < pe Then 'IF ((p2 > p1) AND (p2 < pe)) THEN
            c = TheChain(ID2).Content
            If (c = " ") Then c = "_"
            If (c = CR) Then c = "~"
            Color CursorStdFace, Cursor2Back
            Call StringPrint("PrintCursor2", Cursor2.X, Cursor2.Y, c)
        End If
    End If
End Sub
 
Function StateChange%
    Dim TheReturn As Integer
    Dim MH As Integer
    Dim MW As Integer
    Dim MT As Integer
    Dim MH1 As Integer
    Dim MH2 As Integer
    Dim MH3 As Integer
    Dim KH As Long
    MH = 0
    MW = 0
    MT = 0
 
    KH = _KeyHit
 
    Do While _MouseInput
        MH1 = _MouseButton(1)
        MH2 = _MouseButton(2)
        MH3 = _MouseButton(3)
        MW = _MouseWheel
        If (MW <> 0) Then MT = MW
    Loop
    MW = MT
 
    If (MH1 = -1) Then MH = MouseButton1%
    If (MH2 = -1) Then MH = MouseButton2%
    If (MH3 = -1) Then MH = MouseButton3%
    If (MW = -1) Then MH = MouseWheelUp%
    If (MW = 1) Then MH = MouseWheelDown%
 
    If (KH = KeyboardBksp) Then Call KeyBksp
    If (KH = KeyboardTab) Then Call KeyTab
    If (KH = KeyboardEsc) Then Call KeyEsc
    If (KH = KeyboardEnter) Or ((KH >= 32) And (KH <= 126)) Then Call KeyEnterAlphaNumer(KH)
    If (KH = KeyboardF1) Then Call KeyF1
    If (KH = KeyboardF2) Then Call KeyF2
    If (KH = KeyboardF3) Then Call KeyF3
    If (KH = KeyboardF4) Then Call KeyF4
    If (KH = KeyboardF5) Then Call KeyF5
    If (KH = KeyboardF6) Then Call KeyF6
    'If (KH = KeyboardF7) Then Call KeyF7
    If (KH = KeyboardF10) Then Call KeyF10
    If (KH = KeyboardF11) Then Call KeyF11
    If (KH = KeyboardF12) Then Call KeyF12
    If (KH = KeyboardHome) Then Call KeyHome
    If (KH = KeyboardUpArrow) Then Call KeyUpArrow
    If (KH = KeyboardPgUp) Then Call KeyPgUp
    If (KH = KeyboardLeftArrow) Then Call KeyLeftArrow
    If (KH = KeyboardRightArrow) Then Call KeyRightArrow
    If (KH = KeyboardEnd) Then Call KeyEnd
    If (KH = KeyboardDnArrow) Then Call KeyDwnArrow
    If (KH = KeyboardPgDn) Then Call KeyPgDn
    If (KH = KeyboardIns) Then Call KeyIns
    If (KH = KeyboardDel) Then Call KeyDel
 
    ' Exit sequence
    TheReturn = 0
    If ((MH <> 0) Or (KH > 0)) Then
        TheReturn = 1
        Call MapText
        Call CalibrateCursor(ID1)
        Call CalibrateCursor(ID2)
 
        ' Cursor sync and autoscrolling.
        Do While (Cursor1.Y > TopIndent + TextHeight - 1)
            StartIndex = NthP&(StartIndex, Len(LineAsMapped(1)) + 1)
            Call MapText
            Call CalibrateCursor(ID1)
            Call CalibrateCursor(ID2)
        Loop
        If (TextWrapping = 2) Then '''
            Do While (Cursor1.X > LeftIndent + TextWidth - 0)
                HScroll = HScroll + 1
                Cursor1.X = Cursor1.X - 1
            Loop
        End If
 
    End If
    MH = 0
    KH = 0
    _KeyClear
    StateChange% = TheReturn
End Function
 
Function MouseButton1%
    Dim As Double mx, my
    mx = _MouseX ' Int(_MouseX / 8)
    my = _MouseY ' Int(_MouseY / 16)
    If ((mx > LeftIndent) And (mx < TextWidth + LeftIndent + 1) And (my > TopIndent) And (my < TopIndent + TextHeight)) Then
        Call MouseButton1Cursor
    End If
    If (mx = WindowWidth) Then
        Call MouseButton1VScroll
    End If
    If (my = WindowHeight - 1) Then
        Call MouseButton1Hscroll
    End If
    MouseButton1% = 1
End Function
 
Sub MouseButton1VScroll
    ' This sub does things wrong.
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim t As Long
    Dim r As Double
    Dim f As Double
    Dim As Double mx, my
    mx = _MouseX ' Int(_MouseX / 8)
    my = _MouseY ' Int(_MouseY / 16)
    If ((my > TopIndent) And (my < (TopIndent + TextHeight))) Then
        i = NthL&(ID1, ChainLimit + 1)
        j = NthP&(ID1, ChainLimit + 1)
        If (my = 1 + TopIndent) Then
            i = i ' clicked at top
        ElseIf (my = (TopIndent + TextHeight - 1)) Then
            i = j ' clicked at bottom
        Else
            t = LinearCount&(i, j)
            f = (my - TopIndent + 1) / (WindowHeight - TopIndent)
            For k = 1 To t
                r = k / t
                If (r >= f) Then Exit For
                i = TheChain(i).Pointer
            Next
            If (TextWrapping <> 2) Then
                'i = BackBreak&(i)
            End If
        End If
        StartIndex = i
        ID1 = i
    End If
End Sub
 
Sub MouseButton1Hscroll
    Dim i As Long
    Dim j As Long
    Dim k As Integer
    Dim t As Integer
    Dim r As Double
    Dim f As Double
    Dim As Double mx, my
    mx = _MouseX ' Int(_MouseX / 8)
    my = _MouseY ' Int(_MouseY / 16)
    If ((mx > LeftIndent) And (mx < (LeftIndent + 1 + TextWidth))) Then
        j = ID1
        i = NthP&(StartIndex, FindID%(LeftIndent + 1, Cursor1.Y))
        t = Len(LineAsMapped(Cursor1.Y - TopIndent))
        f = (mx - LeftIndent) / (WindowWidth - LeftIndent)
        For k = 1 To t
            r = k / t
            If (r >= f) Then Exit For
            i = TheChain(i).Pointer
        Next
        ID1 = i
        k = LinearCount&(StartIndex, i) - LinearCount&(StartIndex, j)
        If (TextWrapping = 2) Then HScroll = HScroll + k
        If (HScroll < 1) Then HScroll = 1
    End If
End Sub
 
Sub MouseButton1Cursor
    Dim k As Integer
    Dim As Double mx, my
    mx = _MouseX ' Int(_MouseX / 8)
    my = _MouseY ' Int(_MouseY / 16)
    Cursor1.X = mx
    k = LeftIndent + Len(LineAsMapped(my - TopIndent)) - (HScroll - 1)
    If (Cursor1.X > k) Then
        If (k < 0) Then
            If (Len(LineAsMapped(my - TopIndent)) > TextWidth) Then
                HScroll = 1 + Len(LineAsMapped(my - TopIndent)) - (Cursor1.X - LeftIndent)
            Else
                HScroll = 1
                Cursor1.X = LeftIndent + Len(LineAsMapped(my - TopIndent))
            End If
        Else
            Cursor1.X = k
        End If
    End If
    Cursor1.Y = my
    Call ReassignID1
End Sub
 
Function MouseButton2%
    ' Move Cursor2.
    Dim k As Integer
    Dim As Double mx, my
    mx = _MouseX ' Int(_MouseX / 8)
    my = _MouseY ' Int(_MouseY / 16)
    If (mx > LeftIndent) And (mx < TextWidth + LeftIndent + 1) And (my > TopIndent) And (my < TopIndent + TextHeight + 1) Then
        Cursor2.X = mx
        k = LeftIndent + Len(LineAsMapped(my - TopIndent)) - (HScroll - 1)
        If (Cursor2.X > k) Then
            If (k < 0) Then
            Else
                Cursor2.X = k
            End If
        End If
        Cursor2.Y = my
        Call ReassignID2
    End If
    MouseButton2% = 1
End Function
 
Function MouseButton3%
    Call PasteClipboard(ID1, _Clipboard$)
    MouseButton3% = 1
End Function
 
Function MouseWheelUp%
    Call KeyUpArrow
    MouseWheelUp% = 1
End Function
 
Function MouseWheelDown%
    Call KeyDwnArrow
    MouseWheelDown% = 1
End Function
 
Sub KeyBksp
    Dim qq As Long
    Dim q As Long
    Dim p As Long
    q = TheChain(ID1).Lagger
    p = TheChain(ID1).Pointer
    If (q = BOC) Then
        ' Do nothing.
    End If
    If (q <> BOC) Then
        If ((TextWrapping = 2) And (Cursor1.X - LeftIndent = 1)) Then
            If (HScroll > 1) Then
                HScroll = HScroll - 1
                Call CalibrateCursor(ID1)
            End If
        End If
        qq = TheChain(q).Lagger
        TheChain(ID1).Lagger = qq
        TheChain(q).Identity = 0
        If (qq <> BOC) Then
            If (StartIndex = q) Then StartIndex = BackBreak&(StartIndex)
            TheChain(qq).Pointer = ID1
        End If
        If (qq = BOC) Then
            StartIndex = ID1
        End If
    End If
    ID2 = StartIndex
End Sub
 
Sub KeyDel
    Dim i As _Integer64
    Dim q As Long
    Dim p As Long
    Dim q2 As Long
    Dim p2 As Long
 
    If (LinearCount(StartIndex, ID2) = LinearCount&(StartIndex, EOC)) Then
        i = -1
    Else
        i = LinearCount&(StartIndex, ID2) - LinearCount&(StartIndex, ID1)
    End If
 
    If (i <= 0) Then
        q = TheChain(ID1).Lagger
        p = TheChain(ID1).Pointer
        If (q = BOC) And (p = EOC) Then
            ' Never delete the only character.
            TheChain(ID1).Content = " "
        End If
        If (q <> BOC) And (p <> EOC) Then
            If (StartIndex = ID1) Then StartIndex = p
            TheChain(p).Lagger = q
            TheChain(ID1).Identity = 0
            TheChain(q).Pointer = p
            ID1 = p
        End If
        If ((q = BOC) And (p <> EOC)) Then
            StartIndex = p
            TheChain(p).Lagger = q
            TheChain(ID1).Identity = 0
            ID1 = p
        End If
        If ((q <> BOC) And (p = EOC)) Then
            If (StartIndex = ID1) Then StartIndex = q
            TheChain(ID1).Identity = 0
            TheChain(q).Pointer = p
            ID1 = q
        End If
    End If
 
    If (i > 0) Then
        q = TheChain(ID1).Lagger
        p = TheChain(ID1).Pointer
        q2 = TheChain(ID2).Lagger
        p2 = TheChain(ID2).Pointer
 
        If ((q <> BOC) And (p2 <> EOC)) Then
            If (StartIndex = ID1) Then StartIndex = p2
            Call UnlinkRange(ID1, ID2)
            ID1 = TheChain(q).Pointer
        End If
        If ((q = BOC) And (p2 <> EOC)) Then
            StartIndex = p2
            Call UnlinkRange(p, ID2)
            TheChain(p2).Lagger = q
            ID1 = p2
        End If
        If ((q <> BOC) And (p2 = EOC)) Then
            If (StartIndex = ID1) Then StartIndex = q
            Call UnlinkRange(ID1, q2)
            TheChain(ID2).Identity = 0
            TheChain(q).Pointer = p2
            ID1 = q
        End If
        If ((q = BOC) And (p2 = EOC)) Then
            StartIndex = ID1 '''
            Call UnlinkRange(p, q2)
            TheChain(ID2).Identity = 0
            TheChain(ID1).Content = " "
            TheChain(ID1).Lagger = BOC
            TheChain(ID1).Pointer = EOC
        End If
    End If
 
    ID2 = StartIndex
End Sub
 
Sub UnlinkRange (a As Long, b As Long)
    Dim q As Long
    Dim u As Long
    Dim p As Long
    q = TheChain(a).Lagger
    u = a
    Do
        TheChain(u).Identity = 0
        p = TheChain(u).Pointer
        If (u = b) Then Exit Do
        If (p <> EOC) Then u = p
    Loop
    TheChain(p).Lagger = q
    If (q <> BOC) Then TheChain(q).Pointer = p
End Sub
 
Sub KeyEsc
    If (ID2 <> ID1) Then
        ID2 = ID1
    Else
        ID2 = StartIndex
    End If
End Sub
 
Sub KeyEnterAlphaNumer (k As Integer)
    Dim z As Long
    Dim a As String
    Dim b As String
    Dim c As String
    Dim n As Integer
    If (_KeyDown(KeyboardLeftCtrl) Or _KeyDown(KeyboardRightCtrl)) Then
 
        If (k = KeyboardEnter) Then
            z = BackBreak2&(ID1)
            a = Projection$(z, TheChain(ID1).Lagger)
 
            If (Left$(a, 1) = ">") Then
                a = Right$(a, Len(a) - 1)
                a = _Trim$(a)
                a = pipecom_lite$(a)
                Do While ((Right$(a, 1) = CR) Or (Right$(a, 1) = LF))
                    a = Left$(a, Len(a) - 1)
                Loop
                z = InsertString&(CR + "(" + a + ")" + CR + ">", ID1)
            End If
 
            If (Left$(a, 6) = "]save ") Then
                a = Right$(a, Len(a) - 6)
                n = InStr(a, " ")
                b = Left$(a, n - 1)
                c = Right$(a, Len(a) - n)
                If (b <> "") Then
                    Open b For Output As #1
                    Print #1, c
                    Close #1
                    z = InsertString&(CR + "(" + b + ")" + CR + "]", ID1)
                Else
                    z = InsertString&(CR + "(" + "Error" + ")" + CR + "]", ID1)
                End If
            End If
 
            ID2 = StartIndex
        End If
 
 
        If (k = Asc("c")) Or (k = Asc("C")) Then
            _Clipboard$ = Projection$(ID1, ID2)
            ID2 = StartIndex
        End If
 
        If (k = Asc("v")) Or (k = Asc("V")) Then
            Call PasteClipboard(ID1, _Clipboard$)
            ID2 = StartIndex
        End If
 
        '''
    Else
 
        Call InsertCharacter(k)
 
        If ((k = KeyboardEnter) And (TextWrapping = 2)) Then HScroll = 1
        If ((k = KeyboardEnter) And (Cursor1.Y = TextHeight)) Then
            Call KeyDwnArrow
            Call KeyHome
        End If
 
    End If
 
End Sub
 
Sub KeyF1
    Dim h0 As Integer
    h0 = HScroll
    Call KeyLeftArrow
    If (h0 = HScroll) Then
        If (TextWrapping = 2) Then
            HScroll = HScroll - 1
            If (HScroll < 1) Then HScroll = 1
        End If
    End If
End Sub
 
Sub KeyF2
    Dim h0 As Integer
    h0 = HScroll
    Call KeyRightArrow
    If ((HScroll = h0) And (HScroll <> 1)) Then
        If (TextWrapping = 2) Then
            HScroll = HScroll + 1
        End If
    End If
End Sub
 
Sub KeyF3
    Dim j As Integer
    Dim k As Integer
    For k = 2 To _Width - 1
        For j = Int(_Height / 3) - 2 To Int(_Height / 3) + 2
            Color BackgroundColor, BackgroundColor
            Call StringPrint("", k, j, " ")
        Next
        Color Cursor1Back, Cursor1Back
        Call StringPrint("", k, Int(_Height / 3) - 2, " ")
        Color Cursor1Back, Cursor1Back
        Call StringPrint("", k, Int(_Height / 3) + 2, " ")
    Next
    Color TextFaceColor, BackgroundColor
    Cls
    Locate 1, 1: Line Input "Text to highlight: ", Highlight
End Sub
 
Sub KeyF4
    Cursor1.X = LeftIndent + 1
    Call ReassignID1
    Cursor2.X = LeftIndent + Len(LineAsMapped(Cursor1.Y - TopIndent))
    Cursor2.Y = Cursor1.Y
    Call ReassignID2
End Sub
 
Sub KeyF5
    Dim a As Long
    Dim b As Long
    Dim c As String
    Dim k As Long
    a = NthL&(ID1, ChainLimit + 1)
    b = NthP&(ID1, ChainLimit + 1)
    c = Projection$(a, b) + CR
    For k = 1 To ChainLimit
        TheChain(k).Identity = 0
    Next
    a = Assimilate&(c, BOC, EOC)
End Sub
 
Sub KeyF6
    Dim c As String
    Open WorkingFileName For Output As #1
    c = Projection$(NthL&(ID1, ChainLimit + 1), NthP&(ID1, ChainLimit + 1))
    Print #1, c
    Close #1
End Sub
 
Sub KeyF7
    GOLSwitch = -GOLSwitch
End Sub
 
Sub KeyF10
    ColorTheme = -ColorTheme
    Call SetPalette
End Sub
 
Sub KeyF11
    TextFormatting = -TextFormatting
End Sub
 
Sub KeyF12
    TextWrapping = TextWrapping + 1
    If (TextWrapping > 2) Then
        TextWrapping = 0
    End If
    If (TextWrapping <> 2) Then
        HScroll = 1
    End If
End Sub
 
Sub KeyHome
    If (TextWrapping = 2) Then HScroll = 1
    Cursor1.X = LeftIndent + 1
    Call ReassignID1
End Sub
 
Sub KeyUpArrow
    Dim k As Integer
    If (Cursor1.Y > TopIndent + 1) Then
        Cursor1.Y = Cursor1.Y - 1
    Else
        StartIndex = BackBreak&(StartIndex)
    End If
    k = LeftIndent + Len(LineAsMapped(Cursor1.Y - TopIndent)) - (HScroll - 1)
    If (Cursor1.X > k) Then
        If (k < 0) Then
            If (Len(LineAsMapped(Cursor1.Y - TopIndent)) > TextWidth) Then
                HScroll = 1 + Len(LineAsMapped(Cursor1.Y - TopIndent)) - (Cursor1.X - LeftIndent)
            Else
                HScroll = 1
                Cursor1.X = LeftIndent + Len(LineAsMapped(Cursor1.Y - TopIndent))
            End If
        Else
            Cursor1.X = k
        End If
    End If
    Call ReassignID1
End Sub
 
Sub KeyPgUp
    Dim k As Integer
    For k = 1 To Int(TextHeight / 2)
        StartIndex = BackBreak&(StartIndex)
    Next
    Call ReassignID1
End Sub
 
Sub KeyLeftArrow
    Dim j As Integer
    Dim k As Integer
    ID1 = NthL&(ID1, 2)
    If (TextWrapping = 2) Then
        If (Cursor1.X = LeftIndent + 1) Then
            If (HScroll > 1) Then
                HScroll = HScroll - 1
            Else
                j = Cursor1.Y - TopIndent - 1
                If (j >= 1) Then
                    k = Len(LineAsMapped(j)) - TextWidth + 1
                    If (k >= 1) Then
                        HScroll = k
                    End If
                End If
            End If
        End If
    Else
        If ((Cursor1.X - LeftIndent = 1) And Cursor1.Y - TopIndent = 1) Then
            StartIndex = BackBreak&(StartIndex)
        End If
    End If
End Sub
 
Sub KeyRightArrow
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    ID1 = NthP&(ID1, 2)
    i = Cursor1.X - LeftIndent
    j = Len(LineAsMapped(Cursor1.Y - TopIndent)) - HScroll + 1
    If (TextWrapping = 2) Then
        If (i >= TextWidth) Then
            HScroll = HScroll + 1
            Call ReassignID1
        End If
        If (i >= j) Then
            k = Cursor1.Y - TopIndent + 1
            If ((k <= TextHeight) And (VisibleLines > 1)) Then HScroll = 1
        End If
    Else
        If ((i >= j) And (Cursor1.Y - TopIndent = VisibleLines)) Then
            If (VisibleLines > 1) Then StartIndex = NthP&(StartIndex, Len(LineAsMapped(1)) + 1)
        End If
    End If
End Sub
 
Sub KeyEnd
    Dim k As Integer
    If (TextWrapping <> 2) Then
        Cursor1.X = LeftIndent + Len(LineAsMapped(Cursor1.Y - TopIndent))
        Call ReassignID1
    End If
    If (TextWrapping = 2) Then
        Do
            If (TheChain(ID1).Content = CR) Then Exit Do
            If (TheChain(ID1).Pointer = EOC) Then Exit Do
            ID1 = TheChain(ID1).Pointer
        Loop
        k = Len(LineAsMapped(Cursor1.Y - TopIndent)) - TextWidth + 1
        If (k >= 1) Then
            HScroll = k
            Call CalibrateCursor(ID1)
        End If
    End If
End Sub
 
Sub KeyTab
    Dim z As Long
    z = InsertString&(Chr$(KeyboardTab), ID1)
End Sub
 
Sub KeyDwnArrow
    Dim k As Integer
    If (Cursor1.Y = TopIndent + VisibleLines) Then
        If (VisibleLines > 1) Then
            StartIndex = NthP&(StartIndex, Len(LineAsMapped(1)) + 1)
            Call MapText
        End If
    Else
        Cursor1.Y = Cursor1.Y + 1
    End If
    k = LeftIndent + Len(LineAsMapped(Cursor1.Y - TopIndent)) - (HScroll - 1)
    If (Cursor1.X > k) Then
        If (k < 0) Then
            If (Len(LineAsMapped(Cursor1.Y - TopIndent)) > TextWidth) Then
                HScroll = 1 + Len(LineAsMapped(Cursor1.Y - TopIndent)) - (Cursor1.X - LeftIndent)
            Else
                HScroll = 1
                Cursor1.X = LeftIndent + Len(LineAsMapped(Cursor1.Y - TopIndent))
            End If
        Else
            Cursor1.X = k
        End If
    End If
    Call ReassignID1
End Sub
 
Sub KeyPgDn
    Dim k As Integer
    For k = 1 To Int(TextHeight / 2)
        If (VisibleLines > 1) Then
            StartIndex = NthP&(StartIndex, Len(LineAsMapped(1)) + 1)
            Call MapText
        End If
    Next
    Call ReassignID1
End Sub
 
Sub KeyIns
    InsertKey = -InsertKey
End Sub
 
Sub ConvertToGrid
    Dim i As Integer
    Dim j As Integer
    Dim c As String
    For j = 1 To VisibleLines
        c = LineAsMapped(j)
        For i = 1 To Len(c) - 1 ' BR offset to exclude CR at line end.
            AuxGrid(i, j, 1) = Mid$(c, i, 1)
        Next
    Next
End Sub
 
Sub ConvertFromGrid
    Dim i As Integer
    Dim j As Integer
    Dim k As Long
    Dim c As String
    c = ""
    For j = 1 To VisibleLines
        For i = 1 To Len(LineAsMapped(j)) - 1
            c = c + AuxGrid(i, j, 1)
        Next
        c = c + CR ' Undoes BR offset.
    Next
    For k = 1 To ChainLimit
        TheChain(k).Identity = 0
    Next
    k = Assimilate&(c, BOC, EOC)
End Sub
 
Sub GOL
    Dim i As Integer
    Dim j As Integer
    Dim c As String
    Dim a1 As Integer
    Dim a2 As Integer
    Dim a3 As Integer
    Dim a4 As Integer
    Dim a6 As Integer
    Dim a7 As Integer
    Dim a8 As Integer
    Dim a9 As Integer
    Dim t As Integer
    For j = 1 To VisibleLines
        For i = 1 To Len(LineAsMapped(j)) - 1
            c = AuxGrid(i, j, 1)
            If (c = " ") Then c = "0" Else c = "1"
            AuxGrid(i, j, 1) = c
            AuxGrid(i, j, 2) = c
        Next
    Next
    For j = 2 To VisibleLines - 2 ' BR offset.
        For i = 2 To Len(LineAsMapped(j)) - 2 ' BR offset.
            c = AuxGrid(i, j, 1)
            a1 = Val(AuxGrid(i - 1, j + 1, 1))
            a2 = Val(AuxGrid(i, j + 1, 1))
            a3 = Val(AuxGrid(i + 1, j + 1, 1))
            a4 = Val(AuxGrid(i - 1, j, 1))
            a6 = Val(AuxGrid(i + 1, j, 1))
            a7 = Val(AuxGrid(i - 1, j - 1, 1))
            a8 = Val(AuxGrid(i, j - 1, 1))
            a9 = Val(AuxGrid(i + 1, j - 1, 1))
            t = a1 + a2 + a3 + a4 + a6 + a7 + a8 + a9
            If (c = "1") Then
                Select Case t
                    Case Is < 2
                        AuxGrid(i, j, 2) = "0"
                    Case 2
                        AuxGrid(i, j, 2) = "1"
                    Case 3
                        AuxGrid(i, j, 2) = "1"
                    Case Is > 3
                        AuxGrid(i, j, 2) = "0"
                End Select
            Else
                If (t = 3) Then AuxGrid(i, j, 2) = "1"
            End If
        Next
    Next
    For j = 1 To VisibleLines
        For i = 1 To Len(LineAsMapped(j)) - 1
            c = AuxGrid(i, j, 2)
            If (c = "0") Then c = " " Else c = Chr$(219)
            AuxGrid(i, j, 1) = c
            AuxGrid(i, j, 2) = c
        Next
    Next
End Sub
 
'''
 
$If PIPECOM = UNDEFINED Then
    $Let PIPECOM = TRUE
    Function pipecom& (cmd As String, stdout As String, stderr As String)
        stdout = "": stderr = ""
        $If WIN Then
            Type SECURITY_ATTRIBUTES
                As _Unsigned Long nLength
                $If 64BIT Then
                    As String * 4 padding
                $End If
                As _Offset lpSecurityDescriptor
                As Long bInheritHandle
                $If 64BIT Then
                    As String * 4 padding2
                $End If
            End Type
 
            Type STARTUPINFO
                As Long cb
                $If 64BIT Then
                    As String * 4 padding
                $End If
                As _Offset lpReserved, lpDesktop, lpTitle
                As _Unsigned Long dwX, dwY, dwXSize, dwYSize, dwXCountChars, dwYCountChars, dwFillAttribute, dwFlags
                As _Unsigned Integer wShowWindow, cbReserved2
                $If 64BIT Then
                    As String * 4 padding2
                $End If
                As _Offset lpReserved2, hStdInput, hStdOutput, hStdError
            End Type
 
            Type PROCESS_INFORMATION
                As _Offset hProcess, hThread
                As _Unsigned Long dwProcessId
                $If 64BIT Then
                    As String * 4 padding
                $End If
            End Type
 
            Const STARTF_USESTDHANDLES = &H00000100
            Const CREATE_NO_WINDOW = &H8000000
 
            Const INFINITE = 4294967295
            Const WAIT_FAILED = &HFFFFFFFF
 
            Declare CustomType Library
                Function CreatePipe& (ByVal hReadPipe As _Offset, Byval hWritePipe As _Offset, Byval lpPipeAttributes As _Offset, Byval nSize As _Unsigned Long)
                Function CreateProcess& (ByVal lpApplicationName As _Offset, Byval lpCommandLine As _Offset, Byval lpProcessAttributes As _Offset, Byval lpThreadAttributes As _Offset, Byval bInheritHandles As Long, Byval dwCreationFlags As _Unsigned Long, Byval lpEnvironment As _Offset, Byval lpCurrentDirectory As _Offset, Byval lpStartupInfo As _Offset, Byval lpProcessInformation As _Offset)
                Function GetExitCodeProcess& (ByVal hProcess As _Offset, Byval lpExitCode As _Offset)
                Sub HandleClose Alias "CloseHandle" (ByVal hObject As _Offset)
                Function ReadFile& (ByVal hFile As _Offset, Byval lpBuffer As _Offset, Byval nNumberOfBytesToRead As _Unsigned Long, Byval lpNumberOfBytesRead As _Offset, Byval lpOverlapped As _Offset)
                Function WaitForSingleObject~& (ByVal hHandle As _Offset, Byval dwMilliseconds As _Unsigned Long)
            End Declare
 
            Dim As Long ok: ok = 1
            Dim As _Offset hStdOutPipeRead, hStdOutPipeWrite, hStdReadPipeError, hStdOutPipeError
            Dim As SECURITY_ATTRIBUTES sa: sa.nLength = Len(sa): sa.lpSecurityDescriptor = 0: sa.bInheritHandle = 1
 
            If CreatePipe(_Offset(hStdOutPipeRead), _Offset(hStdOutPipeWrite), _Offset(sa), 0) = 0 Then
                pipecom = -1
                Exit Function
            End If
 
            If CreatePipe(_Offset(hStdReadPipeError), _Offset(hStdOutPipeError), _Offset(sa), 0) = 0 Then
                pipecom = -1
                Exit Function
            End If
 
            Dim As STARTUPINFO si
            si.cb = Len(si)
            si.dwFlags = STARTF_USESTDHANDLES
            si.hStdError = hStdOutPipeError
            si.hStdOutput = hStdOutPipeWrite
            si.hStdInput = 0
            Dim As PROCESS_INFORMATION procinfo
            Dim As _Offset lpApplicationName
            Dim As String lpCommandLine: lpCommandLine = "cmd /c " + cmd + Chr$(0)
            Dim As _Offset lpProcessAttributes, lpThreadAttributes
            Dim As Long bInheritHandles: bInheritHandles = 1
            Dim As _Unsigned Long dwCreationFlags: dwCreationFlags = CREATE_NO_WINDOW
            Dim As _Offset lpEnvironment, lpCurrentDirectory
            ok = CreateProcess(lpApplicationName, _Offset(lpCommandLine), lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, lpCurrentDirectory, _Offset(si), _Offset(procinfo))
 
            If ok = 0 Then
                pipecom = -1
                Exit Function
            End If
 
            HandleClose hStdOutPipeWrite
            HandleClose hStdOutPipeError
 
            Dim As String buf: buf = Space$(4096 + 1)
            Dim As _Unsigned Long dwRead
            While ReadFile(hStdOutPipeRead, _Offset(buf), 4096, _Offset(dwRead), 0) <> 0 And dwRead > 0
                buf = Mid$(buf, 1, dwRead)
                GoSub RemoveChr13
                stdout = stdout + buf
                buf = Space$(4096 + 1)
            Wend
 
            While ReadFile(hStdReadPipeError, _Offset(buf), 4096, _Offset(dwRead), 0) <> 0 And dwRead > 0
                buf = Mid$(buf, 1, dwRead)
                GoSub RemoveChr13
                stderr = stderr + buf
                buf = Space$(4096 + 1)
            Wend
 
            Dim As Long exit_code, ex_stat
            If WaitForSingleObject(procinfo.hProcess, INFINITE) <> WAIT_FAILED Then
                If GetExitCodeProcess(procinfo.hProcess, _Offset(exit_code)) Then
                    ex_stat = 1
                End If
            End If
 
            HandleClose hStdOutPipeRead
            HandleClose hStdReadPipeError
            If ex_stat = 1 Then
                pipecom = exit_code
            Else
                pipecom = -1
            End If
 
            Exit Function
 
            RemoveChr13:
            Dim As Long j
            j = InStr(buf, Chr$(13))
            Do While j
                buf = Left$(buf, j - 1) + Mid$(buf, j + 1)
                j = InStr(buf, Chr$(13))
            Loop
            Return
        $Else
            Declare CustomType Library
            Function popen%& (cmd As String, readtype As String)
            Function feof& (ByVal stream As _Offset)
            Function fgets$ (str As String, Byval n As Long, Byval stream As _Offset)
            Function pclose& (ByVal stream As _Offset)
            End Declare
 
            Declare Library
            Function WEXITSTATUS& (ByVal stat_val As Long)
            End Declare
 
            Dim As _Offset stream
 
            Dim buffer As String * 4096
            If _FileExists("pipestderr") Then
            Kill "pipestderr"
            End If
            stream = popen(cmd + " 2>pipestderr", "r")
            If stream Then
            While feof(stream) = 0
            If fgets(buffer, 4096, stream) <> "" And feof(stream) = 0 Then
            stdout = stdout + Mid$(buffer, 1, InStr(buffer, Chr$(0)) - 1)
            End If
            Wend
            Dim As Long status, exit_code
            status = pclose(stream)
            exit_code = WEXITSTATUS(status)
            If _FileExists("pipestderr") Then
            Dim As Integer errfile
            errfile = FreeFile
            Open "pipestderr" For Binary As #errfile
            If LOF(errfile) > 0 Then
            stderr = Space$(LOF(errfile))
            Get #errfile, , stderr
            End If
            Close #errfile
            Kill "pipestderr"
            End If
            pipecom = exit_code
            Else
            pipecom = -1
            End If
        $End If
    End Function
 
    Function pipecom_lite$ (cmd As String)
        Dim As Long a
        Dim As String stdout, stderr
        a = pipecom(cmd, stdout, stderr)
        If stderr <> "" Then
            pipecom_lite = stderr
        Else
            pipecom_lite = stdout
        End If
    End Function
$End If
 

Programs / Binary Sequence Predictor "game"?

« on: December 09, 2021, 09:57:14 pm »

SKIP RIGHT TO THE BEST ANSWER -> https://www.qb64.org/forum/index.php?topic=4473.msg139248#msg139248
(Ignore everything between here and there.)

Alright I feel like not highjacking r1's thread anymore, so I will show this work here instead. What I've got is a thing that lets you type any random sequence of 1's and 0's, and the program will EERILY predict the next number. You can give this probably any pre-cooked, esoteric sequence you can think of - I know I did - and the program gets the next digit right.

Now, for the cases when you don't know the next digit - such as when you're whimsically flipping a coin or whatever - of course a program cannot *predict* that. That was never the goal, stay away from that straw man. What this thing *does*, is it will tell you the next digit in the sequence according to patterns you had no clue you were inputting. When I test this thing, trying to be random, I can always see why the answer it gives is the most "expected" next result. It's kinda wild.

So in this program, you get a prompt. Press 1011101000101 blah blah your heart's content. Then the thing shows you a few stats that you don't really need to see. For the curious, these are "scores" that say how random you are at different "frequencies". Finally, after a few of those screens, you get the final summary and the computer's prediction. Try this on a few sequences where you know what the next digit *should* be. Watch it get those right, and then "try to be random"... And watch the program understand what you type better than you do! Test data is still included but that mode is commented out.

Code: QB64: [Select]

Option _Explicit
 
' Version: 5 OLD AS HELL, DO NOT RUN
 
Type LetterBin
    Signature As String
    Count As Integer
End Type
 
Dim Shared TheInput(1000, 2) As String
 
Dim Shared FingerPrint(16) As String
 
Dim Shared Alphabet1(2) As LetterBin
Alphabet1(1).Signature = "0"
Alphabet1(2).Signature = "1"
 
Dim Shared Alphabet2(4) As LetterBin
Dim Shared Alphabet3(8) As LetterBin
Dim Shared Alphabet4(16) As LetterBin
Dim Shared Alphabet5(32) As LetterBin
Dim Shared Alphabet6(64) As LetterBin
Dim Shared Alphabet7(128) As LetterBin
Dim Shared Alphabet8(256) As LetterBin
Dim Shared Alphabet9(512) As LetterBin
Dim Shared Alphabet10(1024) As LetterBin
Dim Shared Alphabet11(2048) As LetterBin
Dim Shared Alphabet12(4096) As LetterBin
Dim Shared Alphabet13(8192) As LetterBin
 
Call NewAlphabet(Alphabet1(), Alphabet2())
Call NewAlphabet(Alphabet2(), Alphabet3())
Call NewAlphabet(Alphabet3(), Alphabet4())
Call NewAlphabet(Alphabet4(), Alphabet5())
Call NewAlphabet(Alphabet5(), Alphabet6())
Call NewAlphabet(Alphabet6(), Alphabet7())
Call NewAlphabet(Alphabet7(), Alphabet8())
Call NewAlphabet(Alphabet8(), Alphabet9())
Call NewAlphabet(Alphabet9(), Alphabet10())
Call NewAlphabet(Alphabet10(), Alphabet11())
Call NewAlphabet(Alphabet11(), Alphabet12())
Call NewAlphabet(Alphabet12(), Alphabet13())
 
Call LoadInput
 
Dim m As Integer
Dim k As Integer
 
m = 1
Do
 
    Cls
    Call Analyze(m)
    Print
    Print "Press ESC to try again."
 
    _KeyClear: Do: k = _KeyHit: _Limit 30: Loop Until k = 27: _KeyClear
 
    'Select Case k
    '    Case 19712
    '        m = m + 1
    '    Case 19200
    '        m = m - 1
    '    Case Else
    '        Cls: _Display
    'End Select
    '_KeyClear
 
Loop
 
End
 
Sub Analyze (TheIndex As Integer)
    Dim actual As String
    Dim k As Integer
    Dim As Double p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13
 
    'FingerPrint(1) = TheInput(TheIndex, 1)
    'actual = TheInput(TheIndex, 2)
 
    FingerPrint(1) = ""
    actual = "?"
    Do While (Len(FingerPrint(1)) < 32)
        Print "Type random 1's and 0's and press Enter (at least 32, preferably way more):"
        Print "  ................................"
        _KeyClear
        Input FingerPrint(1)
        Print
    Loop
 
    For k = 2 To UBound(FingerPrint)
        FingerPrint(k) = Right$(FingerPrint(k - 1), Len(FingerPrint(k - 1)) - 1) + Left$(FingerPrint(k - 1), 1)
    Next
 
    Call CreateHisto(Alphabet2(), 2)
    Call CreateHisto(Alphabet3(), 3)
    Call CreateHisto(Alphabet4(), 4)
    Call CreateHisto(Alphabet5(), 5)
    Call CreateHisto(Alphabet6(), 6)
    Call CreateHisto(Alphabet7(), 7)
    Call CreateHisto(Alphabet8(), 8)
    Call CreateHisto(Alphabet9(), 9)
    Call CreateHisto(Alphabet10(), 10)
    Call CreateHisto(Alphabet11(), 11)
    Call CreateHisto(Alphabet12(), 12)
    Call CreateHisto(Alphabet13(), 13)
 
    Call PrintHisto(Alphabet2(), 0) ' Turn these numbers high to see stats for that alphabet.
    Call PrintHisto(Alphabet3(), 10)
    Call PrintHisto(Alphabet4(), 10)
    Call PrintHisto(Alphabet5(), 10)
    Call PrintHisto(Alphabet6(), 0)
    Call PrintHisto(Alphabet7(), 0)
    Call PrintHisto(Alphabet8(), 0)
    Call PrintHisto(Alphabet9(), 5)
    Call PrintHisto(Alphabet10(), 5)
    Call PrintHisto(Alphabet11(), 5)
    Call PrintHisto(Alphabet12(), 0)
    Call PrintHisto(Alphabet13(), 0)
 
    p2 = MakeGuess(Alphabet2(), 2)
    p3 = MakeGuess(Alphabet3(), 3)
    p4 = MakeGuess(Alphabet4(), 4)
    p5 = MakeGuess(Alphabet5(), 5)
    p6 = MakeGuess(Alphabet6(), 6)
    p7 = MakeGuess(Alphabet7(), 7)
    p8 = MakeGuess(Alphabet8(), 8)
    p9 = MakeGuess(Alphabet9(), 9)
    p10 = MakeGuess(Alphabet10(), 10)
    p11 = MakeGuess(Alphabet11(), 11)
    p12 = MakeGuess(Alphabet12(), 12)
    p13 = MakeGuess(Alphabet13(), 13)
 
    Cls
    'Print "String ID:"; TheIndex
    Print "Conclusions:"
    Print
    Print FingerPrint(1)
    Print
    Print "Thinking:  "; p2; p3; p4; p5; p6; p7; p8; p9; p10; p11; p12; p13
    Print
    Print "Predicted next number:"; (1 / 4) * (p10 + p11 + p12 + p13)
    Print
    'Print "Actual next number:    "; actual
End Sub
 
Function MakeGuess (arr() As LetterBin, w As Integer)
    Dim TheReturn As Double
    Dim As Integer k
    For k = 1 To UBound(arr)
        If (Left$(arr(k).Signature, w - 1) = Right$(FingerPrint(1), w - 1)) Then
            Print "..."; arr(k).Signature; arr(k).Count
            TheReturn = Val(Right$(arr(k).Signature, 1))
            If (arr(k).Count = 0) Then TheReturn = .5
            Exit For
        End If
    Next
    MakeGuess = TheReturn
End Function
 
Sub CreateHisto (arr() As LetterBin, w As Integer)
    Dim As Integer m, n, k
    For k = 1 To UBound(arr)
        arr(k).Count = 0
    Next
    For m = 1 To w
        For n = 1 To Len(FingerPrint(m)) - w Step w 'added the -w
            For k = 1 To UBound(arr)
                If (Mid$(FingerPrint(m), n, w) = arr(k).Signature) Then
                    arr(k).Count = arr(k).Count + 1
                End If
            Next
        Next
    Next
    Call BubbleSort(arr())
End Sub
 
Sub NewAlphabet (arrold() As LetterBin, arrnew() As LetterBin)
    Dim As Integer n, j, k
    n = 0
    For j = 1 To 2
        For k = 1 To UBound(arrold)
            n = n + 1
            arrnew(n).Signature = arrold(k).Signature
        Next
    Next
    For k = 1 To UBound(arrnew)
        If (k <= UBound(arrnew) / 2) Then
            arrnew(k).Signature = "0" + arrnew(k).Signature
        Else
            arrnew(k).Signature = "1" + arrnew(k).Signature
        End If
    Next
End Sub
 
Sub PrintHisto (arr() As LetterBin, w As Integer)
    Dim As Integer n, k
    If (w > 0) Then
        Cls
        Print "Unscaled randomness scores (top "; _Trim$(Str$(w)); "), Alphabet size:"; UBound(arr)
        If w > UBound(arr) Then k = UBound(arr) Else k = w
        For n = 1 To k
            Print arr(n).Signature; arr(n).Count
        Next
        Print
        Print "Press any key..."
        Sleep
        _KeyClear
        '_KeyClear: Do: k = _KeyHit: Loop Until k
    End If
End Sub
 
Sub BubbleSort (arr() As LetterBin)
    Dim As Integer i, j
    Dim As Integer u, v
    For j = UBound(arr) To 1 Step -1
        For i = 2 To UBound(arr)
            u = arr(i - 1).Count
            v = arr(i).Count
            If (u < v) Then
                Swap arr(i - 1), arr(i)
            End If
        Next
    Next
End Sub
 
Sub LoadInput
    Dim n As Integer
    '''
    n = 0
    '''
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "01010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "10101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "00100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100100": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "01001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001001": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "10010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010010": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "00010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "00100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "01000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "10001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000100010001000": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "00001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "00010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "00100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "01000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "10000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100001000010000100": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "00000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "00001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "00010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "00100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000100000": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "01000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001000001": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "10000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010000010": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "00000010000001000000100000010000001000000100000010000001000000100000010000001000000100000010000001000000100000010000001000000100": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "00100000010000001000000100000010000001000000100000010000001000000100000010000001000000100000010000001000000100000010000001000000": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "00000001000000010000000100000001000000010000000100000001000000010000000100000001000000010000000100000001000000010000000100000001": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "10000000100000001000000010000000100000001000000010000000100000001000000010000000100000001000000010000000100000001000000010000000": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "00110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "01100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "11001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "10011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "00011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "00111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "01110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "11100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011100011": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "11000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111000111": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "10001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110001110": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "01001100011101001100011101001100011101001100011101001100011101001100011101001100011101001100011101001100011101001100011101001100": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "10011000111010011000111010011000111010011000111010011000111010011000111010011000111010011000111010011000111010011000111010011000": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "00110001110100110001110100110001110100110001110100110001110100110001110100110001110100110001110100110001110100110001110100110001": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "01100011101001100011101001100011101001100011101001100011101001100011101001100011101001100011101001100011101001100011101001100011": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "11000111010011000111010011000111010011000111010011000111010011000111010011000111010011000111010011000111010011000111010011000111": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "10001110100110001110100110001110100110001110100110001110100110001110100110001110100110001110100110001110100110001110100110001110": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "00011101001100011101001100011101001100011101001100011101001100011101001100011101001100011101001100011101001100011101001100011101": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "01001010101010010101010001110100101010101001010101000111010010101010100101010100011101001010101010010101010001110100101010101001": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "10010101010100101010100011101001010101010010101010001110100101010101001010101000111010010101010100101010100011101001010101010010": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "00101010101001010101000111010010101010100101010100011101001010101010010101010001110100101010101001010101000111010010101010100101": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "01010101010010101010001110100101010101001010101000111010010101010100101010100011101001010101010010101010001110100101010101001010": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "10101010100101010100011101001010101010010101010001110100101010101001010101000111010010101010100101010100011101001010101010010101": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "01010101001010101000111010010101010100101010100011101001010101010010101010001110100101010101001010101000111010010101010100101010": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "10101010010101010001110100101010101001010101000111010010101010100101010100011101001010101010010101010001110100101010101001010101": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "01010100101010100011101001010101010010101010001110100101010101001010101000111010010101010100101010100011101001010101010010101010": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "10101001010101000111010010101010100101010100011101001010101010010101010001110100101010101001010101000111010010101010100101010100": TheInput(n, 2) = "0"
    n = n + 1: TheInput(n, 1) = "01010010101010001110100101010101001010101000111010010101010100101010100011101001010101010010101010001110100101010101001010101000": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "10100101010100011101001010101010010101010001110100101010101001010101000111010010101010100101010100011101001010101010010101010001": TheInput(n, 2) = "1"
    n = n + 1: TheInput(n, 1) = "10100101010100011101001010101010010101010001110100101010101001010101000111010010101010100101010100011101001010101010010101010001": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "0001000001011100000011000100011000010010000000000000000011000000000000000001110010000000000001111000000001001110000000000000100000000011110000000000000000000000000000010100000000000000000100000000000000110001111000010001000000000000000000011010000000000000000010001101100000100001000000110011000011010010000000000000000000100001000011000110001010000000100000000000000000000000000000000000010000000000100000000000000010100000100000000000000000000000000000000000100001000000000000000010110100000000000010010000000000000000000100000000001100000011000000000000000000000000000000110010000110000100000": TheInput(n, 2) = "?"
    '''
    'n = 0
    '''
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000100000101110000001100010001100001001000000000000000001100000000000000000111001000000000000111100000000100111000000000000010000000001111000000000000000000000000000001010000000000000000010000000000000011000111100001000100000000000000000001101000000000000000001000110110000010000100000011001100001101001000000000000000000010000100001100011000101000000010000000000000000000000000000000000001000000000010000000000000001010000010000000000000000000000000000000000010000100000000000000001011010000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00011101100000000001011100001011101000100111101100011000000011001010101000101000111111011000111000100000000000000110110000000001001001110110100001011011101100000011001010001111111110101100001101100001100011000111101100110000000101101101110000001110110111000011000110000000001101111000110000000011111100110001111000011101111101010011111111101111010011011001111101100010001100101101001011000010100111111101111010111111010110001100011000000100010001100111111001101101111000000010110111110000001011010011": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000100000000000110000000000000000010000000000000000010000000000000000001000000000000000000000000000000001000000010000000000000000000000000000000000000000000000000000011000000000000000001000000001000000000000000000000000000000000000000001001011001000000000000110000000000000000000000000000000000100010000000000000000000000000000000000001100000000000000000000000000000000100000000000000000001000000000000000000000000000000000000000000000100000000000000000100000000000000000000000000000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "01111011010110000100001000011001101101000011000011000000000100110010001010000100010000001110111000001000000000101110101100000000100011100101101110000010110101111001011010100000111011100110100001100100111010111110000010000110010000000100111100110000000101010100111001000000101000100101111001001001000010000100110011011010011011101000110011000000101000000100010000101101000101000110000100010101010111100000000001100000110010000001000011100001001000100000011100000101000001010101000100011010000100010011": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "11000110011000111000001101000010001000001110001001110010000110000111010001010001100010101100001111100000111100101100000011000111101101110010101101010000101010000001111100000111110101010000000011011100100110101100111101000000100100101000011010000000010110101010011001110011111000010001100110001111111001100010011100010101001100000101010101100000000001001010000011011100010011001000001001110111100110010010000010000111111101100011010101010101000111010110101000000010001001001011011011100101111110110010": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "10101101010001010110010110011111011111111101110100010011101110000000100011010000100111111001110110100011011110011101110001110011110000111011011110111011101100000010100111100010000010100111110010100100010001010101111000111010011101010111001110110000101101110001110010011101010110101110001111000101011001001101001011111101110010110101001100110010111101010111010010000010110100010001101110110101101110000101101010001001101101011000111110100000011101110010101111011110111110100110101001111101110001010110": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000001000000000000000000000000000100000000000000000000000000000000000000000000000100000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000110110101110000001100100101000001001111101111100000011000000000001001000100011000000000100011100000100000001001000001000010000000010111001101000001100000010101100011010011111000100111010000000000001010001011101110010100000000000010001011101000010000100000101100110100000011111000000001110000010101010000111111110000000110000100111110011000100000010001010100000000000110000000011000100000000111110011110010000100001010000010011100000000010001101010000000000110010000000110000000110011000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "11011001010011000110101011011010000110001001010001001111100111001011110110111010001111010110010100100101011010110010010100111010111001101011100100001010011111111010011100101101000011011011000111011011010110111100110011100010100001101010110101110101110111010111010010011001110100011010011010101111101110100100100111101101001011100001001100100111010101100100101000111111111001001111100111010110111100001000000111101000111000001101011001001110001000010100110011111001001010101001110111010101111001100001": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000000000000000010000000001100000000000000000000001010000000000110010000000000000000000000000000000000000000000000000001100000000000111000101000000000000000000000000000100010001000000000000000000000000000000001100010010000000000000000001100000000000000000000000000001000000000000000000000000000000000010000011000000000000010000000000000001000000001000000000000000000000000000000000000100100000000000100000000000000000000000000000000000100000000000000000000000000000000000000000100000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "11101000011011010000101000100000010001001000000110011110001011010001001101101010001100111000000101001000011000001010010100010011100110101000101000000000010100111001010100010010101010100011000011000001011010000000010000000001011110110111000010000001011011100000000111001110100000110000000011000101100000001001000100110011000100100000100001001000000011010010100000000100100000101001100000110001001001110101010001000000011000000010101000110010000100001011000001101000101010011011001110010110000010000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000010100110101001001000100000010100100100101101010010000001001100000000001011001110011011000010000111111001100010110011000010100110110000000000011010011010010100100011011011001100110001101001110000101001001100100010001101001000001011111100011011100000011001001010111000000000111101111001111001111111101000000000101100011001001011011010010000100001100010011110010000001011000001010111010010011111001001001110111100110010000110100111101000000101110100101010001111001111101100010101001001010101000101": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00111100000000000111001001100000111010010010010011100010001100001100000011011000100010000101110010110100110110011100010001111110011011000110010000001001101111111000011000010001101110011101111010100110100110000111011101001111110011011111100110111000001101101110001001001000011110100110000111110111010000001100100100100111110110100001001011100110111000100011110100100100110010011110011011100011101111010010000110000011101100000111001011000110000010001101111011111011001100000010000101000000000000101110": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000000000000000000100000000000000000000000010000000000000001000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000001000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000010111101100110000001011000001001011001100000001001100001001000001001100010000111111000011100001000000001111010010000100001000000010001101001011101011011010000101010011110110110001100001000010000010100011000000110001000000011101110001000000000000110000100000101100000001011010000101000000100100011000111111110010110101010100011110100110110000010001101000000000101001000010100110000100010100111000010010100100001000110000000100010100010000000010000100011100010010110100010000010010001001000010": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "11111111011001010010001100000100110110101110100011010010111011110100101000100000000101100000000100110010111110111000110101101010111111011101101010011111100100110100010011011001100000001110111110000101000000001100110101011110011111101100001110011101111100111100011100010010110111100001010000010001101001001111000000000101001000100100000110011000101011100100000100111011010110100000010001011010101011010010100111011000100011001000001010001011101010000100001011001011100001001011101110100110110010111100": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000010000000000000000000000000000000100000000100000000000000000000011100000000000000000000000000001000000000000000000000000000011001000000000000100000000000000000000000000010010000000000000000000000000000000000000000000000000000000000000000000000000000010001000000000000000000000000000000000000010000000000000000000000010000000000000000000000000000000000000000000000001001000000000011100000000000000001000000000000000000100000000100010000110100000000000000000000000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "01011000100010001000011010000010010010000100100101000100011001000010000010110110010110001100010001000010110110000011010100000100100010010011111101111100110010101100000001000000100111010000010000100000000111100110000101110001100100000001000001001100100100010000001001000110000000000100011100110110000101100011100010110100000011001001011000010001001000101010010010000001000000100101100101001110110010010000100010100010000000100111001100000000001000111111010100001000001010000010101010110101101000001100": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000101000010010110000110001101111110010001110010000010101001111111010000011011100000110000010101101110101111110101001100000100000000100110001000000000000001110011101011011110000001000110101001000000000000010100010010110110000010001100100010011001010011111011001110110000110100010010000010010110011000010110110010101000111000000100000001101100100110010100110111001110110101010001101100000000110010100010000001000101011100000000000111101110101011001011001100100000001101110000001001101010000000111011": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "10100010000111100111110001101101100001100111001010011110011001101110100111000111001010100111100010110010101010100100100000101010111100100000010111001000101110010010111000001100011011001011010100101101101110001001111100110000001011100000010110011010001000001101101111001000011101001000110010110111100011111011001100011110100110100111001110000101010001010001101001101001011001111010011001101010000001111010110011100001010100011100110100011011110011100101000001110010010111100111110011001110011111001010": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000000000000000000100000000000001100000000000000000000000000000000000000000010000000000000000000000000000000001000000000000000000000000000000000001000000000000100000000000000000000000000000000000000000000000001100000000000000000000000000000000000000000000000000000000000000000000000000110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00100000011101101100000000000000000000001010001010001010010000000011101000010100001000000110000110100000000010001000111100100100001010110000011000001010110100110011000010001000110101001001100001011000001000000000000010110000100000110000001001000000100000110100100100100001010011000000010101010010100101000000001011100010000000001100000110100010100010000001110000000100000001110010100100001110000001100110000100001000001000000000010000001000001000000001001100000000010011110100000000001010100001111111": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "01010110100011101001111011101011111111101001100000010100001001111110010111100011101100011111110001101101111000110011010011010011110000101111110110010001000001010100100100110011010010010110101011100000111111111101111110110011111101010011110000111101000010010011010000011100001000011011000011001101100011011101000101010101111011000100001111010100111001011100011100011011011000000010011010010100110010011001111011010010110011111000101110010111111100100100111110111010101001101011010100000001011010010000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000000000000000000000000000000000000000000000000000000100000001000000000000000000000000000000000000000001000000000000000000000000000000000000000010000000000000010010100000000000001000000000001000100000000000000000000001000000000000000000000000000000010000000010000000000000000000000001000000010000000000000000000000000000000000000000010000000110000000000000000000000001000000000010000100000000000000000100000001000000010000000000000000000000010000000000000000001000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000001100010111010101010001001000011001100000000000000010011000111001101001010110010010010010100101010000001001000111000000010110000010001001110100000000101101001110100010100000101000100000101000000010000110000010011010000100101001111000000011110001000001101101100000001000101000000011001011001110111100010010001000011110011110010010001000001110100100010101001110000010100000010010100000000101001000100101000011000000001001010111010110100000011001100101010000000100100100111111001110101000100000001": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "11010010010101000010000011010000101110111010011001101000101111011101001110000001011110100101101111000100000010110001010101000110100001100000111000111100011110110011101101101111101010100100011101000000010010101110000011011100010010101110101010000001110001001111110011011101000010110000101111000000101100011100101100001001100001111110000101110000010010000001001010000000011011000001000101000100000111101100110011000111010000001000010000000000100101010001100001011000001010001000111111110110101000011111": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "11011111000111100000010011111111101111001100100010111010010000011000110100111010011000111101000111010000110110101010011010101011100110011101000001011011111110011100110100001001010000001000010010100101111011000101001000000011110011110001100100100011011001010000101101111110101011011100000111000111000011110101111011101000101010000111011110000111111101011101110110001000011000111011011011111100110000001011011010110101101111011001011000111100101100111010011100110111101100110110100110000010011111110101": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00100000000000000011000000000000000000000110000010011111100000000000000001000000001000000000000000010110000110000001100010000000000011110000000001100000000000110011000011000000010000001110000000011000001000010000110100000010000000111101000000000000000000100000000001100000100011000000000100000000000101000000000011010000001100010100000110110010100001010000110000001000000001100000110000001100000000011010000000000000101001100000000000000000100000011010100000000010010000100100010000000000000001111000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00010100011101010101100000101000001100111001101101000000011001111001100110110111010111111011110001100000000001100000011001111000111001000110011010001110100110011001110111100000101000110001100110100111000111001000001001110101101110000000110000000000011001010101000110011101011001100011001001011001101100011110000101101001100011001010011000001100110000101000001111110110000000001100001100010010101111100101001101010000000110011011111100011111010000000101000000100101100111010110001101111010101010000110": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000010000000000001100000000000000001000000000000000000000000000000000000000000000001001000000000000000000100000000000000000000010000000000000000100100000101000001000000100001100000000000000000000000000010110000000000000000100001000000000000001000000001100010000000010000010000000000000110000000001000000000001000010000000000010000000000000000000000000000000000000100001000000000000100001000000000000000000100000000000100000000000000000000000001001000000000000000000001000010000000000010000011000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "11010000111110000000000011000001011000010011010100100000000000110011011101010010100100000000000000010001101001000001001010011000100101101000111011000001000010010000010000010100001000100110100001100100001001001001100011110010011000110111000011000000011000000000100110001000101101100000001000000000000100000000000001001110001110100000010100001011101010110100001001001000000010010100001010100111011111000100001010000011010001000011001101110001101110000011010101101001010100110100010001011100110100110111": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000110110001000000011001000100000001110011010100010101101111100101100101000001010000000101101010100101011010000010001001110001001100001110101011010111010000100001011001010010100011001011000010000100001000000000100001111001000101011111110100001110010011000100001101000101001101011110001011111000110111010010101000001001011101101110000001011110000011001100011111001010100010101110011000100110000101101010010110000000000010011001001101101000010000010001110000011111100111101100100110000001000110000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00101101111001100011001000011101001000000001100000101001000010110101000011001101110010110011000010101100111010101111100101100111000010110111010100000000001010000111111011001000111011100100011111101010010101011111111010010110010001101010100101010110111010111000101111001101001101101111010101010010110001000110110110101000010100001000010011101010011110001000001111001100110001011010100011101011100000100000111001000111001010101111010010010100110111001000100011010110100011111011101001101010111101101010": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "10000000100000000000000001001001000000100011010001010100000100000000010101100110101000000000000100000101010000000101000000000101100000000000010000001000001011000110100110100010010100010111000100000100001010000000101010001000111001000000010000100100000000000000100000001001000000110001010001001010010000000010101001000111011000100100100000010010000100100000000000001000010010000110010110000110100000000000101001010100000110010001110000111000000110000000000000000000000100101100001010000100000101100010": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "00001101011011101101111110010000011011010000101110101011001001111000101010010001010111100001110011011010100011011010101010111010001010100110101100000110110100101001011001010000001010100000111010111011100100110111010101010100000010000010101110001011010011001111011110110000110010001010001000110100101111101100000110111000000000000010001111101001011011010111110110000100101000111000101001110001010011110100010100100011110000001100001011000100100000011110111111100011000011000011100101111010111010010101": TheInput(n, 2) = "?"
    n = n + 1: TheInput(n, 1) = "01110011000100111110101110110110101110011100101000000011111010011111101010001000000000111110011010111010001110111000111111010010011101111101100111110001000000011000001000001101101001001000010001011000010001111100010001100111000100111111100011010001101101110110000001010110001111000100101110010001101101010001010110110000100111011001010100101101110000001111001111110111100101101001001001111001011111111011000010101001001001101010001111000011011001111111001011111101111001010010110000100001010000011000": TheInput(n, 2) = "?"
    '''
End Sub

[/s]

Programs / Digital Circuit Simulator

« on: December 07, 2021, 08:33:55 pm »

Hello all, time for a mega-post.

Intro:

I was recently motivated to code something that produces much more than it assumes. Projects like this are usually more egg-headed, like creating programming languages, experimental computation paradigms, cellular automata, and so on. After fiddling with each of these for a while, I settled on something that should have been obvious from the start: binary circuits. After all, these are what computers are made of, so I should be able to simulate these kinds of things on a computer.

Remarks:

After deciding on a proper data structure, the evaluation algorithm turned out to be quite simple to code. This thing works for highly parallelized, feedback-ridden, super ugly circuits, as well as pretty circuits. In fact, it's behavior is... dare I say 100% like what you get on a breadboard. I know this because I scoured YouTube for good videos, some of which are linked in this study, for working examples of known circuits. To my delight, the program I've got can easily handle any test I throw it. By "handle", I mean get *exactly* what the real circuit gives.

The reason I gather you here in this thread is not only to show off this program, but to offer a self-teaching crash course in digital electronics. (See the link below.) I had a lot of fun rediscovering precisely how data latches and other computing essentials were done.

More Remarks:

So far, I've tested the heck out of "static state" circuits, along with "edge detection" circuits. We all know that *real* electronics depend on some rather subtle principles, yet this program ignores things like capacitance, inductance - even resistance, because we never had to worry about these in the first place. We're strictly making logic circuits, where if you test for voltage at any place, you'll find a 0 or a 1, no exceptions.

The code takes zero shortcuts to simulate circuit state and edge detection - there is no use of the timer, internal variables, cheat variables, loops, recursion, nothing. Everything is done with a minima of components, namely six: AND, OR, NOT, NOR, XOR, and Split.

Example:

For one example, of which there are a total sixteen in the program, we simulate the four-bit adder, thereby creating a primitive "computer" out of logic gates. Observe the following schematic and program screenshot:

Manual:

To understand what's going on here, it's highly recommended that you read the manual. I drafted this thing in Notepad with no spell check, so it's subject to updates. Anyway, on this page:

http://barnes.x10host.com/pages/Logic-Circuits.php

... you'll see how circuits are modeled, how they're evaluated, and how the user interacts with the circuit. This program is exceedingly simple to use, and designing circuits turned out to be not as daunting as initially believed. I'll refrain from further explaining anything here, and defer to the above link for all elaboration.

Closing Remarks:

While this program is a perfectly nice breadboard simulator, it begs to be expanded in any number of directions. Surely it needs a GUI. Surely it needs more inputs and outputs. Surely it needs a better way to skirt the arrays-in-types issue. I'm still deciding what the next direction, if any, will be.

Thanks for your attention

Programs / Sanctum 2021

« on: November 09, 2021, 08:13:14 pm »

Hello all,

I recently ran the code for Sanctum (various versions floating around on forums) and realized my local copy is a whole lot newer, so it's time for an update post on this. I also made the mistake of fiddling with the code a few days ago, and of course fell into the abyss, and had to take the code in a new direction to find my way out. I may or may not keep (all of) the results, but I figured it would be worth sharing what exists now.

For those who remember more recent versions of this program, everything is now gone. The land, the trees, the air, (I sound like Churchill right now), the snowmen, all the planets, the black hole, the different layers of ground and hell, all gone gone gone. ASCII plotting, gone.

Here is some of what's going on:

Terrain model:
* Terrain is no longer flat, but is procedurally generated (same seed creates same map).
* Created by choosing pseudo-random extreme points and using relaxation algorithm (to basically solve Laplace's equation treating peaks as charges).
* Contains several pre-flattened plateaus for specialized use (nothing specific implemented yet).

Terrain volume:
* Surface supported by layer of dirt and sand.
* Low spots are filled with water.

Terrain surface:
* Surface features generated and relaxed in analogy to terrain model.
* Elevation-specific coloring.
* Elevation-specific plant-life: Parametric clover, Fractal fern, Grass

Sun and Moon:
* As an experimental feature, the sun and moon are always visible if above the horizon. (There is at least one GOTO in the code because of this. It won't last.)
* When observed form below water level, the sun and moon lose their color.
* The sun/moon phases are loosely tied to your system clock.
* If you're lucky, you'll see a solar eclipse.

Weather:
* Clouds occur in different stratified layers. Different speeds, heights, etc.
* Rain falls from randomly-chosen clouds.
* Weather patterns move and adjust height to pass over mountains, etc.
* Tornadoes will mess you up.

Fish:
* If you look in the deepest water, toward the middle, you will see fish.
* Each view of a fish is actually trimmed from what is best described as a three-dimensional sprite sheet.
* At a given moment, the view of the fish is determined by its velocity.
*** This successful proof-of-concept demonstrates motion of asymmetric things like birds, planes, etc. No longer limited to spheres and UFOs.

Movement/controls:
* Player follows the main terrain mesh while walking.
* Recommended "posture" is WSAD plus Numpad. (Mouse is disabled but works if you find and uncomment the code.)
* Use the Z key to zoom, as if using a telescope. Thought this feature was cute, will probably keep it.
* Press F to throw a breakable thing. Looks like a potion I guess.

Very crude building system:
* Press B to spawn a block. The block will fall to the ground, crudely.
* Press B again to stack a block on top of another block.
* Make stairs or primitive towers this way.
* You can stand blocks like they're part of the terrain.
* Super primitive, no need to tell me about floating blocks.

As usual, this project is perpetually unfinished. This is all done using LINE and CIRCLE, and maybe I've done *all* I can in this area without going the way of textures and the like. Let me know what kind of FPS you get. (I stay around 60, which is the target.)

Code: QB64: [Select]

Option _Explicit
 
Do Until _ScreenExists: Loop
_Title "Sanctum 2021"
 
'$ExeIcon:'sanctum.ico'
 
' Hardware.
 
'Screen _NewImage(640, 480, 32)
Screen _NewImage(800, 600, 32)
'Screen _NewImage(1024, 768, 32)
 
_FullScreen , _Smooth
_MouseHide
 
' Performance.
Dim Shared As Integer FPSTarget
FPSTarget = 60
 
' Color constants.
Const Aquamarine = _RGB32(127, 255, 212)
Const Black = _RGB32(0, 0, 0)
Const Blue = _RGB32(0, 0, 255)
Const BlueViolet = _RGB32(138, 43, 226)
Const Chocolate = _RGB32(210, 105, 30)
Const Cyan = _RGB32(0, 255, 255)
Const DarkBlue = _RGB32(0, 0, 139)
Const DarkGoldenRod = _RGB32(184, 134, 11)
Const DarkGray = _RGB32(169, 169, 169)
Const DarkKhaki = _RGB32(189, 183, 107)
Const DeepPink = _RGB32(255, 20, 147)
Const DodgerBlue = _RGB32(30, 144, 255)
Const ForestGreen = _RGB32(34, 139, 34)
Const Gray = _RGB32(128, 128, 128)
Const Green = _RGB32(0, 128, 0)
Const Indigo = _RGB32(75, 0, 130)
Const Ivory = _RGB32(255, 255, 240)
Const LightSeaGreen = _RGB32(32, 178, 170)
Const Lime = _RGB32(0, 255, 0)
Const LimeGreen = _RGB32(50, 205, 50)
Const Magenta = _RGB32(255, 0, 255)
Const PaleGoldenRod = _RGB32(238, 232, 170)
Const Purple = _RGB32(128, 0, 128)
Const Red = _RGB32(255, 0, 0)
Const RoyalBlue = _RGB32(65, 105, 225)
Const SaddleBrown = _RGB32(139, 69, 19)
Const Sienna = _RGB32(160, 82, 45)
Const SlateGray = _RGB32(112, 128, 144)
Const Snow = _RGB32(200, 200, 200) '''(255, 250, 250)
Const Sunglow = _RGB32(255, 207, 72)
Const SunsetOrange = _RGB32(253, 94, 83)
Const Teal = _RGB32(0, 128, 128)
Const White = _RGB32(255, 255, 255)
Const Yellow = _RGB32(255, 255, 0)
 
' Mathematical constants.
Const pi = 4 * Atn(1)
Const ee = Exp(1)
 
' Divine numbers.
Dim Shared bignumber As Long
Dim Shared WorldSeed As Long
bignumber = 10 ^ 7
WorldSeed = 3 'Int(Timer)
 
' Fundamental types.
 
Type Vector3
    x As Double
    y As Double
    z As Double
End Type
 
Type Vector2
    u As Double
    v As Double
End Type
 
Type Camera
    Position As Vector3
    Velocity As Vector3
    Acceleration As Vector3
    Shade As _Unsigned Long
End Type
 
Type GroupElement
    Identity As Long
    Label As String
    Pointer As Long
    Lagger As Long
    Volume As Vector3
    FirstVector As Long
    LastVector As Long
    Centroid As Vector3
    Velocity As Vector3
    Visible As Integer
    Distance2 As Double
    PlotMode As Integer
    FrameLength As Long
    ActiveFrame As Integer
End Type
 
Type ClusterElement
    Identity As Long
    Pointer As Long
    Lagger As Long
    FirstGroup As Long
    LastGroup As Long
    Centroid As Vector3
    Velocity As Vector3
    Acceleration As Vector3
    Visible As Integer
    MotionType As Integer
    Framed As Integer
    DeathTimer As Long
End Type
 
' World-specific types.
 
Type StrataElement
    Height As Double
    Label As String
    Shade As _Unsigned Long
End Type
 
Type PlateauElement
    Location As Vector3
    Radius As Double
End Type
 
' Vectors to specify points.
Dim Shared vec3Dpos(bignumber) As Vector3 ' Absolute position
Dim Shared vec3Dvel(UBound(vec3Dpos)) As Vector3 ' Linear velocity
Dim Shared vec3Dvis(UBound(vec3Dpos)) As Integer ' Visibility toggle
Dim Shared vec2D(UBound(vec3Dpos)) As Vector2 ' Projection onto 2D plane
Dim Shared vec3Dcolor(UBound(vec3Dpos)) As Long ' Original color
Dim Shared vec2Dcolor(UBound(vec3Dpos)) As Long ' Projected color
 
' A collection of vectors is a Group.
Dim Shared Group(UBound(vec3Dpos) / 10) As GroupElement
Dim Shared GroupIdTicker As Long
GroupIdTicker = 0
 
' Groups will eventually be sorted based on distance^2.
Dim Shared SortedGroups(1000) As Long
Dim Shared SortedGroupsCount As Integer
 
' A collection of groups is a Cluster.
Dim Shared ClusterIdTicker As Long
Dim Shared ClusterFillCounter As Integer
Dim Shared Cluster(UBound(Group) / 10) As ClusterElement
ClusterIdTicker = 0
ClusterFillCounter = 0
 
' Main terrain setup. This is a surface z=f(x,y).
Dim Shared WorldMesh(180, 180) As Double
Dim Shared WorldMeshAddress(UBound(WorldMesh, 1), UBound(WorldMesh, 2)) As Long
 
' Terrain elements are formally groups whose size and density are specified here.
Dim Shared BlockSize As Integer
Dim Shared BlockStep As Integer
BlockSize = 40
BlockStep = Int(BlockSize / 8)
 
' World features.
Dim Shared Strata(5) As StrataElement
Dim Shared CloudLayer(5) As StrataElement
Dim Shared Plateau(5) As PlateauElement
Dim Shared SunClusterAddress As Long
Dim Shared MoonClusterAddress As Long
 
' Fixed paths. Primary ticks are one per second, with total cycle of one day.
Dim Shared FixedPath(500, 86400) As Vector3
Dim Shared FixedPathIndexTicker As Long
FixedPathIndexTicker = 0
 
' Three-space basis vectors.
Dim Shared As Double xhat(3), yhat(3), zhat(3)
xhat(1) = 1: xhat(2) = 0: xhat(3) = 0
yhat(1) = 0: yhat(2) = 1: yhat(3) = 0
zhat(1) = 0: zhat(2) = 0: zhat(3) = 1
 
' Camera orientation vectors.
Dim Shared As Double uhat(3), vhat(3), nhat(3)
 
' Camera position.
Dim Shared PlayerCamera As Camera
 
' Field-of-view distance.
Dim Shared fovd As Double
fovd = -192
 
' Clipping planes.
Dim Shared As Double nearplane(4), farplane(4), rightplane(4), leftplane(4), topplane(4), bottomplane(4)
nearplane(4) = 1
farplane(4) = -256
rightplane(4) = -BlockSize / 2
leftplane(4) = -BlockSize / 2
topplane(4) = -BlockSize / 2
bottomplane(4) = -BlockSize / 2
 
' Temporary counters.
Dim Shared NumClusterVisible As Long
Dim Shared NumVectorVisible As Long
Dim Shared NumGroupVisible As Long
 
' Interface.
Dim Shared ToggleAnimate As Integer
Dim Shared FPSReport As Integer
Dim Shared ClosestGroup As Long
 
' Prime and start main loop.
Randomize WorldSeed
Call InitWorld
Call CreateWorld
Call InitCamera
Call MainLoop
End
 
' Subs and Functions
 
Sub MainLoop
    Dim fps As Integer
    Dim fpstimer As Long
    Dim tt As Long
    fps = 0
    fpstimer = Int(Timer)
 
    Do
        Call PlayerDynamics
        Call ComputeVisibleScene
        Call PlotWorld
        Call DisplayHUD
        Call DisplayMiniMap
        Call KeyDownProcess
        Call KeyHitProcess
 
        fps = fps + 1
        tt = Timer
        If (tt = fpstimer + 1) Then
            fpstimer = tt
            FPSReport = fps
            fps = 0
        End If
 
        _Display
        _Limit FPSTarget + 1
    Loop
End Sub
 
Sub InitWorld
    Dim k As Integer
    Dim As Double u, v, w
 
    k = 0
    k = k + 1: Strata(k).Height = -50: Strata(k).Label = "Water": Strata(k).Shade = RoyalBlue
    k = k + 1: Strata(k).Height = 0: Strata(k).Label = "Meadow": Strata(k).Shade = ForestGreen
    k = k + 1: Strata(k).Height = 50: Strata(k).Label = "Grassland": Strata(k).Shade = DarkKhaki
    k = k + 1: Strata(k).Height = 100: Strata(k).Label = "Rocky Terrain": Strata(k).Shade = DarkGoldenRod
    k = k + 1: Strata(k).Height = 150: Strata(k).Label = "Snowy Terrain": Strata(k).Shade = White
 
    k = 0
    k = k + 1: CloudLayer(k).Height = 140: CloudLayer(k).Label = "Dark Cloud": CloudLayer(k).Shade = SlateGray
    k = k + 1: CloudLayer(k).Height = 160: CloudLayer(k).Label = "Gray Cloud": CloudLayer(k).Shade = Gray
    k = k + 1: CloudLayer(k).Height = 180: CloudLayer(k).Label = "Azul Cloud": CloudLayer(k).Shade = DarkBlue
    k = k + 1: CloudLayer(k).Height = 200: CloudLayer(k).Label = "Heavy Cloud": CloudLayer(k).Shade = Snow
    k = k + 1: CloudLayer(k).Height = 220: CloudLayer(k).Label = "Icy Cloud": CloudLayer(k).Shade = Ivory
 
    u = Rnd * 2 * pi
    w = Sqr((UBound(WorldMesh, 1) / 2) ^ 2 + (UBound(WorldMesh, 2) / 2) ^ 2)
    For k = 1 To UBound(Plateau)
        Select Case k
            Case 1 ' Water
                u = u + pi / 2
                v = (w / 2) * (.8 + Rnd * .5)
                Plateau(k).Location.x = Int(v * Cos(u))
                Plateau(k).Location.y = Int(v * Sin(u))
                Plateau(k).Location.z = -250
            Case 2 ' Meadow
                Plateau(k).Location.x = 0
                Plateau(k).Location.y = 0
                Plateau(k).Location.z = Strata(k).Height
            Case Else
                u = u + pi / 2
                v = (w / 2) * (.8 + Rnd * .5)
                Plateau(k).Location.x = Int(v * Cos(u))
                Plateau(k).Location.y = Int(v * Sin(u))
                Plateau(k).Location.z = Strata(k).Height
        End Select
        Plateau(k).Radius = 15
    Next
End Sub
 
Sub CreateWorld
    Dim g As Long
    Dim k As Integer
    ' Initialize and populate list.
    k = 0
    k = k + 1: Call TextCenter(".:. Let there be light .:.", k * 16, DarkKhaki)
    k = k + 1: Call TextCenter("(Initialize linked list)", k * 16, ForestGreen)
    g = NewGroup&(0, 0, 0, 0, 1, 0, 0)
    k = k + 2: Call TextCenter(".:. Let there be a firmament .:.", k * 16, DarkKhaki)
    k = k + 1: Call TextCenter("(Using seed " + LTrim$(RTrim$(Str$(WorldSeed))) + ")", k * 16, ForestGreen)
    k = k + 1: Call TextCenter("(Generate random terrain)", k * 16, ForestGreen)
    g = CreateTerrainGroups&(g)
    k = k + 2: Call TextCenter(".:. Let the dry land appear; bring forth the grass .:.", k * 16, DarkKhaki)
    k = k + 1: Call TextCenter("(Relax terrain mesh)", k * 16, ForestGreen)
    k = k + 1: Call TextCenter("(Fill terrain volumes)", k * 16, ForestGreen)
    k = k + 1: Call TextCenter("(Cover terrain surfaces)", k * 16, ForestGreen)
    g = CreateTerrainVectors&(g)
    g = CreateTerrainVolume&(g)
    g = CreateClover&(g)
    g = CreateFern&(g)
    g = CreateGrass&(g)
    k = k + 2: Call TextCenter(".:. Divide the day from the night .:.", k * 16, DarkKhaki)
    k = k + 1: Call TextCenter("(Create celestial objects)", k * 16, ForestGreen)
    k = k + 1: Call TextCenter("(Create weather events)", k * 16, ForestGreen)
    g = CreateSun&(g)
    g = CreateMoon&(g)
    g = CreateTornado&(g)
    g = CreateWeather&(g)
    k = k + 2: Call TextCenter(".:. Let waters bring forth .:.", k * 16, DarkKhaki)
    k = k + 1: Call TextCenter("(Create fish)", k * 16, ForestGreen)
    g = CreateFish&(g)
    k = k + 2: Call TextCenter(".:. Let us make man .:.", k * 16, DarkKhaki)
    k = k + 1: Call TextCenter("(Initialize player)", k * 16, ForestGreen)
    k = k + 2: Call TextCenter(".:. ...blessed the seventh day and Sanctified it .:.", k * 16, DarkKhaki)
    k = k + 1: Call TextCenter("(Rest)", k * 16, ForestGreen)
    k = k + 3: Call TextCenter("PRESS ANY KEY", k * 16, Sunglow)
    Sleep
    _KeyClear
End Sub
 
' High-order clusters and groups.
 
Function CreateTerrainGroups& (LagAddressIn As Long)
    Dim g As Long
    Dim As Integer i, j, k
    Dim As Integer ii, jj
    Dim As Double u, v, w
    g = LagAddressIn
 
    ' Create world mesh and set extreme points.
    Dim tempworldmesh1(UBound(WorldMesh, 1), UBound(WorldMesh, 2))
    Dim tempworldmesh2(UBound(WorldMesh, 1), UBound(WorldMesh, 2), 2)
 
    u = 1 + .5 * (Rnd - .5)
    v = 1 + .5 * (Rnd - .5)
    For i = 1 To UBound(WorldMesh, 1)
        For j = 1 To UBound(WorldMesh, 2)
 
            ' Overall slant of world.
            tempworldmesh2(i, j, 1) = (u * i + v * j - UBound(WorldMesh, 1) / 2 - UBound(WorldMesh, 2) / 2)
 
            ' Peaks and valleys.
            Select Case Rnd
                Case Is < .005
                    tempworldmesh2(i, j, 1) = tempworldmesh2(i, j, 1) - (100 + Rnd * 100)
                    tempworldmesh2(i, j, 2) = 1 ' fixed
                Case Is > .995
                    tempworldmesh2(i, j, 1) = tempworldmesh2(i, j, 1) + (100 + Rnd * 300)
                    tempworldmesh2(i, j, 2) = 1 ' fixed
                Case Else
                    tempworldmesh2(i, j, 1) = tempworldmesh2(i, j, 1) + 0
                    tempworldmesh2(i, j, 2) = 0 'free
            End Select
 
            ' Plateaus.
            For k = 1 To UBound(Plateau)
                ii = i - Plateau(k).Location.x - UBound(WorldMesh, 1) / 2
                jj = j - Plateau(k).Location.y - UBound(WorldMesh, 2) / 2
                If (ii ^ 2 + jj ^ 2 < Plateau(k).Radius ^ 2) Then
                    tempworldmesh2(i, j, 1) = Plateau(k).Location.z
                    tempworldmesh2(i, j, 2) = 1 ' fixed
                End If
            Next
        Next
    Next
 
    ' Relax the world mesh to generate terrain.
    Dim SmoothFactor As Integer
    SmoothFactor = 30
    For k = SmoothFactor To 1 Step -1
        For i = 1 To UBound(WorldMesh, 1)
            For j = 1 To UBound(WorldMesh, 2)
                tempworldmesh1(i, j) = tempworldmesh2(i, j, 1)
                ' Before last iteration, allow extreme points to relax.
                If (k = 1) Then tempworldmesh2(i, j, 2) = 0
            Next
        Next
        For i = 2 To UBound(WorldMesh, 1) - 1
            For j = 2 To UBound(WorldMesh, 2) - 1
                If (tempworldmesh2(i, j, 2) = 0) Then
                    tempworldmesh2(i, j, 1) = (1 / 4) * (tempworldmesh1(i - 1, j) + tempworldmesh1(i + 1, j) + tempworldmesh1(i, j - 1) + tempworldmesh1(i, j + 1))
                End If
            Next
        Next
    Next
    For i = 1 To UBound(WorldMesh, 1)
        For j = 1 To UBound(WorldMesh, 2)
            WorldMesh(i, j) = tempworldmesh2(i, j, 1)
        Next
    Next
 
    ' Create terrain groups.
    Dim g0 As Long
    For i = 1 To UBound(WorldMesh, 1)
        For j = 1 To UBound(WorldMesh, 2)
            u = BlockSize * (i - (UBound(WorldMesh, 1) / 2))
            v = BlockSize * (j - (UBound(WorldMesh, 2) / 2))
            w = WorldMesh(i, j)
            ' Store first address.
            If ((i = 1) And (j = 1)) Then g0 = g
            g = NewGroup&(g, u, v, w, 10, 0, 0)
            Group(g).Label = TerrainHeightLabel$(w)
            Group(g).Volume.x = BlockSize
            Group(g).Volume.y = BlockSize
            Group(g).Volume.z = Sqr(BlockSize * BlockSize + BlockSize * BlockSize)
            Group(g).PlotMode = 0
            WorldMeshAddress(i, j) = g
        Next
        Call ClusterPinch(g)
    Next
    Call ClusterPinch(g)
 
    CreateTerrainGroups& = g0
End Function
 
Function CreateTerrainVectors& (LagAddressIn As Long)
    Dim g As Long
    Dim As Integer i, j, k
    Dim As Integer ii, jj
    Dim Smoothfactor As Integer
    g = LagAddressIn
 
    ' Create fine-grain block mesh to relax terrain.
    Dim vindex As Long
    Dim BlockBins As Integer
    BlockBins = BlockSize / BlockStep
    Dim blockmesh1(BlockBins, BlockBins)
    Dim blockmesh2(BlockBins, BlockBins, 2)
    vindex = Group(Group(g).Lagger).LastVector
    For i = 1 To UBound(WorldMesh, 1)
        For j = 1 To UBound(WorldMesh, 2)
 
            g = WorldMeshAddress(i, j)
            Group(g).FirstVector = vindex + 1
 
            ' For each world mesh location, use the block mesh whose boundary heights are determined by neighbors.
            For ii = 1 To UBound(blockmesh2, 1)
                For jj = 1 To UBound(blockmesh2, 2)
 
                    ' Lock boundaries.
                    If (ii = 1) Or (ii = UBound(blockmesh2, 1)) Then
                        blockmesh2(ii, jj, 2) = 1
                    End If
                    If (jj = 1) Or (jj = UBound(blockmesh2, 2)) Then
                        blockmesh2(ii, jj, 2) = 1
                    End If
 
                    ' Set boundary values.
                    If (i > 1) Then
                        If (ii = 1) Then
                            blockmesh2(ii, jj, 1) = -WorldMesh(i, j) + (1 / 2) * (WorldMesh(i, j) + WorldMesh(i - 1, j))
                        End If
                    End If
                    If (j > 1) Then
                        If (jj = 1) Then
                            blockmesh2(ii, jj, 1) = -WorldMesh(i, j) + (1 / 2) * (WorldMesh(i, j) + WorldMesh(i, j - 1))
                        End If
                    End If
                    If (i < UBound(WorldMesh, 1)) Then
                        If (ii = UBound(blockmesh2, 1)) Then
                            blockmesh2(ii, jj, 1) = -WorldMesh(i, j) + (1 / 2) * (WorldMesh(i, j) + WorldMesh(i + 1, j))
                        End If
                    End If
                    If (j < UBound(WorldMesh, 2)) Then
                        If (jj = UBound(blockmesh2, 2)) Then
                            blockmesh2(ii, jj, 1) = -WorldMesh(i, j) + (1 / 2) * (WorldMesh(i, j) + WorldMesh(i, j + 1))
                        End If
                    End If
 
                    ' Set extreme points.
                    If ((ii > 1) And (ii < UBound(blockmesh2, 1)) And (jj > 1) And (jj < UBound(blockmesh2, 1))) Then
                        Select Case Rnd
                            Case Is < .01
                                blockmesh2(ii, jj, 1) = -Rnd * 20
                                blockmesh2(ii, jj, 2) = 1 ' fixed
                            Case Is > .99
                                blockmesh2(ii, jj, 1) = Rnd * 20
                                blockmesh2(ii, jj, 2) = 1 ' fixed
                            Case Else
                                blockmesh2(ii, jj, 1) = 0
                                blockmesh2(ii, jj, 2) = 0 'free
                        End Select
                    End If
 
                    ' Copy mesh.
                    blockmesh1(ii, jj) = blockmesh2(ii, jj, 1)
 
                Next
            Next
 
            ' Relax mesh body.
            Smoothfactor = 30
            For k = Smoothfactor To 1 Step -1
                For ii = 2 To UBound(blockmesh1, 1) - 1
                    For jj = 2 To UBound(blockmesh1, 2) - 1
                        ' Before last iteration, allow extreme points to relax.
                        If (k = 5) Then blockmesh2(ii, jj, 2) = 0
                        If (blockmesh2(ii, jj, 2) = 0) Then
                            blockmesh2(ii, jj, 1) = (1 / 4) * (blockmesh1(ii - 1, jj) + blockmesh1(ii + 1, jj) + blockmesh1(ii, jj - 1) + blockmesh1(ii, jj + 1))
                        End If
                    Next
                Next
 
                ' Upate mesh with relaxed version.
                For ii = 1 To UBound(blockmesh1, 1)
                    For jj = 1 To UBound(blockmesh1, 2)
                        blockmesh1(ii, jj) = blockmesh2(ii, jj, 1)
                    Next
                Next
            Next
 
            ' Relax mesh boundaries once.
            For ii = 2 To UBound(blockmesh1, 1) - 1
                jj = 1
                blockmesh2(ii, jj, 1) = (1 / 3) * (blockmesh1(ii - 1, jj) + blockmesh1(ii + 1, jj) + blockmesh1(ii, jj + 1))
                jj = UBound(blockmesh1, 2)
                blockmesh2(ii, jj, 1) = (1 / 3) * (blockmesh1(ii - 1, jj) + blockmesh1(ii + 1, jj) + blockmesh1(ii, jj - 1))
            Next
            For jj = 2 To UBound(blockmesh1, 2) - 1
                ii = 1
                blockmesh2(ii, jj, 1) = (1 / 3) * (blockmesh1(ii + 1, jj) + blockmesh1(ii, jj - 1) + blockmesh1(ii, jj + 1))
                ii = UBound(blockmesh1, 1)
                blockmesh2(ii, jj, 1) = (1 / 3) * (blockmesh1(ii - 1, jj) + blockmesh1(ii, jj - 1) + blockmesh1(ii, jj + 1))
            Next
 
            ii = 1
            jj = 1
            blockmesh2(ii, jj, 1) = (1 / 2) * (blockmesh1(ii + 1, jj) + blockmesh1(ii, jj + 1))
 
            ii = UBound(blockmesh1, 1)
            jj = UBound(blockmesh1, 2)
            blockmesh2(ii, jj, 1) = (1 / 2) * (blockmesh1(ii - 1, jj) + blockmesh1(ii, jj - 1))
 
            ii = 1
            jj = UBound(blockmesh1, 2)
            blockmesh2(ii, jj, 1) = (1 / 2) * (blockmesh1(ii + 1, jj) + blockmesh1(ii, jj - 1))
 
            ii = UBound(blockmesh1, 1)
            jj = 1
            blockmesh2(ii, jj, 1) = (1 / 2) * (blockmesh1(ii - 1, jj) + blockmesh1(ii, jj + 1))
 
            ' Upate mesh with relaxed version.
            For ii = 1 To UBound(blockmesh1, 1)
                For jj = 1 To UBound(blockmesh1, 2)
                    blockmesh1(ii, jj) = blockmesh2(ii, jj, 1)
                Next
            Next
 
            ' Set particle positions relative to group center. Add random fuzz.
            Dim cc As _Unsigned Long
            Dim dd As _Unsigned Long
            For ii = 1 To UBound(blockmesh1, 1)
                For jj = 1 To UBound(blockmesh1, 2)
                    vindex = vindex + 1
                    vec3Dpos(vindex).x = BlockStep * ii - BlockSize / 2 + 3 * (Rnd - .5)
                    vec3Dpos(vindex).y = BlockStep * jj - BlockSize / 2 + 3 * (Rnd - .5)
                    vec3Dpos(vindex).z = blockmesh1(ii, jj)
                    cc = TerrainHeightShade~&(WorldMesh(i, j) + blockmesh1(ii, jj))
                    dd = TerrainHeightShade~&(WorldMesh(i, j) + blockmesh1(ii, jj) + BlockSize)
                    vec3Dcolor(vindex) = ShadeMix~&(cc, ShadeMix~&(cc, dd, blockmesh1(ii, jj) / 10), .5)
                Next
            Next
 
            Group(g).LastVector = vindex + 1 ''' why on earth is this +1?
        Next
    Next
 
    CreateTerrainVectors& = g
End Function
 
Function CreateTerrainVolume& (LagAddressIn As Long)
    Dim g As Long
    Dim As Integer i, j
    Dim k As Long
    Dim As Double u, v, z
    Dim groupcount As Integer
    Dim clustertick As Integer
    g = LagAddressIn
    groupcount = 0
    clustertick = 0
    For i = 1 To UBound(WorldMesh, 1)
        For j = 1 To UBound(WorldMesh, 2)
            z = WorldMesh(i, j) + BlockSize / 2
            If (z < 0) Then
                groupcount = groupcount + 1
                u = BlockSize * (i - (UBound(WorldMesh, 1) / 2))
                v = BlockSize * (j - (UBound(WorldMesh, 2) / 2))
                g = NewCube&(g, "Water", 50, u, v, WorldMesh(i, j) - z / 2, BlockSize, BlockSize, -z, Blue, RoyalBlue, DarkBlue, 0, 0)
                For k = Group(g).FirstVector To Group(g).LastVector
                    vec3Dvel(k).x = (Rnd - .5) * .20
                    vec3Dvel(k).y = (Rnd - .5) * .20
                    vec3Dvel(k).z = 0
                Next
            End If
            clustertick = clustertick + 1
            If (clustertick = 12) Then
                clustertick = 0
                If (groupcount > 0) Then
                    groupcount = 0
                    Call ClusterPinch(g)
                End If
            End If
        Next
        Call ClusterPinch(g)
    Next
    Call ClusterPinch(g)
 
    groupcount = 0
    clustertick = 0
    For i = 1 To UBound(WorldMesh, 1)
        For j = 1 To UBound(WorldMesh, 2)
            z = WorldMesh(i, j) + BlockSize / 2
            If (z > 0) Then
                groupcount = groupcount + 1
                u = BlockSize * (i - (UBound(WorldMesh, 1) / 2))
                v = BlockSize * (j - (UBound(WorldMesh, 2) / 2))
                g = NewCube&(g, "Dirt and Sand", 20, u, v, WorldMesh(i, j) / 2 - BlockSize / 4, BlockSize, BlockSize, WorldMesh(i, j), SaddleBrown, DarkKhaki, Sienna, 0, 0)
                g = NewCube&(g, "Dirt and Sand", 20, u, v, -50, BlockSize, BlockSize, 80, SaddleBrown, DarkKhaki, Sienna, 0, 0)
            End If
            clustertick = clustertick + 1
            If (clustertick = 12) Then
                clustertick = 0
                If (groupcount > 0) Then
                    groupcount = 0
                    Call ClusterPinch(g)
                End If
            End If
        Next
        Call ClusterPinch(g)
    Next
    Call ClusterPinch(g)
 
    groupcount = 0
    clustertick = 0
    For i = 1 To UBound(WorldMesh, 1)
        For j = 1 To UBound(WorldMesh, 2)
            groupcount = groupcount + 1
            u = BlockSize * (i - (UBound(WorldMesh, 1) / 2))
            v = BlockSize * (j - (UBound(WorldMesh, 2) / 2))
            z = WorldMesh(i, j)
            If (z < 0) Then z = 0
            g = NewCube&(g, "Atmospheric Dust", 30, u, v, 100 + BlockSize * (3 - 1 / 2) + z, BlockSize, BlockSize, BlockSize * 3, DarkGray, White, Snow, 0, 0)
            clustertick = clustertick + 1
            If (clustertick = 12) Then
                clustertick = 0
                If (groupcount > 0) Then
                    groupcount = 0
                    Call ClusterPinch(g)
                End If
            End If
        Next
        Call ClusterPinch(g)
    Next
    Call ClusterPinch(g)
 
    CreateTerrainVolume& = g
End Function
 
Function CreateTornado& (LagAddressIn As Long)
    Dim As Integer n, k
    Dim As Double u, v, w, x0, y0, z0
    Dim As Long p, g
    Dim wi As Integer
    Dim wj As Integer
    g = LagAddressIn
    For n = 1 To 4
        u = Rnd * 2 * pi
        FixedPathIndexTicker = FixedPathIndexTicker + 1
        For p = 1 To 86400
            x0 = BlockSize * 30 * Cos(u + 2 * pi * (6 * 30) * (p - 1) / 86400)
            y0 = BlockSize * 30 * Sin(u + 2 * pi * (6 * 30) * (p - 1) / 86400)
            FixedPath(FixedPathIndexTicker, p).x = x0
            FixedPath(FixedPathIndexTicker, p).y = y0
            wi = 1 + Int(x0 / BlockSize + UBound(WorldMesh, 1) / 2)
            wj = 1 + Int(y0 / BlockSize + UBound(WorldMesh, 2) / 2)
            z0 = WorldMesh(wi, wj)
            If (z0 < 0) Then z0 = 0
            FixedPath(FixedPathIndexTicker, p).z = z0 + 50
        Next
        For k = 1 To 30
            u = Rnd * 100
            v = Rnd * u / 3
            w = Rnd * 2 * pi
            g = NewCube&(g, "Tornado", 35, v * Cos(w), v * Sin(w), u, 15, 15, 15, DarkGray, SunsetOrange, DarkGoldenRod, FixedPathIndexTicker, 0)
            Call SetParticleVelocity(g, -Sin(w), Cos(w), 0)
        Next
        Call ClusterPinch(g)
    Next
    CreateTornado& = g
End Function
 
Function CreateWeather& (LagAddressIn As Long)
    Dim As Integer n, k
    Dim As Double u, v, w, x0, y0, z0, tallness
    Dim As Long p, g
    Dim wi As Integer
    Dim wj As Integer
    g = LagAddressIn
    For n = 1 To 100
        FixedPathIndexTicker = FixedPathIndexTicker + 1
        u = Rnd * 2 * pi
        v = Rnd * .7 * BlockSize * Sqr((UBound(WorldMesh, 1) / 2) ^ 2 + (UBound(WorldMesh, 2) / 2) ^ 2)
        w = pi / 2
        tallness = Rnd * (CloudLayer(UBound(CloudLayer)).Height - CloudLayer(1).Height)
        For p = 1 To 86400
            x0 = v * Cos(u + 2 * pi * (1 * 30) * (p - 1) / 86400 + w)
            y0 = v * Sin(u + 4 * pi * (1 * 30) * (p - 1) / 86400)
            FixedPath(FixedPathIndexTicker, p).x = x0
            FixedPath(FixedPathIndexTicker, p).y = y0
            wi = 1 + Int(x0 / BlockSize + UBound(WorldMesh, 1) / 2)
            wj = 1 + Int(y0 / BlockSize + UBound(WorldMesh, 2) / 2)
            z0 = WorldMesh(wi, wj)
            If (z0 < 0) Then z0 = 0
            z0 = z0 + CloudLayer(1).Height + tallness
            FixedPath(FixedPathIndexTicker, p).z = z0
        Next
        For k = 1 To 20 '30
            u = Rnd * 80
            v = u
            w = Rnd * 2 * pi
            z0 = z0 + 10 * (Rnd - .5)
            g = NewCube&(g, CloudHeightLabel$(z0), 20, v * Cos(w), v * Sin(w), z0, BlockSize / 2, BlockSize / 2, BlockSize / 2, Red, Red, Red, FixedPathIndexTicker, 0)
            Call SetParticleVelocity(g, .01 * (Rnd - .5), .01 * (Rnd - .5), 0)
            For p = Group(g).FirstVector To Group(g).LastVector
                vec3Dcolor(p) = CloudHeightShade~&(Group(g).Centroid.z + vec3Dpos(p).z)
            Next
            Group(g).PlotMode = 0
 
            If (Rnd < .2) Then
                z0 = Group(g).Centroid.z
                g = NewCube&(g, "Rain", 20, v * Cos(w), v * Sin(w), z0 / 2 - BlockSize / 2, BlockSize / 2, BlockSize / 2, z0, Blue, RoyalBlue, DodgerBlue, 0, 0)
                Call SetParticleVelocity(g, 0, 0, -1)
            End If
 
        Next
        Call ClusterPinch(g)
    Next
    CreateWeather& = g
End Function
 
Function CreateClover& (LagAddressIn As Long)
    Dim As Long g, vindex
    Dim As Integer i, j
    Dim As Double x, y, z, u, t
    Dim As Integer pedals
    Dim As Double scale
    Dim As Double height
    g = LagAddressIn
    For i = 1 To UBound(WorldMesh, 1)
        For j = 1 To UBound(WorldMesh, 2)
            z = WorldMesh(i, j)
            If (TerrainHeightIndex(z) = 1) Then
                If (Rnd < .1) Then
                    x = (Rnd - .5) * BlockSize + BlockSize * (i - (UBound(WorldMesh, 1) / 2))
                    y = (Rnd - .5) * BlockSize + BlockSize * (j - (UBound(WorldMesh, 2) / 2))
                    scale = 1 / (4 + Rnd * 3)
                    g = NewGroup&(g, x, y, z, 12, 0, 0)
                    Group(g).Label = "Clover"
                    Group(g).Volume.x = BlockSize
                    Group(g).Volume.y = BlockSize
                    Group(g).Volume.z = BlockSize
                    vindex = Group(Group(g).Lagger).LastVector
                    Group(g).FirstVector = vindex + 1
                    Group(g).PlotMode = 1
                    pedals = 2 + Int(Rnd * 4)
                    height = 2 + Rnd
                    t = Rnd * 2 * pi
                    For u = 0 To 2 * pi Step .1
                        vindex = vindex + 1
                        vec3Dpos(vindex).x = scale * ((Group(g).Volume.x) * (0 + Cos(pedals * u) * Cos(u))) * Cos(t)
                        vec3Dpos(vindex).y = scale * ((Group(g).Volume.y) * (0 + Cos(pedals * u) * Cos(u))) * Sin(t)
                        vec3Dpos(vindex).z = scale * ((Group(g).Volume.z) * (height + Cos(pedals * u) * Sin(u)))
                        Select Case pedals
                            Case 3
                                vec3Dcolor(vindex) = Magenta
                            Case Else
                                vec3Dcolor(vindex) = Lime
                        End Select
                    Next
                    For u = (Group(g).Volume.z) * height To 0 Step -(Group(g).Volume.z) * height / 10
                        vindex = vindex + 1
                        vec3Dpos(vindex).x = scale * (0 + (Rnd - .5))
                        vec3Dpos(vindex).y = scale * (0 + (Rnd - .5))
                        vec3Dpos(vindex).z = scale * (u)
                        vec3Dcolor(vindex) = LimeGreen
                    Next
                    Group(g).LastVector = vindex '''+ 1 ''' why on earth is this +1?
                    Call ClusterPinch(g)
                End If
            End If
        Next
    Next
    CreateClover& = g
End Function
 
Function CreateGrass& (LagAddressIn As Long)
    Dim As Long g, vindex
    Dim As Integer i, j, k
    Dim As Double x0, y0, x, y, z, u, t
    Dim As Double scale
    Dim As Double height
    g = LagAddressIn
    For i = 1 To UBound(WorldMesh, 1)
        For j = 1 To UBound(WorldMesh, 2)
            z = WorldMesh(i, j)
            If (TerrainHeightIndex(z) = 2) Then
                For k = 1 To 5
                    If (Rnd < .5) Then
                        x = (Rnd - .5) * BlockSize + BlockSize * (i - (UBound(WorldMesh, 1) / 2))
                        y = (Rnd - .5) * BlockSize + BlockSize * (j - (UBound(WorldMesh, 2) / 2))
                        scale = 1 / (4 + Rnd * 3)
                        g = NewGroup&(g, x, y, z, 16, 0, 0)
                        Group(g).Label = "Grass"
                        Group(g).Volume.x = BlockSize
                        Group(g).Volume.y = BlockSize
                        Group(g).Volume.z = BlockSize
                        vindex = Group(Group(g).Lagger).LastVector
                        Group(g).FirstVector = vindex + 1
                        Group(g).PlotMode = 1
                        height = 1 + Rnd
                        t = Rnd * 2 * pi
                        x0 = BlockSize * 1 * (Rnd - .5)
                        y0 = BlockSize * 1 * (Rnd - .5)
                        For u = (Group(g).Volume.z) * height To 0 Step -(Group(g).Volume.z) * height / 5
                            vindex = vindex + 1
                            vec3Dpos(vindex).x = scale * (x0 + (Rnd - .5))
                            vec3Dpos(vindex).y = scale * (y0 + (Rnd - .5))
                            vec3Dpos(vindex).z = scale * (u)
                            vec3Dcolor(vindex) = ShadeMix~&(DarkGoldenRod, Sienna, Rnd)
                        Next
                        Group(g).LastVector = vindex '''+ 1 ''' why on earth is this +1?
                    End If
                Next
            End If
        Next
        Call ClusterPinch(g)
    Next
    CreateGrass& = g
End Function
 
Function CreateFern& (LagAddressIn As Long)
    Dim As Long g, vindex
    Dim As Integer i, j, k
    Dim As Double xx, yy, zz, x, y, z, t
    Dim As Double scale
    g = LagAddressIn
    For i = 1 To UBound(WorldMesh, 1)
        For j = 1 To UBound(WorldMesh, 2)
            z = WorldMesh(i, j)
            If (TerrainHeightIndex(z) = 1) Then
                If (Rnd < .1) Then
                    x = (Rnd - .5) * BlockSize + BlockSize * (i - (UBound(WorldMesh, 1) / 2))
                    y = (Rnd - .5) * BlockSize + BlockSize * (j - (UBound(WorldMesh, 2) / 2))
                    scale = .05 + Rnd * .05
                    g = NewGroup&(g, x, y, z, 12, 0, 0)
                    Group(g).Label = "Fern"
                    Group(g).Volume.x = BlockSize
                    Group(g).Volume.y = BlockSize
                    Group(g).Volume.z = BlockSize
                    vindex = Group(Group(g).Lagger).LastVector
                    Group(g).FirstVector = vindex + 1
                    Group(g).PlotMode = 2
                    t = Rnd * 2 * pi
                    xx = 0
                    yy = xx
                    zz = 0
                    For k = 1 To 100
                        Select Case Rnd * 100
                            Case Is < 1
                                xx = 0
                                zz = .16 * zz
                            Case Is < 86
                                xx = .85 * xx + .04 * zz
                                zz = -.04 * xx + .85 * zz + 1.6
                            Case Is < 93
                                xx = .2 * xx - .26 * zz
                                zz = .23 * xx + .22 * zz + 1.6
                            Case Else
                                xx = -.15 * xx + .28 * zz
                                zz = .26 * xx + .24 * zz + .44
                        End Select
                        yy = xx
                        vindex = vindex + 1
                        vec3Dpos(vindex).x = scale * Group(g).Volume.x * xx * Cos(t)
                        vec3Dpos(vindex).y = scale * Group(g).Volume.y * yy * Sin(t)
                        vec3Dpos(vindex).z = scale * Group(g).Volume.z * zz
                        vec3Dcolor(vindex) = Lime
                    Next
                    Group(g).LastVector = vindex '''+ 1 ''' why on earth is this +1?
                    Call ClusterPinch(g)
                End If
            End If
        Next
    Next
    CreateFern& = g
End Function
 
Function CreateSun& (LagAddressIn As Long)
    Dim As Integer k
    Dim As Double xx, yy, zz, x0, y0, z0, phase
    Dim As Long p, g
    g = LagAddressIn
    FixedPathIndexTicker = FixedPathIndexTicker + 1
    For p = 1 To 86400
        phase = -2 * pi * (24) * (p - 1) / 86400 - pi / 2
        x0 = 5000 * Cos(phase)
        y0 = 0
        z0 = 3000 * Sin(phase)
        FixedPath(FixedPathIndexTicker, p).x = x0
        FixedPath(FixedPathIndexTicker, p).y = y0
        FixedPath(FixedPathIndexTicker, p).z = z0
    Next
    For k = 1 To 30
        Do
            xx = (Rnd - .5) * 6 * BlockSize
            yy = (Rnd - .5) * 6 * BlockSize
            zz = (Rnd - .5) * 6 * BlockSize
        Loop Until ((xx ^ 2 + yy ^ 2 + zz ^ 2) < (.5 * 6 * BlockSize) ^ 2)
        g = NewCube&(g, "Sun", 50, xx, yy, zz, BlockSize * 6, BlockSize * 6, BlockSize * 6, Red, Red, Red, FixedPathIndexTicker, 0)
        For p = Group(g).FirstVector To Group(g).LastVector
            vec3Dcolor(p) = ShadeMix~&(Sunglow, SunsetOrange, Rnd)
        Next
        Call SetParticleVelocity(g, .5 * (Rnd - .5), .5 * (Rnd - .5), .5 * (Rnd - .5))
        Group(g).PlotMode = 0
    Next
    SunClusterAddress = ClusterIdTicker
    Call ClusterPinch(g)
    CreateSun& = g
End Function
 
Function CreateMoon& (LagAddressIn As Long)
    Dim As Integer k
    Dim As Double xx, yy, zz, x0, y0, z0, phase
    Dim As Long p, g
    g = LagAddressIn
    FixedPathIndexTicker = FixedPathIndexTicker + 1
    For p = 1 To 86400
        phase = -2 * pi * (48) * (p - 1) / 86400 + pi / 2
        x0 = 0
        y0 = 4000 * Cos(phase)
        z0 = 2000 * Sin(phase)
        FixedPath(FixedPathIndexTicker, p).x = x0
        FixedPath(FixedPathIndexTicker, p).y = y0
        FixedPath(FixedPathIndexTicker, p).z = z0
    Next
    For k = 1 To 30
        Do
            xx = (Rnd - .5) * 5 * BlockSize
            yy = (Rnd - .5) * 5 * BlockSize
            zz = (Rnd - .5) * 5 * BlockSize
        Loop Until ((xx ^ 2 + yy ^ 2 + zz ^ 2) < (.5 * 5 * BlockSize) ^ 2)
        g = NewCube&(g, "Moon", 50, xx, yy, zz, 5 * BlockSize, 5 * BlockSize, 5 * BlockSize, Gray, DarkGray, SlateGray, FixedPathIndexTicker, 0)
        Group(g).PlotMode = 0
    Next
    MoonClusterAddress = ClusterIdTicker
    Call ClusterPinch(g)
    CreateMoon& = g
End Function
 
Function CreateFish& (LagAddressIn As Long)
    Dim As Integer n, m, wi, wj
    Dim As Double u, v, x0, y0, z0
    Dim As Long p, g, p0
    g = LagAddressIn
    For n = 1 To 12
        u = Rnd * 2 * pi
        FixedPathIndexTicker = FixedPathIndexTicker + 1
        For p = 1 To 86400
            x0 = BlockSize * Plateau(1).Location.x + BlockSize * (4 + Cos(2 * pi * n / 12)) * Cos(u + 2 * pi * (24 * 30) * (p - 1) / 86400)
            y0 = BlockSize * Plateau(1).Location.y + BlockSize * (4 + Cos(2 * pi * n / 12)) * Sin(u + 2 * pi * (24 * 30) * (p - 1) / 86400)
            FixedPath(FixedPathIndexTicker, p).x = x0
            FixedPath(FixedPathIndexTicker, p).y = y0
            wi = 1 + Int(x0 / BlockSize + UBound(WorldMesh, 1) / 2)
            wj = 1 + Int(y0 / BlockSize + UBound(WorldMesh, 2) / 2)
            z0 = WorldMesh(wi, wj) + 100 + 80 * Cos(2 * pi * n / 12) * Cos(2 * pi * (24 * 30) * (p - 1) / 86400)
            FixedPath(FixedPathIndexTicker, p).z = z0
        Next
        ' In the following group, there are 48 frames with 36 vectors per frame. The +1 offset is fishy, no pun.
        g = NewCube&(g, "Fish", 36 * (48 + 1), 0, 0, 0, BlockSize / 4, BlockSize / 4, BlockSize / 4, LimeGreen, SunsetOrange, DarkGoldenRod, FixedPathIndexTicker, 1)
        Group(g).FrameLength = 36
        u = 0
        For p = Group(g).FirstVector To Group(g).FirstVector + Group(g).FrameLength - 1
            u = u + 2 * pi / Group(g).FrameLength
            vec3Dpos(p).x = Group(g).Volume.x * (Cos(u) - Sin(u) ^ 2 / Sqr(2))
            vec3Dpos(p).y = 0
            vec3Dpos(p).z = Group(g).Volume.z * (Cos(u) * Sin(u))
        Next
        v = 0
        For m = 1 To 48
            v = v - 2 * pi / 48
            p0 = 0
            For p = Group(g).FirstVector + Group(g).FrameLength * (m) To Group(g).FirstVector + Group(g).FrameLength * (m + 1) - 1
                vec3Dpos(p).x = Cos(v) * vec3Dpos(Group(g).FirstVector + p0).x + Sin(v) * vec3Dpos(Group(g).FirstVector + p0).y
                vec3Dpos(p).y = -Sin(v) * vec3Dpos(Group(g).FirstVector + p0).x + Cos(v) * vec3Dpos(Group(g).FirstVector + p0).y
                vec3Dpos(p).z = vec3Dpos(Group(g).FirstVector + p0).z
                p0 = p0 + 1
            Next
        Next
        Call ClusterPinch(g)
    Next
    CreateFish& = g
End Function
 
Sub InitCamera
    ToggleAnimate = 1
    PlayerCamera.Position.x = 0
    PlayerCamera.Position.y = 0
    PlayerCamera.Position.z = 100 + 40 + WorldMesh(UBound(WorldMesh, 1) / 2, UBound(WorldMesh, 2) / 2)
    PlayerCamera.Velocity.x = 0
    PlayerCamera.Velocity.y = 0
    PlayerCamera.Velocity.z = .1
    PlayerCamera.Acceleration.x = 0
    PlayerCamera.Acceleration.y = 0
    PlayerCamera.Acceleration.z = -.5
    uhat(1) = 1: uhat(2) = 0: uhat(3) = 0
    vhat(1) = 0: vhat(2) = 0: vhat(3) = 1
    Call CalculateScreenVectors
End Sub
 
Sub RegulateCamera
    Dim As Double dx, dy, t
    dx = -nhat(1)
    dy = -nhat(2)
    If ((dx > 0) And (dy > 0)) Then t = -pi / 2 + (Atn(dy / dx))
    If ((dx < 0) And (dy > 0)) Then t = -pi / 2 + pi + (Atn(dy / dx))
    If ((dx < 0) And (dy < 0)) Then t = -pi / 2 + pi + (Atn(dy / dx))
    If ((dx > 0) And (dy < 0)) Then t = -pi / 2 + 2 * pi + (Atn(dy / dx))
    uhat(1) = Cos(t): uhat(2) = Sin(t): uhat(3) = 0
    vhat(1) = 0: vhat(2) = 0: vhat(3) = 1
    Call CalculateScreenVectors
End Sub
 
' Terrain tools.
 
Function TerrainHeightIndex (z0 As Double)
    Dim j As Integer
    Dim h0 As Integer
    h0 = -1
    For j = 1 To UBound(Strata)
        If (z0 <= Strata(j).Height) Then
            h0 = j - 1
            Exit For
        End If
    Next
    If (h0 = -1) Then h0 = UBound(Strata)
    TerrainHeightIndex = h0
End Function
 
Function TerrainHeightShade~& (z0 As Double)
    Dim j As Integer
    Dim h0 As Integer
    h0 = -1
    For j = 1 To UBound(Strata)
        If (z0 <= Strata(j).Height) Then
            h0 = j - 1
            Exit For
        End If
    Next
    If (h0 = -1) Then h0 = UBound(Strata)
    Dim u As Double
    Dim v As Double
    Dim alpha As Double
    Dim sh1 As _Unsigned Long
    Dim sh2 As _Unsigned Long
    Select Case h0
        Case 0
            sh1 = Strata(1).Shade
            sh2 = Strata(1).Shade
            alpha = 0
        Case UBound(Strata)
            sh1 = Strata(h0).Shade
            sh2 = Strata(h0).Shade
            alpha = 0
        Case Else
            sh1 = Strata(h0).Shade
            sh2 = Strata(h0 + 1).Shade
            u = z0 - Strata(h0).Height
            v = Strata(h0 + 1).Height - Strata(h0).Height
            alpha = u / v
    End Select
    TerrainHeightShade~& = ShadeMix~&(sh1, sh2, alpha)
End Function
 
Function TerrainHeightLabel$ (z0 As Double)
    Dim TheReturn As String
    Dim j As Integer
    Dim h0 As Integer
    h0 = -1
    For j = 1 To UBound(Strata)
        If (z0 <= Strata(j).Height) Then
            h0 = j
            Exit For
        End If
    Next
    If (h0 = -1) Then h0 = UBound(Strata)
    Select Case h0
        Case 0
            TheReturn = Strata(1).Label
        Case UBound(Strata)
            TheReturn = Strata(h0).Label
        Case Else
            TheReturn = Strata(h0).Label
    End Select
    TerrainHeightLabel$ = TheReturn
End Function
 
Function CloudHeightShade~& (z0 As Double)
    Dim j As Integer
    Dim h0 As Integer
    h0 = -1
    For j = 1 To UBound(CloudLayer)
        If (z0 <= CloudLayer(j).Height) Then
            h0 = j - 1
            Exit For
        End If
    Next
    If (h0 = -1) Then h0 = UBound(CloudLayer)
    Dim u As Double
    Dim v As Double
    Dim alpha As Double
    Dim sh1 As _Unsigned Long
    Dim sh2 As _Unsigned Long
    Select Case h0
        Case 0
            sh1 = CloudLayer(1).Shade
            sh2 = CloudLayer(1).Shade
            alpha = 0
        Case UBound(CloudLayer)
            sh1 = CloudLayer(h0).Shade
            sh2 = CloudLayer(h0).Shade
            alpha = 0
        Case Else
            sh1 = CloudLayer(h0).Shade
            sh2 = CloudLayer(h0 + 1).Shade
            u = z0 - CloudLayer(h0).Height
            v = CloudLayer(h0 + 1).Height - CloudLayer(h0).Height
            alpha = u / v
    End Select
    CloudHeightShade~& = ShadeMix~&(sh1, sh2, alpha)
End Function
 
Function CloudHeightLabel$ (z0 As Double)
    Dim TheReturn As String
    Dim j As Integer
    Dim h0 As Integer
    h0 = -1
    For j = 1 To UBound(CloudLayer)
        If (z0 <= CloudLayer(j).Height) Then
            h0 = j
            Exit For
        End If
    Next
    If (h0 = -1) Then h0 = UBound(CloudLayer)
    Select Case h0
        Case 0
            TheReturn = CloudLayer(1).Label
        Case UBound(CloudLayer)
            TheReturn = CloudLayer(h0).Label
        Case Else
            TheReturn = CloudLayer(h0).Label
    End Select
    CloudHeightLabel$ = TheReturn
End Function
 
' Low-order groups.
 
Function NewCube& (LagAddressIn As Long, TheName As String, Weight As Integer, PosX As Double, PosY As Double, PosZ As Double, VolX As Double, VolY As Double, VolZ As Double, ShadeA As _Unsigned Long, ShadeB As _Unsigned Long, ShadeC As _Unsigned Long, TheDynamic As Integer, Framing As Integer)
    Dim k As Integer
    Dim g As Long
    Dim q As Long
    Dim vindex As Long
    q = LagAddressIn
    vindex = Group(q).LastVector
    g = NewGroup&(q, PosX, PosY, PosZ, 64, TheDynamic, Framing)
    Group(g).Label = TheName
    Group(g).Volume.x = VolX
    Group(g).Volume.y = VolY
    Group(g).Volume.z = VolZ
    Group(g).FirstVector = vindex + 1
    Group(g).PlotMode = 1
    For k = 1 To Weight
        vindex = vindex + 1
        vec3Dpos(vindex).x = (Rnd - .5) * VolX
        vec3Dpos(vindex).y = (Rnd - .5) * VolY
        vec3Dpos(vindex).z = (Rnd - .5) * VolZ
        If (Rnd > .5) Then
            vec3Dcolor(vindex) = ShadeA
        Else
            If (Rnd > .5) Then
                vec3Dcolor(vindex) = ShadeB
            Else
                vec3Dcolor(vindex) = ShadeC
            End If
        End If
    Next
    Group(g).LastVector = vindex
    NewCube& = g
End Function
 
Function NewWireCube& (LagAddressIn As Long, TheName As String, PosX As Double, PosY As Double, PosZ As Double, VolX As Double, VolY As Double, VolZ As Double, ShadeA As _Unsigned Long, TheDynamic As Integer)
    Dim g As Long
    Dim q As Long
    Dim vindex As Long
    q = LagAddressIn
    vindex = Group(q).LastVector
    g = NewGroup&(q, PosX, PosY, PosZ, 64, TheDynamic, 0)
    Group(g).Label = TheName
    Group(g).Volume.x = VolX
    Group(g).Volume.y = VolY
    Group(g).Volume.z = VolZ
    Group(g).FirstVector = vindex + 1
    Group(g).PlotMode = -1
 
    vindex = vindex + 1
    vec3Dpos(vindex).x = (0 - .5) * VolX
    vec3Dpos(vindex).y = (0 - .5) * VolY
    vec3Dpos(vindex).z = (0 - .5) * VolZ
    vec3Dcolor(vindex) = ShadeA
    vindex = vindex + 1
    vec3Dpos(vindex).x = (1 - .5) * VolX
    vec3Dpos(vindex).y = (0 - .5) * VolY
    vec3Dpos(vindex).z = (0 - .5) * VolZ
    vec3Dcolor(vindex) = ShadeA
    vindex = vindex + 1
    vec3Dpos(vindex).x = (0 - .5) * VolX
    vec3Dpos(vindex).y = (1 - .5) * VolY
    vec3Dpos(vindex).z = (0 - .5) * VolZ
    vec3Dcolor(vindex) = ShadeA
    vindex = vindex + 1
    vec3Dpos(vindex).x = (1 - .5) * VolX
    vec3Dpos(vindex).y = (1 - .5) * VolY
    vec3Dpos(vindex).z = (0 - .5) * VolZ
    vec3Dcolor(vindex) = ShadeA
 
    vindex = vindex + 1
    vec3Dpos(vindex).x = (0 - .5) * VolX
    vec3Dpos(vindex).y = (0 - .5) * VolY
    vec3Dpos(vindex).z = (1 - .5) * VolZ
    vec3Dcolor(vindex) = ShadeA
    vindex = vindex + 1
    vec3Dpos(vindex).x = (1 - .5) * VolX
    vec3Dpos(vindex).y = (0 - .5) * VolY
    vec3Dpos(vindex).z = (1 - .5) * VolZ
    vec3Dcolor(vindex) = ShadeA
    vindex = vindex + 1
    vec3Dpos(vindex).x = (0 - .5) * VolX
    vec3Dpos(vindex).y = (1 - .5) * VolY
    vec3Dpos(vindex).z = (1 - .5) * VolZ
    vec3Dcolor(vindex) = ShadeA
    vindex = vindex + 1
    vec3Dpos(vindex).x = (1 - .5) * VolX
    vec3Dpos(vindex).y = (1 - .5) * VolY
    vec3Dpos(vindex).z = (1 - .5) * VolZ
    vec3Dcolor(vindex) = ShadeA
 
    Group(g).LastVector = vindex
    NewWireCube& = g
End Function
 
' Linked list utility.
 
Function LatestGroupIdentity& (StartingID As Long)
    Dim TheReturn As Long
    Dim As Long p, q
    p = StartingID
    If (p = 0) Then
        q = 0
    Else
        Do
            q = p
            p = Group(q).Pointer
            If (p = -999) Then Exit Do
        Loop
    End If
    TheReturn = q
    LatestGroupIdentity& = TheReturn
End Function
 
Function LatestClusterIdentity& (StartingID As Long)
    Dim TheReturn As Long
    Dim As Long p, q
    p = StartingID
    If (p = 0) Then
        q = 0
    Else
        Do
            q = p
            p = Cluster(q).Pointer
            If (p = -999) Then Exit Do
        Loop
    End If
    TheReturn = q
    LatestClusterIdentity& = TheReturn
End Function
 
Function NewGroup& (LagAddressIn As Long, CenterX As Double, CenterY As Double, CenterZ As Double, ClusterSize As Integer, TheDynamic As Integer, Framing As Integer)
    Dim As Long g0
    g0 = LatestGroupIdentity&(LagAddressIn)
    GroupIdTicker = GroupIdTicker + 1
    Group(GroupIdTicker).Identity = GroupIdTicker
    Group(GroupIdTicker).Pointer = -999
    Group(GroupIdTicker).Lagger = g0
    Group(GroupIdTicker).Centroid.x = CenterX
    Group(GroupIdTicker).Centroid.y = CenterY
    Group(GroupIdTicker).Centroid.z = CenterZ
    Group(GroupIdTicker).FrameLength = 0
    Group(GroupIdTicker).ActiveFrame = 0
    If (Group(GroupIdTicker).Lagger <> 0) Then
        Group(g0).Pointer = GroupIdTicker
    End If
 
    ' Adjust corresponding cluster.
    ClusterFillCounter = ClusterFillCounter + 1
    If (ClusterFillCounter = 1) Then
        Call NewCluster(1, Group(GroupIdTicker).Identity, TheDynamic, Framing) '''
    End If
    If (ClusterFillCounter = ClusterSize) Then
        Call ClusterPinch(Group(GroupIdTicker).Identity)
    End If
 
    NewGroup& = Group(GroupIdTicker).Identity
End Function
 
 
Sub NewCluster (ClusterLagIn As Long, FirstGroupIn As Long, TheDynamic As Integer, Framing As Integer)
    Dim As Long k0
    If (ClusterIdTicker = 0) Then
        k0 = -1
    Else
        k0 = LatestClusterIdentity&(ClusterLagIn)
    End If
    ClusterIdTicker = ClusterIdTicker + 1
    Cluster(ClusterIdTicker).Identity = ClusterIdTicker
    Cluster(ClusterIdTicker).Pointer = -999
    Cluster(ClusterIdTicker).Lagger = k0
    Cluster(ClusterIdTicker).FirstGroup = FirstGroupIn
    Cluster(ClusterIdTicker).MotionType = TheDynamic
    Cluster(ClusterIdTicker).Framed = Framing
    If (ClusterIdTicker > 1) Then Cluster(k0).Pointer = ClusterIdTicker
End Sub
 
 
 
Sub RemoveGroup (TheAddressIn As Long)
    Dim As Long g, p, l, k, ci
    Dim As Integer f
    g = TheAddressIn
 
    f = 0
    k = 1
    Do
        If (Cluster(k).FirstGroup = g) And (Cluster(k).LastGroup <> g) Then
            f = 1
            ci = k
            Exit Do
        End If
        If (Cluster(k).FirstGroup <> g) And (Cluster(k).LastGroup = g) Then
            f = 2
            ci = k
            Exit Do
        End If
        If ((Cluster(k).LastGroup = g) And (Cluster(k).LastGroup = g)) Then
            f = 3
            ci = k
            Exit Do
        End If
        k = Cluster(k).Pointer
        If (k = -999) Then Exit Do
    Loop
 
    Select Case f
        Case 0
            p = Group(g).Pointer
            l = Group(g).Lagger
            Group(l).Pointer = p
            If (p <> -999) Then
                Group(p).Lagger = l
            End If
 
        Case 1
            p = Group(g).Pointer
            l = Group(g).Lagger
            Group(l).Pointer = p
            If (p <> -999) Then
                Group(p).Lagger = l
            End If
 
            Cluster(ci).FirstGroup = p
            Call ClusterCentroidCalc(ci)
        Case 2
            p = Group(g).Pointer
            l = Group(g).Lagger
            Group(l).Pointer = p
            If (p <> -999) Then
                Group(p).Lagger = l
            End If
 
            Cluster(ci).LastGroup = l
            Call ClusterCentroidCalc(ci)
        Case 3
            p = Group(g).Pointer
            l = Group(g).Lagger
            Group(l).Pointer = p
            If (p <> -999) Then
                Group(p).Lagger = l
            End If
 
            Call RemoveCluster(ci)
    End Select
End Sub
 
Sub RemoveCluster (TheAddressIn As Long)
    Dim As Long k, p, l
    k = TheAddressIn
    p = Cluster(k).Pointer
    l = Cluster(k).Lagger
    If (l <> -1) Then
        Cluster(l).Pointer = p
    End If
    If (p <> -999) Then
        Cluster(p).Lagger = l
    End If
End Sub
 
Sub ClusterPinch (TheLastGroup As Long)
    ClusterFillCounter = 0
    Cluster(ClusterIdTicker).LastGroup = TheLastGroup
    Call ClusterCentroidCalc(ClusterIdTicker)
End Sub
 
Sub ClusterCentroidCalc (TheCluster As Long)
    Dim As Long g
    Dim As Integer n
    Cluster(TheCluster).Centroid.x = 0
    Cluster(TheCluster).Centroid.y = 0
    Cluster(TheCluster).Centroid.z = 0
    g = Cluster(TheCluster).FirstGroup
    n = 0
    Do
        Cluster(TheCluster).Centroid.x = Cluster(TheCluster).Centroid.x + Group(g).Centroid.x
        Cluster(TheCluster).Centroid.y = Cluster(TheCluster).Centroid.y + Group(g).Centroid.y
        Cluster(TheCluster).Centroid.z = Cluster(TheCluster).Centroid.z + Group(g).Centroid.z
        n = n + 1
        If (g = Cluster(TheCluster).LastGroup) Then Exit Do
        g = Group(g).Pointer
    Loop
    Cluster(TheCluster).Centroid.x = Cluster(TheCluster).Centroid.x / n
    Cluster(TheCluster).Centroid.y = Cluster(TheCluster).Centroid.y / n
    Cluster(TheCluster).Centroid.z = Cluster(TheCluster).Centroid.z / n
End Sub
 
' Player Dynamics
 
Sub PlayerDynamics
    If (ToggleAnimate = 1) Then
 
        ' Player kinematics
        PlayerCamera.Velocity.x = PlayerCamera.Velocity.x + PlayerCamera.Acceleration.x
        PlayerCamera.Velocity.y = PlayerCamera.Velocity.y + PlayerCamera.Acceleration.y
        PlayerCamera.Velocity.z = PlayerCamera.Velocity.z + PlayerCamera.Acceleration.z
        PlayerCamera.Velocity.x = .95 * PlayerCamera.Velocity.x
        PlayerCamera.Velocity.y = .95 * PlayerCamera.Velocity.y
        PlayerCamera.Velocity.z = .95 * PlayerCamera.Velocity.z
        PlayerCamera.Position.x = PlayerCamera.Position.x + PlayerCamera.Velocity.x
        PlayerCamera.Position.y = PlayerCamera.Position.y + PlayerCamera.Velocity.y
        PlayerCamera.Position.z = PlayerCamera.Position.z + PlayerCamera.Velocity.z
 
        ' Terrain traversal.
        Dim As Double qi, qj
        Dim As Integer wi, wj
        qi = (PlayerCamera.Position.x) / BlockSize + UBound(WorldMesh, 1) / 2
        qj = (PlayerCamera.Position.y) / BlockSize + UBound(WorldMesh, 2) / 2
        wi = 1 + Int(qi)
        wj = 1 + Int(qj)
        If (wi < 1) Then wi = 1
        If (wj < 1) Then wj = 1
        If (wi > UBound(WorldMesh, 1)) Then wi = UBound(WorldMesh, 1)
        If (wj > UBound(WorldMesh, 2)) Then wj = UBound(WorldMesh, 2)
        If (PlayerCamera.Velocity.z = 0) Then
            PlayerCamera.Position.z = PlayerCamera.Position.z + .15 * ((40 + WorldMesh(wi, wj) - PlayerCamera.Position.z))
        End If
 
        ' Collision with ground after jump.
        If ((PlayerCamera.Velocity.z <> 0) And (PlayerCamera.Position.z < (40 + WorldMesh(wi, wj)))) Then
            PlayerCamera.Acceleration.z = 0
            PlayerCamera.Velocity.z = 0
        End If
 
        ' Collision with tornado.
        If (Group(ClosestGroup).Label = "Tornado") Then
            PlayerCamera.Velocity.x = (Rnd - .5) * 20
            PlayerCamera.Velocity.y = (Rnd - .5) * 20
            PlayerCamera.Velocity.z = 20
            PlayerCamera.Acceleration.z = -.5
        End If
 
        'Un-zoom camera.
        If ((fovd <> -192) And (_KeyDown(90) = 0) And (_KeyDown(122) = 0)) Then
            fovd = Int(.5 * (fovd - 192)) + 1
            farplane(4) = -256 'Int(.5 * (farplane(4) - 256))
            Call CalculateClippingPlanes(_Width, _Height)
        End If
 
    End If
End Sub
 
' Compute Visible Scene
 
Sub ComputeVisibleScene
    Dim As Long g, k
    Dim As Double dx, dy, dz
    Dim closestdist2 As Double
    Dim fp42 As Double
    Dim dist2 As Double
    Dim GroupInView As Integer
    ClosestGroup = 1
    closestdist2 = 10000000
    fp42 = farplane(4) * farplane(4)
 
    k = 1
    Do
        dx = Cluster(k).Centroid.x - PlayerCamera.Position.x
        dy = Cluster(k).Centroid.y - PlayerCamera.Position.y
        dz = Cluster(k).Centroid.z - PlayerCamera.Position.z
        dist2 = dx * dx + dy * dy + dz * dz
        '''
        If k = SunClusterAddress And Cluster(k).Centroid.z > 0 Then GoTo 100
        If k = MoonClusterAddress And Cluster(k).Centroid.z > 0 Then GoTo 100
        '''
        If (dist2 > 600 * 600) Then
            Cluster(k).Visible = 0
            If ((Cluster(k).MotionType <> 0) And (ToggleAnimate = 1)) Then
                Call EvolveCluster(k)
            End If
        Else
            '''
            100
            '''
            Cluster(k).Visible = 1
            g = Cluster(k).FirstGroup
            If ((Cluster(k).MotionType <> 0) And (ToggleAnimate = 1)) Then
                Call EvolveCluster(k)
            End If
            Do
                dx = Group(g).Centroid.x - PlayerCamera.Position.x
                dy = Group(g).Centroid.y - PlayerCamera.Position.y
                dz = Group(g).Centroid.z - PlayerCamera.Position.z
                dist2 = dx * dx + dy * dy + dz * dz
                Group(g).Visible = 0
                '''
                If k = SunClusterAddress Then GoTo 200
                If k = MoonClusterAddress Then GoTo 200
                '''
 
                If (dist2 < fp42) Then
                    '''
                    200
                    '''
                    GroupInView = 1
                    If dx * nearplane(1) + dy * nearplane(2) + dz * nearplane(3) - nearplane(4) < 0 Then GroupInView = 0
                    'IF dx * farplane(1) + dy * farplane(2) + dz * farplane(3) - farplane(4) < 0 THEN groupinview = 0 ''' Redundant
                    If dx * rightplane(1) + dy * rightplane(2) + dz * rightplane(3) - rightplane(4) < 0 Then GroupInView = 0
                    If dx * leftplane(1) + dy * leftplane(2) + dz * leftplane(3) - leftplane(4) < 0 Then GroupInView = 0
                    If dx * topplane(1) + dy * topplane(2) + dz * topplane(3) - topplane(4) < 0 Then GroupInView = 0
                    If dx * bottomplane(1) + dy * bottomplane(2) + dz * bottomplane(3) - bottomplane(4) < 0 Then GroupInView = 0
                    If (GroupInView = 1) Then
                        Group(g).Visible = 1
                        If (dist2 < closestdist2) Then
                            closestdist2 = dist2
                            ClosestGroup = g
                        End If
                        Group(g).Distance2 = dist2
                        If (ToggleAnimate = 1) And (Group(g).FrameLength = 0) Then Call EvolveVectors(g)
 
                        '''
                        If k = SunClusterAddress Or k = MoonClusterAddress Then
                            If PlayerCamera.Position.z < -40 Then
                                Call ProjectGroup(g, Group(g).FirstVector, Group(g).LastVector, 1)
                            Else
                                Call ProjectGroup(g, Group(g).FirstVector, Group(g).LastVector, 0)
                            End If
                        Else
                            If Group(g).FrameLength <> 0 And Group(g).ActiveFrame <> 0 Then
                                Call ProjectGroup(g, Group(g).FirstVector + Group(g).ActiveFrame * Group(g).FrameLength, Group(g).FirstVector + Group(g).ActiveFrame * Group(g).FrameLength + Group(g).FrameLength, 1)
                            Else
                                Call ProjectGroup(g, Group(g).FirstVector, Group(g).LastVector, 1)
                            End If
                        End If
                        '''
 
                    End If
                End If
                If (g = Cluster(k).LastGroup) Then Exit Do
                g = Group(g).Pointer
            Loop
        End If
 
        k = Cluster(k).Pointer
        If (k = -999) Then Exit Do
    Loop
End Sub
 
Sub CalculateScreenVectors
    Dim As Double mag
    mag = 1 / Sqr(uhat(1) * uhat(1) + uhat(2) * uhat(2) + uhat(3) * uhat(3))
    uhat(1) = uhat(1) * mag: uhat(2) = uhat(2) * mag: uhat(3) = uhat(3) * mag
    mag = 1 / Sqr(vhat(1) * vhat(1) + vhat(2) * vhat(2) + vhat(3) * vhat(3))
    vhat(1) = vhat(1) * mag: vhat(2) = vhat(2) * mag: vhat(3) = vhat(3) * mag
    nhat(1) = uhat(2) * vhat(3) - uhat(3) * vhat(2)
    nhat(2) = uhat(3) * vhat(1) - uhat(1) * vhat(3)
    nhat(3) = uhat(1) * vhat(2) - uhat(2) * vhat(1)
    Call CalculateClippingPlanes(_Width, _Height)
End Sub
 
Sub CalculateClippingPlanes (TheWidth As Double, TheHeight As Double)
    Dim As Double h2, w2, h2f, w2f, h2w2, mag
    h2 = TheHeight * .5
    w2 = TheWidth * .5
    h2f = h2 * fovd
    w2f = w2 * fovd
    h2w2 = h2 * w2
    nearplane(1) = -nhat(1)
    nearplane(2) = -nhat(2)
    nearplane(3) = -nhat(3)
    farplane(1) = nhat(1)
    farplane(2) = nhat(2)
    farplane(3) = nhat(3)
    rightplane(1) = h2f * uhat(1) - h2w2 * nhat(1)
    rightplane(2) = h2f * uhat(2) - h2w2 * nhat(2)
    rightplane(3) = h2f * uhat(3) - h2w2 * nhat(3)
    mag = 1 / Sqr(rightplane(1) * rightplane(1) + rightplane(2) * rightplane(2) + rightplane(3) * rightplane(3))
    rightplane(1) = rightplane(1) * mag
    rightplane(2) = rightplane(2) * mag
    rightplane(3) = rightplane(3) * mag
    leftplane(1) = -h2f * uhat(1) - h2w2 * nhat(1)
    leftplane(2) = -h2f * uhat(2) - h2w2 * nhat(2)
    leftplane(3) = -h2f * uhat(3) - h2w2 * nhat(3)
    mag = 1 / Sqr(leftplane(1) * leftplane(1) + leftplane(2) * leftplane(2) + leftplane(3) * leftplane(3))
    leftplane(1) = leftplane(1) * mag
    leftplane(2) = leftplane(2) * mag
    leftplane(3) = leftplane(3) * mag
    topplane(1) = w2f * vhat(1) - h2w2 * nhat(1)
    topplane(2) = w2f * vhat(2) - h2w2 * nhat(2)
    topplane(3) = w2f * vhat(3) - h2w2 * nhat(3)
    mag = 1 / Sqr(topplane(1) * topplane(1) + topplane(2) * topplane(2) + topplane(3) * topplane(3))
    topplane(1) = topplane(1) * mag
    topplane(2) = topplane(2) * mag
    topplane(3) = topplane(3) * mag
    bottomplane(1) = -w2f * vhat(1) - h2w2 * nhat(1)
    bottomplane(2) = -w2f * vhat(2) - h2w2 * nhat(2)
    bottomplane(3) = -w2f * vhat(3) - h2w2 * nhat(3)
    mag = 1 / Sqr(bottomplane(1) * bottomplane(1) + bottomplane(2) * bottomplane(2) + bottomplane(3) * bottomplane(3))
    bottomplane(1) = bottomplane(1) * mag
    bottomplane(2) = bottomplane(2) * mag
    bottomplane(3) = bottomplane(3) * mag
End Sub
 
Sub ProjectGroup (TheGroup As Long, LowIndex As Long, HighIndex As Long, GraySwitch As Integer)
    Dim As Vector3 vec(UBound(vec3Dpos))
    Dim As Integer vectorinview
    Dim As Double vec3ddotnhat
    Dim i As Long
    Dim f As Integer
    For i = LowIndex To HighIndex
        vec(i).x = Group(TheGroup).Centroid.x + vec3Dpos(i).x - PlayerCamera.Position.x
        vec(i).y = Group(TheGroup).Centroid.y + vec3Dpos(i).y - PlayerCamera.Position.y
        vec(i).z = Group(TheGroup).Centroid.z + vec3Dpos(i).z - PlayerCamera.Position.z
        f = -1
        vec3Dvis(i) = 0
        vectorinview = 1
        If vec(i).x * nearplane(1) + vec(i).y * nearplane(2) + vec(i).z * nearplane(3) - nearplane(4) < 0 Then vectorinview = 0
        'IF vec(i).x * farplane(1) + vec(i).y * farplane(2) + vec(i).z* farplane(3) - farplane(4) < 0 THEN vectorinview = 0
        If vec(i).x * farplane(1) + vec(i).y * farplane(2) + vec(i).z * farplane(3) - farplane(4) * .85 < 0 Then f = 1
        'IF vec(i).x * rightplane(1) + vec(i).y * rightplane(2) + vec(i).z * rightplane(3) - rightplane(4) < 0 THEN vectorinview = 0
        'IF vec(i).x * leftplane(1) + vec(i).y * leftplane(2) + vec(i).z * leftplane(3) - leftplane(4) < 0 THEN vectorinview = 0
        'IF vec(i).x * topplane(1) + vec(i).y * topplane(2) + vec(i).z * topplane(3) - topplane(4) < 0 THEN vectorinview = 0
        'IF vec(i).x * bottomplane(1) + vec(i).y * bottomplane(2) + vec(i).z* bottomplane(3) - bottomplane(4) < 0 THEN vectorinview = 0
        If (vectorinview = 1) Then
            vec3Dvis(i) = 1
            vec3ddotnhat = vec(i).x * nhat(1) + vec(i).y * nhat(2) + vec(i).z * nhat(3)
            vec2D(i).u = (vec(i).x * uhat(1) + vec(i).y * uhat(2) + vec(i).z * uhat(3)) * fovd / vec3ddotnhat
            vec2D(i).v = (vec(i).x * vhat(1) + vec(i).y * vhat(2) + vec(i).z * vhat(3)) * fovd / vec3ddotnhat
            If ((GraySwitch = 1) And (f = 1)) Then
                vec2Dcolor(i) = Gray
            Else
                vec2Dcolor(i) = vec3Dcolor(i)
            End If
        End If
    Next
End Sub
 
Sub EvolveCluster (TheCluster As Long)
    Dim u As Long
    Dim k As Long
    Dim As Single xx, yy, zz ' Needs to be single otherwise the fish flip flop. wtf?
    Dim As Double x0, y0 ', z0
    Dim As Double dx, dy, dz
    Dim As Double t
    Dim As Double v
    'Dim xx, yy, zz, x0, y0, dx, dy, dz, t, v As Double
    Select Case Cluster(TheCluster).MotionType
        Case 0
            ' Do nothing.
 
        Case -1
            ' Freefall and explode.
            Cluster(TheCluster).Velocity.x = Cluster(TheCluster).Velocity.x + Cluster(TheCluster).Acceleration.x
            Cluster(TheCluster).Velocity.y = Cluster(TheCluster).Velocity.y + Cluster(TheCluster).Acceleration.y
            Cluster(TheCluster).Velocity.z = Cluster(TheCluster).Velocity.z + Cluster(TheCluster).Acceleration.z
            dx = Cluster(TheCluster).Velocity.x
            dy = Cluster(TheCluster).Velocity.y
            dz = Cluster(TheCluster).Velocity.z
            If ((dx <> 0) Or (dy <> 0) Or (dz <> 0)) Then
                Call TranslateCluster(TheCluster, dx, dy, dz)
            End If
            Dim wi As Integer
            Dim wj As Integer
            wi = 1 + Int((Cluster(TheCluster).Centroid.x) / BlockSize + UBound(WorldMesh, 1) / 2)
            wj = 1 + Int((Cluster(TheCluster).Centroid.y) / BlockSize + UBound(WorldMesh, 2) / 2)
            If (Cluster(TheCluster).Centroid.z <= WorldMesh(wi, wj)) Then
                Cluster(TheCluster).Acceleration.x = 0
                Cluster(TheCluster).Acceleration.y = 0
                Cluster(TheCluster).Acceleration.z = 0
                Cluster(TheCluster).Velocity.x = 0
                Cluster(TheCluster).Velocity.y = 0
                Cluster(TheCluster).Velocity.z = 0
                Cluster(TheCluster).MotionType = -9
                Cluster(TheCluster).DeathTimer = Timer + 2
                k = Cluster(TheCluster).FirstGroup
                Do
                    Group(k).Volume.x = BlockSize * 3
                    Group(k).Volume.y = BlockSize * 3
                    Group(k).Volume.z = BlockSize * 3
                    For u = Group(k).FirstVector To Group(k).LastVector
                        vec3Dvel(u).x = (Rnd - .5) * .8
                        vec3Dvel(u).y = (Rnd - .5) * .8
                        vec3Dvel(u).z = (Rnd - 0) * .8
                    Next
                    If (k = Cluster(TheCluster).LastGroup) Then Exit Do
                    k = Group(k).Pointer
                Loop
            End If
 
        Case -2
            ' Freefall and stack.
            Cluster(TheCluster).Velocity.x = Cluster(TheCluster).Velocity.x + Cluster(TheCluster).Acceleration.x
            Cluster(TheCluster).Velocity.y = Cluster(TheCluster).Velocity.y + Cluster(TheCluster).Acceleration.y
            Cluster(TheCluster).Velocity.z = Cluster(TheCluster).Velocity.z + Cluster(TheCluster).Acceleration.z
            dx = Cluster(TheCluster).Velocity.x
            dy = Cluster(TheCluster).Velocity.y
            dz = Cluster(TheCluster).Velocity.z
            If ((dx <> 0) Or (dy <> 0) Or (dz <> 0)) Then
                Call TranslateCluster(TheCluster, dx, dy, dz)
            End If
            wi = 1 + Int((Cluster(TheCluster).Centroid.x) / BlockSize + UBound(WorldMesh, 1) / 2)
            wj = 1 + Int((Cluster(TheCluster).Centroid.y) / BlockSize + UBound(WorldMesh, 2) / 2)
            If (Cluster(TheCluster).Centroid.z <= WorldMesh(wi, wj)) Then
                Cluster(TheCluster).Acceleration.x = 0
                Cluster(TheCluster).Acceleration.y = 0
                Cluster(TheCluster).Acceleration.z = 0
                Cluster(TheCluster).Velocity.x = 0
                Cluster(TheCluster).Velocity.y = 0
                Cluster(TheCluster).Velocity.z = 0
                Cluster(TheCluster).MotionType = 0
                WorldMesh(wi, wj) = WorldMesh(wi, wj) + BlockSize / 3
            End If
 
        Case -9
            If (Timer >= Cluster(TheCluster).DeathTimer) Then
                Call RemoveCluster(TheCluster)
            End If
 
        Case Else
            ' Fixed path.
            ' Note: This chunk of code is subject to the midnight bug.
            t = Timer
            u = Int(t)
            v = t - u
            xx = v * FixedPath(Cluster(TheCluster).MotionType, u).x + (1 - v) * FixedPath(Cluster(TheCluster).MotionType, u - 1).x
            yy = v * FixedPath(Cluster(TheCluster).MotionType, u).y + (1 - v) * FixedPath(Cluster(TheCluster).MotionType, u - 1).y
            zz = v * FixedPath(Cluster(TheCluster).MotionType, u).z + (1 - v) * FixedPath(Cluster(TheCluster).MotionType, u - 1).z
 
            ' Choose frame based on derived velocity vector.
            If (Cluster(TheCluster).Framed = 1) Then
                k = Cluster(TheCluster).FirstGroup
                Do
                    If (Group(k).FrameLength <> 0) Then
                        x0 = Group(k).Centroid.x
                        y0 = Group(k).Centroid.y
                        'z0 = Group(k).Centroid.z
                        dx = xx - x0
                        dy = yy - y0
                        'dz = zz - z0
                        If ((dx > 0) And (dy > 0)) Then Group(k).ActiveFrame = 1 + Int(((48 / (2 * pi)) * (Atn(dy / dx))))
                        If ((dx < 0) And (dy > 0)) Then Group(k).ActiveFrame = 1 + 24 + Int(((48 / (2 * pi)) * (Atn(dy / dx))))
                        If ((dx < 0) And (dy < 0)) Then Group(k).ActiveFrame = 1 + 24 + Int(((48 / (2 * pi)) * (Atn(dy / dx))))
                        If ((dx > 0) And (dy < 0)) Then Group(k).ActiveFrame = 1 + 48 + Int(((48 / (2 * pi)) * (Atn(dy / dx))))
                    End If
                    If (k = Cluster(TheCluster).LastGroup) Then Exit Do
                    k = Group(k).Pointer
                Loop
            End If
 
            Call PlaceCluster(TheCluster, xx, yy, zz)
 
    End Select
End Sub
 
Sub PlaceCluster (TheCluster As Long, xc As Double, yc As Double, zc As Double)
    Dim As Long g
    Dim As Double x0, y0, z0
    x0 = Cluster(TheCluster).Centroid.x
    y0 = Cluster(TheCluster).Centroid.y
    z0 = Cluster(TheCluster).Centroid.z
    Cluster(TheCluster).Centroid.x = xc
    Cluster(TheCluster).Centroid.y = yc
    Cluster(TheCluster).Centroid.z = zc
    g = Cluster(TheCluster).FirstGroup
    Do
        Group(g).Centroid.x = Group(g).Centroid.x + xc - x0
        Group(g).Centroid.y = Group(g).Centroid.y + yc - y0
        Group(g).Centroid.z = Group(g).Centroid.z + zc - z0
        If (g = Cluster(TheCluster).LastGroup) Then Exit Do
        g = Group(g).Pointer
    Loop
End Sub
 
Sub TranslateCluster (TheCluster As Long, dx As Double, dy As Double, dz As Double)
    Dim As Long g
    g = Cluster(TheCluster).FirstGroup
    Do
        Group(g).Centroid.x = Group(g).Centroid.x + dx
        Group(g).Centroid.y = Group(g).Centroid.y + dy
        Group(g).Centroid.z = Group(g).Centroid.z + dz
        If (g = Cluster(TheCluster).LastGroup) Then Exit Do
        g = Group(g).Pointer
    Loop
    Cluster(TheCluster).Centroid.x = Cluster(TheCluster).Centroid.x + dx
    Cluster(TheCluster).Centroid.y = Cluster(TheCluster).Centroid.y + dy
    Cluster(TheCluster).Centroid.z = Cluster(TheCluster).Centroid.z + dz
End Sub
 
Sub EvolveVectors (TheGroup As Long)
    Dim As Long g
    Dim As Double xdim, ydim, zdim
    Dim As Double dx, dy, dz
    Dim As Double px, py, pz
 
    xdim = Group(TheGroup).Volume.x
    ydim = Group(TheGroup).Volume.y
    zdim = Group(TheGroup).Volume.z
 
    For g = Group(TheGroup).FirstVector To Group(TheGroup).LastVector
 
        ' Position update with periodic boundaries inside group volume.
        dx = vec3Dvel(g).x
        dy = vec3Dvel(g).y
        dz = vec3Dvel(g).z
        If (dx <> 0) Then
            px = vec3Dpos(g).x + dx
            If Abs(px) > xdim / 2 Then
                If (px > xdim / 2) Then
                    px = -xdim / 2
                Else
                    px = xdim / 2
                End If
            End If
            vec3Dpos(g).x = px
        End If
        If (dy <> 0) Then
            py = vec3Dpos(g).y + dy
            If Abs(py) > ydim / 2 Then
                If (py > ydim / 2) Then
                    py = -ydim / 2
                Else
                    py = ydim / 2
                End If
            End If
            vec3Dpos(g).y = py
        End If
        If (dz <> 0) Then
            pz = vec3Dpos(g).z + dz
            If Abs(pz) > zdim / 2 Then
                If (pz > zdim / 2) Then
                    pz = -zdim / 2
                Else
                    pz = zdim / 2
                End If
            End If
            vec3Dpos(g).z = pz
        End If
    Next
End Sub
 
Sub SetParticleVelocity (TheGroup As Long, vx As Double, vy As Double, vz As Double)
    Dim As Long j, m, n
    m = Group(TheGroup).FirstVector
    n = Group(TheGroup).LastVector
    For j = m To n
        vec3Dvel(j).x = vx
        vec3Dvel(j).y = vy
        vec3Dvel(j).z = vz
    Next
End Sub
 
' Sorting
 
Sub QuickSort (LowLimit As Long, HighLimit As Long)
    Dim As Long piv
    If (LowLimit < HighLimit) Then
        piv = Partition(LowLimit, HighLimit)
        Call QuickSort(LowLimit, piv - 1)
        Call QuickSort(piv + 1, HighLimit)
    End If
End Sub
 
Function Partition (LowLimit As Long, HighLimit As Long)
    Dim As Long i, j
    Dim As Double pivot, tmp
    pivot = Group(SortedGroups(HighLimit)).Distance2
    i = LowLimit - 1
 
    For j = LowLimit To HighLimit - 1
        tmp = Group(SortedGroups(j)).Distance2 - pivot
        If (tmp >= 0) Then
            i = i + 1
            Swap SortedGroups(i), SortedGroups(j)
        End If
    Next
    Swap SortedGroups(i + 1), SortedGroups(HighLimit)
    Partition = i + 1
End Function
 
'Sub BubbleSort
'    ' Antiquated but works fine.
'    Dim As Integer i, j
'    Dim As Double u, v
'    For j = SortedGroupsCount To 1 Step -1
'        For i = 2 To SortedGroupsCount
'            u = Group(SortedGroups(i - 1)).Distance2
'            v = Group(SortedGroups(i)).Distance2
'            If (u < v) Then
'                Swap SortedGroups(i - 1), SortedGroups(i)
'            End If
'        Next
'    Next
'End Sub
 
' Graphics
 
Sub PlotWorld
    Dim As Long g, k, p
    Dim j As Integer
    Dim lowlim, highlim As Long
    Dim x1 As Double
    Dim y1 As Double
    Dim x2 As Double
    Dim y2 As Double
    Dim clrtmp As _Unsigned Long
    Dim ThePlotMode As Integer
 
    NumClusterVisible = 0
    NumVectorVisible = 0
 
    SortedGroupsCount = 0
    k = 1
    Do
        If (Cluster(k).Visible = 1) Then
            NumClusterVisible = NumClusterVisible + 1
            g = Cluster(k).FirstGroup
            Do
                If (Group(g).Visible = 1) Then
                    SortedGroupsCount = SortedGroupsCount + 1
                    SortedGroups(SortedGroupsCount) = g
                End If
                If (g = Cluster(k).LastGroup) Then Exit Do
                g = Group(g).Pointer
            Loop
        End If
        k = Cluster(k).Pointer
        If (k = -999) Then Exit Do
    Loop
    NumGroupVisible = SortedGroupsCount
 
    Call QuickSort(1, SortedGroupsCount)
    'Call BubbleSort
 
    PlayerCamera.Shade = ShadeMix~&(PlayerCamera.Shade, _RGB32(_Red32(vec3Dcolor(Group(ClosestGroup).FirstVector)), _Green32(vec3Dcolor(Group(ClosestGroup).FirstVector)), _Blue32(vec3Dcolor(Group(ClosestGroup).FirstVector)), 200), .01)
    PlayerCamera.Shade = ShadeMix~&(PlayerCamera.Shade, _RGB32(0, 0, 0, 255), .01)
    Cls
    Line (0, 0)-(_Width, _Height), PlayerCamera.Shade, BF
 
    For j = 1 To SortedGroupsCount
        g = SortedGroups(j)
        ThePlotMode = Group(g).PlotMode
 
        If (ThePlotMode = -1) Then ' Wire cube
            Dim x3 As Double
            Dim y3 As Double
            Dim x4 As Double
            Dim y4 As Double
            p = Group(g).FirstVector
            clrtmp = vec2Dcolor(p)
            x1 = vec2D(p).u: y1 = vec2D(p).v: x2 = vec2D(p + 1).u: y2 = vec2D(p + 1).v: x3 = vec2D(p + 2).u: y3 = vec2D(p + 2).v: x4 = vec2D(p + 4).u: y4 = vec2D(p + 4).v
            Call CLine(x1, y1, x2, y2, clrtmp)
            Call CLine(x1, y1, x3, y3, clrtmp)
            Call CLine(x1, y1, x4, y4, clrtmp)
            x1 = vec2D(p + 3).u: y1 = vec2D(p + 3).v: x2 = vec2D(p + 1).u: y2 = vec2D(p + 1).v: x3 = vec2D(p + 2).u: y3 = vec2D(p + 2).v: x4 = vec2D(p + 7).u: y4 = vec2D(p + 7).v
            Call CLine(x1, y1, x2, y2, clrtmp)
            Call CLine(x1, y1, x3, y3, clrtmp)
            Call CLine(x1, y1, x4, y4, clrtmp)
            x1 = vec2D(p + 5).u: y1 = vec2D(p + 5).v: x2 = vec2D(p + 4).u: y2 = vec2D(p + 4).v: x3 = vec2D(p + 7).u: y3 = vec2D(p + 7).v: x4 = vec2D(p + 1).u: y4 = vec2D(p + 1).v
            Call CLine(x1, y1, x2, y2, clrtmp)
            Call CLine(x1, y1, x3, y3, clrtmp)
            Call CLine(x1, y1, x4, y4, clrtmp)
            x1 = vec2D(p + 6).u: y1 = vec2D(p + 6).v: x2 = vec2D(p + 4).u: y2 = vec2D(p + 4).v: x3 = vec2D(p + 7).u: y3 = vec2D(p + 7).v: x4 = vec2D(p + 2).u: y4 = vec2D(p + 2).v
            Call CLine(x1, y1, x2, y2, clrtmp)
            Call CLine(x1, y1, x3, y3, clrtmp)
            Call CLine(x1, y1, x4, y4, clrtmp)
        End If
 
        If Group(g).ActiveFrame = 0 Then
            lowlim = Group(g).FirstVector
            highlim = Group(g).LastVector - 1
        Else
            lowlim = Group(g).FirstVector + Group(g).FrameLength * (Group(g).ActiveFrame)
            highlim = Group(g).FirstVector + Group(g).FrameLength * (Group(g).ActiveFrame + 1) - 2
        End If
 
        For p = lowlim To highlim
            If (vec3Dvis(p) = 1) Then
                NumVectorVisible = NumVectorVisible + 1
                If (g = ClosestGroup) Then
                    clrtmp = Yellow
                Else
                    clrtmp = vec2Dcolor(p)
                End If
                Select Case ThePlotMode
                    Case 0
                        x1 = vec2D(p).u
                        y1 = vec2D(p).v
                        Call BlockPoint(x1, y1, clrtmp)
                    Case 1
                        x1 = vec2D(p).u
                        y1 = vec2D(p).v
                        x2 = vec2D(p + 1).u
                        y2 = vec2D(p + 1).v
                        If (((x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1)) < 225) Then
                            'Call cline(x1, y1, x2, y2, clrtmp)
                            Call LineSmooth(x1, y1, x2, y2, clrtmp)
                        Else
                            Call CCircle(x1, y1, 1, clrtmp)
                            '''
                            'If p = highlim Then Call CCircle(x2, y2, 1, clrtmp)
                            '''
                        End If
                    Case 2
                        x1 = vec2D(p).u
                        y1 = vec2D(p).v
                        Call CCircle(x1, y1, 1, clrtmp)
                End Select
            End If
        Next
    Next
 
End Sub
 
Sub DisplayHUD
    Dim a As String
    Call LineSmooth(0, 0, 25 * (xhat(1) * uhat(1) + xhat(2) * uhat(2) + xhat(3) * uhat(3)), 25 * (xhat(1) * vhat(1) + xhat(2) * vhat(2) + xhat(3) * vhat(3)), _RGB32(255, 0, 0, 150))
    Call LineSmooth(0, 0, 25 * (yhat(1) * uhat(1) + yhat(2) * uhat(2) + yhat(3) * uhat(3)), 25 * (yhat(1) * vhat(1) + yhat(2) * vhat(2) + yhat(3) * vhat(3)), _RGB32(0, 255, 0, 150))
    Call LineSmooth(0, 0, 25 * (zhat(1) * uhat(1) + zhat(2) * uhat(2) + zhat(3) * uhat(3)), 25 * (zhat(1) * vhat(1) + zhat(2) * vhat(2) + zhat(3) * vhat(3)), _RGB32(30, 144, 255, 150))
    Call TextCenter(" Closest ", (1) * 16, LimeGreen)
    a = " " + Group(ClosestGroup).Label + " "
    Color DarkKhaki
    _PrintString (_Width / 2 - (Len(a) / 2) * 8, 2 * 16), a
    Color LimeGreen
    _PrintString ((1) * 8, _Height - (4) * 16), "   Movement   "
    Color DarkKhaki
    _PrintString ((1) * 8, _Height - (3) * 16), "  W  &/or  " + Chr$(30) + "  "
    _PrintString ((1) * 8, _Height - (2) * 16), "A S D    " + Chr$(17) + " " + Chr$(31) + " " + Chr$(16)
    Color LimeGreen
    _PrintString (_Width - (13) * 8, _Height - (4) * 16), "Orientation "
    Color DarkKhaki
    _PrintString (_Width - (13) * 8, _Height - (3) * 16), " Keypad 1-9 "
    If ((nhat(3) <> 0) Or (uhat(3) <> 0)) Then Color Red Else Color Gray
    _PrintString (_Width - (13) * 8, _Height - (2) * 16), "  5=Level   "
    Color LimeGreen
    _PrintString ((1) * 8, (1) * 16), "- Report -"
    Color DarkKhaki
    _PrintString ((1) * 8, (2) * 16), "FPS: " + LTrim$(RTrim$(Str$(FPSReport))) + "/" + LTrim$(RTrim$(Str$(FPSTarget)))
    _PrintString ((1) * 8, (3) * 16), "Particles: " + LTrim$(RTrim$(Str$(NumVectorVisible)))
    '_PrintString ((1) * 8, (5) * 16), "Clusters: " + LTrim$(RTrim$(Str$(NumClusterVisible)))
    '_PrintString ((1) * 8, (4) * 16), "Groups: " + LTrim$(RTrim$(Str$(NumGroupVisible)))
    Color LimeGreen
    _PrintString ((1) * 8, (10) * 16), "Abilities"
    Color DarkKhaki
    _PrintString ((1) * 8, (11) * 16), "F = throw"
    _PrintString ((1) * 8, (12) * 16), "B = build"
    _PrintString ((1) * 8, (13) * 16), "N = scramble"
    _PrintString ((1) * 8, (14) * 16), "K = delete"
    _PrintString ((1) * 8, (15) * 16), "Z = zoom"
    Color LimeGreen
    Call TextCenter(" SPACE = Ascend ", _Height - (2) * 16, LimeGreen)
End Sub
 
Sub TextCenter (TheText As String, TheHeight As Integer, TheShade As _Unsigned Long)
    Color TheShade
    _PrintString (_Width / 2 - (Len(TheText) / 2) * 8, TheHeight), TheText
End Sub
 
Sub DisplayMiniMap
    Dim As Integer i, j, wi, wj
    Dim As Double dx, dy, u, v
    Dim As String a
    Dim As _Unsigned Long Shade
    wi = 1 + Int((PlayerCamera.Position.x) / BlockSize + UBound(WorldMesh, 1) / 2)
    wj = 1 + Int((PlayerCamera.Position.y) / BlockSize + UBound(WorldMesh, 2) / 2)
    u = _Width / 2 - UBound(WorldMesh, 1)
    v = _Height / 2 - UBound(WorldMesh, 2)
    For i = 1 To UBound(WorldMesh, 1)
        For j = 1 To UBound(WorldMesh, 2)
            Shade = TerrainHeightShade~&(WorldMesh(i, j))
            Call CPset(i + u, j + v, _RGB32(_Red32(Shade), _Green32(Shade), _Blue32(Shade), 150))
        Next
    Next
    Call CCircle(wi + u, wj + v, 2, Red)
    Call LineSmooth(wi + u, wj + v, wi + u - 5 * nhat(1) * Sqr((fovd / -192)), wj + v - 5 * nhat(2) * Sqr((fovd / -192)), White)
    Color DarkKhaki, PlayerCamera.Shade
    _PrintString (_Width - UBound(WorldMesh, 1), UBound(WorldMesh, 2)), "x:" + LTrim$(RTrim$(Str$(Int(PlayerCamera.Position.x)))) + " " + "y:" + LTrim$(RTrim$(Str$(Int(PlayerCamera.Position.y)))) + " " + "z:" + LTrim$(RTrim$(Str$(Int(PlayerCamera.Position.z))))
    dx = -nhat(1)
    dy = -nhat(2)
    If ((dx > 0) And (dy > 0)) Then a = LTrim$(RTrim$(Str$(1 + Int(((180 / pi) * (Atn(dy / dx))))))) + Chr$(248)
    If ((dx < 0) And (dy > 0)) Then a = LTrim$(RTrim$(Str$(1 + 180 + Int(((180 / pi) * (Atn(dy / dx))))))) + Chr$(248)
    If ((dx < 0) And (dy < 0)) Then a = LTrim$(RTrim$(Str$(1 + 180 + Int(((180 / pi) * (Atn(dy / dx))))))) + Chr$(248)
    If ((dx > 0) And (dy < 0)) Then a = LTrim$(RTrim$(Str$(1 + 360 + Int(((180 / pi) * (Atn(dy / dx))))))) + Chr$(248)
    _PrintString (_Width - Len(a) * 8, UBound(WorldMesh, 2) - 16), a
End Sub
 
' Interface
 
Sub KeyDownProcess
    Dim As Double modifier
    modifier = 0.05
 
    If (_KeyDown(32) <> 0) Then ' Space
        PlayerCamera.Velocity.z = 5
        PlayerCamera.Acceleration.z = -.5
    End If
    If ((_KeyDown(87) <> 0) Or (_KeyDown(119) <> 0) Or (_KeyDown(18432) <> 0)) Then ' W or w or upparrow
        Call StrafeCameraNhat(-1, -1, 0)
        If ((nhat(3) <> 0) Or (uhat(3) <> 0)) Then Call RegulateCamera
        If (ToggleAnimate = 1) Then
            PlayerCamera.Velocity.x = PlayerCamera.Velocity.x - modifier * nhat(1)
            PlayerCamera.Velocity.y = PlayerCamera.Velocity.y - modifier * nhat(2)
            'PlayerCamera.Velocity.z = PlayerCamera.Velocity.z - modifier * nhat(3)
        End If
    End If
    If ((_KeyDown(83) <> 0) Or (_KeyDown(115) <> 0) Or (_KeyDown(20480) <> 0)) Then ' S or s or downarrow
        Call StrafeCameraNhat(1, 1, 0)
        If ((nhat(3) <> 0) Or (uhat(3) <> 0)) Then Call RegulateCamera
        If (ToggleAnimate = 1) Then
            PlayerCamera.Velocity.x = PlayerCamera.Velocity.x + modifier * nhat(1)
            PlayerCamera.Velocity.y = PlayerCamera.Velocity.y + modifier * nhat(2)
            'PlayerCamera.Velocity.z = PlayerCamera.Velocity.z + modifier * nhat(3)
        End If
    End If
    If ((_KeyDown(65) <> 0) Or (_KeyDown(97) <> 0)) Then ' A or a
        If ((nhat(3) <> 0) Or (uhat(3) <> 0)) Then Call RegulateCamera
        Call StrafeCameraUhat(-1, -1, -1)
        If (ToggleAnimate = 1) Then
            PlayerCamera.Velocity.x = PlayerCamera.Velocity.x - modifier * uhat(1)
            PlayerCamera.Velocity.y = PlayerCamera.Velocity.y - modifier * uhat(2)
            'PlayerCamera.Velocity.z = PlayerCamera.Velocity.z - modifier * uhat(3)
        End If
    End If
    If ((_KeyDown(68) <> 0) Or (_KeyDown(100) <> 0)) Then ' D or d
        If ((nhat(3) <> 0) Or (uhat(3) <> 0)) Then Call RegulateCamera
        Call StrafeCameraUhat(1, 1, 1)
        If (ToggleAnimate = 1) Then
            PlayerCamera.Velocity.x = PlayerCamera.Velocity.x + modifier * uhat(1)
            PlayerCamera.Velocity.y = PlayerCamera.Velocity.y + modifier * uhat(2)
            'PlayerCamera.Velocity.z = PlayerCamera.Velocity.z + modifier * uhat(3)
        End If
    End If
    'If ((_KeyDown(81) <> 0) Or (_KeyDown(113) <> 0)) Then ' Q or q
    '    Call StrafeCameraVhat(1, 1, 1)
    '    If (ToggleAnimate = 1) Then
    '        PlayerCamera.Velocity.x = PlayerCamera.Velocity.x - modifier * vhat(1)
    '        PlayerCamera.Velocity.y = PlayerCamera.Velocity.y - modifier * vhat(2)
    '        PlayerCamera.Velocity.z = PlayerCamera.Velocity.z - modifier * vhat(3)
    '    End If
    'End If
    'If ((_KeyDown(69) <> 0) Or (_KeyDown(101) <> 0)) Then ' E or e
    '    Call StrafeCameraVhat(-1, -1, -1)
    '    If (ToggleAnimate = 1) Then
    '        PlayerCamera.Velocity.x = PlayerCamera.Velocity.x + modifier * vhat(1)
    '        PlayerCamera.Velocity.y = PlayerCamera.Velocity.y + modifier * vhat(2)
    '        PlayerCamera.Velocity.z = PlayerCamera.Velocity.z + modifier * vhat(3)
    '    End If
    'End If
    If ((_KeyDown(90) <> 0) Or (_KeyDown(122) <> 0)) Then ' Z or z.
        fovd = fovd - 5
        If (fovd < -600) Then
            fovd = -600
        Else
            farplane(4) = farplane(4) - 5
        End If
        Call CalculateClippingPlanes(.5 * _Width, .5 * _Height)
    End If
 
    modifier = 0.0333
    If (_KeyDown(19200) <> 0) Or (_KeyDown(52) <> 0) Then Call RotateUhat(-modifier, -modifier, -modifier): Call CalculateScreenVectors ' 4
    If (_KeyDown(19712) <> 0) Or (_KeyDown(54) <> 0) Then Call RotateUhat(modifier, modifier, modifier): Call CalculateScreenVectors ' 6
    If (_KeyDown(56) <> 0) Then Call RotateVhat(modifier, modifier, modifier): Call CalculateScreenVectors ' 8
    If (_KeyDown(50) <> 0) Then Call RotateVhat(-modifier, -modifier, -modifier): Call CalculateScreenVectors ' 2
    If (_KeyDown(55) <> 0) Then Call RotateUV(-modifier, -modifier, -modifier) ' 7
    If (_KeyDown(57) <> 0) Then Call RotateUV(modifier, modifier, modifier) ' 9
    If (_KeyDown(49) <> 0) Then Call RotateUhat(-modifier, -modifier, -modifier): Call CalculateScreenVectors: Call RotateUV(-modifier, -modifier, -modifier) ' 1
    If (_KeyDown(51) <> 0) Then Call RotateUhat(modifier, modifier, modifier): Call CalculateScreenVectors: Call RotateUV(modifier, modifier, modifier) ' 3
 
    'modifier = 0.0222
    'Do While _MouseInput
    '    If (_MouseMovementX > 0) Then Call RotateUhat(modifier, modifier, modifier): Call CalculateScreenVectors
    '    If (_MouseMovementX < 0) Then Call RotateUhat(-modifier, -modifier, -modifier): Call CalculateScreenVectors
    '    If (_MouseMovementY > 0) Then Call RotateVhat(modifier, modifier, modifier): Call CalculateScreenVectors
    '    If (_MouseMovementY < 0) Then Call RotateVhat(-modifier, -modifier, -modifier): Call CalculateScreenVectors
    'Loop
End Sub
 
Sub KeyHitProcess
    Dim As Long g, p
    Dim As Double x0, y0, z0
    Dim As Integer kh
    kh = _KeyHit
    If (kh <> 0) Then
        Select Case kh
            Case 27 ' Quit
                System
 
            Case 53 ' 5
                Call RegulateCamera
 
            Case Asc("b"), Asc("B")
                x0 = (PlayerCamera.Position.x - 40 * nhat(1))
                y0 = (PlayerCamera.Position.y - 40 * nhat(2))
                z0 = (PlayerCamera.Position.z - 40 * nhat(3))
                x0 = x0 - x0 Mod BlockSize / 3
                y0 = y0 - y0 Mod BlockSize / 3
                z0 = z0 - z0 Mod BlockSize / 3
                g = LatestGroupIdentity&(1)
                g = NewCube&(g, "Custom block", 100, x0, y0, z0, BlockSize / 3, BlockSize / 3, BlockSize / 3, Lime, Purple, Teal, -2, 0)
                g = NewWireCube&(g, "Custom block", x0, y0, z0, BlockSize / 3, BlockSize / 3, BlockSize / 3, Lime, -2)
                Cluster(ClusterIdTicker).Acceleration.x = 0
                Cluster(ClusterIdTicker).Acceleration.y = 0
                Cluster(ClusterIdTicker).Acceleration.z = -.15
                Call ClusterPinch(g)
 
            Case Asc("f"), Asc("F")
                x0 = (PlayerCamera.Position.x - 40 * nhat(1))
                y0 = (PlayerCamera.Position.y - 40 * nhat(2))
                z0 = (PlayerCamera.Position.z - 40 * nhat(3))
                g = LatestGroupIdentity&(1)
                g = NewCube&(g, "Potion", 150, x0, y0, z0, 10, 10, 10, Red, Purple, Teal, -1, 0)
                g = NewCube&(g, "Potion", 50, x0, y0, z0 + 10, 2, 2, 10, Blue, Purple, Teal, -1, 0)
                Cluster(ClusterIdTicker).Acceleration.x = 0
                Cluster(ClusterIdTicker).Acceleration.y = 0
                Cluster(ClusterIdTicker).Acceleration.z = -.15
                Cluster(ClusterIdTicker).Velocity.x = -5 * nhat(1)
                Cluster(ClusterIdTicker).Velocity.y = -5 * nhat(2)
                Cluster(ClusterIdTicker).Velocity.z = -5 * nhat(3)
                Call ClusterPinch(g)
 
            Case Asc("n"), Asc("N")
                For p = Group(ClosestGroup).FirstVector To Group(ClosestGroup).LastVector
                    vec3Dvel(p).x = (Rnd - .5) * .20
                    vec3Dvel(p).y = (Rnd - .5) * .20
                    vec3Dvel(p).z = (Rnd - .5) * .20
                Next
 
            Case Asc("k"), Asc("K")
                Call RemoveGroup(ClosestGroup)
 
            Case Asc("t"), Asc("T")
                ToggleAnimate = -ToggleAnimate
        End Select
    End If
    _KeyClear
End Sub
 
' Plotting and color tools.
 
Sub CLine (x0 As Double, y0 As Double, x1 As Double, y1 As Double, shade As _Unsigned Long)
    Line (_Width / 2 + x0, -y0 + _Height / 2)-(_Width / 2 + x1, -y1 + _Height / 2), shade
End Sub
 
Sub CPset (x0, y0, shade As _Unsigned Long)
    PSet (_Width / 2 + x0, -y0 + _Height / 2), shade
End Sub
 
Sub CCircle (x0 As Double, y0 As Double, rad As Double, shade As _Unsigned Long)
    Circle (_Width / 2 + x0, -y0 + _Height / 2), rad, shade
End Sub
 
Sub BlockPoint (x0 As Double, y0 As Double, shade As _Unsigned Long)
    Line (_Width / 2 + x0 - 3, -y0 + _Height / 2 - 3)-(_Width / 2 + x0 + 3, -y0 + _Height / 2 + 3), _RGB32(_Red32(shade), _Green32(shade), _Blue32(shade), 200), BF
End Sub
 
Function ShadeMix~& (shade0 As _Unsigned Long, shade1 As _Unsigned Long, weight As Double)
    ShadeMix~& = _RGB32((1 - weight) * _Red32(shade0) + weight * _Red32(shade1), (1 - weight) * _Green32(shade0) + weight * _Green32(shade1), (1 - weight) * _Blue32(shade0) + weight * _Blue32(shade1))
End Function
 
Sub LineSmooth (x0, y0, x1, y1, c As _Unsigned Long)
    ' source: https://en.wikipedia.org/w/index.php?title=Xiaolin_Wu%27s_line_algorithm&oldid=852445548
    ' translated: FellippeHeitor @ qb64.org
    ' updated slightly for this project
 
    Dim plX As Integer, plY As Integer, plI
 
    Dim steep As _Byte
    steep = Abs(y1 - y0) > Abs(x1 - x0)
 
    If steep Then
        Swap x0, y0
        Swap x1, y1
    End If
 
    If x0 > x1 Then
        Swap x0, x1
        Swap y0, y1
    End If
 
    Dim dx, dy, gradient
    dx = x1 - x0
    dy = y1 - y0
    gradient = dy / dx
 
    If dx = 0 Then
        gradient = 1
    End If
 
    'handle first endpoint
    Dim xend, yend, xgap, xpxl1, ypxl1
    xend = _Round(x0)
    yend = y0 + gradient * (xend - x0)
    xgap = (1 - ((x0 + .5) - Int(x0 + .5)))
    xpxl1 = xend 'this will be used in the main loop
    ypxl1 = Int(yend)
    If steep Then
        plX = ypxl1
        plY = xpxl1
        plI = (1 - (yend - Int(yend))) * xgap
        GoSub plot
 
        plX = ypxl1 + 1
        plY = xpxl1
        plI = (yend - Int(yend)) * xgap
        GoSub plot
    Else
        plX = xpxl1
        plY = ypxl1
        plI = (1 - (yend - Int(yend))) * xgap
        GoSub plot
 
        plX = xpxl1
        plY = ypxl1 + 1
        plI = (yend - Int(yend)) * xgap
        GoSub plot
    End If
 
    Dim intery
    intery = yend + gradient 'first y-intersection for the main loop
 
    'handle second endpoint
    Dim xpxl2, ypxl2
    xend = _Round(x1)
    yend = y1 + gradient * (xend - x1)
    xgap = ((x1 + .5) - Int(x1 + .5))
    xpxl2 = xend 'this will be used in the main loop
    ypxl2 = Int(yend)
    If steep Then
        plX = ypxl2
        plY = xpxl2
        plI = (1 - (yend - Int(yend))) * xgap
        GoSub plot
 
        plX = ypxl2 + 1
        plY = xpxl2
        plI = (yend - Int(yend)) * xgap
        GoSub plot
    Else
        plX = xpxl2
        plY = ypxl2
        plI = (1 - (yend - Int(yend))) * xgap
        GoSub plot
 
        plX = xpxl2
        plY = ypxl2 + 1
        plI = (yend - Int(yend)) * xgap
        GoSub plot
    End If
 
    'main loop
    Dim x
    If steep Then
        For x = xpxl1 + 1 To xpxl2 - 1
            plX = Int(intery)
            plY = x
            plI = (1 - (intery - Int(intery)))
            GoSub plot
 
            plX = Int(intery) + 1
            plY = x
            plI = (intery - Int(intery))
            GoSub plot
 
            intery = intery + gradient
        Next
    Else
        For x = xpxl1 + 1 To xpxl2 - 1
            plX = x
            plY = Int(intery)
            plI = (1 - (intery - Int(intery)))
            GoSub plot
 
            plX = x
            plY = Int(intery) + 1
            plI = (intery - Int(intery))
            GoSub plot
 
            intery = intery + gradient
        Next
    End If
 
    Exit Sub
 
    plot:
    ' Change to regular PSET for standard coordinate orientation.
    Call CPset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
    Return
End Sub
 
' Camera transformation
 
Sub RotateUhat (dx As Double, dy As Double, dz As Double)
    uhat(1) = uhat(1) + nhat(1) * dx
    uhat(2) = uhat(2) + nhat(2) * dy
    uhat(3) = uhat(3) + nhat(3) * dz
End Sub
 
Sub RotateVhat (dx As Double, dy As Double, dz As Double)
    vhat(1) = vhat(1) + nhat(1) * dx
    vhat(2) = vhat(2) + nhat(2) * dy
    vhat(3) = vhat(3) + nhat(3) * dz
End Sub
 
Sub RotateUV (dx As Double, dy As Double, dz As Double)
    Dim As Double v1, v2, v3
    v1 = vhat(1)
    v2 = vhat(2)
    v3 = vhat(3)
    vhat(1) = v1 + uhat(1) * dx
    vhat(2) = v2 + uhat(2) * dy
    vhat(3) = v3 + uhat(3) * dz
    uhat(1) = uhat(1) - v1 * dx
    uhat(2) = uhat(2) - v2 * dy
    uhat(3) = uhat(3) - v3 * dz
End Sub
 
Sub StrafeCameraUhat (dx As Double, dy As Double, dz As Double)
    PlayerCamera.Position.x = PlayerCamera.Position.x + uhat(1) * dx
    PlayerCamera.Position.y = PlayerCamera.Position.y + uhat(2) * dy
    PlayerCamera.Position.z = PlayerCamera.Position.z + uhat(3) * dz
End Sub
 
Sub StrafeCameraVhat (dx As Double, dy As Double, dz As Double)
    PlayerCamera.Position.x = PlayerCamera.Position.x + vhat(1) * dx
    PlayerCamera.Position.y = PlayerCamera.Position.y + vhat(2) * dy
    PlayerCamera.Position.z = PlayerCamera.Position.z + vhat(3) * dz
End Sub
 
Sub StrafeCameraNhat (dx As Double, dy As Double, dz As Double)
    PlayerCamera.Position.x = PlayerCamera.Position.x + nhat(1) * dx
    PlayerCamera.Position.y = PlayerCamera.Position.y + nhat(2) * dy
    PlayerCamera.Position.z = PlayerCamera.Position.z + nhat(3) * dz
End Sub
 
'''
 

EDIT: Attached screenshot of looking straight up, about to capture an eclipse.

QB64 Discussion / [fixed] possible editor bug

« on: November 06, 2021, 09:37:38 am »

its not 2022 yet but i figured yall wanna know what i found whilst running windows 10, all-new qb64-everything as of last week. this problem arose maybe 3x recently, managed to capture it this time:

when i type (RND - .5) * whatever, the editor removes the .5 and throws the parentheses off.

Programs / A do-nothing zen garden

« on: March 19, 2021, 11:54:01 am »

Click the mouse to create heat, life, and waves. Right click to destroy.

Code: QB64: [Select]

OPTION _EXPLICIT
SCREEN _NEWIMAGE(800, 800, 32)
 
DIM SHARED GridWidth
DIM SHARED GridHeight
DIM SHARED CellWidth
DIM SHARED CellHeight
GridWidth = _WIDTH / 8
GridHeight = _HEIGHT / 8
CellWidth = _WIDTH / GridWidth
CellHeight = _HEIGHT / GridHeight
 
TYPE Vector
    x AS DOUBLE
    y AS DOUBLE
    z AS DOUBLE
END TYPE
 
DIM SHARED MainGrid(GridWidth, GridHeight) AS Vector
DIM SHARED AuxiGrid(GridWidth, GridHeight) AS Vector
DIM SHARED GridVel(GridWidth, GridHeight) AS DOUBLE
 
DIM SelectedCelli
DIM SelectedCellj
DO
 
    DO WHILE _MOUSEINPUT
        SelectedCelli = INT(_MOUSEX / CellWidth)
        SelectedCellj = INT(_MOUSEY / CellHeight)
        IF _MOUSEBUTTON(1) THEN
            MainGrid(SelectedCelli, SelectedCellj).x = 8
            MainGrid(SelectedCelli, SelectedCellj).y = 1
            MainGrid(SelectedCelli, SelectedCellj).z = 6
            GridVel(SelectedCelli, SelectedCellj) = 0
        END IF
        IF _MOUSEBUTTON(2) THEN
            MainGrid(SelectedCelli, SelectedCellj).x = 0
            MainGrid(SelectedCelli, SelectedCellj).y = 0
            MainGrid(SelectedCelli, SelectedCellj).z = 0
            GridVel(SelectedCelli, SelectedCellj) = 0
        END IF
    LOOP
 
    CALL UpdateGrid
    CLS
    CALL PlotGrid
    _DISPLAY
    _LIMIT 30
LOOP
 
END
 
SUB UpdateGrid
    DIM i AS INTEGER
    DIM j AS INTEGER
    DIM t AS DOUBLE
    DIM AS Vector a1, a2, a3, a4, a5, a6, a7, a8, a9
    FOR i = 1 TO GridWidth
        FOR j = 1 TO GridHeight
            AuxiGrid(i, j).x = MainGrid(i, j).x
            AuxiGrid(i, j).y = MainGrid(i, j).y
            AuxiGrid(i, j).z = MainGrid(i, j).z
        NEXT
    NEXT
    FOR i = 1 TO GridWidth - 2
        FOR j = 1 TO GridHeight - 2
            a1 = AuxiGrid(i - 1, j + 1)
            a2 = AuxiGrid(i, j + 1)
            a3 = AuxiGrid(i + 1, j + 1)
            a4 = AuxiGrid(i - 1, j)
            a5 = AuxiGrid(i, j)
            a6 = AuxiGrid(i + 1, j)
            a7 = AuxiGrid(i - 1, j - 1)
            a8 = AuxiGrid(i, j - 1)
            a9 = AuxiGrid(i + 1, j - 1)
 
 
            ' Diffusion
            MainGrid(i, j).x = (1 / 5) * (a2.x + a4.x + a6.x + a8.x + a5.x)
 
            ' Game of life
            t = a1.y + a2.y + a3.y + a4.y + a6.y + a7.y + a8.y + a9.y
            IF (a5.y = 1) THEN
                SELECT CASE t
                    CASE IS < 2
                        MainGrid(i, j).y = 0
                    CASE 2
                        MainGrid(i, j).y = 1
                    CASE 3
                        MainGrid(i, j).y = 1
                    CASE IS > 3
                        MainGrid(i, j).y = 0
                END SELECT
            ELSE
                IF (t = 3) THEN
                    MainGrid(i, j).y = 1
                END IF
            END IF
 
            ' Wave propagation
            DIM alpha
            DIM wp1, wp2
            alpha = .25
            wp1 = alpha * (a6.z + a4.z) + 2 * (1 - alpha) * a5.z - GridVel(i, j)
            wp2 = alpha * (a2.z + a8.z) + 2 * (1 - alpha) * a5.z - GridVel(i, j)
            MainGrid(i, j).z = (0.98) * (1 / 2) * (wp1 + wp2)
            GridVel(i, j) = AuxiGrid(i, j).z
        NEXT
    NEXT
END SUB
 
SUB PlotGrid
    DIM i AS INTEGER
    DIM j AS INTEGER
    FOR i = 0 TO GridWidth
        FOR j = 0 TO GridHeight
            LINE (i * CellWidth, j * CellHeight)-(i * CellWidth + CellWidth, j * CellHeight + CellHeight), _RGB32(255 * MainGrid(i, j).x, 25 + 230 * MainGrid(i, j).y, 255 * ABS(MainGrid(i, j).z)), BF
            LINE (i * CellWidth, j * CellHeight)-(i * CellWidth + CellWidth, j * CellHeight + CellHeight), _RGB32(100, 100, 100), B
        NEXT
    NEXT
END SUB

QB64 Discussion / Alright, this is weird on my machine...

« on: February 10, 2021, 02:50:59 pm »

I get two different answers at the bottom of this code. Someone else tells me they get the same answer twice. Can I get some community testing? Or someone otherwise set me straight please.

Code: QB64: [Select]

DIM z AS _INTEGER64
z = 9223372036854775807 ' This is the biggest allowed number of this type.
'                         (Only here for reference.)
 
DIM a AS _INTEGER64
DIM b AS _INTEGER64
a = 2 ^ 55 - 1 '          This number should be odd.
b = 36028797018963967 '   The number above should equal this one.
PRINT a
PRINT b
 

Pages: [1] 2 3 ... 5

News:

Show Posts

Topics - STxAxTIC

QB64 Discussion / TIMER vs SLEEP

Programs / Finished Driven Pendulum + Mouse Toy

Programs / Double Pendulum Studies

Programs / Oddly satisfying Lissajous Glyphs

Programs / Domain Coloring

Programs / Scalar Field

Programs / Draw any curve using only circles

Programs / Combinator Calculator: The purest math you'll ever see

Programs / qXed 2021

Programs / Binary Sequence Predictor "game"?

Programs / Digital Circuit Simulator

Programs / Sanctum 2021

QB64 Discussion / [fixed] possible editor bug

Programs / A do-nothing zen garden

QB64 Discussion / Alright, this is weird on my machine...