'===========================================================================
' Subject: GRAPHICS LOADER                   Date: 08-12-96 (21:48)       
' Author:  Jonathan Leger                    Code: QB, QBasic, PDS        
' Origin:  leger@mail.dtx.net              Packet: GRAPHICS.ABC
'===========================================================================
'----------------------------------------------------------
' Requires Luke Molnar's ULTIMATE FONT V1.1
'   Please refer to GRAPHICS.ABC of the July 1996 Edition
'----------------------------------------------------------

DEFINT A-Z

'**** Screen routines
DECLARE SUB LoadGif (file$)
DECLARE SUB LoadPcx (file$)
DECLARE SUB BsaveScreen (file$)
DECLARE SUB GiftoBSAVE (gif$, bsave$, pal$)

'*** Palette routines
DECLARE SUB GetPal (pal())
DECLARE SUB PutPal (pal())
DECLARE SUB SavePal (file$)
DECLARE SUB LoadPal (file$)
DECLARE SUB RotatePal (direction, pal())
DECLARE SUB CyclePal (direction, pal(), numcycles)

'*** Palette fx
DECLARE SUB FadeOut (pal())
DECLARE SUB FadeIn (pal())
DECLARE SUB BlackOut ()

'*** Drawing Routines
DECLARE SUB ClrScr (col)

'*** Font routines
DECLARE SUB Font (Text$, XStart, Ystart, Xscale, Yscale, Style, clr)
DECLARE SUB LoadFont ()
DECLARE SUB MakeFont ()
DECLARE SUB FontPal ()

'*** EMS routines
DECLARE FUNCTION NumEMSHandles% ()
DECLARE FUNCTION NumEMSPages% (Handle%)
DECLARE FUNCTION GetEMS% (numpages%)
DECLARE FUNCTION EMSPages% (func%)
DECLARE FUNCTION PageFrame% ()
DECLARE FUNCTION EMSstatus% ()
DECLARE SUB ReleaseEMS (Handle%)
DECLARE SUB MapEMS (Handle%, block%)

'*** Memory manipulation routines
DECLARE SUB MemCopy (fromseg, fromoff, toseg, tooff, numbytes)
DECLARE SUB FillChar (segment, offset, value, bytes)

'*** Miscelaneous
DECLARE SUB WaitRetrace ()

OPTION BASE 0

'$STATIC
DIM pal1(0 TO 255, 3) AS INTEGER
DIM pal2(0 TO 255, 3) AS INTEGER
DIM SHARED FontBuf(0) AS STRING * 10368

'$DYNAMIC

LoadFont

SCREEN 13

GetPal pal1()

FontPal
GetPal pal2()
BlackOut

Font "BASIC FX", 50, 75, 3, 3, 3, 70
FadeIn pal2()

WHILE INKEY$ = "": WEND
FadeOut pal2()
CLS

Font "The font routines were written by:", 0, 0, 1, 1, 3, 120
Font "Luke Molnar", 70, 25, 2, 2, 3, 1
Font "Other routines written/collected by:", 0, 100, 1, 1, 3, 120
Font "Jonathan Leger", 40, 125, 2, 2, 3, 1

FadeIn pal2()

WHILE INKEY$ = "": WEND

FadeOut pal2()
CLS

PutPal pal1()

Font "LoadGif()", 115, 100, 1, 1, 5, 15
Font "press a key", 105, 125, 1, 1, 5, 15
WHILE INKEY$ = "": WEND

LoadGif "letterma.gif"
FOR snd = 1000 TO 1500 STEP 100
   SOUND snd, .1
   SOUND snd + 100, .1
   SOUND snd + 200, .1
NEXT snd

WHILE INKEY$ = "": WEND

CLS
PutPal pal1()

Font "LoadPcx()", 115, 100, 1, 1, 5, 15
Font "press a key", 105, 125, 1, 1, 5, 15
WHILE INKEY$ = "": WEND

LoadPcx "bwface.pcx"
FOR snd = 1000 TO 1500 STEP 100
   SOUND snd, .1
   SOUND snd + 100, .1
   SOUND snd + 200, .1
NEXT snd

