'===========================================================================
' Subject: 400X200 18-BIT COLOR MODE         Date: 02-16-99 (09:51)       
' Author:  Jernej Simoncic                   Code: QB, QBasic, PDS        
' Origin:  jernej.simoncic@guest.arnes.si  Packet: GRAPHICS.ABC
'===========================================================================
'Pseudo 18-bit color mode. This is a 400x200 18 bit color mode for use with
'Quick Basic. It has complete primitive support (Pset, Line, Circle) and even
'Get and Put.
'To see demo & speed test, run program.
'
'What is 'pseudo-18-bit' mode?
'This is actually a Mode-X 400x600 256-color mode. Palette colors are set to
'shades of red, green and blue. To achieve 18 bit color effect, 3 pixels are
'drawn next to each other, first with red shade, second with green and third
'with blue shade. This color mode should work on *any* VGA.
'
'Note for QB4.x users: Load with QB /L or this program won't work. (FillChar
' uses CALL ABSOLUTE)
'
'Credits:
'Mode-X rutine was taken from SLIX 0.987 by Lloyd Chang
'Ellipse drawing algorithm and GIF loader by Righ Geldreich
'
'Use this program as you wish, just give me a credit.
'
'         Jernej Simoncic, jernej.simoncic@guest.arnes.si
'
DEFINT A-Z
DECLARE FUNCTION GifView% (a$)
DECLARE SUB MakeChars ()
DECLARE SUB PutX (xx%, yy%, Array%())
DECLARE SUB GetX (x1%, y1%, x2%, y2%, Array%())
DECLARE SUB CircleX (x%, y%, r%, rx%, gc%, bc%)
DECLARE SUB EllipseX (ox%, oy%, prx%, pry%, r%, g%, bl%)
DECLARE SUB LineX (x1%, y1%, x2%, y2%, r%, g%, bl%, style%)
DECLARE SUB Center (txt$, y%, r%, g%, bl%)
DECLARE SUB LoadSCN (file$)
DECLARE SUB SaveSCN (file$)
DECLARE SUB PrintX (txt$, x%, y%, r%, g%, bl%)
DECLARE SUB Set18bitMode ()
DECLARE SUB ClearScn ()
DECLARE SUB FillChar (segment%, offset%, value%, bytes%)
DECLARE SUB SetPal (c%, r%, g%, bl%)
DECLARE SUB PsetX (x%, y%, r%, g%, bl%)
DECLARE SUB CharLoad ()
DECLARE FUNCTION BIN$ (Number&)
DECLARE FUNCTION BIND& (Number$)
DECLARE FUNCTION SBL& (DWORD&, Shifter%)
DECLARE SUB outport (Addr&, WORD&)
DIM SHARED Char(255, 7, 7) AS STRING * 1, LookUp(3) AS INTEGER
CONST B = 1, BF = 2           'use with LineX

DIM Test(9000) AS INTEGER

'============================================================================'
'                                    Demo                                    '
'============================================================================'

Set18bitMode

tt! = TIMER
DO
     PsetX INT(RND * 400), INT(RND * 200), INT(RND * 64), INT(RND * 64), INT(RND * 64)
     a = a + 1
LOOP UNTIL TIMER - tt! >= 1
LineX 0, 0, 400, 200, 0, 0, 63, 0
EllipseX 200, 100, 50, 50, 63, 0, 63
CircleX 200, 100, 50, 0, 63, 63
LineX 40, 40, 360, 160, 47, 47, 47, B
LineX 190, 93, 210, 106, 31, 31, 31, BF
Center "Pseudo 18-bit color mode by Jernej SimonŸiŸ", 10, 63, 63, 63
Center "This mode has all the QBasic primitives:", 30, 63, 63, 0
Center "Circles, Lines, Boxes and of course Pset.", 40, 63, 63, 0
Center "Even Get & Put and saving whole screen to file.", 50, 63, 63, 0
PrintX "Press any key to save screen to file... (without  this text)", 0, 90, 0, 63, 0
GetX 50, 10, 89, 40, Test()
PutX 10, 150, Test()
SLEEP
PrintX "Press any key to save screen to file... (without  this text)", 0, 90, 0, 0, 0
SaveSCN "abc"
ClearScn
PrintX "Press any key to restore screen...", 0, 0, 0, 0, 63
SLEEP
LoadSCN "abc"
SLEEP
ClearScn
PrintX "Pixel drawing speed test:", 0, 0, 63, 63, 63
a = 0
t! = TIMER
DO
     a = a + 1
     PsetX RND * 400, RND * 200, RND * 64, RND * 64, RND * 64
LOOP UNTIL TIMER >= t! + 1
PrintX "Line drawing speed test:", 0, 10, 63, 63, 63
bb = 0
t! = TIMER
DO
     bb = bb + 1
     LineX RND * 400, RND * 200, RND * 400, RND * 200, RND * 64, RND * 64, RND * 64, 0
LOOP UNTIL TIMER >= t! + 1
PrintX "Circle drawing speed test:", 0, 20, 63, 63, 63
c = 0
t! = TIMER
DO
     c = c + 1
     EllipseX RND * 300, RND * 150, RND * 150, RND * 80, RND * 64, RND * 64, RND * 64
LOOP UNTIL TIMER >= t! + 1
PrintX "Box drawing speed test:", 0, 30, 63, 63, 63
d = 0
t! = TIMER
DO
     d = d + 1
     LineX RND * 400, RND * 200, RND * 400, RND * 200, RND * 64, RND * 64, RND * 64, B
LOOP UNTIL TIMER >= t! + 1
PrintX "Filled box drawing speed test:", 0, 40, 63, 63, 63
e = 0
t! = TIMER
DO
     e = e + 1
     LineX RND * 400, RND * 200, RND * 400, RND * 200, RND * 64, RND * 64, RND * 64, BF
LOOP UNTIL TIMER >= t! + 1
PrintX "Get 16x16 spirite speed test:", 0, 50, 63, 63, 63
f = 0
t! = TIMER
DO
     f = f + 1
     x = RND * 380
     y = RND * 180
     GetX x, y, x + 16, y + 16, Test()
LOOP UNTIL TIMER >= t! + 1
PrintX "Put 16x16 spirite speed test:", 0, 60, 63, 63, 63
g = 0
t! = TIMER
DO
     g = g + 1
     x = RND * 380
     y = RND * 180
     PutX x, y, Test()
LOOP UNTIL TIMER >= t! + 1
PrintX "Print one letter speed test:", 0, 70, 63, 63, 63
h = 0
t! = TIMER
DO
     h = h + 1
     PrintX CHR$(RND * 255), RND * 390, RND * 190, RND * 64, RND * 64, RND * 64
LOOP UNTIL TIMER >= t! + 1

LineX 0, 0, 399, 80, 0, 0, 31, BF
LineX 0, 0, 399, 0, 0, 0, 63, 0
LineX 0, 0, 0, 80, 0, 0, 63, 0
LineX 399, 80, 0, 80, 0, 0, 15, 0
LineX 399, 80, 399, 0, 0, 0, 15, 0

PrintX "Pixel drawing speed test:", 0, 0, 63, 63, 63
PrintX STR$(a) + " pixels/second", 200, 0, 63, 63, 0
PrintX "Line drawing speed test:", 0, 10, 63, 63, 63
PrintX STR$(bb) + " lines/second", 192, 10, 63, 63, 0
PrintX "Circle drawing speed test:", 0, 20, 63, 63, 63
PrintX STR$(c) + " circles/second", 208, 20, 63, 63, 0
PrintX "Box drawing speed test:", 0, 30, 63, 63, 63
PrintX STR$(d) + " boxes/second", 184, 30, 63, 63, 0
PrintX "Filled box drawing speed test:", 0, 40, 63, 63, 63
PrintX STR$(e) + " boxes/second", 240, 40, 63, 63, 0
PrintX "Get 16x16 spirite speed test:", 0, 50, 63, 63, 63
PrintX STR$(f) + " gets/second", 232, 50, 63, 63, 0
PrintX "Put 16x16 spirite speed test:", 0, 60, 63, 63, 63
PrintX STR$(g) + " puts/second", 232, 60, 63, 63, 0
PrintX "Print one letter speed test:", 0, 70, 63, 63, 63
PrintX STR$(h) + " letters/second", 224, 70, 63, 63, 0
SLEEP
ClearScn
Center "Enter name of GIF file to load!", 0, 63, 63, 63
LineX 0, 10, 399, 20, 0, 0, 31, BF
DO
     DO: in$ = INKEY$: LOOP WHILE in$ = ""
     SELECT CASE in$
          CASE CHR$(8)
               IF LEN(s$) > 0 THEN s$ = LEFT$(s$, LEN(s$) - 1)
          CASE CHR$(27)
               s$ = ""
               EXIT DO
          CASE CHR$(13)
               EXIT DO
          CASE ELSE
               s$ = s$ + in$
     END SELECT
     LineX 0, 10, 399, 20, 0, 0, 31, BF
     PrintX s$, 0, 11, 63, 63, 0
LOOP
ON ERROR GOTO gifErr
IF s$ <> "" THEN a% = GifView(s$) ELSE a% = 0
Res:
ON ERROR GOTO 0
IF a% <> 0 THEN Center "Error in GIF file!", 20, 63, 0, 0
Center "Press any key to quit demo...", 191, 47, 47, 47
SLEEP
SCREEN 0
WIDTH 80
END

gifErr:
a% = 6
RESUME Res

           'from SLIX
FUNCTION BIN$ (Number&)
DO WHILE Number& > 0
  bit% = Number& MOD 2
  Number& = Number& \ 2
  Number$ = RIGHT$(STR$(bit%), 1) + Number$
LOOP
BIN$ = Number$
END FUNCTION

           'from SLIX
'Limited from 0 to 2,147,483,647 (1111111111111111111111111111111)
FUNCTION BIND& (Number$)
FOR Count% = LEN(Number$) TO 1 STEP -1
  IF MID$(Number$, Count%, 1) = "1" THEN Number& = (Number& + (2 ^ (LEN(Number$) - Count%)))
NEXT Count%
BIND& = Number&
END FUNCTION

' Center - center text on screen
'
' Usage: Center text$, y%, r%, g%, b%
'
SUB Center (txt$, y%, r%, g%, bl%)
PrintX txt$, 200 - LEN(txt$) * 4, y%, r%, g%, bl%
END SUB

' CharLoad - load fonts (called automatically)
SUB CharLoad
OPEN "8x8chars.fnt" FOR BINARY AS 1
IF LOF(1) <> 16384 THEN            'font file does not exist or corrupted
     CLOSE
     SCREEN 0
     MakeChars
     SCREEN 0
     WIDTH 80
     PRINT "Font file created."
     PRINT "Please re-run program."
     END
END IF
FOR a = 0 TO 255
     FOR x = 0 TO 7
          FOR y = 0 TO 7
               GET 1, , Char(a, x, y)
NEXT y, x, a
CLOSE 1
END SUB

' CircleX - draw circle
'
' Usage: CircleX x%, y%, radius%, r%, g%, b%
'
SUB CircleX (x%, y%, r%, rx%, gc%, bc%)
EllipseX x%, y%, r%, r% * (2 / 3), rc%, gc%, bc%
END SUB

' ClearScn - clears scren
'
' Usage: ClearScn
'
SUB ClearScn
OUT &H3C4, 2
OUT &H3C5, 1
FillChar &HA000, 0, 0, &HFFFF
OUT &H3C5, 2
FillChar &HA000, 0, 0, &HFFFF
OUT &H3C5, 4
FillChar &HA000, 0, 0, &HFFFF
OUT &H3C5, 8
FillChar &HA000, 0, 0, &HFFFF
END SUB

' EllipseX - draws ellipse
'
' Usage: EllipseX x%, y%, Xradius%, Yradius%, r%, g%, b%
'
' Converted from Rich Geldreich's DrawEllipse
'
SUB EllipseX (ox, oy, prx, pry, r, g, bl)
  DIM xe AS LONG, ye AS LONG, e AS LONG
  IF pry = 0 THEN 'special cases for horizontal & vertical ellipses
    LineX ox - prx, oy, ox + prx, oy, r, g, bl, 0
    EXIT SUB
  END IF
  IF prx = 0 THEN
    LineX ox, oy - pry, ox, oy + pry, r, g, bl, 0
    EXIT SUB
  END IF
  'work with largest axis to avoid rounding errors
  IF pry <= prx THEN
    x = 0: y = pry
    xe = 0: ye = CLNG(prx) * prx
    e = -ye \ 2: c = ye \ pry
    DO
      IF e <= 0 THEN
        DO
          PsetX ox + x, oy + y, r, g, bl: PsetX ox - x, oy + y, r, g, bl
          PsetX ox + x, oy - y, r, g, bl: PsetX ox - x, oy - y, r, g, bl
          x = x + 1
          xe = xe + pry
          e = e + xe
        LOOP WHILE e <= 0
      ELSE
        PsetX ox + x, oy + y, r, g, bl: PsetX ox - x, oy + y, r, g, bl
        PsetX ox + x, oy - y, r, g, bl: PsetX ox - x, oy - y, r, g, bl
      END IF
      y = y - 1
      ye = ye - c
      e = e - ye
    LOOP UNTIL y = 0
    PsetX ox + x, oy, r, g, bl: PsetX ox - x, oy, r, g, bl
    PsetX ox + x, oy, r, g, bl: PsetX ox - x, oy, r, g, bl
  ELSE
    x = 0: y = prx
    xe = 0: ye = CLNG(pry) * pry
    e = -ye \ 2: c = ye \ prx
    DO
      IF e <= 0 THEN
        DO
          PsetX ox + y, oy + x, r, g, bl: PsetX ox - y, oy + x, r, g, bl
          PsetX ox + y, oy - x, r, g, bl: PsetX ox - y, oy - x, r, g, bl
          x = x + 1
          xe = xe + prx
          e = e + xe
        LOOP WHILE e <= 0
      ELSE
        PsetX ox + y, oy + x, r, g, bl: PsetX ox - y, oy + x, r, g, bl
        PsetX ox + y, oy - x, r, g, bl: PsetX ox - y, oy - x, r, g, bl
      END IF
      y = y - 1
      ye = ye - c
      e = e - ye
    LOOP UNTIL y = 0
    PsetX ox, oy + x, r, g, bl: PsetX ox, oy + x, r, g, bl
    PsetX ox, oy - x, r, g, bl: PsetX ox, oy - x, r, g, bl
  END IF
END SUB

'*****************************************************
'***                 FillChar()                    ***
'*****************************************************
'***  FillChar() puts whatever is in value% (which ***
'***  should be a number from 0-255) into memory   ***
'***  starting at location segment:offset, ending  ***
'***  at location segment:offset+bytes%.  An good  ***
'***  example of its use would be for clearing the ***
'***  screen with a different background color in  ***
'***  a graphics screen (which is pitifully slow   ***
'***  usint PSET).  To do this for SCREEN 13, for  ***
'***  example:                                     ***
'***                                               ***
'***  FillChar &HA000, 0, 15, &HFA00               ***
'***             ^     ^   ^    ^                  ***
'***             |     |   |    |                  ***
'***  Screen 13--+     |   |    |                  ***
'***                   |   |    |                  ***
'*** Start with first  |   |    |                  ***
'*** pixel.------------+   |    |                  ***
'***                       |    |                  ***
'*** Fill with character/  |    |                  ***
'*** color 15--------------+    |                  ***
'***                            |                  ***
'*** Do so 64,000 times---------+                  ***
'***                                               ***
'*** This will "clear" SCREEN 13 with the color 15 ***
'*** (bright white), and it does so _faster_ than  ***
'*** the CLS routine clears SCREEN 13 in black.    ***
'***                                               ***
'*** Notice that the 64,000 is in HEX (FA00).  This***
'*** is the same as with MemCopy(), where a value  ***
'*** greater than 32,767 has to be put into hex.   ***
'*** Since BASIC integers are signed (can be plus  ***
'*** or minues 32,767), BASIC does not let you use ***
'*** 65,534 (64k) in an integer, and there is no   ***
'*** way to declare a variable as an unsigned int- ***
'*** eger.  Machine Language, however, does not    ***
'*** recognize the plus or minus of a number unless***
'*** you tell it to, so by using the HEX value, we ***
'*** can trick BASIC into passing a number larger  ***
'*** than 32767 to the Machine Language routine,   ***
'*** which will treat &HFA00 as 64000 (even though ***
'*** if you do a PRINT &HFA00 it returns -1536).   ***
'*****************************************************
'Note: Used by ClearScn, Set18bitMode & LineX
SUB FillChar (segment%, offset%, value%, bytes%)

asm$ = ""
asm$ = asm$ + CHR$(85)                             'PUSH BP
asm$ = asm$ + CHR$(137) + CHR$(229)                'MOV BP,SP
asm$ = asm$ + CHR$(139) + CHR$(78) + CHR$(6)       'MOV CX,[BP+06]
asm$ = asm$ + CHR$(139) + CHR$(86) + CHR$(8)       'MOV DX,[BP+08]
asm$ = asm$ + CHR$(139) + CHR$(70) + CHR$(12)      'MOV AX,[BP+0C]
asm$ = asm$ + CHR$(30)                             'PUSH DS
asm$ = asm$ + CHR$(142) + CHR$(216)                'MOV DS,AX
asm$ = asm$ + CHR$(139) + CHR$(94) + CHR$(10)      'MOV BX,[BP+0A]
asm$ = asm$ + CHR$(136) + CHR$(23)                 'MOV [BX],DL <------+
asm$ = asm$ + CHR$(67)                             'INC BX             |
asm$ = asm$ + CHR$(226) + CHR$(251)                'LOOP 0112   -------+
asm$ = asm$ + CHR$(31)                             'POP DS
asm$ = asm$ + CHR$(93)                             'POP BP
asm$ = asm$ + CHR$(203)                            'RETF

DEF SEG = VARSEG(asm$)
   CALL Absolute(BYVAL segment%, BYVAL offset%, BYVAL value%, BYVAL bytes%, SADD(asm$))
DEF SEG

END SUB

' GetX - get a portion of scren to array (be carefull with thisone it may not
'        calculate correct values for array size)
'
' Usage: GetX x1%, y1%, x2%, y2%, Array()
'
SUB GetX (x1%, y1%, x2%, y2%, Array())

IF x2% < x1% THEN SWAP x2%, x1%
IF y2% < y1% THEN SWAP y2%, y1%

IF x1% > 399 THEN x1% = 399
IF x2% > 399 THEN x2% = 399
IF y1% > 199 THEN y1% = 199
IF y2% > 199 THEN y2% = 199

IF x1% < 0 THEN x1% = 0
IF x2% < 0 THEN x2% = 0
IF y1% < 0 THEN y1% = 0
IF y2% < 0 THEN y2% = 0

xSize = x2% - x1% + 1
ySize = y2% - y1% + 1
reqd = ((xSize + 1) \ 2) * ySize * 3 + 1

IF UBOUND(Array) < reqd THEN ERROR 5

Array(0) = xSize * 18 'QB stores x size as (x2-x1)*BitDepth ;)
Array(1) = ySize

FOR x% = x1% TO x2%
    
     OUT &H3CE, 4
     OUT &H3CF, (x MOD 4)

     FOR y% = y1% * 3 TO y2% * 3 + 2

          DEF SEG = &HA000
          yCord& = y%
          by = PEEK((100 * yCord&) + (x% \ 4))

          DEF SEG = VARSEG(Array(2))
          POKE VARPTR(Array(2)) + (x% - x1%) + (y% - y1% * 3) * xSize, by
     NEXT
NEXT
END SUB

'GifView - load GIF file
'
' Usage: error% = GifView(filename$)
'
'  error%:  0   - no error
'           1   - file not a GIF87a file
'           2   - bad screen descriptor
'           3   - unknown extension type
'           4   - file has local colormaps
'           255 - no file name given
'
' Original by Rich Geldreich
'
FUNCTION GifView (a$)
DIM Prefix(4095), Suffix(4095), OutStack(4095), ShiftOut(8)
DIM PalLook(255, 2) AS INTEGER 'Palette lookup table

'The following line is for the QB environment(slow).
DIM Ybase AS LONG, Powersof2(11) AS LONG, WorkCode AS LONG
'For more speed, unremark the next line and remark the one above,
'before you compile... (Change back when inside the environment.)
'DIM Ybase AS INTEGER, Powersof2(11) AS INTEGER, WorkCode AS INTEGER

FOR a = 0 TO 7: ShiftOut(8 - a) = 2 ^ a: NEXT
FOR a = 0 TO 11: Powersof2(a) = 2 ^ a: NEXT
'A$ = COMMAND$: IF A$ = "" THEN INPUT "GIF file"; A$: IF A$ = "" THEN END
IF a$ = "" THEN GifView = 255: EXIT FUNCTION
IF INSTR(a$, ".") = 0 THEN a$ = a$ + ".gif"
OPEN a$ FOR BINARY AS #1
a$ = "      ": GET #1, , a$
IF a$ <> "GIF87a" THEN GifView = 1: EXIT FUNCTION
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 GifView = 2: EXIT FUNCTION
IF NoPalette = 0 THEN
     p$ = SPACE$(NumColors * 3): GET #1, , p$
     FOR i% = 0 TO 255'len(p$)
          PalLook(i%, 0) = ASC(MID$(p$, 1 + 3 * i%, 1)) \ 4
          PalLook(i%, 1) = ASC(MID$(p$, 2 + 3 * i%, 1)) \ 4
          PalLook(i%, 2) = ASC(MID$(p$, 3 + 3 * i%, 1)) \ 4
     NEXT
END IF
DO
    GOSUB GetByte
    IF a = 44 THEN
        EXIT DO
    ELSEIF a <> 33 THEN
        GifView = 3: EXIT FUNCTION
    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 GifView = 4: EXIT FUNCTION
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 * 400&

'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
'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 < 400 THEN PsetX x, y, PalLook(LastPixel, 0), PalLook(LastPixel, 1), PalLook(LastPixel, 2)
            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 < 400 THEN PsetX x, y, PalLook(LastPixel, 0), PalLook(LastPixel, 1), PalLook(LastPixel, 2)
            x = x + 1: IF x = XEnd THEN GOSUB NextScanLine

            FOR a = StackPointer - 1 TO 0 STEP -1
                IF x < 400 THEN PsetX x, y, PalLook(OutStack(a), 0), PalLook(OutStack(a), 1), PalLook(OutStack(a), 2)
                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
'a$ = INPUT$(1)
EXIT FUNCTION

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
        DoneFlag = y > 199
    END IF
    x = XStart: Ybase = y * 400&
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 FUNCTION

' LineX - draw line, box or filled box
'
' Usage: LineX x1%, y1%, x2%, y2%, r%, g%, b%, style%
'
'   style%:  0    - line
'            1=B  - box
'            2=BF - filled box
'
SUB LineX (x1%, y1%, x2%, y2%, r%, g%, bl%, style%)

SELECT CASE style
     CASE 0
          DX2% = 1
          a% = x2% - x1%: IF a% < 0 THEN a% = -a%: DX2% = -1
          DY2% = 1
          bb% = y2% - y1%: IF bb% < 0 THEN bb% = -bb%: DY2% = -1
          DX1% = DX2%: DY1% = 0
          IF a% < bb% THEN SWAP a%, bb%: DX1% = 0: DY1% = DY2%
          I1% = bb% * 2
          d% = I1% - a%
          I2% = d% - a%
          x% = x1%: y% = y1%
          FOR i% = 0 TO a%
               PsetX x%, y%, r%, g%, bl%
               IF d% < 0 THEN
                    x% = x% + DX1%
                    y% = y% + DY1%
                    d% = d% + I1%
               ELSE
                    x% = x% + DX2%
                    y% = y% + DY2%
                    d% = d% + I2%
               END IF
          NEXT
     CASE 1
          IF x1 > x2 THEN SWAP x1, x2
          IF y1 > y2 THEN SWAP y1, y2
          FOR x = x1 TO x2
               PsetX x, y1%, r%, g%, bl%
               PsetX x, y2%, r%, g%, bl%
          NEXT
          FOR y = y1 TO y2
               PsetX x1%, y, r%, g%, bl%
               PsetX x2%, y, r%, g%, bl%
          NEXT
     CASE ELSE
          IF x1% > x2 THEN SWAP x1%, x2%
          IF y1% > y2 THEN SWAP y1%, y2%
          IF x1% < 0 THEN x1% = 0
          IF x2% > 399 THEN x2% = 399
          IF y1% < 0 THEN y1% = 0
          IF y2% > 199 THEN y2% = 199
          byts = (x2 - x1) \ 4
          FOR x = 0 TO 3
               OUT &H3C4, 2
               OUT &H3C5, LookUp(x)
               FOR y = y1 * 3 TO y2 * 3 STEP 3
                    yy& = y
                    strt& = yy& * 100 + x1 \ 4
                    IF strt& > 32767 THEN strt = strt& - 65536 ELSE strt = strt&
                    FillChar &HA000, strt, r%, byts
                    strt& = strt& + 100
                    IF strt& > 32767 THEN strt = strt& - 65536 ELSE strt = strt&
                    FillChar &HA000, strt, g% + 64, byts
                    strt& = strt& + 100
                    IF strt& > 32767 THEN strt = strt& - 65536 ELSE strt = strt&
                    FillChar &HA000, strt, bl% + 128, byts
               NEXT
          NEXT
END SELECT

END SUB

' LoadSCN - load previously saved screen (see SaveSCN)
'
' Usage: LoadSCN filename$
'
SUB LoadSCN (file$)
IF INSTR(file$, ".") > 0 THEN file$ = LEFT$(file$, INSTR(file$, ".")) ELSE file$ = file$ + "."
OUT &H3C4, 2
OUT &H3C5, 1
DEF SEG = &HA000
BLOAD file$ + "bs1"
DEF SEG
OUT &H3C4, 2
OUT &H3C5, 2
DEF SEG = &HA000
BLOAD file$ + "bs2"
DEF SEG
OUT &H3C4, 2
OUT &H3C5, 4
DEF SEG = &HA000
BLOAD file$ + "bs3"
DEF SEG
OUT &H3C4, 2
OUT &H3C5, 8
DEF SEG = &HA000
BLOAD file$ + "bs4"
DEF SEG
END SUB

' MakeChars - make font file (this sub is called first time you run program)
'
SUB MakeChars
SCREEN 13
LOCATE 5, 1: PRINT "Please, wait, building font file...";
nul$ = CHR$(0): Ful$ = CHR$(219)
OPEN "8x8chars.fnt" FOR BINARY AS 1
FOR a = 0 TO 255
     LOCATE 1, 1: IF a <> 7 THEN PRINT CHR$(a) ELSE PRINT " "
     IF a = 32 THEN LOCATE 5, 1: PRINT "Please, wait, building font file..."
     FOR x = 0 TO 7
          FOR y = 0 TO 7
               l = POINT(x, y)
               IF l = 0 THEN PUT 1, , nul$ ELSE PUT 1, , Ful$
               PSET (x, y), 15 - l
          NEXT
     NEXT
NEXT
END SUB

SUB outport (Addr&, WORD&)
OUT Addr&, (WORD& MOD 256)
OUT Addr& + 1, (WORD& \ 256)
END SUB

' PointX - read point from screen
'
' Usage: PointX x%, y%, r%, g%, b%
'
' Returns: r%, g%, b%
'
SUB PointX (x, y, r, g, bl)

yCord& = y * 3

OUT &H3CE, 4
OUT &H3CF, (x MOD 4)
DEF SEG = &HA000

r = PEEK((100 * yCord&) + (x \ 4))
g = PEEK((100 * (yCord& + 1)) + (x \ 4)) - 64
bl = PEEK((100 * (yCord& + 2)) + (x \ 4)) - 128

DEF SEG
END SUB

' PrintX - print text to screen
'
' Usage: PrintX text$, x%, y%, r%, g%, b%
'
SUB PrintX (txt$, x%, y%, r%, g%, bl%)
pX% = x%
FOR a% = 1 TO LEN(txt$)
     t$ = MID$(txt$, a%, 1)
     tl% = ASC(t$)
     FOR cX% = 0 TO 7
          FOR cy% = 0 TO 7
               IF Char(tl%, cX%, cy%) <> CHR$(0) AND pX% + cX% < 400 THEN PsetX pX% + cX%, y% + cy%, r%, g%, bl%
          NEXT
     NEXT
     pX% = pX% + 8
     IF pX% >= 399 THEN pX% = 0: y% = y% + 8
     IF y% + 7 >= 200 THEN EXIT SUB
NEXT
END SUB

' PsetX - set rgb point
'
' Usage: PsetX x%, y%, r%, g%, b%
'
SUB PsetX (x, y, r, g, bl)
IF x > 399 OR x < 0 THEN EXIT SUB
IF y > 199 OR y < 0 THEN EXIT SUB
OUT &H3C4, 2
OUT &H3C5, LookUp(x MOD 4)
yCord& = y * 3
red& = ((100 * yCord&) + (x \ 4))
grn& = ((100 * (yCord& + 1)) + (x \ 4))
blu& = ((100 * (yCord& + 2)) + (x \ 4))
DEF SEG = &HA000
POKE red&, r
POKE grn&, g + 64
POKE blu&, bl + 128
DEF SEG
END SUB

' PutX - put image from array previously created with GetX to screen
'
' Usage: PutX x%, y%, Array()
'
SUB PutX (xx, yy, Array())
xSize = Array(0) \ 18
ySize = Array(1)

FOR x = xx TO xx + xSize - 1
     OUT &H3C4, 2
     OUT &H3C5, LookUp(x MOD 4)

     FOR y = yy * 3 TO (yy + ySize) * 3 + 2

          DEF SEG = VARSEG(Array(2))
          by = PEEK(VARPTR(Array(2)) + (x - xx) + (y - yy * 3) * xSize)

          DEF SEG = &HA000
          yCoord& = y
          POKE (100 * yCoord&) + (x \ 4), by
     NEXT
NEXT

END SUB

' SaveSCN - save whole screen to disk (4 BSAVE files)
'
' Usage:  SaveSCN filename$
'
SUB SaveSCN (file$)
IF INSTR(file$, ".") > 0 THEN file$ = LEFT$(file$, INSTR(file$, ".")) ELSE file$ = file$ + "."

OUT &H3CE, 4
OUT &H3CF, 0
DEF SEG = &HA000
BSAVE file$ + "bs1", 0, 60000
DEF SEG
OUT &H3CE, 4
OUT &H3CF, 1
DEF SEG = &HA000
BSAVE file$ + "bs2", 0, 60000
DEF SEG
OUT &H3CE, 4
OUT &H3CF, 2
DEF SEG = &HA000
BSAVE file$ + "bs3", 0, 60000
DEF SEG
OUT &H3CE, 4
OUT &H3CF, 3
DEF SEG = &HA000
BSAVE file$ + "bs4", 0, 60000
DEF SEG

END SUB

'Shift byte to the left
FUNCTION SBL& (DWORD&, Shifter%)
Number& = DWORD& * (2 ^ Shifter%)
SELECT CASE Number&
  CASE IS > 65535
    Number& = BIND&(RIGHT$(BIN$(Number&), LEN(BIN$(Number&)) - 1))
END SELECT
SBL& = Number&
END FUNCTION

' Set18BitMode - set pseudo 18-bit mode (it's 400x600x256 ModeX actually)
'
' Usage: Set18BitMode
'
SUB Set18bitMode
    SCREEN 0
    SCREEN 13
    outport &H3C4, &H604
    FillChar &HA000, 0, 0, &HFFFF
    OUT &H3D4, &H11
    TempByte& = (INP(&H3D5) AND &H7F)
    outport &H3D4, (&H11 OR SBL(TempByte&, 8))
    outport &H3C4, &H100
    outport &H3C4, &H300
    OUT &H3C0, &H20
    outport &H3D4, &H2C11
    OUT &H3C2, &HE3
    outport &H3D4, &H5F00
    outport &H3D4, &H4F01
    outport &H3D4, &H5002
    outport &H3D4, &H8203&
    outport &H3D4, &H5404
    outport &H3D4, &H8005&
    outport &H3D4, &HBF06&
    outport &H3D4, &H1F07
    outport &H3D4, &H8
    outport &H3D4, &H4109
    outport &H3D4, &H9C10&
    outport &H3D4, &H8E11&
    outport &H3D4, &H8F12&
    outport &H3D4, &H2813
    outport &H3D4, &H14
    outport &H3D4, &H9615&
    outport &H3D4, &HB916&
    outport &H3D4, &HE317&
    outport &H3D4, &H14
    outport &H3D4, &H2C11
    OUT &H3C2, &HE7
    outport &H3D4, &H7000
    outport &H3D4, &H6301
    outport &H3D4, &H6402
    outport &H3D4, &H9203&
    outport &H3D4, &H6504
    outport &H3D4, &H8205&
    outport &H3D4, &H7006
    outport &H3D4, &HF007&
    outport &H3D4, &H6009
    outport &H3D4, &H5B10
    outport &H3D4, &H8C11&
    outport &H3D4, &H5712
    outport &H3D4, &H3213
    outport &H3D4, &H5815
    outport &H3D4, &H7016
    FOR x = 0 TO 63           'Set palette for 63 shades of red green & blue
     SetPal x, x, 0, 0
     SetPal x + 64, 0, x, 0
     SetPal x + 128, 0, 0, x
    NEXT
    FOR i = 0 TO 3            'LookUp table for powers of 2 - used by PsetX
     LookUp(i) = 2 ^ i        'and PutX
    NEXT
    CharLoad                  'Load font for printing
END SUB

' SetPal - set palette (you shouldn't use this except for colors 192-255)
SUB SetPal (c, r, g, bl)
  OUT &H3C8, c
  OUT &H3C9, r
  OUT &H3C9, g
  OUT &H3C9, bl
END SUB