DECLARE SUB grad (col1%, r1%, g1%, b1%, col2%, r2%, g2%, b2%)
DECLARE SUB pal (colour%, r%, g%, b%)

COMMON SHARED buffer() AS INTEGER
COMMON SHARED buffer1() AS INTEGER
COMMON SHARED buffer2() AS INTEGER

TYPE part
    x AS SINGLE
    y AS SINGLE
    z AS SINGLE
    vx AS SINGLE
    vy AS SINGLE
    vz AS SINGLE
END TYPE
TYPE rgb
    r AS INTEGER
    g AS INTEGER
    b AS INTEGER
END TYPE
DIM SHARED colors(255) AS rgb

CONST PI = 3.1415926#
CONST numparts = 100

SCREEN 13
RANDOMIZE TIMER
DEFINT A-Z

DIM buffer1(8001) AS INTEGER            'used for ripple effect
buffer1(0) = 1280
buffer1(1) = 100
segment1 = VARSEG(buffer1(2))
offset1 = VARPTR(buffer1(2))

DIM buffer2(8001) AS INTEGER            'used for ripple effect
buffer2(0) = 1280
buffer2(1) = 100
segment2 = VARSEG(buffer2(2))
offset2 = VARPTR(buffer2(2))

DIM buffer(8001) AS INTEGER             'what's PUT on screen
buffer(0) = 1280
buffer(1) = 100
segment = VARSEG(buffer(2))
offset = VARPTR(buffer(2))
                         
DIM SHARED tile(15, 15) AS INTEGER
FOR x = 0 TO 15
    FOR y = 0 TO 15
        tile(y, x) = (x AND y) * 8
    NEXT
NEXT x

DIM rdivs(3840) AS INTEGER
FOR d = 0 TO 3840
    rdivs(d) = d \ 256
NEXT d

DIM light(63, 63) AS INTEGER
FOR y = 0 TO 63
    FOR x = 0 TO 63
        light(y, x) = 127 - 2 * SQR(x ^ 2 + y ^ 2)
        IF light(y, x) < 0 THEN light(y, x) = 0
    NEXT x
NEXT y

grad 0, 0, 0, 0, 63, 31, 31, 63
grad 64, 31, 31, 63, 127, 63, 63, 63
grad 128, 63, 63, 63, 191, 31, 31, 63
grad 192, 31, 31, 63, 255, 0, 0, 0
FOR c = 0 TO 255
    pal c, 0, 0, 0
NEXT c
COLOR 127

DIM sins(-720 TO 720) AS SINGLE
DIM coss(-720 TO 720) AS SINGLE
FOR s = -720 TO 720
    sins(s) = SIN(s * PI / 180)
    coss(s) = COS(s * PI / 180)
NEXT s

DIM rsins(128) AS INTEGER
DIM rcoss(128) AS INTEGER
FOR s = 0 TO 128
    rsins(s) = 256 * SIN(s * PI / 64) * (COS(s * PI / 64) + 1.5)
    rcoss(s) = 256 * COS(s * PI / 64) * (COS(s * PI / 64) + 1.5)
NEXT s

DIM SHARED divs(1280) AS INTEGER
FOR d = 0 TO 1280
    divs(d) = d / 5.5
NEXT d

DIM parts(1 TO numparts) AS part
FOR p = 1 TO numparts
    parts(p).x = RND * 100 - 50
    parts(p).z = RND * 100 - 50
    parts(p).y = RND * 97 + 1' 98
    parts(p).vy = -.5
NEXT p

LINE (79, 49)-(240, 150), 127, B

bright = 0
ripple = 100
tiles = 0
part = 0
frame = 0

