'===========================================================================
' Subject: TEXT COLOR PALETTE EDITOR          Date: 04-21-98 (04:10)       
'  Author: Andrew S. Gibson                   Code: QB, PDS                
'  Origin: zapf_dingbat@juno.com            Packet: TEXT.ABC
'===========================================================================
' You need QuickBASIC 4.5 for this to work
' My E-mail address is Zapf_DingBat@JUNO.COM
' Help is included - this will compile. No bugs.
DEFINT A-Z
DECLARE FUNCTION Monitor% (VSSegment)
DECLARE SUB Box (Row%, Column%, BoxWidth%, Height%, BoxColor%, BoxCharacter%, BorderType%, BorderColor%)
DECLARE SUB Center (Row, Text$, ForeG, BackG, Blink)
DECLARE SUB Delay (Period!)
DECLARE SUB DrawScreen ()
DECLARE SUB Editor (Text$, LeftCol, RightCol, KeyCode)
DECLARE SUB Init.XTable ()
DECLARE SUB Pal (Act$)
DECLARE SUB Shine (sx%, sy%, ex%, ey%, C%)
DECLARE SUB ShowImage ()
DECLARE SUB TextButton (Position%, XButton%, YButton%, Button$, ButtonForeColour%, ButtonBackColour%, ButtonHiLightChar%, ShadowColour%, ShadowBackGround%, Shadow%)

TYPE RegType
  AX    AS INTEGER
  BX    AS INTEGER
  CX    AS INTEGER
  DX    AS INTEGER
  BP    AS INTEGER
  SI    AS INTEGER
  DI    AS INTEGER
  FLAGS AS INTEGER
  DS    AS INTEGER
  ES    AS INTEGER
END TYPE

CONST TRUE = -1, FALSE = 0
CONST Right = -1, Left = 0, Up = -1, Down = 0
CONST MaxRow = 43, MaxColumn = 80, Version$ = "Text Color Pal - Version 00.911á"

DIM SHARED XTable(1 TO MaxRow) AS INTEGER
DIM SHARED Registers AS RegType, HighEight(15), r(255), g(255), b(255)

MonType = Monitor%(VSeg)
SELECT CASE MonType
  CASE 5, 4
  CASE ELSE
     PRINT "Text Color Pal Requires at least an Ega Video System.": GOTO Term
END SELECT

' Defaults
  ColSelect = 0: Col = 1: Red = 0: Green = 0: Blue = 0
  HighEight(0) = 0: HighEight(1) = 0
  HighEight(2) = 0: HighEight(3) = 0
  HighEight(4) = 0: HighEight(5) = 0
  HighEight(6) = 14: HighEight(7) = 0
  HighEight(8) = 48: HighEight(9) = 48
  HighEight(10) = 48: HighEight(11) = 48
  HighEight(12) = 48: HighEight(13) = 48
  HighEight(14) = 48: HighEight(15) = 48

Pal "SAVE"
Pal "FADEOUT"
DrawScreen
GOSUB SetColorBars
Pal "FADEIN"

DO
   Key$ = UCASE$(INKEY$)
   SELECT CASE Key$
   CASE IS = CHR$(66)
      TextButton Down, 37, 14, "~Blue", 9, 1, 15, 9, 0, Right
      COLOR 7, 0: LOCATE 24, 1: PRINT "Use the left or right arrow keys to change the amount of Blue in the color.";
      COLOR 7, 0: LOCATE 25, 1: PRINT "Press ESCape to restore old color, press Enter<ÄÙ to set new color.";
      GOSUB AlterBlue
      GOSUB ClearHelpStatLine
      TextButton Up, 37, 14, "~Blue", 9, 1, 15, 9, 0, Right
   CASE IS = CHR$(67) 'Change Color
      TextButton Down, 5, 18, "~Change Color", 14, 5, 15, 8, 0, Right
      COLOR 7, 0: LOCATE 24, 1: PRINT "Use the left or right arrow keys to select the new color, press Enter<ÄÙ to use.";
      COLOR 7, 0: LOCATE 25, 1: PRINT "Press ESCape to restore old color, press Enter<ÄÙ to set new color.";
      GOSUB ChooseCol
      GOSUB ClearHelpStatLine
      TextButton Up, 5, 18, "~Change Color", 14, 5, 15, 8, 0, Right
   CASE IS = CHR$(71)
      TextButton Down, 36, 11, "~Green", 10, 2, 15, 10, 0, Right
      COLOR 7, 0: LOCATE 24, 1: PRINT "Use the left or right arrow keys to change the amount of Green in the color.";
      COLOR 7, 0: LOCATE 25, 1: PRINT "Press ESCape to restore old color, press Enter<ÄÙ to set new color.";
      GOSUB AlterGreen
      GOSUB ClearHelpStatLine
      TextButton Up, 36, 11, "~Green", 10, 2, 15, 10, 0, Right
   CASE IS = CHR$(76) 'Load Palette File
      TextButton Down, 22, 18, "~Load Palette", 14, 5, 15, 8, 0, Right
      COLOR 7, 0: LOCATE 24, 1: PRINT "Type in a filename of the palette file to load. Press ESCape or Enter<ÄÙ with a blank box to abort.";
      GOSUB LoadPalette
      GOSUB ClearHelpStatLine
      TextButton Up, 22, 18, "~Load Palette", 14, 5, 15, 8, 0, Right
   CASE IS = CHR$(81) 'Quit
      TextButton Down, 56, 18, "~Quit Text Color Pal", 14, 5, 15, 8, 0, Right
      Delay .15
      TextButton Up, 56, 18, "~Quit Text Color Pal", 14, 5, 15, 8, 0, Right
      EXIT DO
   CASE IS = CHR$(82)
      TextButton Down, 37, 8, "~Red", 12, 4, 15, 12, 0, Right
      COLOR 7, 0: LOCATE 24, 1: PRINT "Use the left or right arrow keys to change the amount of Red in the color.";
      COLOR 7, 0: LOCATE 25, 1: PRINT "Press ESCape to restore old color, press Enter<ÄÙ to set new color.";
      GOSUB AlterRed
      GOSUB ClearHelpStatLine
      TextButton Up, 37, 8, "~Red", 12, 4, 15, 12, 0, Right
   CASE IS = CHR$(83) 'Save Palette
      TextButton Down, 39, 18, "~Save Palette", 14, 5, 15, 8, 0, Right
      COLOR 7, 0: LOCATE 24, 1: PRINT "Type in a filename of the palette file to save. Press ESCape or Enter<ÄÙ with a blank box to abort.";
      GOSUB SavePalette
      GOSUB ClearHelpStatLine
      TextButton Up, 39, 18, "~Save Palette", 14, 5, 15, 8, 0, Right
   END SELECT