WHILE INKEY$ = "": WEND

IF EMSstatus THEN
   IF EMSPages(1) >= 4 THEN
      PCXHandle = GetEMS(4)
      MapEMS PCXHandle, 0
      MemCopy &HA000, 0, PageFrame, 0, &HFA00
      CLS
      Font "The previous picture has been", 0, 0, 1, 1, 5, 15
      Font "loaded into EMS memory.", 0, 25, 1, 1, 5, 15
      Font "Press any key to load picture.", 0, 50, 1, 1, 5, 15
      WHILE INKEY$ = "": WEND
      MemCopy PageFrame, 0, &HA000, 0, &HFA00
      WHILE INKEY$ = "": WEND
      ReleaseEMS PCXHandle
   END IF
END IF

GetPal pal2()

Font "CyclePal()", 115, 100, 1, 1, 5, 15

DO UNTIL LEN(INKEY$) > 0
   CyclePal 1, pal2(), 1
LOOP

BlackOut
CLS

FontPal
GetPal pal2()
BlackOut

Font "End of..", 0, 25, 1, 1, 5, 18
Font "BASIC FX", 50, 75, 3, 3, 3, 70
Font "...Demo", 240, 145, 1, 1, 5, 18
FadeIn pal2()

WHILE INKEY$ = "": WEND
FadeOut pal2()
CLS
PutPal pal1()

SCREEN 0
WIDTH 80, 25
END

REM $STATIC
SUB BlackOut

   FOR clr = 0 TO 255
      OUT &H3C8, clr
      OUT &H3C9, 0
      OUT &H3C9, 0
      OUT &H3C9, 0
   NEXT clr

END SUB

SUB BsaveScreen (file$)

DEF SEG = &HA000
BSAVE file$, 0, 64000
DEF SEG

END SUB

SUB ClrScr (col)

FillChar &HA000, 0, col, &HFA00

END SUB

SUB CyclePal (direction, pal(), numcycles)

FOR x = 1 TO numcycles
   WaitRetrace
   RotatePal direction, pal()
NEXT x

END SUB

'************* EMSPages%() ****************
'*** When func% is 0, returns the total ***
'*** number of 16k pages, when func% is ***
'*** 1, returns the number of available ***
'*** 16k pages.                         ***
'******************************************
FUNCTION EMSPages% (func%)

asm$ = ""
asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(180)
asm$ = asm$ + CHR$(66) + CHR$(205) + CHR$(103) + CHR$(139) + CHR$(126)
asm$ = asm$ + CHR$(6) + CHR$(137) + CHR$(29) + CHR$(139) + CHR$(126)
asm$ = asm$ + CHR$(8) + CHR$(137) + CHR$(21) + CHR$(93) + CHR$(203)

TotalPages% = 0: AvailablePages% = 0

DEF SEG = VARSEG(asm$)
   CALL Absolute(TotalPages%, AvailablePages%, SADD(asm$))
DEF SEG

IF func% = 0 THEN
   EMSPages% = TotalPages%
ELSE
   EMSPages% = AvailablePages%
END IF

END FUNCTION

'**************** EMSstatus%() ******************
'*** Returns whether EMS is available.  -1 is ***
'*** returned if it is available, 0 otherwise ***
'************************************************
FUNCTION EMSstatus%

asm$ = ""
asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(180)
asm$ = asm$ + CHR$(64) + CHR$(205) + CHR$(103) + CHR$(176) + CHR$(0)
asm$ = asm$ + CHR$(139) + CHR$(94) + CHR$(6) + CHR$(137) + CHR$(7)
asm$ = asm$ + CHR$(93) + CHR$(203)

EMS% = -1
DEF SEG = VARSEG(asm$)
   CALL Absolute(EMS%, SADD(asm$))
DEF SEG

IF EMS% = 0 THEN
   EMSstatus = -1         'EMS installed, set to BASIC's TRUE value.
ELSE
   EMSstatus = 0          'EMS not installed, set to FALSE.
END IF

END FUNCTION

SUB FadeIn (pal())

DIM Tmp(0 TO 255, 3)

