您所在位置：主题：转贴： 闪电源程序。绝对精彩
dhej666
[专家分：580] 发布于 2004-03-02 16:02:00
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
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 "coded entirely in QuickBASIC"
PRINT "Average fps of"; frame / (TIMER - tt#)
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