LOOP

Pal "FADEOUT"
COLOR 7, 0: CLS
Pal "FADEIN"
DEF SEG = &HB800
 Init.XTable
 ShowImage
 DO
   Shine 1, 1, 79, 42, 15
 LOOP UNTIL INKEY$ <> ""
DEF SEG
Pal "FADEOUT"
WIDTH 80, 25: COLOR 7, 0
Pal "FADEIN"
Term:
END

AlterBlue:
OldBlue = Blue
DO
  x$ = INKEY$
  SELECT CASE x$
    CASE IS = CHR$(13)
        Center 16, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
        COLOR 9, 0: LOCATE 16, 9 + Blue: PRINT CHR$(42);
        GOSUB UpdateRegisters
        Pal "SAVE"
        EXIT DO
    CASE IS = CHR$(27)
        Center 16, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
        COLOR 9, 0: LOCATE 16, 9 + OldBlue: PRINT CHR$(42); : Blue = OldBlue
        GOSUB UpdateRegisters
        Pal "SAVE"
        EXIT DO
    CASE CHR$(0) + CHR$(75), CHR$(0) + CHR$(72)
        Blue = Blue - 1
        IF Blue < 0 THEN Blue = 63
        Center 16, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
        COLOR 9, 0: LOCATE 16, 9 + Blue: PRINT CHR$(42);
        GOSUB UpdateRegisters
    CASE CHR$(0) + CHR$(77), CHR$(0) + CHR$(80)
        Blue = Blue + 1
        IF Blue > 63 THEN Blue = 0
        Center 16, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
        COLOR 9, 0: LOCATE 16, 9 + Blue: PRINT CHR$(42);
        GOSUB UpdateRegisters
  END SELECT
LOOP
RETURN

ChooseCol:
OldCol = Col
OldChooseColor = (OldCol \ 5 + HighEight(OldCol \ 5))
DO
  x$ = INKEY$
  SELECT CASE x$
    CASE IS = CHR$(13)
        FOR NumPrin = 1 TO 80 STEP 5
          COLOR 7, 0: LOCATE 6, (NumPrin + 2): PRINT LTRIM$(STR$(NumPrin \ 5));
        NEXT NumPrin
        COLOR 0, 7: LOCATE 6, (Col + 2): PRINT LTRIM$(STR$(Col \ 5)); : COLOR 7, 0: ColSelect = (Col \ 5 + HighEight(Col \ 5)): EXIT DO
    CASE IS = CHR$(27)
        FOR NumPrin = 1 TO 80 STEP 5
          COLOR 7, 0: LOCATE 6, (NumPrin + 2): PRINT LTRIM$(STR$(NumPrin \ 5));
        NEXT NumPrin
        COLOR 0, 7: LOCATE 6, (OldCol + 2): PRINT LTRIM$(STR$(OldCol \ 5)); : COLOR 7, 0: Col = OldCol: ColSelect = OldChooseColor: GOSUB SetColorBars: EXIT DO
    CASE CHR$(0) + CHR$(75), CHR$(0) + CHR$(72)
        Col = Col - 5
        IF Col < 1 THEN Col = 76
        FOR NumPrin = 1 TO 80 STEP 5
          COLOR 7, 0: LOCATE 6, (NumPrin + 2): PRINT LTRIM$(STR$(NumPrin \ 5));
        NEXT NumPrin
        COLOR 0, 7: LOCATE 6, (Col + 2): PRINT LTRIM$(STR$(Col \ 5));
        GOSUB SetColorBars
    CASE CHR$(0) + CHR$(77), CHR$(0) + CHR$(80)
        Col = Col + 5
        IF Col > 76 THEN Col = 1
        FOR NumPrin = 1 TO 80 STEP 5
          COLOR 7, 0: LOCATE 6, (NumPrin + 2): PRINT LTRIM$(STR$(NumPrin \ 5));
        NEXT NumPrin
        COLOR 0, 7: LOCATE 6, (Col + 2): PRINT LTRIM$(STR$(Col \ 5));
        GOSUB SetColorBars
  END SELECT
LOOP
RETURN

AlterGreen:
OldGreen = Green
DO
  x$ = INKEY$
  SELECT CASE x$
    CASE IS = CHR$(13)
        Center 13, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
        COLOR 10, 0: LOCATE 13, 9 + Green: PRINT CHR$(42);
        GOSUB UpdateRegisters
        Pal "SAVE"
        EXIT DO
    CASE IS = CHR$(27)
        Center 13, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
        COLOR 10, 0: LOCATE 13, 9 + OldGreen: PRINT CHR$(42); : Green = OldGreen
        GOSUB UpdateRegisters
        Pal "SAVE"
        EXIT DO
    CASE CHR$(0) + CHR$(75), CHR$(0) + CHR$(72)
        Green = Green - 1
        IF Green < 0 THEN Green = 63
        Center 13, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
        COLOR 10, 0: LOCATE 13, 9 + Green: PRINT CHR$(42);
        GOSUB UpdateRegisters
    CASE CHR$(0) + CHR$(77), CHR$(0) + CHR$(80)
        Green = Green + 1
        IF Green > 63 THEN Green = 0
        Center 13, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
        COLOR 10, 0: LOCATE 13, 9 + Green: PRINT CHR$(42);
        GOSUB UpdateRegisters
  END SELECT
