'===========================================================================
' Subject: AMOBE PLASMA                      Date: 06-21-98 (11:19)       
' Author:  Per Larsson                       Code: QB, QBasic, PDS        
' Origin:  www.algonet.se/~emden/          Packet: GRAPHICS.ABC
'===========================================================================
'Nerladdat fr†n Qbasic Universe
'http://qbu.home.ml.org
'Flera hundra andra qbasic-program att ladda ner.



DECLARE SUB quit ()
'AMOBE.BAS
'CODED BY: Per Larsson
'
'This program demonstrates some palette manipulation stuff
'
'
'This is one of those build on programs, therefore
'the code may seem a little weird
'
DECLARE SUB palcycl ()
DECLARE SUB initpal ()
 CONST PI = 3.141592654#
 COMMON SHARED mel
 COMMON SHARED band1r, band1g, band1b, band1w, band1pos, band1s
 COMMON SHARED band2r, band2g, band2b, band2w, band2pos, band2s
 DIM SHARED palett(255, 2)
 RANDOMIZE TIMER
SCREEN 13

        '*** You may change these vaules to find a different pattern ***
res = 1      'Resolution, higer vaule=faster rendering lower quality
zoom = 128   'Those two variables changes style
zoom2 = 64   'and dimention of the pattern
noise = 1    'Adds "noise" - try 256 :-)

CALL initpal    'fix the cool yellow palette

                '*** Paint the pattern ***
FOR x = 0 TO 320 STEP res
 FOR y = 0 TO 480 STEP res
  LINE (x, y)-(x + res - 1, y + res - 1), ((((((SIN(x * (PI / zoom))) * 255) + ((COS(y * (PI / zoom))) * 255)) / 2)) + (((((SIN(x * (PI / zoom2))) * 255) + ((COS(y * (PI / zoom2))) * 255)) / 2))) / 2, BF
 NEXT y
NEXT x

FOR x = 0 TO 320 STEP res
 FOR y = 0 TO 480 STEP res
  IF POINT(x, y) = 15 THEN z = 1
  IF z = 1 THEN
  FOR x1 = -1 TO 1
   FOR y1 = -1 TO 1
    IF POINT(x + (x1 * res), y + (y1 * res)) > 128 THEN c = 1
   NEXT y1
  NEXT x1
  END IF
  IF c = 1 THEN LINE (x, y)-(x + res - 1, y + res - 1), 0, BF
  LINE (x, y)-(x + res - 1, y + res - 1), (POINT(x, y) + INT(RND * (noise + 1))) MOD 256, BF
  c = 0
  z = 0
 NEXT y
NEXT x




DO              'start of main loop

                '*** Find random vaules ***
band1rz = INT(RND * 64)
band1gz = INT(RND * 64)
band1bz = INT(RND * 64)
band1pos = INT(RND * 64) * 4
band2rz = INT(RND * 64)
band2gz = INT(RND * 64)
band2bz = INT(RND * 64)
band2pos = INT(RND * 64) * 4
band1w = INT(RND * 112) + 16
band2w = INT(RND * 112) + 16
band1s = INT(RND * 3) + 1
band2s = INT(RND * 3) + 1
IF band1s = 3 THEN band1s = 4
IF band2s = 3 THEN band2s = 4


                '*** Fade in ***
FOR i = 0 TO 64
 band1r = band1rz - ((band1rz / 64) * (64 - i))
 band1g = band1gz - ((band1gz / 64) * (64 - i))
 band1b = band1bz - ((band1bz / 64) * (64 - i))
 band2r = band2rz - ((band2rz / 64) * (64 - i))
 band2g = band2gz - ((band2gz / 64) * (64 - i))
 band2b = band2bz - ((band2bz / 64) * (64 - i))
 band1pos = band1pos + band1s
 band2pos = band2pos - band2s
 IF band1pos > 511 THEN band1pos = band1pos - 256
 IF band2pos < 256 THEN band2pos = band2pos + 256
 CALL palcycl
NEXT i

                '*** Main part ***
