' QBPALETE.BAS is being released as public domain. You may modify this
' code in any way you see fit.
'
' I wrote this file for an RPG game I was writing in QBasic. I,
' unfortunately, haven't finished the game as of yet. However, I felt this
' code could benefit some out there with a weak grasp on the VGA palette.
' There are two primary subroutines called in this program, those being:
'
' FadePalette   - fade in \ automatic palette save upon fade out
'                 supports fading of specified registers
'                 fade red, green, blue, or all components of register
'
' RotatePalette - rotate specified palette registers up or down
'
' A quick look over all of the code should be enough to explain what's
' going on. Any questions, comments, etc? Send 'em to Abakus@juno.com.
' Have fun, and if you happen to make any improvements, you can send them
' to the email address above. - Dennis Shimkoski Jr.
'-----------------------------------------------------------------------

'Palette ports
CONST PALACCESS = &H3C6
CONST PALREAD = &H3C7
CONST PALWRITE = &H3C8
CONST PALDATA = &H3C9

'Palette Fade directions & component selectors
CONST FIN = 0
CONST FOUT = 1
CONST FRED = 0
CONST FGREEN = 1
CONST FBLUE = 2
CONST FALL = 3

'Palette rotate directions
CONST UP = 0
CONST DOWN = 1

TYPE RGBregister
   red AS INTEGER
   green AS INTEGER
   blue AS INTEGER
END TYPE

DECLARE SUB SavePalette (startreg AS INTEGER, endreg AS INTEGER)
DECLARE SUB GetPaletteReg (tableindex AS INTEGER, RGBval AS RGBregister)
DECLARE SUB SetPaletteReg (tableindex AS INTEGER, RGBval AS RGBregister)
DECLARE SUB FadePaletteReg (register AS INTEGER, direction AS INTEGER, comptofade AS INTEGER)
DECLARE SUB FadePalette (startreg AS INTEGER, endreg AS INTEGER, direction AS INTEGER, comptofade AS INTEGER)
DECLARE SUB RotatePalette (startreg AS INTEGER, endreg AS INTEGER, direction AS INTEGER)

DIM SHARED VGApalette(255)  AS RGBregister     'Holds palette info
DIM register AS INTEGER, intensity AS INTEGER

SCREEN 13

'this code demonstrates what these routines can do.

'use 64 registers, leave 0th register alone so as not to affect the
'background color while rotating the palette

FOR register = 1 TO 64

 intensity = intensity + 1

  'create grey palette section
   VGApalette(register).red = intensity
   VGApalette(register).green = intensity
   VGApalette(register).blue = intensity

  'write to color table
  SetPaletteReg register, VGApalette(register)

NEXT register

'draw lines on screen
FOR register = 1 TO 64
 LINE (0, register + 10)-(319, register + 10), register
 LINE (0, register + 74)-(319, register + 74), register
 LINE (0, register + 138)-(319, register + 138), register
 LINE (0, register + 202)-(319, register + 202), register
NEXT register



DO
RotatePalette 1, 64, DOWN
LOOP UNTIL INKEY$ = "q"

FadePalette 1, 64, FOUT, FRED
FadePalette 10, 40, FIN, FRED

SUB FadePalette (startreg AS INTEGER, endreg AS INTEGER, direction AS INTEGER, comptofade AS INTEGER)
'FIN = fade palette in FOUT = fade palette out

DIM intensity AS INTEGER
DIM register AS INTEGER

'check if fading out, if so, save palette.
IF direction = FOUT THEN SavePalette startreg, endreg

 FOR intensity = 0 TO 63
  FOR register = startreg TO endreg
   FadePaletteReg register, direction, comptofade
  NEXT register
 NEXT intensity
END SUB

SUB FadePaletteReg (register AS INTEGER, direction AS INTEGER, comptofade AS INTEGER)
DIM PaletteOP AS RGBregister
DIM Redval AS INTEGER, Greenval AS INTEGER, Blueval AS INTEGER

SELECT CASE comptofade  'decide which RGB components will be faded
 CASE FRED
  Redval = 1: Greenval = 0: Blueval = 0
 CASE FGREEN
  Redval = 0: Greenval = 1: Blueval = 0
 CASE FBLUE
  Redval = 0: Greenval = 0: Blueval = 1
 CASE FALL
  Redval = 1: Greenval = 1: Blueval = 1