LOOP
RETURN

LoadPalette:
COLOR 8, 7
Filename$ = UCASE$(Filename$)
OldName$ = Filename$
IF OldName$ = "" OR Filename$ = "" THEN
  LOCATE 21, 2: PRINT STRING$(78, 32);
END IF

DO
LOCATE 21, 2
DO                              'edit until Enter or Esc
   Editor Filename$, 2, 79, KeyCode
LOOP UNTIL KeyCode = 13 OR KeyCode = 27
IF KeyCode = 27 THEN
   IF OldName$ = "" OR Filename$ = "" THEN
      LOCATE 21, 2: PRINT STRING$(79, 32);
   ELSE
      Filename$ = OldName$: LOCATE 21, 2: PRINT Filename$
   END IF
   EXIT DO
END IF

   SELECT CASE Filename$
     CASE IS = "": EXIT DO
     CASE ELSE
         ErrorStatus = FALSE
         ON ERROR GOTO EHandler
         OPEN Filename$ FOR INPUT AS #1
             LINE INPUT #1, A$
             IF A$ <> "Text Color Pal Save File Version .03á" THEN
                 CLOSE
                 GOSUB ClearHelpStatLine
                 LOCATE 24, 1: PRINT UCASE$(Filename$);
                 LOCATE 25, 1: PRINT "Is not a Text Color Pal palette file !!!";
                 Filename$ = "": OldName$ = Filename$
                 COLOR 8, 7: LOCATE 21, 2: PRINT STRING$(78, 32); : COLOR 7, 0
                 Delay 2
                 EXIT DO
             END IF
             FOR ColLoad = 1 TO 80 STEP 5
                LINE INPUT #1, A$
                r(ColLoad \ 5 + HighEight(ColLoad \ 5)) = VAL(A$)
                LINE INPUT #1, A$
                g(ColLoad \ 5 + HighEight(ColLoad \ 5)) = VAL(A$)
                LINE INPUT #1, A$
                b(ColLoad \ 5 + HighEight(ColLoad \ 5)) = VAL(A$)
            NEXT ColLoad
         CLOSE
             FOR SetPal = 1 TO 80 STEP 5
                OUT &H3C8, (SetPal \ 5 + HighEight(SetPal \ 5))
                OUT &H3C9, r(SetPal \ 5 + HighEight(SetPal \ 5))
                OUT &H3C9, g(SetPal \ 5 + HighEight(SetPal \ 5))
                OUT &H3C9, b(SetPal \ 5 + HighEight(SetPal \ 5))
            NEXT SetPal
            Pal "Save"
         GOSUB SetColorBars
         LOCATE , , 0
         COLOR 8, 7: LOCATE 21, 2: PRINT UCASE$(Filename$);
         GOSUB ClearHelpStatLine

         IF ErrorStatus = FALSE THEN
            LOCATE 24, 1: PRINT UCASE$(Filename$);
            LOCATE 25, 1: PRINT "Loaded!";
            Delay 2
         ELSE
            LOCATE 24, 1: PRINT UCASE$(Filename$);
            LOCATE 25, 1: PRINT "NOT Loaded!"; : Filename$ = "": OldName$ = Filename$
            Delay 2
            COLOR 8, 7: LOCATE 21, 2: PRINT STRING$(78, 32); : COLOR 7, 0
         END IF
         EXIT DO
   END SELECT
LOOP
LOCATE , , 0
RETURN

AlterRed:
OldRed = Red
DO
  x$ = INKEY$
  SELECT CASE x$
    CASE IS = CHR$(13)
        Center 10, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
        COLOR 12, 0: LOCATE 10, 9 + Red: PRINT CHR$(42);
        GOSUB UpdateRegisters
        Pal "SAVE"
        EXIT DO
    CASE IS = CHR$(27)
        Center 10, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
        COLOR 12, 0: LOCATE 10, 9 + OldRed: PRINT CHR$(42); : Red = OldRed
        GOSUB UpdateRegisters
        Pal "SAVE"
        EXIT DO
    CASE CHR$(0) + CHR$(75), CHR$(0) + CHR$(72)
        Red = Red - 1
        IF Red < 0 THEN Red = 63
        Center 10, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
        COLOR 12, 0: LOCATE 10, 9 + Red: PRINT CHR$(42);
        GOSUB UpdateRegisters
    CASE CHR$(0) + CHR$(77), CHR$(0) + CHR$(80)
        Red = Red + 1
        IF Red > 63 THEN Red = 0
        Center 10, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
        COLOR 12, 0: LOCATE 10, 9 + Red: PRINT CHR$(42);
        GOSUB UpdateRegisters
  END SELECT
LOOP
RETURN

SavePalette:
COLOR 8, 7
Filename$ = UCASE$(Filename$)
OldName$ = Filename$
IF OldName$ = "" OR Filename$ = "" THEN
  LOCATE 21, 2: PRINT STRING$(78, 32);
END IF

DO
LOCATE 21, 2
DO                              'edit until Enter or Esc
   Editor Filename$, 2, 79, KeyCode
LOOP UNTIL KeyCode = 13 OR KeyCode = 27
IF KeyCode = 27 THEN
   IF OldName$ = "" OR Filename$ = "" THEN
      LOCATE 21, 2: PRINT STRING$(78, 32);
   ELSE
      Filename$ = OldName$: LOCATE 21, 2: PRINT Filename$
   END IF
   EXIT DO
