'===========================================================================
' Subject: PLASMA, 320X200X256 VERSION       Date: 07-06-98 (22:27)       
' Author:  Anders Olofsson                   Code: QB, QBasic, PDS        
' Origin:  anders.olofsson@mail.bip.net    Packet: GRAPHICS.ABC
'===========================================================================
'
'  Plasma, 320x200x256 version.
'
'    By Anders Olofsson 1998.
'
'      E-mail: anders.olofsson@mail.bip.net
'
'-------------------------------------------------------
'   ** Compile for maximum speed **
'
'   Press space to change palette rotation direction
'   Press "P" to get a new palette
'   Press "N" to get new plasma
'   Press Enter to save current plasma in a bitmap file!!!
'-------------------------------------------------------
'
'   Thanks to:
'     Davey W. Taylor for the bmpinfo type def.
'     Jonathan Leger - Memcopy routine.
'
'
'-------------------------------------------------------

DEFINT A-Z
DECLARE SUB Memcopy (fromseg%, fromoffset%, toseg%, tooffset%, bytes%)
DECLARE SUB CyclePalette (Dir%)
DECLARE SUB Paletteget (A%, R%, G%, B%)
DECLARE SUB MakeRandomPalette ()
DECLARE SUB Pal (A%, R%, G%, B%)
DECLARE SUB SaveBMP (N$)
DECLARE SUB SetScreenmode (SM%)
                      

CONST Noise = 0           ' If you want noise, change the value to 1
CONST StartSize = 5       ' Bigger value = bigger clouds...
CONST Plasmatimer = 120   ' Changes plasma every .. second(s).
CONST PaletteTimer = 30   ' Changes palette every .. second(s).
  File$ = "PLASMA"        ' Name of the captured files... (this will turn out
                          ' plasma.bmp, plasma1.bmp, plasma2.bmp and so on...)
'-------------------------------------------------------



' Needed to save screen-shots in bitmap format...

TYPE BmpInfo
 id AS STRING * 2
 filesize AS LONG
 reserved AS STRING * 4
 Offset AS LONG
 SizeOfHeader AS LONG
 BMPWidth AS LONG
 BmpHeight AS LONG
 Bitplanes AS INTEGER
 Bitsperpixel AS INTEGER
 Compression AS LONG
 Imagesize AS LONG
 Pelspermetrex AS LONG
 Pelspermetrey AS LONG
 UsedColors AS LONG
 importantcolors AS LONG
END TYPE


SCREEN 13

GOSUB ChangePalette

CurrentDir = 1

RedrawPlasma:

FOR y = 0 TO 199 STEP StartSize
 FOR x = 0 TO 319 STEP StartSize
  C = RND * 254 + 1
  LINE (x, y)-STEP(StartSize, StartSize), C, BF
 NEXT
NEXT


DEF SEG = &HA000
FOR s = StartSize TO 1 STEP -1
FOR y = 0 TO 199 STEP s
 Y2 = y + s: IF Y2 >= 199 THEN Y2 = 199
 FOR x = 0 TO 319 STEP s
  C = (PEEK(320& * y + x) + PEEK(320& * Y2 + (x + s)) + PEEK(320& * Y2 + x) + PEEK(320& * y + (x + s))) \ 4
  IF s > 1 THEN LINE (x, y)-STEP(s, s), C, BF ELSE POKE 320& * y + x, C
 NEXT
NEXT
NEXT

IF Noise THEN
FOR y = 0 TO 199
FOR x = 0 TO 319
 C = PEEK(320& * y + x + 1) - (RND * 10) + 1
 POKE 320& * y + x, C
NEXT
CyclePalette CurrentDir
NEXT
END IF

PlasmaCounter! = TIMER
PaletteCounter! = TIMER

DO
 Keys$ = UCASE$(INKEY$)
 IF LEN(Keys$) THEN
  IF Keys$ = " " AND CurrentDir = 2 THEN CurrentDir = 1: Keys$ = ""
  IF Keys$ = " " AND CurrentDir = 1 THEN CurrentDir = 2
  IF Keys$ = "P" THEN GOSUB ChangePalette: Keys$ = ""
  IF Keys$ = "N" THEN GOTO RedrawPlasma
  IF Keys$ = CHR$(13) THEN
   filen$ = File$
FileCheck: F = FREEFILE
   OPEN filen$ + ".BMP" FOR BINARY AS #F
   IF LOF(1) > 0 THEN
    CLOSE #F
    FCounter = FCounter + 1
    filen$ = File$ + LTRIM$(RTRIM$(STR$(FCounter)))
    GOTO FileCheck
   ELSE
    CLOSE #F
    KILL filen$ + ".BMP"
   END IF
   SaveBMP filen$ + ".BMP"
   Keys$ = ""
  END IF
 END IF
 CyclePalette CurrentDir
 IF TIMER - PlasmaCounter! > Plasmatimer THEN GOTO RedrawPlasma
 IF TIMER - PaletteCounter! > PaletteTimer THEN GOSUB ChangePalette

 'Lots of retraices... else it goes to fast!
 WAIT &H3DA, 8: WAIT &H3DA, 8, 1
 WAIT &H3DA, 8: WAIT &H3DA, 8, 1
LOOP UNTIL LEN(Keys$) AND Keys$ <> " "

FOR x = 0 TO 63                  'Fade out
 FOR C = 0 TO 255
  Paletteget C, R, G, B
  IF R THEN R = R - 1
  IF G THEN G = G - 1
  IF B THEN B = B - 1
  Pal C, R, G, B
 NEXT
 WAIT &H3DA, 8: WAIT &H3DA, 8, 1
NEXT

SCREEN 0: WIDTH 80, 25

END