FOR lp = 1 TO 64
   FOR clr = 0 TO 255
      FOR rgb = 1 TO 3
         IF Tmp(clr, rgb) < pal(clr, rgb) THEN
            Tmp(clr, rgb) = Tmp(clr, rgb) + 1
         END IF
      NEXT rgb
      OUT &H3C8, clr
      OUT &H3C9, Tmp(clr, 1)
      OUT &H3C9, Tmp(clr, 2)
      OUT &H3C9, Tmp(clr, 3)
   NEXT clr
NEXT lp


END SUB

SUB FadeOut (pal())

DIM Tmp(0 TO 255, 3)

FOR clr = 0 TO 255
   FOR rgb = 1 TO 3
      Tmp(clr, rgb) = pal(clr, rgb)
   NEXT rgb
NEXT clr

FOR lp = 1 TO 64
   FOR clr = 0 TO 255
      FOR rgb = 1 TO 3
         IF Tmp(clr, rgb) > 0 THEN
            Tmp(clr, rgb) = Tmp(clr, rgb) - 1
         END IF
      NEXT rgb
      OUT &H3C8, clr
      OUT &H3C9, Tmp(clr, 1)
      OUT &H3C9, Tmp(clr, 2)
      OUT &H3C9, Tmp(clr, 3)
   NEXT clr
NEXT lp


END SUB

SUB FillChar (segment, offset, value, bytes)

asm$ = ""
asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(139)
asm$ = asm$ + CHR$(78) + CHR$(6) + CHR$(139) + CHR$(86) + CHR$(8)
asm$ = asm$ + CHR$(139) + CHR$(70) + CHR$(12) + CHR$(30) + CHR$(142)
asm$ = asm$ + CHR$(216) + CHR$(139) + CHR$(94) + CHR$(10) + CHR$(136)
asm$ = asm$ + CHR$(23) + CHR$(67) + CHR$(226) + CHR$(251) + CHR$(31)
asm$ = asm$ + CHR$(93) + CHR$(203)

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

END SUB

SUB Font (Text$, XStart, Ystart, Xscale, Yscale, Style, clr)

px = XStart  ' physical x and physical y
py = Ystart

LHeight = Yscale * 8
Optimize = 63 \ LHeight ' Any constant math operations done multipe times
                          ' in the main loop should, well, not be done
                          ' in the main loop.


' Instead of wasting our time with all this MID$ garbage to access bytes in
' font buffer, we'll just take a PEEK directly at them.
DEF SEG = VARSEG(FontBuf(0))

 FOR h = 1 TO LEN(Text$)
  FPtr = 81 * (ASC(MID$(Text$, h, 1)) - 1) - 1
  FOR x = 0 TO 8
   FOR y = 0 TO 8

    col = PEEK(VARPTR(FontBuf(0)) + FPtr)
    FPtr = FPtr + 1
    IF col THEN
     SELECT CASE Style
      ' If you desire a y scale factor greater than 8, you
      ' must change the division to higher precision...very slow.
      ' Or, you could find a way around it.
      CASE 1: PSET (px, py), Optimize * (py - Ystart) + clr
              LINE (px, py)-(px, py + Yscale), Optimize * (py - Ystart) + clr
      ' Notice how this style only uses 54 colors, so you can see the top
      ' of the letters where they would normally be black
      CASE 2: CIRCLE (px, py), Yscale, (54 \ LHeight) * (py - Ystart) + clr + 9, , , 4
      CASE 3:  FOR sty = px TO px + Xscale
                FOR sty2 = py TO py + Yscale
                 PSET (sty, sty2), Optimize * (sty2 - Ystart) + clr
                 IF POINT(sty - 1, sty2) = 0 THEN PSET (sty - 1, sty2), 63 + clr - 1
                 IF POINT(sty, sty2 - 1) = 0 THEN PSET (sty, sty2 - 1), 63 + clr - 1
                NEXT
               NEXT
       CASE 4: FOR sty = px TO px + Xscale
                FOR sty2 = py TO py + Yscale
                 PSET (sty + .4 * sty2, sty2), Optimize * (sty2 - Ystart) + clr
                 IF POINT((sty - 1) + .4 * sty2, sty2) = 0 THEN PSET ((sty - 1) + .4 * sty2, sty2), 63 + clr - 1
                NEXT
               NEXT
       CASE ELSE
            PSET (px, py), clr
     END SELECT
    END IF
    py = py + Yscale
   NEXT
  px = px + Xscale
  py = Ystart
  NEXT
 NEXT h