END IF

   SELECT CASE Filename$
     CASE IS = "": EXIT DO
     CASE ELSE
         ErrorStatus = FALSE
         ON ERROR GOTO EHandler
         OPEN Filename$ FOR OUTPUT AS #1
             PRINT #1, "Text Color Pal Save File Version .03á"
             FOR ColPrin = 1 TO 80 STEP 5
                PRINT #1, LTRIM$(RTRIM$(STR$(r(ColPrin \ 5 + HighEight(ColPrin \ 5)))))
                PRINT #1, LTRIM$(RTRIM$(STR$(g(ColPrin \ 5 + HighEight(ColPrin \ 5)))))
                PRINT #1, LTRIM$(RTRIM$(STR$(b(ColPrin \ 5 + HighEight(ColPrin \ 5)))))
            NEXT ColPrin
         CLOSE
         LOCATE , , 0
         COLOR 8, 7: LOCATE 21, 2: PRINT UCASE$(Filename$);
         GOSUB ClearHelpStatLine
        
         IF ErrorStatus = FALSE THEN
            LOCATE 24, 1: PRINT UCASE$(Filename$);
            LOCATE 25, 1: PRINT "Saved!";
            Delay 2
         ELSE
            LOCATE 24, 1: PRINT UCASE$(Filename$);
            LOCATE 25, 1: PRINT "NOT Saved!"; : Filename$ = "": OldName$ = Filename$
            Delay 2
            COLOR 8, 7: LOCATE 21, 2: PRINT STRING$(78, 32); : COLOR 7, 0
         END IF
         EXIT DO
   END SELECT
LOOP
LOCATE , , 0
RETURN

ClearHelpStatLine:
COLOR 7, 0: LOCATE 24, 1: PRINT STRING$(80, 32); : LOCATE 25, 1: PRINT STRING$(80, 32);
RETURN

SetColorBars:
'Red
Center 10, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
COLOR 12, 0: LOCATE 10, 9 + r(Col \ 5 + HighEight(Col \ 5)): PRINT CHR$(42);
'Green
Center 13, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
COLOR 10, 0: LOCATE 13, 9 + g(Col \ 5 + HighEight(Col \ 5)): PRINT CHR$(42);
'Blue
Center 16, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
COLOR 9, 0: LOCATE 16, 9 + b(Col \ 5 + HighEight(Col \ 5)): PRINT CHR$(42);
Red = r(Col \ 5 + HighEight(Col \ 5)): Green = g(Col \ 5 + HighEight(Col \ 5)): Blue = b(Col \ 5 + HighEight(Col \ 5))
RETURN

UpdateRegisters:
WAIT &H3DA, 8, 8
OUT &H3C8, ColSelect  ' Set color to write
OUT &H3C9, Red        ' write red value
OUT &H3C9, Green      ' write green value
OUT &H3C9, Blue       ' write blue value
RETURN
        
EHandler:
ErrorStatus = TRUE
CLOSE
GOSUB ClearHelpStatLine
SELECT CASE ERR
  CASE IS = 7
   LOCATE 24, 1: PRINT "Program Error: Out of memory";
   LOCATE 25, 1: PRINT "I used up all of the DGROUP space, Try again."; : END
  CASE IS = 9
   LOCATE 24, 1: PRINT "Program Error: Array Subscript out of range";
   LOCATE 25, 1: PRINT "Upper limit of allocated space exceeded.";
  CASE IS = 14
   LOCATE 24, 1: PRINT "Program Error: Out of String Space";
   LOCATE 25, 1: PRINT "I can't fit this into memory, it is partially loaded.";
  CASE IS = 24
   LOCATE 24, 1: PRINT "Informative Error: Device timeout";
   LOCATE 25, 1: PRINT "Turn on your printer or activate `on-line' mode.";
  CASE IS = 25
   LOCATE 24, 1: PRINT "Printer Error: Device fault";
   LOCATE 25, 1: PRINT "I can't talk to your printer or print que.";
  CASE IS = 27
   LOCATE 24, 1: PRINT "Printer Error: Out of paper";
   LOCATE 25, 1: PRINT "Put Paper in your printer.";
  CASE IS = 52
   LOCATE 24, 1: PRINT "Program or User Error: Bad File Name or number"
   LOCATE 25, 1: PRINT "You provided a bad file name or I tried to use a file number that doesn't exist.";
  CASE IS = 53
   LOCATE 24, 1: PRINT "FileManager/User input Error: File not found";
   LOCATE 25, 1: PRINT "I cannot find the file you requested.";
  CASE IS = 54
   LOCATE 24, 1: PRINT "FileManager/Programmer Error: Bad file mode";
   LOCATE 25, 1: PRINT "I am unable to read a file properly. Bug fix by programmer required.";
  CASE IS = 55
   LOCATE 24, 1: PRINT "FileManager Error: File already open";
   LOCATE 25, 1: PRINT "A file was already opened, all files are now closed.";
  CASE IS = 57
   LOCATE 24, 1: PRINT "System Fault: Device I/O error";
   LOCATE 25, 1: PRINT "I can not 'talk' to a specific device.";
  CASE IS = 58
   LOCATE 24, 1: PRINT "Informative Error: File already exists";
  CASE IS = 59
   LOCATE 24, 1: PRINT "FileManager Error: Bad record length";
   LOCATE 25, 1: PRINT "A database record of some sort is not long enough or is too long.";
  CASE IS = 61
   LOCATE 24, 1: PRINT "Informative Error: Disk FULL";
   LOCATE 25, 1: PRINT "Free up some disk space.";
  CASE IS = 62
   LOCATE 24, 1: PRINT "FileManager Error: Input past end of file.";
   LOCATE 25, 1: PRINT "Attempt to read beyond the end of current file.";
  CASE IS = 63
   LOCATE 24, 1: PRINT "Program Error: Bad record number";
   LOCATE 25, 1: PRINT "A database record of some sort doesn't exist.";
  CASE IS = 64
   LOCATE 24, 1: PRINT "User Error: Bad file name";
   LOCATE 25, 1: PRINT "You specifically told me to use a file name that is incorrect.";
  CASE IS = 67
   LOCATE 24, 1: PRINT "FileManager Fault: Too many files open";
   LOCATE 25, 1: PRINT "I can't handle more files than listed in your CONFIG.SYS file.";
  CASE IS = 68
   LOCATE 24, 1: PRINT "System Error: Device UNAVAILABLE";
   LOCATE 25, 1: PRINT "A user serviceable device is not accessable to the computer.";
  CASE IS = 71
   LOCATE 24, 1: PRINT "User or System Error: Disk not Ready";
   LOCATE 25, 1: PRINT "Insert a diskette in the current drive. (Excepting Hardrives)";
  CASE IS = 72
   LOCATE 24, 1: PRINT "Serious Informative Error: Disk-Media error";
   LOCATE 25, 1: PRINT "The recordable media surface of the current disk has developed a defect.";
  CASE IS = 73
   LOCATE 24, 1: PRINT "Informative Error: Feature unavailable";
   LOCATE 25, 1: PRINT "An advanced capability is not available within this computer.";
  CASE IS = 75
   LOCATE 24, 1: PRINT "FileManager/User input Error: Path/File access error";
  CASE IS = 76
   LOCATE 24, 1: PRINT "FileManager/User input Error: Path not found";
   LOCATE 25, 1: PRINT "The path to a file is non-existant.";
  CASE ELSE
   LOCATE 24, 1: PRINT "Bug squashing Required. Contact orginal programmer."; : Delay 3: END