band1r = band1rz
band1g = band1gz
band1b = band1bz
band2r = band2rz
band2g = band2gz
band2b = band2bz
FOR i = 0 TO 512
 band1pos = band1pos + band1s
 band2pos = band2pos - band2s
 IF band1pos > 511 THEN band1pos = band1pos - 256
 IF band2pos < 256 THEN band2pos = band2pos + 256
 CALL palcycl
NEXT i

                '*** Fade out ***   
FOR i = 0 TO 64
 band1r = band1rz - ((band1rz / 64) * i)
 band1g = band1gz - ((band1gz / 64) * i)
 band1b = band1bz - ((band1bz / 64) * i)
 band2r = band2rz - ((band2rz / 64) * i)
 band2g = band2gz - ((band2gz / 64) * i)
 band2b = band2bz - ((band2bz / 64) * i)
 band1pos = band1pos + band1s
 band2pos = band2pos - band2s
 IF band1pos > 511 THEN band1pos = band1pos - 256
 IF band2pos < 256 THEN band2pos = band2pos + 256
 CALL palcycl
NEXT i
LOOP

SUB initpal
FOR i = 0 TO 127
 OUT &H3C7, i: OUT &H3C8, i: OUT &H3C9, INT(i / 2): OUT &H3C9, INT(i / 2):     OUT &H3C9, 0
NEXT i
FOR i = 128 TO 255
 OUT &H3C7, i: OUT &H3C8, i: OUT &H3C9, INT(64 - ((i - 127) / 2)): OUT &H3C9, INT(64 - ((i - 127) / 2)): OUT &H3C9, 0
NEXT i
END SUB

SUB palcycl
  FOR i = 0 TO 255
    dist1a = band1pos MOD 256 - i
    dist2a = band2pos MOD 256 - i
    IF dist1a < 0 THEN dist1a = -dist1a
    IF dist2a < 0 THEN dist2a = -dist2a
    dist1b = band1pos MOD 256
    dist2b = band2pos MOD 256
    dist1b = dist1b + (256 - i)
    dist2b = dist2b + (256 - i)
    dist1c = 256 - (band1pos MOD 256)
    dist2c = 256 - (band2pos MOD 256)
    dist1c = dist1c + i
    dist2c = dist2c + i
    IF dist1a > dist1b THEN dist1 = dist1b ELSE dist1 = dist1a
    IF dist2a > dist2b THEN dist2 = dist2b ELSE dist2 = dist2a
    IF dist1 > dist1c THEN dist1 = dist1c
    IF dist2 > dist2c THEN dist2 = dist2c

    r1 = band1r - ((band1r / band1w) * dist1)
    g1 = band1g - ((band1g / band1w) * dist1)
    b1 = band1b - ((band1b / band1w) * dist1)
    r2 = band2r - ((band2r / band2w) * dist2)
    g2 = band2g - ((band2g / band2w) * dist2)
    b2 = band2b - ((band2b / band2w) * dist2)
    IF r1 < 0 THEN r1 = 0
    IF g1 < 0 THEN g1 = 0
    IF b1 < 0 THEN b1 = 0
    IF r2 < 0 THEN r2 = 0
    IF g2 < 0 THEN g2 = 0
    IF b2 < 0 THEN b2 = 0
 
    r = (r1 + r2)
    g = (g1 + g2)
    b = (b1 + b2)

    IF r > 63 THEN r = 63
    IF g > 63 THEN g = 63
    IF b > 63 THEN b = 63

    palett(i, 0) = r
    palett(i, 1) = g
    palett(i, 2) = b
    
    IF INKEY$ = CHR$(27) THEN CALL quit
  NEXT i

  FOR i = 0 TO 255
  OUT &H3C7, i: OUT &H3C8, i: OUT &H3C9, palett(i, 0): OUT &H3C9, palett(i, 1): OUT &H3C9, palett(i, 2)
  NEXT i

END SUB

SUB quit
SCREEN 0
WIDTH 80
CLS
PRINT "Code by Per Larsson"
PRINT "E-Mail    elliott@alfaskop.net"
PRINT "Homepage  www.alfaskop.net/~elliott/start.htm"
PRINT
PRINT "Greetings goes to: nuzic & Damn You"
END
END SUB