'===========================================================================
' Subject: SVGA 24-BIT COLOR GRAPHICS        Date: 01-16-99 (10:59)       
' Author:  Anthony Tyler                     Code: QB, PDS                
' Origin:  ATyler@aol.com                  Packet: GRAPHICS.ABC
'===========================================================================
DECLARE SUB SetText ()
' Hi everybody its me again. I'm the maker of the SVGA 16 Bit graphic thingy
' if you remember. Well this is another SVGA thing, but its 24 bit graphics.
' Each register takes up a byte ie Red = 1 byte, Green = 1 byte, and Blue = 1
' byte. That means that each register can have 256 combinations. This gives us
' 256*256*256 colors or 16,777,216 colors and thats great!! Every single
' program in Windows uses this mode, yet no programs in DOS use this mode.
' Until now... In this program I have provided you with a GIF viewer.
' If you created a program using any of these routines or have created your own
' routines looking at these routines for reference then please put my name in
' your program somewhere(Anthony Tyler). If you have improved these very slow
' routines at all please send me a copy of the improved routines. My E-Mail
' address is: ATyler85@aol.com
' - Anthony
DECLARE SUB ShowGIF (a$)
DECLARE SUB Pixel (X%, Y%, r%, g%, b%)
DECLARE SUB InitASM ()
DEFINT A-Z
'$INCLUDE: 'qb.bi'
DIM SHARED inregs AS RegType, outregs AS RegType, curbank, BANK.asm$
' If you do not want to use the GIF routines you can delete the following
' three lines. Along with the SUB ShowGif
DIM SHARED PAL(256, 3) AS INTEGER
DIM SHARED Prefix(4095), Suffix(4095), OutStack(4095), ShiftOut(8)
DIM SHARED Ybase AS LONG, Powersof2(11) AS LONG, WorkCode AS LONG
InitASM  'This sub initializes the assembly routines, but don't worry
         ' I only used it for speed
inregs.ax = &H4F02
inregs.bx = &H112
CALL INTERRUPT(&H10, inregs, outregs)
ShowGIF "font.gif"  ' GIF File goes here
asdfsa$ = INPUT$(1)
SetText
END

SUB InitASM
BANK.asm$ = ""
BANK.asm$ = BANK.asm$ + CHR$(&H55)                                    'PUSH     BP
BANK.asm$ = BANK.asm$ + CHR$(&H89) + CHR$(&HE5)                       'MOV      BP,SP
BANK.asm$ = BANK.asm$ + CHR$(&HB8) + CHR$(&H5) + CHR$(&H4F)           'MOV      AX,4F05
BANK.asm$ = BANK.asm$ + CHR$(&HBB) + CHR$(&H0) + CHR$(&H0)            'MOV      BX,0000
BANK.asm$ = BANK.asm$ + CHR$(&H8B) + CHR$(&H56) + CHR$(&H6)           'MOV      DX,[BP+06]
BANK.asm$ = BANK.asm$ + CHR$(&HCD) + CHR$(&H10)                       'INT      10
BANK.asm$ = BANK.asm$ + CHR$(&H5D)                                    'POP      BP
BANK.asm$ = BANK.asm$ + CHR$(&HCB)                                    'RETF
END SUB

SUB Pixel (X, Y, r, g, b)
DEF SEG = &HA000
offset& = (Y * 4) * 640& + (X * 4)
BANK = INT(offset& \ &H10000)
offset& = offset& - &H10000 * BANK
IF BANK <> curbank THEN
BANK% = BANK ' must make it an integer
' These statements are the same as the assembly ones, but in QB.
'
'  InRegs.ax = &H4F05
'  InRegs.bx = 0
'  InRegs.dx = curBank
'  CALL INTERRUPT(&H10, InRegs, OutRegs)

 DEF SEG = VARSEG(BANK.asm$)
  CALL ABSOLUTE(BYVAL BANK%, SADD(BANK.asm$))
 DEF SEG
 DEF SEG = &HA000
END IF
curbank = BANK
POKE offset&, b
POKE offset& + 1, g
POKE offset& + 2, r
END SUB

SUB SetText
inregs.ax = &H3
CALL INTERRUPT(&H10, inregs, outregs)
END SUB

SUB ShowGIF (a$)
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.": 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 * 640&

IF NoPalette = 0 THEN
     FOR a = 1 TO NUMCOLORS * 3 STEP 3
     PAL(b, 1) = ASC(MID$(P$, a, 1))
     PAL(b, 2) = ASC(MID$(P$, a + 1, 1))
     PAL(b, 3) = ASC(MID$(P$, a + 2, 1))
     b = b + 1
     NEXT
END IF

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 < 640 THEN Pixel X, Y, PAL(LastPixel, 1), PAL(LastPixel, 2), PAL(LastPixel, 3)
            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 < 640 THEN Pixel X, Y, PAL(LastPixel, 1), PAL(LastPixel, 2), PAL(LastPixel, 3)
            X = X + 1: IF X = XEnd THEN GOSUB NextScanLine

            FOR a = StackPointer - 1 TO 0 STEP -1
                IF X < 640 THEN Pixel X, Y, PAL(OutStack(a), 1), PAL(OutStack(a), 2), PAL(OutStack(a), 3)
                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
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 * 640&: DoneFlag = Y > 479
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