END SELECT
Delay 1
GOSUB ClearHelpStatLine
RESUME NEXT

SUB Box (Row%, Column%, BoxWidth%, Height%, BoxColor%, BoxCharacter%, BorderType%, BorderColor%)
'*******************************************************************************
'*  displays a box of definable attributes on the screen                       *
'*******************************************************************************
    StartRow% = Row%
    SELECT CASE BorderType%
'      no border
       CASE 0
          UpperLeft$ = CHR$(BoxCharacter%)
          UpperRight$ = CHR$(BoxCharacter%)
          LowerLeft$ = CHR$(BoxCharacter%)
          LowerRight$ = CHR$(BoxCharacter%)
          Vertical$ = CHR$(BoxCharacter%)
          Horizontal$ = CHR$(BoxCharacter%)
'      single border
       CASE 1
          UpperLeft$ = CHR$(218)
          UpperRight$ = CHR$(191)
          LowerLeft$ = CHR$(192)
          LowerRight$ = CHR$(217)
          Vertical$ = CHR$(179)
          Horizontal$ = CHR$(196)
'      double border
       CASE 2
          UpperLeft$ = CHR$(201)
          UpperRight$ = CHR$(187)
          LowerLeft$ = CHR$(200)
          LowerRight$ = CHR$(188)
          Vertical$ = CHR$(186)
          Horizontal$ = CHR$(205)
    END SELECT

    InnerWidth% = BoxWidth% - 2
    InnerHeight% = Height% - 2
    InnerFilling$ = STRING$(InnerWidth%, CHR$(BoxCharacter%))
    BoxTopBottom$ = STRING$(InnerWidth%, Horizontal$)

    COLOR BorderColor%, BoxColor%
    LOCATE StartRow%, Column%
    PRINT UpperLeft$ + BoxTopBottom$ + UpperRight$;
    StartRow% = StartRow% + 1

    FOR FillLoop% = 1 TO InnerHeight%
        LOCATE StartRow%, Column%
        PRINT Vertical$ + InnerFilling$ + Vertical$;
        StartRow% = StartRow% + 1
    NEXT FillLoop%

    LOCATE StartRow%, Column%
    PRINT LowerLeft$ + BoxTopBottom$ + LowerRight$;
END SUB

SUB Center (Row, Text$, ForeG, BackG, Blink)
IF Blink = -1 THEN ForeG = ForeG + 16
COLOR ForeG, BackG
LOCATE Row, (41 - LEN(Text$) \ 2), 0
PRINT Text$;
COLOR 7, 0
END SUB

SUB Delay (Period!)
Begin! = TIMER: DO UNTIL (TIMER - Begin! > Period!) OR (TIMER - Begin! < 0): LOOP
END SUB