DEF SEG

END SUB

SUB FontPal
FOR x = 1 TO 63
 OUT &H3C8, x
 OUT &H3C9, x
 OUT &H3C9, 0
 OUT &H3C9, 0
NEXT
FOR x = 64 TO 126
 OUT &H3C8, x
 OUT &H3C9, 0
 OUT &H3C9, x
 OUT &H3C9, 0
NEXT
FOR x = 127 TO 189
 OUT &H3C8, x
 OUT &H3C9, 0
 OUT &H3C9, 0
 OUT &H3C9, x
NEXT
FOR x = 190 TO 252
 OUT &H3C8, x
 OUT &H3C9, x
 OUT &H3C9, 0
 OUT &H3C9, x
NEXT
FOR x = 253 TO 255
 OUT &H3C8, x
 OUT &H3C9, x
 OUT &H3C9, x
 OUT &H3C9, x
NEXT
END SUB

'********************** GetEMS%() ********************
'*** Function returns the handle value for a block ***
'*** of EMS memory that consists of numpages% 16k  ***
'*** pages.  You _must_ keep the handle value for  ***
'*** later calls that require the handle.  Example:***
'***                                               ***
'*** EmsHandle% = GetEMS%(5)                       ***
'***                                               ***
'*** EmsHandle% holds the handle info for a block  ***
'*** of memory 5 16k pages in size, oh 80k.        ***
'*****************************************************
FUNCTION GetEMS% (numpages%)

'pageoffset% = EMSPages%(0) - EMSPages%(1)

asm$ = ""
asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(139)
asm$ = asm$ + CHR$(94) + CHR$(8) + CHR$(180) + CHR$(67) + CHR$(205)
asm$ = asm$ + CHR$(103) + CHR$(139) + CHR$(94) + CHR$(6) + CHR$(137)
asm$ = asm$ + CHR$(23) + CHR$(93) + CHR$(203)

Handle% = 0
DEF SEG = VARSEG(asm$)
   CALL Absolute(BYVAL numpages%, Handle%, SADD(asm$))
DEF SEG

'asm$ = ""
'asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(139)
'asm$ = asm$ + CHR$(86) + CHR$(8) + CHR$(139) + CHR$(126) + CHR$(6)
'asm$ = asm$ + CHR$(139) + CHR$(118) + CHR$(10) + CHR$(177) + CHR$(0)
'asm$ = asm$ + CHR$(48) + CHR$(237) + CHR$(180) + CHR$(68) + CHR$(136)
'asm$ = asm$ + CHR$(200) + CHR$(137) + CHR$(243) + CHR$(205) + CHR$(103)
'asm$ = asm$ + CHR$(70) + CHR$(65) + CHR$(57) + CHR$(254) + CHR$(117)
'asm$ = asm$ + CHR$(242) + CHR$(93) + CHR$(203)
'
'DEF SEG = VARSEG(asm$)
'   CALL Absolute(BYVAL pageoffset%, BYVAL Handle%, BYVAL numpages%, SADD(asm$))
'DEF SEG

GetEMS% = Handle%

END FUNCTION

SUB GetPal (pal())
   FOR clr = 0 TO 255
      OUT &H3C7, clr
      pal(clr, 1) = INP(&H3C9)
      pal(clr, 2) = INP(&H3C9)
      pal(clr, 3) = INP(&H3C9)
   NEXT clr
END SUB

SUB GiftoBSAVE (gif$, bsave$, pal$)

LoadGif gif$
BsaveScreen bsave$
SavePal pal$

END SUB

SUB LoadFont

   fontfile = FREEFILE

   OPEN "basefont.dat" FOR BINARY AS #fontfile
   GET #fontfile, , FontBuf(0)
   CLOSE #fontfile

END SUB