ChangePalette:
PaletteCounter! = TIMER
R = INP(64) \ 5: G = INP(64) \ 5: G = INP(64) \ 5
Pal 1, R, G, B: Pal 255, R + (10 * RND), G + (10 * RND), B + (10 * RND)
 MakeRandomPalette
Pal 0, 0, 0, 0
Pal 64, 63, 63, 0
RETURN

SUB CyclePalette (Dir)

IF Dir = 1 THEN
FOR T = 2 TO 255
 Paletteget T, R, G, B
 Pal T - 1, R, G, B
NEXT

Paletteget 1, R, G, B
Pal 255, R, G, B

ELSE

Paletteget 255, R, G, B
Pal 1, R, G, B

FOR T = 254 TO 1 STEP -1
 Paletteget T, R, G, B
 Pal T + 1, R, G, B
NEXT

END IF

WAIT &H3DA, 8
WAIT &H3DA, 8, 1

END SUB

SUB MakeRandomPalette
DIM used(0 TO 255) AS STRING * 2: used(0) = CHR$(1) + CHR$(255): s = 1

DO
getnext: IF s = 0 THEN EXIT DO
         s = s - 1
         c1 = ASC(used(s)): c2 = ASC(RIGHT$(used(s), 1))
         current = (c1 + c2) \ 2
IF c1 = c2 OR current = c1 OR current = c2 GOTO getnext

 Paletteget c1, r1, g1, b1: Paletteget c2, r2, g2, b2
  T = (ABS(c1 - c2) \ 8) * ((INP(64) MOD 3) - 1)
  R = (r1 + r2) \ 2 + T: G = (g1 + g2) \ 2 + T: B = (b1 + b2) \ 2 + T
 Pal current, R, G, B
 used(s) = CHR$(c1) + CHR$(current): s = s + 1
 used(s) = CHR$(current) + CHR$(c2): s = s + 1
LOOP UNTIL s = 0
Pal 0, 0, 0, 0

END SUB

SUB Memcopy (fromseg%, fromoffset%, toseg%, tooffset%, bytes%)

DIM MemCopy.ASM AS STRING
MemCopy.ASM = ""
MemCopy.ASM = MemCopy.ASM + CHR$(85)                             'PUSH BP
MemCopy.ASM = MemCopy.ASM + CHR$(137) + CHR$(229)                'MOV BP,SP
MemCopy.ASM = MemCopy.ASM + CHR$(30)                             'PUSH DS
MemCopy.ASM = MemCopy.ASM + CHR$(139) + CHR$(70) + CHR$(10)      'MOV AX,[BP+0A]
MemCopy.ASM = MemCopy.ASM + CHR$(142) + CHR$(192)                'MOV ES,AX
MemCopy.ASM = MemCopy.ASM + CHR$(139) + CHR$(70) + CHR$(14)      'MOV AX,[BP+0E]
MemCopy.ASM = MemCopy.ASM + CHR$(142) + CHR$(216)                'MOV DS,AX
MemCopy.ASM = MemCopy.ASM + CHR$(139) + CHR$(118) + CHR$(12)     'MOV SI,[BP+0C]
MemCopy.ASM = MemCopy.ASM + CHR$(139) + CHR$(126) + CHR$(8)      'MOV DI,[BP+08]
MemCopy.ASM = MemCopy.ASM + CHR$(139) + CHR$(78) + CHR$(6)       'MOV CX,[BP+06]
MemCopy.ASM = MemCopy.ASM + CHR$(243)                            'REPZ
MemCopy.ASM = MemCopy.ASM + CHR$(164)                            'MOVSB
MemCopy.ASM = MemCopy.ASM + CHR$(31)                             'POP DS
MemCopy.ASM = MemCopy.ASM + CHR$(93)                             'POP BP
MemCopy.ASM = MemCopy.ASM + CHR$(203)                            'RETF

DEF SEG = VARSEG(MemCopy.ASM)
        CALL Absolute(BYVAL fromseg%, BYVAL fromoffset%, BYVAL toseg%, BYVAL tooffset%, BYVAL bytes%, SADD(MemCopy.ASM))
DEF SEG

END SUB

SUB Pal (A, R, G, B)
OUT &H3C8, A
OUT &H3C9, R
OUT &H3C9, G
OUT &H3C9, B

END SUB

SUB Paletteget (A, R, G, B)
OUT &H3C7, A
R = INP(&H3C9)
G = INP(&H3C9)
B = INP(&H3C9)
END SUB

SUB SaveBMP (Filename$)
DIM BMPHeader AS BmpInfo

BMPHeader.id = "BM"
BMPHeader.SizeOfHeader = 40
BMPHeader.BMPWidth = 320
BMPHeader.BmpHeight = 200
BMPHeader.Bitsperpixel = 8
BMPHeader.Imagesize = 64000
BMPHeader.UsedColors = 255
BMPHeader.Bitplanes = 1
BMPHeader.Offset = 1078
BMPHeader.Pelspermetrex = 3780
BMPHeader.Pelspermetrey = 3790


F = FREEFILE
OPEN Filename$ FOR BINARY AS #F

 PUT #F, , BMPHeader

FOR C = 0 TO 255
 Paletteget C, R, G, B
 PData$ = CHR$(R * 4) + CHR$(G * 4) + CHR$(B * 4) + " "
 PUT #F, , PData$
NEXT

DIM Buffer AS STRING
Segment = &HA000 + (64000 \ 16) - 20

FOR y = 200 TO 1 STEP -1
 Buffer = SPACE$(320)
 Memcopy Segment, 0, VARSEG(Buffer), SADD(Buffer), 320
 PUT #F, , Buffer
 Segment = Segment - 20
NEXT

CLOSE #F

END SUB