SUB DrawScreen
VIEW PRINT 1 TO 25: CLS
Center 1, Version$, 7, 0, FALSE
LOCATE 2, 1: PRINT STRING$(80, 196);
FOR Col = 1 TO 80 STEP 5
' (Row%, Column%, BoxWidth%, Height%, BoxColor%, BoxCharacter%, BorderType%, BorderColor%)
Box 3, Col + 1, 4, 3, Col \ 10, 0, 1, (Col \ 10 + 1)
COLOR (Col \ 5), 0: LOCATE 4, (Col + 2): PRINT CHR$(219) + CHR$(219);
COLOR 7, 0: LOCATE 6, (Col + 2): PRINT LTRIM$(STR$(Col \ 5));
NEXT Col
COLOR 0, 7: LOCATE 6, 3: PRINT "0"; : COLOR 7, 0
LOCATE 7, 1: PRINT STRING$(80, 196);
'(Position%, XButton%, YButton%, Button$, ButtonForeColour%, ButtonBackColour%, ButtonHiLightChar%, ShadowColour%, ShadowBackGround%, Shadow%)
'Set Up Color Bars - Red
TextButton Up, 37, 8, "~Red", 12, 4, 15, 12, 0, Right
Center 10, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
COLOR 12, 0: LOCATE 10, 9: PRINT CHR$(42);
' Green
TextButton Up, 36, 11, "~Green", 10, 2, 15, 10, 0, Right
Center 13, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
COLOR 10, 0: LOCATE 13, 9: PRINT CHR$(42);
'Blue
TextButton Up, 37, 14, "~Blue", 9, 1, 15, 9, 0, Right
Center 16, "0 " + STRING$(64, 42) + " 63", 7, 0, FALSE
COLOR 9, 0: LOCATE 16, 9: PRINT CHR$(42);
'Set Up Other Buttons
TextButton Up, 5, 18, "~Change Color", 14, 5, 15, 8, 0, Right
TextButton Up, 22, 18, "~Load Palette", 14, 5, 15, 8, 0, Right
TextButton Up, 39, 18, "~Save Palette", 14, 5, 15, 8, 0, Right
TextButton Up, 56, 18, "~Quit Text Color Pal", 14, 5, 15, 8, 0, Right
'Set up File Box & Help Line  !
Box 20, 1, 80, 3, 7, 0, 1, 8
COLOR 7, 0: LOCATE 23, 1: PRINT STRING$(80, 196);
END SUB

SUB Editor (Text$, LeftCol, RightCol, KeyCode)
  '----- Find the cursor's size.
  DEF SEG = 0
  IF PEEK(&H463) = &HB4 THEN
     CsrSize = 12               'mono uses 13 scan lines
  ELSE
     CsrSize = 7                'color uses 8
  END IF

  '----- Work with a temporary copy.
  Edit$ = SPACE$(RightCol - LeftCol + 1)
  LSET Edit$ = Text$

  '----- See where to begin editing and print the string.
  TxtPos = POS(0) - LeftCol + 1
  IF TxtPos < 1 THEN TxtPos = 1
  IF TxtPos > LEN(Edit$) THEN TxtPos = LEN(Edit$)

  LOCATE , LeftCol
  PRINT Edit$;

  '----- This is the main loop for handling key presses.
  DO
     LOCATE , LeftCol + TxtPos - 1, 1

     DO
       Ky$ = INKEY$
     LOOP UNTIL LEN(Ky$)        'wait for a keypress

     IF LEN(Ky$) = 1 THEN       'create a key code
       KeyCode = ASC(Ky$)       'regular character key
     ELSE                       'extended key
       KeyCode = -ASC(RIGHT$(Ky$, 1))
     END IF

     '----- Branch according to the key pressed.
     SELECT CASE KeyCode

       '----- Backspace: decrement the pointer and the
       '      cursor, and ignore if in the first column.
       CASE 8
         TxtPos = TxtPos - 1
         LOCATE , LeftCol + TxtPos - 1, 0
         IF TxtPos > 0 THEN
           IF InsStatus THEN
             MID$(Edit$, TxtPos) = MID$(Edit$, TxtPos + 1) + " "
           ELSE
             MID$(Edit$, TxtPos) = " "
           END IF
             PRINT MID$(Edit$, TxtPos);
         END IF

       '----- Enter or Escape: this block is optional in
       '      case you want to handle these separately.
       CASE 13, 27
         EXIT DO                'exit the subprogram

       '----- Letter keys: turn off the cursor to hide
       '      the printing, handle Insert mode as needed.
       CASE 32 TO 254
         LOCATE , , 0
         IF InsStatus THEN      'expand the string
           MID$(Edit$, TxtPos) = Ky$ + MID$(Edit$, TxtPos)
           PRINT MID$(Edit$, TxtPos);
         ELSE                   'else insert character
           MID$(Edit$, TxtPos) = Ky$
           PRINT Ky$;
         END IF
         TxtPos = TxtPos + 1    'update position counter

       '----- Left arrow: decrement the position counter.
       CASE -75
         TxtPos = TxtPos - 1

       '----- Right arrow: increment position counter.
       CASE -77
         TxtPos = TxtPos + 1

       '----- Home: jump to the first character position.
       CASE -71
         TxtPos = 1

       '----- End: search for the last non-blank, and
       '      make that the current editing position.
       CASE -79
         FOR N = LEN(Edit$) TO 1 STEP -1
           IF MID$(Edit$, N, 1) <> " " THEN EXIT FOR
         NEXT
         TxtPos = N + 1
         IF TxtPos > LEN(Edit$) THEN TxtPos = LEN(Edit$)

       '----- Insert key: toggle the Insert state and
       '      adjust the cursor size.
       CASE -82
         InsStatus = NOT InsStatus
         IF InsStatus THEN
           LOCATE , , , CsrSize \ 2, CsrSize
         ELSE
           LOCATE , , , CsrSize - 1, CsrSize
         END IF

       '----- Delete: delete the current character and
       '      reprint what remains in the string.
       CASE -83
         MID$(Edit$, TxtPos) = MID$(Edit$, TxtPos + 1) + " "
         LOCATE , , 0
         PRINT MID$(Edit$, TxtPos);

       '---- All other keys: exit the subprogram
       CASE ELSE
         EXIT DO
     END SELECT

  '----- Loop until the cursor moves out of the field.
  LOOP UNTIL TxtPos < 1 OR TxtPos > LEN(Edit$)

  Text$ = RTRIM$(Edit$)         'trim the text
END SUB

SUB Init.XTable
  FOR cnt = 0 TO MaxRow - 1
    XTable(cnt + 1) = -cnt
  NEXT cnt
END SUB

FUNCTION Monitor% (VSSegment)
DEF SEG = 0              'first see if it's color or mono
VSSegment = &HB800         'assume color

