'===========================================================================
' Subject: Text-mode Palette                  Date: 10-12-01 (  :  )       
'  Author: Walt Decker                        Code: QBasic,QB, PDS         
'  Origin: lydia2hg@yahoo.com               Packet: TEXT.ABC
'===========================================================================
'*********************************************************
'PROGRAM NAME: BASICFX.BAS
'DATE:         10-20-2001
'*********************************************************

'Many people don't realize that the colors in screen mode 0 can be changed.
'This little routine writes directly to the DAC registers to change the
'palette in mode 0.

'With some modification, this routine should work in all screen modes. 
'Modifications include the print locations (LOCATE) to fit the screen
'resolution, adjusting the size of typSysPal() and typNewPal() to fit the
'size of the palette (although that is not necessary), and adding mouse
'support.

'SUBs SetPal, GetKey, SetColors, and GetColors can be used with a variety of
'applications and screen modes.

'-------------------------------------------------------------------------
'                DECLARE SUB ROUTINES
'------------------------------------------------------------------------
DECLARE SUB PrtColorBar (Hline$, CLine$)
DECLARE SUB GetKey (KeyPress AS STRING)
DECLARE SUB PrtBlock (intCly%, intClx%, strHline$, strLine$, intColor%)
DECLARE SUB PrtColorGraph (intRy%, intRx%, strHline$, intSysPal%, strLine$, intColor%, intO%)
DECLARE SUB GetColorNum (intBy%, intBx%, intColor%)
DECLARE SUB SetPal (Pal() AS ANY, intVal%, intComPonent%, intColor%)
DECLARE SUB SetCurX (intX%, intY%, intRy%, intGy%, intBy%, intJ%, Hline$)
DECLARE SUB SetColors (Pal() AS ANY, Ic1%, Lc%)
DECLARE SUB Getcolors (Pal() AS ANY, Ic1%, Lc%)

'------------------------- STRUCTURE FOR DAC REGISTERS -----------------
TYPE Pal
  red   AS INTEGER
  blue  AS INTEGER
  green AS INTEGER
END TYPE

'----------------------- DECLARE VARIABLES -----------------------------
DIM strLine  AS STRING * 1
DIM strHline AS STRING
DIM strInput AS STRING
DIM strRed   AS STRING
DIM strGreen AS STRING
DIM strBlue  AS STRING
DIM strUarow AS STRING * 2
DIM strLarow AS STRING * 2
DIM strDarow AS STRING * 2
DIM strRarow AS STRING * 2
DIM strEnd   AS STRING * 2
DIM strStrng AS STRING

DIM intI     AS INTEGER
DIM intJ     AS INTEGER
DIM intRx    AS INTEGER
DIM intRy    AS INTEGER
DIM intBx    AS INTEGER
DIM intBy    AS INTEGER
DIM intGx    AS INTEGER
DIM intGy    AS INTEGER
DIM intClx   AS INTEGER
DIM intCly   AS INTEGER
DIM intColor AS INTEGER
DIM intCval  AS INTEGER
DIM intCurX  AS INTEGER
DIM intCurY  AS INTEGER

DIM typSysPal(0 TO 255) AS Pal
DIM typNewPal(0 TO 255) AS Pal

'------------------------ INITIALIZE SOME VARIABLES ----------------------
strLine = CHR$(219)
strUarow = CHR$(0) + "H"
strLarow = CHR$(0) + "K"
strDarow = CHR$(0) + "P"
strRarow = CHR$(0) + "M"
strEnd = CHR$(0) + "O"

intClx = 60
intCly = 1
intRx = 1
intRy = 9
intGx = 1
intGy = 11
intBx = 1
intBy = 13

SCREEN 0             '  SET SCREEN MODE
CLS                  '  CLEAR THE SCREEN

CALL Getcolors(typSysPal(), 0, 255)  'LOAD SYSTEM PALETTE ARRAY

FOR intI = 0 TO 255                  'INITIALIZE WORKING PALETTE ARRAY
  typNewPal(intI) = typSysPal(intI)
NEXT intI