END SELECT

SELECT CASE direction
 CASE FIN
   GetPaletteReg register, PaletteOP
     IF PaletteOP.red < VGApalette(register).red THEN PaletteOP.red = PaletteOP.red + Redval
     IF PaletteOP.green < VGApalette(register).green THEN PaletteOP.green = PaletteOP.green + Greenval
     IF PaletteOP.blue < VGApalette(register).blue THEN PaletteOP.blue = PaletteOP.blue + Blueval
   SetPaletteReg register, PaletteOP
                     
  CASE FOUT
   GetPaletteReg register, PaletteOP
     IF PaletteOP.red > 0 THEN PaletteOP.red = PaletteOP.red - Redval
     IF PaletteOP.green > 0 THEN PaletteOP.green = PaletteOP.green - Greenval
     IF PaletteOP.blue > 0 THEN PaletteOP.blue = PaletteOP.blue - Blueval
   SetPaletteReg register, PaletteOP
  END SELECT
END SUB

SUB GetPaletteReg (tableindex AS INTEGER, RGBval AS RGBregister)

OUT PALACCESS, &HFF          'request access to all 256 registers
OUT PALREAD, tableindex      'reading from this index
RGBval.red = INP(PALDATA)    'store data extracted from color table
RGBval.green = INP(PALDATA)
RGBval.blue = INP(PALDATA)
END SUB

SUB RotatePalette (startreg AS INTEGER, endreg AS INTEGER, direction AS INTEGER)

'Shifting registers up moves register values towards the first
'register, down moves towards last

DIM PaletteOP AS RGBregister   'used to move RGB values around
DIM savedRGB AS RGBregister    'stores value of register to save
DIM regtosave AS INTEGER       'based on direction
DIM nextreg AS INTEGER         'based on direction
DIM register AS INTEGER

'Save first or last register according to direction
  IF direction = DOWN THEN
      regtosave = endreg: nextreg = startreg
      ELSE
      regtosave = startreg: nextreg = endreg
  END IF
  
   GetPaletteReg regtosave, savedRGB
 
  'Begin rotation
   FOR register = startreg TO endreg
     
      'get register value
      GetPaletteReg nextreg, PaletteOP

      'increment\decrement next register accordingly
      IF direction = DOWN THEN
      nextreg = nextreg + 1
      ELSE
      nextreg = nextreg - 1
      END IF

     'If saved register has been replaced, exit loop and move saved register
      IF direction = DOWN AND nextreg = endreg + 1 THEN EXIT FOR
      IF direction = UP AND nextreg = startreg - 1 THEN EXIT FOR
       
     'Set register's new values
     VGApalette(nextreg).red = PaletteOP.red
     VGApalette(nextreg).green = PaletteOP.green
     VGApalette(nextreg).blue = PaletteOP.blue
  
   NEXT register
  
   'move saved register
   IF regtosave = startreg THEN
    VGApalette(endreg).red = savedRGB.red
    VGApalette(endreg).green = savedRGB.green
    VGApalette(endreg).blue = savedRGB.blue
   ELSE
    VGApalette(startreg).red = savedRGB.red
    VGApalette(startreg).green = savedRGB.green
    VGApalette(startreg).blue = savedRGB.blue
   END IF

  'Assign values to color table
   FOR register = startreg TO endreg
    SetPaletteReg register, VGApalette(register)
   NEXT register

END SUB

SUB SavePalette (startreg AS INTEGER, endreg AS INTEGER)
DIM PaletteOP AS RGBregister
DIM register AS INTEGER

FOR register = startreg TO endreg
  GetPaletteReg register, PaletteOP
  VGApalette(register).red = PaletteOP.red
  VGApalette(register).green = PaletteOP.green
  VGApalette(register).blue = PaletteOP.blue
NEXT register
END SUB

SUB SetPaletteReg (tableindex AS INTEGER, RGBval AS RGBregister)

OUT PALACCESS, &HFF        'request access to all 256 registers
OUT PALWRITE, tableindex   'writing to this index
OUT PALDATA, RGBval.red    'write values to color table
OUT PALDATA, RGBval.green
OUT PALDATA, RGBval.blue
END SUB