SUB LoadGif (file$)
DIM byte AS STRING * 1
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

giffile = FREEFILE
OPEN file$ FOR BINARY AS #giffile
file$ = "      ": GET #giffile, , file$
IF file$ <> "GIF87a" THEN PRINT "Not a GIF87a file.": END
GET #giffile, , TotalX: GET #giffile, , 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 #giffile, , 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: file$ = SPACE$(a): GET #giffile, , file$: LOOP UNTIL a = 0
LOOP
GET #giffile, , XStart: GET #giffile, , Ystart: GET #giffile, , XLength: GET #giffile, , 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&

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
GOTO LeaveProc

GetByte: file$ = " ": GET #giffile, , file$: a = ASC(file$): 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
        file$ = SPACE$(BlockSize): GET #giffile, , file$
        BlockPointer = 1
    END IF
    a = ASC(MID$(file$, BlockPointer, 1)): BlockPointer = BlockPointer + 1
RETURN
LeaveProc:
CLOSE

END SUB

SUB LoadPal (file$)

palfile = FREEFILE
OPEN file$ FOR BINARY AS palfile

FOR clr = 0 TO 255
   OUT &H3C8, clr
   OUT &H3C9, ASC(INPUT$(1, palfile))
   OUT &H3C9, ASC(INPUT$(1, palfile))
   OUT &H3C9, ASC(INPUT$(1, palfile))
NEXT clr

CLOSE palfile

END SUB

SUB LoadPcx (file$)
pcxfile = FREEFILE
OPEN file$ FOR BINARY AS pcxfile

DEF SEG = &HA000
 
  SEEK #pcxfile, LOF(1) - 767
  FOR pal = 0 TO 255
     OUT &H3C8, pal
     rgb% = ASC(INPUT$(1, pcxfile))
     OUT &H3C9, rgb% / 4
     rgb% = ASC(INPUT$(1, pcxfile))
     OUT &H3C9, rgb% / 4
     rgb% = ASC(INPUT$(1, pcxfile))
     OUT &H3C9, rgb% / 4
  NEXT pal
  SEEK #pcxfile, 129
  c = 0
  WHILE c < 32000
    clr = ASC(INPUT$(1, pcxfile))
    IF clr > 192 AND clr <= 255 THEN
      LPS = clr - 192
      clr = ASC(INPUT$(1, pcxfile))
        FOR L = LPS TO 1 STEP -1
          POKE c, clr
          c = c + 1
          LPS = LPS - 1
        NEXT L
    ELSE
      POKE c, clr
      c = c + 1
    END IF
  WEND
  c = 0
  DEF SEG = &HA7D0
  WHILE c < 32000
    clr = ASC(INPUT$(1, pcxfile))
    IF clr > 192 AND clr <= 255 THEN
      LPS = clr - 192
      clr = ASC(INPUT$(1, pcxfile))
         FOR L = LPS TO 1 STEP -1
          POKE c, clr
          c = c + 1
          LPS = LPS - 1
         NEXT L
    ELSE
      POKE c, clr
      c = c + 1
    END IF
  WEND
CLOSE
DEF SEG

END SUB

SUB MakeFont

fontfile = FREEFILE

OPEN "basefont.dat" FOR BINARY AS #giffile
' Hey, change 128 to 255 for the full font.
CLS
SCREEN 13
COLOR 16
FOR ascii = 1 TO 128
 CLS
 PRINT CHR$(ascii)
 FOR x = 0 TO 8
  FOR y = 0 TO 8
   pnt$ = CHR$(POINT(x, y))
   PUT #giffile, , pnt$
   pnt$ = ""
  NEXT
 NEXT
NEXT
CLOSE
OPEN "basefont.dat" FOR BINARY AS #giffile
 GET #giffile, , FontBuf(0)
CLOSE #giffile
END SUB