CALL PrtColorBar(strHline, strLine)  'PRINT SOME COLORS

'----------------------- SHOW INSTRUCTIONS ---------------------------
COLOR 7
PRINT
PRINT

PRINT "Use Up/Down Arrow Keys and ENTER to select"
PRINT "     color component or color"

PRINT "Use Right/Left Arrow Keys to increase/decrease"
PRINT "     color component values"

PRINT "Use END to quit program"
CALL PrtBlock((intCly), intClx, strHline, strLine, intColor) 'MAKE A BLOCK OF COLOR

'--------------------- BUILD COLOR GRAPH --------------------------
intI = typNewPal(1).red
intColor = 1
CALL PrtColorGraph(intRy, intRx, strHline, intI, strLine, intColor, 1)
intI = typNewPal(1).green
CALL PrtColorGraph(intGy, intGx, strHline, intI, strLine, intColor, 2)
intI = typNewPal(1).blue
CALL PrtColorGraph(intBy, intBx, strHline, intI, strLine, intColor, 3)

Color.Loop: '

CALL GetColorNum(intBy, intBx, intColor)
CALL PrtColorBar(strHline, strLine)
CALL PrtBlock((intCly), intClx, strHline, strLine, intColor)

intCval = typNewPal(intColor).green
intJ = 1
CALL PrtColorGraph(intGy, intGx, strHline, intCval, strLine, intColor, 2)

intCval = typNewPal(intColor).blue
CALL PrtColorGraph(intBy, intBx, strHline, intCval, strLine, intColor, 3)

intCval = typNewPal(intColor).red
CALL PrtColorGraph(intRy, intRx, strHline, intCval, strLine, intColor, intJ)

'------------------ SET CURSOR AT 1ST GRAPH ---------------------------
intCurX = LEN("RED :" + strHline)
intCurY = intRy

LOCATE intCurY, intCurX, 1, 31, 1

'------------------ GET USER INPUT ---------------------------
DO
  CALL GetKey(strStrng)
  SELECT CASE strStrng
    CASE IS = strUarow

      intJ = intJ - 1
      IF intJ < 0 THEN intJ = 3
      GOSUB GetCval
      GOSUB SelectGraph
      CALL SetCurX(intCurX, intCurY, intRy, intGy, intBy, intJ, strHline)

    CASE IS = strLarow

      intCval = intCval - 1
      IF intCval < 0 THEN intCval = 0
      CALL SetPal(typNewPal(), intCval, intJ, intColor)
      CALL SetColors(typNewPal(), intColor, intColor)
      GOSUB SelectGraph
      CALL SetCurX(intCurX, intCurY, intRy, intGy, intBy, intJ, strHline)

    CASE IS = strDarow

      intJ = intJ + 1
      IF intJ > 3 THEN intJ = 1
      GOSUB GetCval
      GOSUB SelectGraph
      CALL SetCurX(intCurX, intCurY, intRy, intGy, intBy, intJ, strHline)

    CASE IS = strRarow

      intCval = intCval + 1
      IF intCval > 63 THEN intCval = 63
      CALL SetPal(typNewPal(), intCval, intJ, intColor)
      CALL SetColors(typNewPal(), intColor, intColor)
      GOSUB SelectGraph
      CALL SetCurX(intCurX, intCurY, intRy, intGy, intBy, intJ, strHline)

    CASE IS = strEnd

      EXIT DO

    CASE IS = CHR$(13)
      GOTO Color.Loop
  END SELECT
LOOP
CALL SetColors(typSysPal(), 0, 255)   'RESET SYSTEM PALETTE
END

SelectGraph:      '

  SELECT CASE intJ
    CASE 1
      CALL PrtColorGraph(intRy, intRx, strHline, intCval, strLine, intColor, intJ)
    CASE 2
      CALL PrtColorGraph(intGy, intGx, strHline, intCval, strLine, intColor, intJ)
    CASE 3
      CALL PrtColorGraph(intBy, intBx, strHline, intCval, strLine, intColor, intJ)
  END SELECT
RETURN

