'GRAPHIC2.TXT example program
'GRAPHIC2.BAS by David Zohrob
'
'The SUBroutine BSAVEExample shows how to BSAVE a picture.
'The rest of the program is an animation.
'
'GIF loading author is unknown.
'
'Taken from The QBasic Page at http://qbasic.com
'
'
DECLARE SUB BSAVEExample ()
DECLARE SUB GifLoad (a$)

GifLoad "palette.gif": CLOSE
DIM m1(6200)
DIM mallard(8000)
SCREEN 13
speed = 1000
DO
FOR i = 1 TO 8
IF x < 95 THEN x = x + 1:  ELSE EXIT DO
'IF y < 50 THEN y = y + 1
DEF SEG = VARSEG(m1(0)): BLOAD "b" + LTRIM$(STR$(i)) + ".gfx", 0: DEF SEG
PUT (x, y), m1, PSET
ERASE m1
FOR j = 1 TO speed: NEXT
NEXT
LOOP

FOR z = 1 TO 3
FOR i = 1 TO 8
DEF SEG = VARSEG(m1(0)): BLOAD "b" + LTRIM$(STR$(i)) + ".gfx", 0: DEF SEG
PUT (x, y), m1, PSET
ERASE m1
FOR j = 1 TO speed: NEXT
NEXT
NEXT z

speed = speed - (speed \ 1.5)

DEF SEG = VARSEG(mallard(0)): BLOAD "mallard.gfx", 0: DEF SEG

x2 = 60
y2 = 119
DO
FOR i = 1 TO 8
IF y2 >= 80 THEN y2 = y2 - 1:  ELSE EXIT DO
PUT (x2, y2), mallard, PSET
DEF SEG = VARSEG(m1(0)): BLOAD "b" + LTRIM$(STR$(i)) + ".gfx", 0: DEF SEG
PUT (x, y), m1, PSET
ERASE m1
FOR j = 1 TO speed: NEXT
NEXT
LOOP

speed = speed - (speed \ 2)
a = 101
DO
FOR i = 1 TO 8
DEF SEG = VARSEG(m1(0)): BLOAD "b" + LTRIM$(STR$(i)) + ".gfx", 0: DEF SEG
PUT (x, y), m1, PSET
ERASE m1
FOR j = 1 TO speed: NEXT
IF s < 60 THEN
s = s + 1: PALETTE s + 100, s: s = s + 1: PALETTE s + 100, s: s = s + 1: PALETTE s + 100, s
s = s + 1: PALETTE s + 100, s: s = s + 1: PALETTE s + 100, s: s = s + 1: PALETTE s + 100, s
END IF
IF s = 60 THEN
IF ajsaikj = 0 THEN speed = speed * 2: ajsaikj = 1
a = a + .25
IF a >= 160 THEN EXIT DO
COLOR INT(a)
LOCATE 18, 15
PRINT "presents"
END IF
NEXT
LOOP

i = 0
DO WHILE INKEY$ = ""
i = i + 1: IF i = 9 THEN i = 1
DEF SEG = VARSEG(m1(0)): BLOAD "b" + LTRIM$(STR$(i)) + ".gfx", 0: DEF SEG
PUT (x, y), m1, PSET
ERASE m1
FOR j = 1 TO speed: NEXT
LOOP
DEFINT A-Z


DEFSNG A-Z
SUB BSAVEExample
GifLoad "mallard.gif"
DIM mallard(10000)
GET (0, 0)-(200, 80), mallard
DEF SEG = VARSEG(mallard(0))
BSAVE "mallard.gfx", 0, 10000
DEF SEG
END SUB

SUB GifLoad (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 a%
FOR a% = 0 TO 11: powersof2(a%) = 2 ^ a%: NEXT a%
IF a$ = "" THEN INPUT "GIF file"; a$: IF a$ = "" THEN END
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.": END
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.": END
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
    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.": END
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&

SCREEN 13: 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 a%
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
            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 a%

            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
'BEEP
'A$ = INPUT$(1)
EXIT SUB

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

END SUB