'***************** MapEMS () ***********************************
'*** Sets the page of a memory block (identified by Handle%) ***
'*** that is located at the beginning of the page frame.     ***
'*** Example:                                                ***
'***                                                         ***
'*** EmsHandle% = GetEMS%(8)                                 ***
'*** MapEMS EmsHandle%, 4                                    ***
'***                                                         ***
'*** When the page frame segment is next written to, the info***
'*** will be placed starting at the 4th page in the block of ***
'*** memory represented by EmsHandle%.  This could be use,   ***
'*** for instance, to store multiple SCREEN 13 images in one ***
'*** EMS block, by moving the first 64k image into the first ***
'*** 4 16k pages (16000 * 4 = 64000) by using:               ***
'***                                                         ***
'*** MapEMS EmsHandle%, 0                                    ***
'***                                                         ***
'*** And then putting the next 64k image into the next 4 EMS ***
'*** pages by using:                                         ***
'***                                                         ***
'*** MapEMS EmsHandle%, 4                                    ***
'***                                                         ***
'*** ... and then moving the image into the memory block.    ***
'***************************************************************
SUB MapEMS (Handle%, pageoffset%)

numpages% = 4

asm$ = ""
asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(139)
asm$ = asm$ + CHR$(86) + CHR$(8) + CHR$(139) + CHR$(126) + CHR$(6)
asm$ = asm$ + CHR$(139) + CHR$(118) + CHR$(10) + CHR$(177) + CHR$(0)
asm$ = asm$ + CHR$(48) + CHR$(237) + CHR$(180) + CHR$(68) + CHR$(136)
asm$ = asm$ + CHR$(200) + CHR$(137) + CHR$(243) + CHR$(205) + CHR$(103)
asm$ = asm$ + CHR$(70) + CHR$(65) + CHR$(57) + CHR$(249) + CHR$(117)
asm$ = asm$ + CHR$(242) + CHR$(93) + CHR$(203)

DEF SEG = VARSEG(asm$)
   CALL Absolute(BYVAL pageoffset%, BYVAL Handle%, BYVAL numpages%, SADD(asm$))
DEF SEG

END SUB

SUB MemCopy (fromseg, fromoff, toseg, tooff, bytes)

asm$ = ""
asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(30)
asm$ = asm$ + CHR$(139) + CHR$(70) + CHR$(10) + CHR$(142) + CHR$(192)
asm$ = asm$ + CHR$(139) + CHR$(70) + CHR$(14) + CHR$(142) + CHR$(216)
asm$ = asm$ + CHR$(139) + CHR$(118) + CHR$(8) + CHR$(139) + CHR$(126)
asm$ = asm$ + CHR$(12) + CHR$(139) + CHR$(78) + CHR$(6) + CHR$(243)
asm$ = asm$ + CHR$(164) + CHR$(31) + CHR$(93) + CHR$(203)

DEF SEG = VARSEG(asm$)
   CALL Absolute(BYVAL fromseg, BYVAL fromoff, BYVAL toseg, BYVAL tooff, BYVAL bytes, SADD(asm$))
DEF SEG

END SUB

'****************************** NumEMSHandles%() *********************
'*** Returns the number of EMS handles presently being used (there ***
'*** are a maximum of 256 handles possible at any given time).     ***
'*********************************************************************
FUNCTION NumEMSHandles%

asm$ = ""
asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(180)
asm$ = asm$ + CHR$(75) + CHR$(205) + CHR$(103) + CHR$(139) + CHR$(126)
asm$ = asm$ + CHR$(6) + CHR$(137) + CHR$(29) + CHR$(93) + CHR$(203)

NumHandles% = 0
DEF SEG = VARSEG(asm$)
   CALL Absolute(NumHandles%, SADD(asm$))
DEF SEG

NumEMSHandles% = NumHandles%

END FUNCTION

'***************************** NumEMSPages%() *************************
'*** Returns the number of 16k pages being used by the memory block ***
'*** that is represented by Handle%.                                ***
'**********************************************************************
FUNCTION NumEMSPages% (Handle%)

asm$ = ""
asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(139)
asm$ = asm$ + CHR$(86) + CHR$(6) + CHR$(180) + CHR$(76) + CHR$(205)
asm$ = asm$ + CHR$(103) + CHR$(139) + CHR$(126) + CHR$(8) + CHR$(137)
asm$ = asm$ + CHR$(29) + CHR$(93) + CHR$(203)