GetCval: '

  SELECT CASE intJ
    CASE 1
      intCval = typNewPal(intColor).red
    CASE 2
      intCval = typNewPal(intColor).green
    CASE 3
      intCval = typNewPal(intColor).blue
  END SELECT
RETURN

DEFINT A-Z
SUB GetColorNum (intBy, intBx, intColor)

LOCATE intBy + 2, intBx
PRINT STRING$(75, " ")

LOCATE intBy + 2, intBx
PRINT "Enter Color (0 to 63)";

INPUT intColor

END SUB

SUB Getcolors (Pal() AS Pal, Ic1, Lc)

'polls the DAC registers for the current colors
'values for the colors are in the range 0 to 63
'each for red, green, and blue

   OUT &H3C7, Ic1                    'tell controller to get ready
   FOR I = Ic1 TO Lc                 'first to last
      Pal(I).red = INP(&H3C9)        'get red component
      Pal(I).green = INP(&H3C9)       'get green component
      Pal(I).blue = INP(&H3C9)        'get blue component
   NEXT I
END SUB

DEFSNG A-Z
SUB GetKey (KeyPress AS STRING)
DO
  KeyPress = INKEY$
  IF LEN(KeyPress) THEN EXIT DO
LOOP
END SUB

DEFINT A-Z
SUB PrtBlock (intCly, intClx, strHline$, strLine$, intColor)

IF intColor > 31 THEN EXIT SUB

DIM intI AS INTEGER

LOCATE intCly, intClx
COLOR intColor
strHline$ = STRING$(19, strLine$)

FOR intI = 1 TO 4
  PRINT strHline$
  LOCATE , intClx
NEXT intI

END SUB

SUB PrtColorBar (Hline$, CLine$)

Hline$ = CLine$ + CLine$ + CLine$
LOCATE 1, 1
FOR intI = 1 TO 16
  COLOR intI
  PRINT Hline$;
NEXT intI

END SUB

SUB PrtColorGraph (intRy, intRx, strHline$, intSysPal, strLine$, intColor, intO)

strHline$ = STRING$(75, " ")
COLOR 0
LOCATE intRy, intRx
PRINT strHline$
COLOR 7
LOCATE intRy, intRx

IF intO = 1 THEN
  strHline$ = STRING$(intSysPal, strLine$)
  PRINT "RED :"; strHline$
END IF

IF intO = 2 THEN
  strHline$ = STRING$(intSysPal, strLine$)
  PRINT "GREEN :"; strHline$
END IF

IF intO = 3 THEN
  strHline$ = STRING$(intSysPal, strLine$)
  PRINT "BLUE :"; strHline$
END IF
END SUB

SUB SetColors (Pal() AS Pal, Ic1, Lc)

'sets the DAC registers with the values contained in variable Pal()
'values are in the range of 0 to 63 each for red, green, and blue

   OUT &H3C8, Ic1                            'tell controller to get ready
   FOR I = Ic1 TO Lc                         'from first to last
      OUT &H3C9, Pal(I).red                  'send red component
      OUT &H3C9, Pal(I).green                  'send green component
      OUT &H3C9, Pal(I).blue                  'send blue component
   NEXT I
END SUB

SUB SetCurX (intX%, intY%, intRy%, intGy%, intBy%, intJ%, Hline$)
      SELECT CASE intJ%
        CASE 1
          intX% = LEN("RED :" + Hline$)
          intY = intRy
        CASE 2
          intX% = LEN("GREEN :" + Hline$)
          intY% = intGy%
        CASE 3
          intX% = LEN("BLUE :" + Hline$)
          intY% = intBy%
      END SELECT
      LOCATE intY%, intX%, 1, 31, 1

END SUB

DEFSNG A-Z
SUB SetPal (Pal() AS Pal, intVal%, intComPonent%, intColor%)
      SELECT CASE intComPonent%
        CASE 1
          Pal(intColor%).red = intVal%
        CASE 2
          Pal(intColor%).green = intVal%
        CASE 3
          Pal(intColor%).blue = intVal%
      END SELECT

END SUB