tf = 0
t# = TIMER
tt# = TIMER
DO
    IF INKEY$ = CHR$(27) THEN EXIT DO
    IF INKEY$ = " " THEN frame = frame + 25
    frame = frame + 1
   
    SELECT CASE frame
        CASE 1 TO 100
            bright = bright + 1
        CASE 201 TO 300
            bump = bump + 1
        CASE 471 TO 570
            ripple = 0
            bump = 0
            rotblur = rotblur + 1
        CASE 771 TO 870
            rotblur = rotblur - 1
            tiles = tiles + 1
        CASE 1071 TO 1170
            tiles = tiles - 1
            part = part + 1
        CASE 1371 TO 1470
            bright = bright - 1
        CASE 1471
            enddemo = 1
        CASE ELSE
    END SELECT

    angle = (angle + 1) MOD 360
   
    FOR c = 0 TO 255
        OUT &H3C8, c
        OUT &H3C9, colors(c).r * bright \ 100
        OUT &H3C9, colors(c).g * bright \ 100
        OUT &H3C9, colors(c).b * bright \ 100
    NEXT c

    IF ripple > 0 THEN
        SWAP segment1, segment2
        SWAP offset1, offset2
        DEF SEG = segment2
        POKE 160 * INT(RND * 98) + INT(RND * 158) + offset2 + 161, 255 * ripple \ 100
        p1 = offset1 + 161
        p2 = offset2 + 161
        p = offset + 161
        FOR y = -49 TO 48
            FOR x = -79 TO 78
                DEF SEG = segment1
                col = PEEK(p1) + PEEK(p1 - 1) + PEEK(p1 + 1) + PEEK(p1 - 160) + PEEK(p1 + 160)
                DEF SEG = segment2
                col = ABS(col / 2.5 - PEEK(p2)) * .99
                POKE p2, col
                DEF SEG = segment
                POKE p, col * ripple \ 100
                p1 = p1 + 1
                p2 = p2 + 1
                p = p + 1
            NEXT x
            p1 = p1 + 2
            p2 = p2 + 2
            p = p + 2
        NEXT y
    END IF

    IF bump > 0 THEN
        bangle = (bangle + 1) MOD 360
        lighty = 20 * sins(bangle) + 50
        lightx = 140 * coss(bangle) + 80
        p = offset + 161
        p2 = offset2 + 161
        FOR y = 1 TO 98
            FOR x = 1 TO 158
                DEF SEG = segment2
                lx = ABS(x - lightx + (PEEK(p2 - 1) - PEEK(p2 + 1)) \ 4)
                ly = ABS(y - lighty + (PEEK(p2 - 160) - PEEK(p2 + 160)) \ 4)
                IF lx < 64 AND ly < 64 THEN col = light(ly, lx) ELSE col = 0
                DEF SEG = segment
                'POKE p, col
                POKE p, col + PEEK(p) * (100 - bump) / 100
                p = p + 1
                p2 = p2 + 1
            NEXT x
            p = p + 2
            p2 = p2 + 2
        NEXT y
    END IF

    IF part > 0 THEN
        DEF SEG = segment
        pcol = 255 * part \ 100
        FOR p = 1 TO numparts
            x! = parts(p).x
            z! = parts(p).z
            y! = parts(p).y
            xrot = x! * coss(angle) + z! * sins(angle) + 80
            yrot = y! + (z! * coss(angle) - x! * sins(angle)) / 5
            IF xrot > 0 AND xrot < 160 AND yrot > 1 AND yrot < 99 THEN POKE offset + 160 * yrot + xrot, pcol
            parts(p).y = parts(p).y - .5
            IF parts(p).y < 2 THEN
                parts(p).x = RND * 100 - 50
                parts(p).z = RND * 100 - 50
                parts(p).y = 105
            END IF
        NEXT
        IF frame MOD 5 = 0 THEN
            rx = RND * 160
            ry = RND * 100
            size = RND * 40 + 20
            a2 = 0
            FOR a = 0 TO 359
                d! = size * coss(a2)
                x = rx + d! * coss(a)
                y = ry + d! * sins(a)
                IF x > 0 AND y > 1 AND x < 160 AND y < 99 THEN POKE offset + 160 * y + x, pcol
                a2 = (a2 + 5) MOD 360
            NEXT a
        END IF
        FOR p = offset TO offset + 319
            POKE p, 0
        NEXT p
        FOR p = offset + 15838 TO offset + 161 STEP -1
            POKE p + 160, (divs(PEEK(p - 160) + PEEK(p - 1) + PEEK(p) + PEEK(p + 1) + PEEK(p + 160)) * part + PEEK(p) * (100 - part)) / 100
        NEXT p
    END IF

    IF rotblur > 0 THEN
        rf = (rf + 1) MOD 360
        GET (80, 50)-(239, 149), buffer1
        zoom! = coss(rf) + 1.5
        ca! = coss(10) / zoom!
        sa! = sins(10) / zoom!
        DEF SEG = segment1
        FOR y = 0 TO 99
            POKE offset1 + 160 * FIX(RND * 100) + RND * 160, 127
        NEXT y
        p = offset1 + 81
        FOR y = 1 TO 98
            POKE p, 127
            p = p + 160 + INT(RND * 3) - 1
        NEXT y
        IF rf < 270 THEN POKE offset1 + 8080, 0 ELSE POKE offset1 + 8080, 127
        POKE offset1 + 8080, 0
        p = offset
        yca! = 50 - 50 * ca! + 80 * sa!
        ysa! = 80 - 50 * sa! - 80 * ca!
        FOR y = -50 TO 49
            xrot! = ysa!
            yrot! = yca!
            FOR x = -80 TO 79
                x2 = INT(xrot!)
                y2 = INT(yrot!)
                x3 = x2 + 1
                y3 = y2 + 1
                IF x3 > 0 AND y3 > 0 AND x2 < 159 AND y2 < 99 THEN
                    p2 = y2 * 160 + x2 + offset1
                    DEF SEG = segment1
                    col = (PEEK(p2) * (x3 - xrot!) * (y3 - yrot!) + PEEK(p2 + 1) * (xrot! - x2) * (y3 - yrot!) + PEEK(p2 + 160) * (x3 - xrot!) * (yrot! - y2) + PEEK(p2 + 161) * (xrot! - x2) * (yrot! - y2)) '* .9
                ELSE
                    col = 0
                END IF
                IF col > 127 THEN col = 127
                IF col < 0 THEN col = 0
                DEF SEG = segment
                POKE p, col * rotblur \ 100 + PEEK(p) * (100 - rotblur) \ 100
                p = p + 1
                xrot! = xrot! + ca!
                yrot! = yrot! - sa!
            NEXT x
            yca! = yca! + ca!
            ysa! = ysa! + sa!
        NEXT y
    END IF

    IF tiles > 0 THEN
        rangle = (rangle + 1) AND 127
        f = f + 1
        ca = rcoss(rangle)
        sa = rsins(rangle)
        yca = 12800 - 50 * rcoss(rangle) + 80 * rsins(rangle)
        ysa = 20480 - 50 * rsins(rangle) - 80 * rcoss(rangle)
        DEF SEG = segment
        p = offset
        FOR y = 0 TO 99
            xrot = ysa
            yrot = yca
            FOR x = 0 TO 159
                col = (tile(rdivs(xrot AND 3840), rdivs(yrot AND 3840)) * tiles + PEEK(p) * (100 - tiles)) \ 100
                IF col > 255 THEN col = 255
                POKE p, col
                p = p + 1
                xrot = xrot + ca
                yrot = yrot - sa
            NEXT x
            yca = yca + ca
            ysa = ysa + sa
        NEXT y
    END IF

    PUT (80, 50), buffer, PSET
    LOCATE 1: PRINT fps

    tf = tf + 1
    IF TIMER - t# > 1 THEN
        fps = tf / (TIMER - t#)
        t# = TIMER
        tf = 0
    END IF
LOOP UNTIL enddemo = 1

SCREEN 0
WIDTH 80
COLOR 15: PRINT "Element"
COLOR 9: PRINT STRING$(80, "-")
COLOR 15: PRINT "by Entropy"
PRINT
PRINT "coded entirely in QuickBASIC"
PRINT "Average fps of"; frame / (TIMER - tt#)
PRINT
PRINT "Entropia: http://www.uslink.net/~insty/"
PRINT "e-mail: entropy@hotbot.com"

SUB grad (col1, r1, g1, b1, col2, r2, g2, b2)

cols = col2 - col1 + 1
rstep# = (r2 - r1 + 1) / cols
gstep# = (g2 - g1 + 1) / cols
bstep# = (b2 - b1 + 1) / cols
r# = r1
g# = g1
b# = b1
FOR col = col1 TO col2
    r# = r# + rstep#
    g# = g# + gstep#
    b# = b# + bstep#
    IF r# > 63 THEN r# = 63
    IF r# < 0 THEN r# = 0
    IF g# > 63 THEN g# = 63
    IF g# < 0 THEN g# = 0
    IF b# > 63 THEN b# = 63
    IF b# < 0 THEN b# = 0
    colors(col).r = INT(r#)
    colors(col).g = INT(g#)
    colors(col).b = INT(b#)
NEXT

END SUB

SUB pal (colour, r, g, b)

OUT &H3C8, colour
OUT &H3C9, r
OUT &H3C9, g
OUT &H3C9, b

END SUB