IF PEEK(&H463) = &HB4 THEN

  VSSegment = &HB000       'assign the monochrome segment
  Status = INP(&H3BA)    'get the current video status
  FOR x = 1 TO 30000     'test for a Hercules 30000 times
    IF INP(&H3BA) <> Status THEN
      Monitor% = 2       'the port changed, it's a Herc
      EXIT FUNCTION      'all done
    END IF
  NEXT
  Monitor% = 1           'it's a plain monochrome

ELSE                     'it's some sort of color monitor

  Registers.AX = &H1A00     'first test for VGA
  CALL InterruptX(&H10, Registers, Registers)
  IF (Registers.AX AND &HFF) = &H1A THEN
    Monitor% = 5         'it's a VGA
    EXIT FUNCTION        'all done
  END IF

  Registers.AX = &H1200     'now test for EGA
  Registers.BX = &H10
  CALL InterruptX(&H10, Registers, Registers)
  IF (Registers.BX AND &HFF) = &H10 THEN
    Monitor% = 3         'if BL is still &H10 it's a CGA
  ELSE
    Monitor% = 4         'otherwise it's an EGA
  END IF
END IF
DEF SEG
END FUNCTION

SUB Pal (Act$)
   SELECT CASE UCASE$(Act$)
   ' "save","fadein","fadeout","restore","blackout"
      CASE "SAVE"
         FOR colour% = 0 TO 255
            OUT &H3C7, colour%          ' Set color to read
            r(colour%) = INP(&H3C9)   ' read red value
            g(colour%) = INP(&H3C9)   ' read green value
            b(colour%) = INP(&H3C9)   ' read blue value
         NEXT
      CASE "FADEIN"
         DO
            done% = 0
            FOR colour% = 0 TO 255
               OUT &H3C7, colour%       ' Set color to read
               Red% = INP(&H3C9)        ' read red value
               grn% = INP(&H3C9)        ' read green value
               blu% = INP(&H3C9)        ' read blue value
               ' Test the color values, decrementing if necessary.
               ' Set loop variable if saved palette not in use.
               IF Red% < r(colour%) THEN Red% = Red% + 1: done% = 1
               IF grn% < g(colour%) THEN grn% = grn% + 1: done% = 1
               IF blu% < b(colour%) THEN blu% = blu% + 1: done% = 1
               WAIT &H3DA, 8, 8
               OUT &H3C8, colour%       ' Set color to write
               OUT &H3C9, Red%          ' write red value
               OUT &H3C9, grn%          ' write green value
               OUT &H3C9, blu%          ' write blue value
            NEXT
         LOOP WHILE done% <> 0
      CASE "FADEOUT"
         DO
            visible% = 0
            FOR colour% = 0 TO 255
               OUT &H3C7, colour%       ' Set color to read
               Red% = INP(&H3C9)        ' read red value
               grn% = INP(&H3C9)        ' read green value
               blu% = INP(&H3C9)        ' read blue value
               ' Test the color values, decrementing if necessary.
               ' Set loop variable if colors are still visible.
               IF Red% > 0 THEN Red% = Red% - 1: visible% = 1
               IF grn% > 0 THEN grn% = grn% - 1: visible% = 1
               IF blu% > 0 THEN blu% = blu% - 1: visible% = 1
               WAIT &H3DA, 8, 8
               OUT &H3C8, colour%       ' Set color to write
               OUT &H3C9, Red%          ' write red value
               OUT &H3C9, grn%          ' write green value
               OUT &H3C9, blu%          ' write blue value
            NEXT
         LOOP WHILE visible% <> 0
      CASE "RESTORE"
         FOR colour% = 0 TO 255
            OUT &H3C8, colour%          ' Set color to write
            OUT &H3C9, r(colour%)     ' write red value
            OUT &H3C9, g(colour%)     ' write green value
            OUT &H3C9, b(colour%)     ' write blue value
         NEXT
      CASE "BLACKOUT"
         FOR colour% = 0 TO 255
            OUT &H3C8, colour%          ' Set color to write
            OUT &H3C9, 0                ' write red value
            OUT &H3C9, 0                ' write green value
            OUT &H3C9, 0                ' write blue value
         NEXT
   END SELECT
END SUB

SUB Shine (sx%, sy%, ex%, ey%, C%)
DIM Buffer(1 TO MaxRow) AS INTEGER     ' Add or remove the number
DIM Buffer2(1 TO MaxRow) AS INTEGER    ' of light sequences as desired, and
DIM Buffer3(1 TO MaxRow) AS INTEGER    ' delete necessary code from below

 cnt = 0
 FOR x = sx TO ex + ey - sy
   FOR y = sy TO ey
     IF (XTable(y - sy + 1) + x > sx - 1) AND (XTable(y - sy + 1) + x < ex + 1) THEN
       num = (y - 1) * 160 + (XTable(y - sy + 1) + (x - 1)) * 2 + 1
       Buffer(y) = PEEK(num)                    'save background attr.
       Buffer2(y) = PEEK(num + 2)               '2nd save
       Buffer3(y) = PEEK(num + 4)               '3rd save
       POKE num, C + (Buffer(y) AND 240)        'highlight the spot
                                                'Just change the attribute
       POKE num + 2, C + (Buffer2(y) AND 240)   '2nd highlight
       POKE num + 4, C + (Buffer3(y) AND 240)   '3rd highlight
     END IF
   NEXT y

   WAIT &H3DA, 8     ' Wait for retrace, else chaos erupts!
 
   FOR y = sy TO ey
     IF (XTable(y - sy + 1) + x > sx - 1) AND (XTable(y - sy + 1) + x < ex + 1) THEN
       'restore background attr.
       ' 1st, 2nd, then 3rd
       POKE ((y - 1) * 160 + (XTable(y - sy + 1) + (x - 1)) * 2 + 1), Buffer(y)
       POKE ((y - 1) * 160 + (XTable(y - sy + 1) + (x - 1)) * 2 + 1) + 2, Buffer2(y)
       POKE ((y - 1) * 160 + (XTable(y - sy + 1) + (x - 1)) * 2 + 1) + 4, Buffer3(y)
     END IF
   NEXT y
 NEXT x
