'===========================================================================
' Subject: SPECIAL EFFECTS (LOADS GIFS)      Date: 08-01-97 (17:33)       
' Author:  Ben Paine                         Code: QB, QBasic, PDS        
' Origin:  lozt@hotmail.com                Packet: GRAPHICS.ABC
'===========================================================================
DECLARE FUNCTION pixelate$ (sz!)
DECLARE FUNCTION fx1$ ()
DECLARE FUNCTION fx2$ ()
DECLARE FUNCTION size$ (n!)
DECLARE FUNCTION PalBSave$ (FileName$)
DECLARE FUNCTION loadgif$ (a$)
TYPE Colr
 Dat AS STRING * 3
END TYPE
SCREEN 13
c$ = loadgif$("c:\bud\hbclogo.gif")
c$ = pixelate$(1)

FUNCTION fx1$
fx1:
p = POINT(a, b)
PSET (a - 1, b), p
PSET (a + 1, b), p
PSET (a, b + 1), p
PSET (a, b - 1), p
a = a + 2
IF a > 320 THEN a = 0: b = b + 1.5
IF b > 200 THEN  ELSE GOTO fx1

END FUNCTION

FUNCTION fx2$
fx2:
p = POINT(a, b)
PSET (a - 1, b), p
PSET (a + 1, b), p
PSET (a, b + 1), p
PSET (a, b - 1), p
a = a + 1.2
IF a > 320 THEN a = 0: b = b + 1.5
IF b > 200 THEN  ELSE GOTO fx2

END FUNCTION

FUNCTION loadgif$ (a$)
DEFINT A-Z
DIM Prefix(4095), Suffix(4095), OutStack(4095), ShiftOut(8)
DIM Ybase AS LONG, Powersof2(11) AS LONG, WorkCode AS LONG

FOR a = 0 TO 7: ShiftOut(8 - a) = 2 ^ a: NEXT
FOR a = 0 TO 11: Powersof2(a) = 2 ^ a: NEXT
IF INSTR(a$, ".") = 0 THEN a$ = a$ + ".gif"
OPEN a$ FOR BINARY AS #1
a$ = "      ": GET #1, , a$
IF a$ <> "GIF87a" THEN PRINT "Not a GIF87a file.":
GET #1, , TotalX: GET #1, , TotalY: GOSUB GetByte
NumColors = 2 ^ ((a AND 7) + 1): NoPalette = (a AND 128) = 0
GOSUB GetByte: Background = a
GOSUB GetByte: IF a <> 0 THEN PRINT "Bad screen descriptor.":
IF NoPalette = 0 THEN p$ = SPACE$(NumColors * 3): GET #1, , p$
DO
    GOSUB GetByte
    IF a = 44 THEN
        EXIT DO
    ELSEIF a <> 33 THEN
        PRINT "Unknown extension type.":
    END IF
    GOSUB GetByte
    DO: GOSUB GetByte: a$ = SPACE$(a): GET #1, , a$: LOOP UNTIL a = 0
LOOP
GET #1, , XStart: GET #1, , YStart: GET #1, , XLength: GET #1, , YLength
XEnd = XStart + XLength: YEnd = YStart + YLength: GOSUB GetByte
IF a AND 128 THEN PRINT "Can't handle local colormaps.":
Interlaced = a AND 64: PassNumber = 0: PassStep = 8
GOSUB GetByte
ClearCode = 2 ^ a
EOSCode = ClearCode + 1
FirstCode = ClearCode + 2: NextCode = FirstCode
StartCodeSize = a + 1: CodeSize = StartCodeSize
StartMaxCode = 2 ^ (a + 1) - 1: MaxCode = StartMaxCode

BitsIn = 0: BlockSize = 0: BlockPointer = 1
X = XStart: Y = YStart: Ybase = Y * 320&

DEF SEG = &HA000
IF NoPalette = 0 THEN
    OUT &H3C7, 0: OUT &H3C8, 0
    FOR a = 1 TO NumColors * 3: OUT &H3C9, ASC(MID$(p$, a, 1)) \ 4: NEXT
