' **** Press F5 now to begin ****
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'  Code
'  
DECLARE SUB PaletteBar ()
DECLARE SUB MakeGrid (Acuracy!)
DECLARE SUB Solarize (r!, g!, B!)
DECLARE SUB Negative ()
DECLARE SUB Mosaic (sz!)
DECLARE SUB ChangePal (Red%, Green%, Blue%, syscolor%)
DECLARE SUB ShowBitmap (f$, mde!)
DECLARE FUNCTION FillIn$ (t$, num!)
DECLARE SUB ReadPal (Red%, Green%, Blue%)
DECLARE FUNCTION Exist! (fle$)
CLS
PALETTE 0, 23
COLOR 15, 0
PRINT "Press any key to begin the sequence"
DO WHILE INKEY$ = ""
FOR q = 0 TO 2
PALETTE 0, 63
PALETTE 15, 0
NEXT q
FOR q = 0 TO 1.5
PALETTE 0, 0
PALETTE 15, 63
NEXT q
LOOP
CLEAR , , 15000
'==== All code above the line above this one is ignored ====
CONST mx = 40
CONST Bmp$ = "C:\PSP\NEUTON.BMP"
ShowBitmap Bmp$, 2
FOR q = 1 TO mx + 1
d$ = "TEMP" + LTRIM$(RTRIM$(STR$(q - 1))) + ".BSV"
IF Exist(d$) THEN xx = 1
IF Lstxx = 0 THEN ShowBitmap Bmp$, 3
IF xx = 0 THEN Mosaic q
DEF SEG = &HA000
IF xx = 0 THEN BSAVE d$, 0, 64000
Lstxx = xx
NEXT q

CLEAR , , 1000
Negative
LOCATE 1, 1: PRINT mx
DO WHILE INKEY$ = ""
DEF SEG = &HA000
d = TIMER
FOR a = mx TO 0 STEP -1
d$ = "TEMP" + LTRIM$(RTRIM$(STR$(a))) + ".BSV"
BLOAD d$, 0
NEXT a
s = TIMER
'PaletteBar
LOCATE 1, 1: PRINT CINT(mx / (s - d)); " frames per second": SLEEP 1
Negative
SLEEP 1
FOR a = 0 TO mx STEP 1
d$ = "TEMP" + LTRIM$(RTRIM$(STR$(a))) + ".BSV"
BLOAD d$, 0
NEXT a
SLEEP 1
Negative
LOOP

FOR a = 0 TO mx STEP 1
d$ = "TEMP" + LTRIM$(RTRIM$(STR$(a))) + ".BSV"
KILL d$
NEXT a

SUB ChangePal (Red%, Green%, Blue%, syscolor%)
palmask = &H3C6
palregrd = &H3CF
palregwr = &H3C8
paldata = &H3C9
OUT palmask, &HFF
OUT palregwr, syscolor%
OUT paldata, Red%
OUT paldata, Green%
OUT paldata, Blue%
END SUB

FUNCTION Exist (fle$)
OPEN fle$ FOR BINARY AS #4
IF LOF(4) = 0 THEN Exist = 0 ELSE Exist = 1
CLOSE 4
END FUNCTION

FUNCTION FillIn$ (t$, num)
FillIn$ = STRING$(num - LEN(t$), ASC("0")) + t$
END FUNCTION

SUB MakeGrid (Acuracy)
sz = Acuracy
FOR x = 0 TO 320 STEP sz
FOR y = 0 TO 200 STEP sz
c = POINT(x + sz, y)
LINE (x, y)-(x + sz - 1, y + sz - 1), c, B
NEXT y
NEXT x
END SUB

SUB Mosaic (sz)
IF sz <= 1 THEN EXIT SUB
FOR x = 0 TO 320 STEP sz
FOR y = 0 TO 200 STEP sz
c = POINT(x, y)
LINE (x, y)-(x + sz - 1, y + sz - 1), c, BF
NEXT y
NEXT x
END SUB

SUB Negative
Solarize 255, 255, 255
END SUB

SUB PaletteBar
FOR q = 0 TO 255
LINE (q, 0)-(q, 8), q
NEXT q
END SUB

SUB ReadPal (Red%, Green%, Blue%)
palmask = &H3C6
paldata = &H3C9
IF INT(Colr% / 2) = Colr% / 2 THEN Red% = INP(paldata): Green% = INP(paldata): Blue% = INP(paldata)
Red% = INP(paldata)
Green% = INP(paldata)
Blue% = INP(paldata)
END SUB

SUB ShowBitmap (f$, mde)
DIM Red AS STRING * 1
DIM Green AS STRING * 1
DIM Blue AS STRING * 1
DIM PicType AS STRING * 1
OPEN f$ FOR BINARY AS #1
  GET #1, 29, PicType
mxcol = ASC(PicType)
SCREEN 13
IF mde = 2 THEN
        FOR i% = 0 TO 255
        GET #1, 55 + (i% * 4), Red
        GET #1, 55 + (i% * 4) + 1, Green
        GET #1, 55 + (i% * 4) + 2, Blue
        CCHex1% = INT(ASC(Red)) / 8
        CCHex2% = INT(ASC(Green)) / 8
        CCHex3% = INT(ASC(Blue)) / 8
        ChangePal CCHex3%, CCHex2%, CCHex1%, i%
        NEXT i%
END IF
DEF SEG = &HA000
DIM v AS STRING * 10000
Inc = 10000
pt1$ = CHR$(253) + CHR$(0) + CHR$(160)
pt2$ = CHR$(VAL("&H" + MID$(FillIn$(HEX$(Inc), 4), 3, 2))) + CHR$(VAL("&H" + MID$(FillIn$(HEX$(Inc), 4), 1, 2)))
FOR q = 1079 TO LOF(1) STEP Inc
GET #1, q, v
OPEN "1.TMP" FOR BINARY AS #3
pt3$ = CHR$(VAL("&H" + MID$(FillIn$(HEX$(x1), 4), 3, 2))) + CHR$(VAL("&H" + MID$(FillIn$(HEX$(x1), 4), 1, 2)))
PUT #3, , pt1$
PUT #3, , pt3$
PUT #3, , pt2$
PUT #3, , v
CLOSE 3
BLOAD "1.TMP", x1
KILL "1.TMP"
x1 = x1 + Inc
NEXT q
IF mde = 1 THEN
        FOR i% = 0 TO 255
        GET #1, 55 + (i% * 4), Red
        GET #1, 55 + (i% * 4) + 1, Green
        GET #1, 55 + (i% * 4) + 2, Blue
        CCHex1% = INT(ASC(Red)) / 8
        CCHex2% = INT(ASC(Green)) / 8
        CCHex3% = INT(ASC(Blue)) / 8
        ChangePal CCHex3%, CCHex2%, CCHex1%, i%
        NEXT i%
END IF
CLOSE 1, 2, 3
END SUB

SUB Solarize (r, g, B)
        FOR i% = 0 TO 255
        ReadPal CCHex3%, CCHex2%, CCHex1%
        ChangePal ABS(CCHex3% - r), ABS(CCHex2% - g), ABS(CCHex1% - B), i%
        NEXT i%
END SUB