DEF SEG = VARSEG(asm$)
   CALL Absolute(numpages%, Handle%, SADD(asm$))
DEF SEG

NumEMSPages% = numpages%

END FUNCTION

'******************************* PageFrame% ***************************
'*** Returns the segment that you will need to write to in order to ***
'*** store your data into EMS memory.  For example, PageFrame% may  ***
'*** return D000 (HEX, -12288 decimal), and then you might do this: ***
'***                                                                ***
'*** DEF SEG = PageFrame%        'D000                              ***
'*** MyData$ = "This is a block of data I want to store in EMS."    ***
'*** FOR X = 1 TO LEN(MyData$)                                      ***
'***   POKE X, ASC(MID$(MyData$, X, 1))                             ***
'*** NEXT X                                                         ***
'*** DEF SEG                                                        ***
'***                                                                ***
'*** Note, though, that you have to have a block of EMS opened with ***
'*** GetEMS%() and maped with MapEMS before you can write to the    ***
'*** block.                                                         ***
'**********************************************************************
FUNCTION PageFrame%

asm$ = ""
asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(180)
asm$ = asm$ + CHR$(65) + CHR$(205) + CHR$(103) + CHR$(139) + CHR$(126)
asm$ = asm$ + CHR$(6) + CHR$(137) + CHR$(29) + CHR$(93) + CHR$(203)

PageFrameAddr% = 0
DEF SEG = VARSEG(asm$)
   CALL Absolute(PageFrameAddr%, SADD(asm$))
DEF SEG

PageFrame% = PageFrameAddr%

END FUNCTION

SUB PutPal (pal())
  
   FOR clr = 0 TO 255
      OUT &H3C8, clr
      OUT &H3C9, pal(clr, 1)
      OUT &H3C9, pal(clr, 2)
      OUT &H3C9, pal(clr, 3)
   NEXT clr

END SUB

'****************************** ReleaseEMS() **************************
'*** Releases the EMS memory associated with Handle%.  This is very ***
'*** important to do before you exit your program, otherwise the    ***
'*** memory being used by your open handles will not be available   ***
'*** again until you reboot.                                        ***
'**********************************************************************
SUB ReleaseEMS (Handle%)

asm$ = ""
asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(180)
asm$ = asm$ + CHR$(69) + CHR$(139) + CHR$(86) + CHR$(6) + CHR$(205)
asm$ = asm$ + CHR$(103) + CHR$(93) + CHR$(203)

DEF SEG = VARSEG(asm$)
   CALL Absolute(BYVAL Handle%, SADD(asm$))
DEF SEG

END SUB

SUB RotatePal (direction, pal())

   SELECT CASE direction
         CASE 1
            temp1 = pal(255, 1)
            temp2 = pal(255, 2)
            temp3 = pal(255, 3)
            FOR rgb = 1 TO 3
               FOR col = 254 TO 0 STEP -1
                  pal(col + 1, rgb) = pal(col, rgb)
               NEXT col
            NEXT rgb
            pal(0, 1) = temp1
            pal(0, 2) = temp2
            pal(0, 3) = temp3
         CASE -1
            temp1 = pal(0, 1)
            temp2 = pal(0, 2)
            temp3 = pal(0, 3)
            FOR rgb = 1 TO 3
               FOR col = 0 TO 254
                  pal(col, rgb) = pal(col + 1, rgb)
               NEXT col
            NEXT rgb
            pal(255, 1) = temp1
            pal(255, 2) = temp2
            pal(255, 3) = temp3
   END SELECT

   PutPal pal()

END SUB

SUB SavePal (file$)

   palfile = FREEFILE
   OPEN file$ FOR OUTPUT AS palfile

   FOR clr = 0 TO 255
      OUT &H3C7, clr
      PRINT #palfile, CHR$(INP(&H3C9));
      PRINT #palfile, CHR$(INP(&H3C9));
      PRINT #palfile, CHR$(INP(&H3C9));
   NEXT clr

   CLOSE palfile

END SUB

SUB SetPal (pal())
END SUB

SUB WaitRetrace
   WAIT &H3DA, 8
END SUB