END IF
LINE (0, 0)-(319, 199), Background, BF
DO
    GOSUB GetCode
    IF Code <> EOSCode THEN
        IF Code = ClearCode THEN
            NextCode = FirstCode
            CodeSize = StartCodeSize
            MaxCode = StartMaxCode
            GOSUB GetCode
            CurCode = Code: LastCode = Code: LastPixel = Code
            IF X < 320 THEN POKE X + Ybase, LastPixel
            X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
        ELSE
            CurCode = Code: StackPointer = 0
            IF Code > NextCode THEN EXIT DO 'bad GIF if this happens
            IF Code = NextCode THEN
                CurCode = LastCode
                OutStack(StackPointer) = LastPixel
                StackPointer = StackPointer + 1
            END IF

            DO WHILE CurCode >= FirstCode
                OutStack(StackPointer) = Suffix(CurCode)
                StackPointer = StackPointer + 1
                CurCode = Prefix(CurCode)
            LOOP

            LastPixel = CurCode
            IF X < 320 THEN POKE X + Ybase, LastPixel
            X = X + 1: IF X = XEnd THEN GOSUB NextScanLine

            FOR a = StackPointer - 1 TO 0 STEP -1
                IF X < 320 THEN POKE X + Ybase, OutStack(a)
                X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
            NEXT

            IF NextCode < 4096 THEN
                Prefix(NextCode) = LastCode
                Suffix(NextCode) = LastPixel
                NextCode = NextCode + 1
                IF NextCode > MaxCode AND CodeSize < 12 THEN
                    CodeSize = CodeSize + 1
                    MaxCode = MaxCode * 2 + 1
                END IF
            END IF
            LastCode = Code
        END IF
    END IF
LOOP UNTIL DoneFlag OR Code = EOSCode
GOTO dun

GetByte: a$ = " ": GET #1, , a$: a = ASC(a$): RETURN

NextScanLine:
    IF Interlaced THEN
        Y = Y + PassStep
        IF Y >= YEnd THEN
            PassNumber = PassNumber + 1
            SELECT CASE PassNumber
            CASE 1: Y = 4: PassStep = 8
            CASE 2: Y = 2: PassStep = 4
            CASE 3: Y = 1: PassStep = 2
            END SELECT
        END IF
    ELSE
        Y = Y + 1
    END IF
    X = XStart: Ybase = Y * 320&: DoneFlag = Y > 199
RETURN
GetCode:
    IF BitsIn = 0 THEN GOSUB ReadBufferedByte: LastChar = a: BitsIn = 8
    WorkCode = LastChar \ ShiftOut(BitsIn)
    DO WHILE CodeSize > BitsIn
        GOSUB ReadBufferedByte: LastChar = a
        WorkCode = WorkCode OR LastChar * Powersof2(BitsIn)
        BitsIn = BitsIn + 8
    LOOP
    BitsIn = BitsIn - CodeSize
    Code = WorkCode AND MaxCode
RETURN
ReadBufferedByte:
    IF BlockPointer > BlockSize THEN
        GOSUB GetByte: BlockSize = a
        a$ = SPACE$(BlockSize): GET #1, , a$
        BlockPointer = 1
    END IF
    a = ASC(MID$(a$, BlockPointer, 1)): BlockPointer = BlockPointer + 1
RETURN
dun:
CLOSE
END FUNCTION

DEFSNG A-Z
FUNCTION pixelate$ (sz)
pxlate:
p = POINT(a, b)
LINE (a, b)-(a + sz, b + sz), p, BF
a = a + sz + 1
IF a > 320 THEN a = 0: b = b + sz + 1
IF b > 200 THEN  ELSE GOTO pxlate

END FUNCTION

FUNCTION size$ (n)
sizer:
r = INT(RND(1) * 2)
p = POINT(a, b)
PSET (a / n, b / n), p
a = a + 2
IF a > 320 THEN a = 0: b = b + 2
IF b > 200 THEN  ELSE GOTO sizer

END FUNCTION