END SUB

SUB ShowImage
WIDTH 80, 43: VIEW PRINT 1 TO 43: CLS
GOSUB RF
Box 2, 2, 78, 41, 4, 0, 2, Foreground
GOSUB RF
Center 4, Version$, Foreground, 4, FALSE
GOSUB RF
Center 5, "96% Coded by Zapf DingBat", Foreground, 4, FALSE
GOSUB RF
Center 7, STRING$(76, 196), Foreground, 4, FALSE
GOSUB RF
Center 9, "Other credits include ..", Foreground, 4, FALSE
GOSUB RF
Center 11, "William Yu for converting the Shine FX pascal code and", Foreground, 4, FALSE
GOSUB RF
Center 12, "the really easy to use Text button routine.", Foreground, 4, FALSE
GOSUB RF
Center 14, "Christopher J. C. - for actually writing the pascal code.", Foreground, 4, FALSE
GOSUB RF
Center 16, "Ethan Winer for the line editor sub & video system detection code.", Foreground, 4, FALSE
GOSUB RF
Center 18, "Matthew R. Usner for finding the Box routine and his QBSUBFUN library.", Foreground, 4, FALSE
GOSUB RF
Center 20, "Logic Lord for being my friend, testing my stuff, giving me advice", Foreground, 4, FALSE
GOSUB RF
Center 21, "and ideas. He also puts up with my 'old' ways. Plus he writes cool", Foreground, 4, FALSE
GOSUB RF
Center 22, "programs.", Foreground, 4, FALSE
GOSUB RF
Center 24, STRING$(76, 196), Foreground, 4, FALSE
GOSUB RF
Center 26, "Program Plugs (programs you really need to see) ..", Foreground, 4, FALSE
GOSUB RF
Center 28, "Fm Tracker - Logic Lord (VGA, Txt based)", Foreground, 4, FALSE
GOSUB RF
Center 29, "Mega CD Player - Logic Lord (VGA, Gfx based)", Foreground, 4, FALSE
GOSUB RF
Center 31, "Simple DingPlayer - Zapf DingBat (VGA, Txt based)", Foreground, 4, FALSE
GOSUB RF
Center 32, "DingPlayer - Zapf DingBat (VGA, Gfx based)", Foreground, 4, FALSE
GOSUB RF
Center 34, "The CD Playing routines used in Mega CD Player, Simple DingPlayer", Foreground, 4, FALSE
GOSUB RF
Center 35, "& DingPlayer were coded by Logic Lord & Zapf DingBat.", Foreground, 4, FALSE
GOSUB RF
Center 37, STRING$(76, 196), Foreground, 4, FALSE
GOSUB RF
Center 39, "...Spam, Eggs, Spam & Spam. Spam, Spam, Sausage & Spam...", Foreground, 4, FALSE
Center 40, "...Doctor It's time to Operate...", Foreground, 4, FALSE
EXIT SUB

RF:
DO: Foreground = CINT(RND * 15): LOOP UNTIL Foreground <> 4
RETURN
END SUB

SUB TextButton (Position%, XButton%, YButton%, Button$, ButtonForeColour%, ButtonBackColour%, ButtonHiLightChar%, ShadowColour%, ShadowBackGround%, Shadow%)
XCor = XButton

IF (Shadow = Left) AND (Position = Up) THEN      ' Place shadows on the
  LOCATE YButton, XButton - 1                    ' left side of button
  COLOR ShadowColour, ShadowBackGround
  PRINT "Ü";
  LOCATE YButton + 1, XButton - 1: PRINT "ßß";
END IF

IF Position = Down THEN        ' This routine removes the shadows
  LOCATE YButton, XButton
  COLOR , ShadowBackGround
  PRINT " ";
  IF Shadow = Right THEN XCor = XCor + 1 ELSE XCor = XCor - 1
  LOCATE YButton + 1, XCor: PRINT " ";
END IF

LOCATE YButton, XCor
COLOR ButtonForeColour, ButtonBackColour
PRINT " ";              ' Spaces are automatically inserted, remove if desired

Length = LEN(Button$)   ' Number of characters in BUTTON$
FOR I = 1 TO Length     ' Parse them all
  IF MID$(Button$, I, 1) = "~" THEN
    COLOR ButtonHiLightChar
  ELSE
    XCor = XCor + 1
    LOCATE YButton, XCor
    PRINT MID$(Button$, I, 1);
    COLOR ShadowColour, ShadowBackGround
    IF Position = Up THEN
      LOCATE YButton + 1, XCor: PRINT "ß";
    ELSE
      LOCATE YButton + 1, XCor: PRINT " ";
    END IF
    COLOR ButtonForeColour, ButtonBackColour
  END IF
NEXT I

IF Position = Down THEN        ' This routine also removes the shadows
  LOCATE YButton + 1, XCor + 1
  COLOR ShadowColour, ShadowBackGround
  PRINT " ";
  IF Shadow = Left THEN
    LOCATE YButton, XCor + 2: PRINT " ";
  END IF
END IF

COLOR ButtonForeColour, ButtonBackColour
LOCATE YButton, XCor + 1
PRINT " ";              ' Spaces are automatically inserted, remove if desired

IF (Shadow = Right) AND (Position = Up) THEN
  COLOR ShadowColour, ShadowBackGround
  PRINT "Ü";
  LOCATE YButton + 1, XCor + 1: PRINT "ßß";
END IF
END SUB