'===========================================================================
' Subject: BMP PALETTE STRIPPER              Date: 01-03-98 (14:37)       
' Author:  Ka-Lok Fung                       Code: QB, QBasic, PDS        
' Origin:  kalok@vcn.bc.ca                 Packet: GRAPHICS.ABC
'===========================================================================
'BMP Palette Stripper
'Programmed by Jason Downey <qasic@hotmail.com>
'Public Domain.
'Various Portions Leeched by Publicly Avaible BMP Loading Source Code

'Requirements : VGA Monitor and Graphics Card
'Purpose      : Loads a .BMP and saves its palette to disk.
'Instructions : 1) To create palette file, run program
'               2) To load palette file, copy LoadPal subroutine into your
'                  program
'Comments     : Code such be self explanatory. As with most public domain
'               programs, author asssumes no liability for the use of this              
'               program! Use it any way you want.

'Declarations
DECLARE SUB Delay (Seconds!)
DECLARE SUB LoadPal (FileName$)
DECLARE SUB WritePal (FileName$)

'Introduction Stuff
PRINT "ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ"
PRINT "BMP Palette Stripper"
PRINT "Version 1.0"
PRINT "Programmed by Jason Downey"
PRINT "ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ"
PRINT

'Input BMP File
PRINT "þ Enter .BMP File: ";
LINE INPUT ; "", FileName$
FileName$ = UCASE$(RTRIM$(LTRIM$(FileName$)))
IF FileName$ = "" THEN
   PRINT "Cancelled..."
   SYSTEM
END IF
IF RIGHT$(FileName$, 4) <> ".BMP" THEN FileName$ = FileName$ + ".BMP"
PRINT

'Get Information
PRINT "þ Retrieving Information...";
OPEN FileName$ FOR BINARY AS #1
header$ = SPACE$(14)
sizing$ = SPACE$(4)
GET #1, 1, header$
GET #1, 15, sizing$
bmpinfosize = CVI(sizing$)

'bmpinfosize - Is the size of the information header for the bitmap.
'              Different bitmap versions have variations in filetypes.
'              40 is a standard windows 3.1 bitmap.
'              12 is for OS/2 bitmaps


'Reads in the appropriate headers and colour tables.
'   nbits is the number of bits per pixel - i.e. number of colours
'   1 bit = 2 colours, 4 bits = 16 colours, 8 bits = 256 colours, etc.
'   the 24 bit mode does not have a palette, its colours are expressed as
'   image data
IF bmpinfosize = 12 THEN
   infoheader$ = SPACE$(12)
   GET #1, 15, infoheader$
   nbits = CVI(MID$(infoheader$, 15, 4))
   IF nbits = 1 THEN
      palet$ = SPACE$(6)
      GET #1, bmpinfosize + 15, palet$
   ELSEIF nbits = 4 THEN
      palet$ = SPACE$(48)
      GET #1, bmpinfosize + 15, palet$
   ELSEIF nbits = 8 THEN
      palet$ = SPACE$(768)
      GET #1, bmpinfosize + 15, palet$
   END IF
ELSEIF bmpinfosize = 40 THEN
   infoheader$ = SPACE$(40)
   GET #1, 15, infoheader$
   nbits = CVI(MID$(infoheader$, 15, 4))
   IF nbits = 1 THEN
      palet$ = SPACE$(8)
      GET #1, bmpinfosize + 15, palet$
   ELSEIF nbits = 4 THEN
      palet$ = SPACE$(64)
      GET #1, bmpinfosize + 15, palet$
   ELSEIF nbits = 8 THEN
      palet$ = SPACE$(1024)
      GET #1, bmpinfosize + 15, palet$
   END IF
END IF
IF LOF(1) = 0 THEN
        PRINT "File Not Found."
        PRINT "þ Aborting..."
        CLOSE #1
        KILL FileName$
        SYSTEM
END IF
CLOSE #1
Delay .3
PRINT "Done."
    
'Check for BMP File
PRINT "þ Checking for BMP File Declaration...";
ft$ = MID$(header$, 1, 2)
IF ft$ <> "BM" THEN
        PRINT "Failed."
        PRINT "þ Aborting..."
        SYSTEM
END IF
Delay .3
PRINT "Passed."

'Determine Correct Screen
PRINT "þ Changing to appropriate Screen Mode...";
IF nbits = 1 THEN
   SCREEN 11
ELSEIF nbits = 4 THEN
   SCREEN 12
ELSEIF nbits = 8 OR nbits = 24 THEN
   SCREEN 13
END IF

'Determine Palette
PRINT "þ Getting Palette...";
IF bmpinfosize = 40 THEN ngroups = 4
IF bmpinfosize = 12 THEN ngroups = 3
IF nbits = 24 THEN
   IF ngroups = 3 THEN
      FOR c = 0 TO 63
         d = c * 4
         palet$ = palet$ + CHR$(d) + CHR$(d) + CHR$(d)
         palet$ = palet$ + CHR$(d) + CHR$(d) + CHR$(d + 1)
         palet$ = palet$ + CHR$(d) + CHR$(d + 1) + CHR$(d)
         palet$ = palet$ + CHR$(d + 1) + CHR$(d) + CHR$(d)
      NEXT c
   ELSEIF ngroups = 4 THEN
      FOR c = 0 TO 63
         d = c * 4
         palet$ = palet$ + CHR$(d) + CHR$(d) + CHR$(d) + CHR$(0)
         palet$ = palet$ + CHR$(d) + CHR$(d) + CHR$(d + 1) + CHR$(0)
         palet$ = palet$ + CHR$(d) + CHR$(d + 1) + CHR$(d) + CHR$(0)
         palet$ = palet$ + CHR$(d + 1) + CHR$(d) + CHR$(d) + CHR$(0)
      NEXT c
   END IF
END IF
PRINT "Done."

'Load Palette
PRINT "þ Placing Palette...";
FOR x = 1 TO LEN(palet$) STEP ngroups
   zb# = INT((ASC(MID$(palet$, x, 1))) / 4)
   zg# = INT((ASC(MID$(palet$, x + 1, 1))) / 4)
   zr# = INT((ASC(MID$(palet$, x + 2, 1))) / 4)
   zc# = zb# * 65536# + zg# * 256# + zr#
   cres = ASC(MID$(palet$, x + 3, 1))
   PALETTE ((x - 1) / ngroups), zc#
NEXT x
PRINT "Done."


'Save Palette to Disk
PRINT "þ Saving Palette....";
Position = INSTR(FileName$, ".")
SavePalName$ = LEFT$(FileName$, Position - 1)
SavePalName$ = SavePalName$ + ".PAL"
WritePal (SavePalName$)

'Clean up code
WIDTH 80: SCREEN 9: SCREEN 0
PRINT "þ Palette saved as: "; SavePalName$
PRINT "þ Operation Complete."
PLAY "T120L16MLO3BF#"

SUB Delay (Seconds)
  JINX = TIMER
  XDELAY = JINX + Seconds
  WHILE NOT (TIMER > XDELAY): WEND
END SUB

SUB LoadPal (FileName$)
DEFINT A-Z
'Routine "borrowed" from M \ K Productions
'All Hats Off to Them
'LoadPal: Loads palette file

DIM Byte AS STRING * 1

OPEN FileName$ FOR BINARY AS #1
 FOR Att% = 0 TO 255
  OUT &H3C8, Att%
   FOR RedGreenAndBlue% = 1 TO 3
    GET #1, , Byte
    Valew% = ASC(Byte)
    OUT &H3C9, Valew%
   NEXT RedGreenAndBlue%
 NEXT Att%
CLOSE #1

END SUB

SUB WritePal (FileName$)
'Routine "borrowed" from M \ K Productions
'All Hats Off to Them
'WritePal: Creates the palette file.

DIM Byte AS STRING * 1

OPEN FileName$ FOR BINARY AS #1
FOR Att% = 0 TO 255
 OUT &H3C7, Att%
  FOR RedGreenAndBlue% = 1 TO 3
   Buffer% = INP(&H3C9)
   Byte = CHR$(Buffer%)
   PUT #1, , Byte
  NEXT RedGreenAndBlue%
NEXT Att%
CLOSE #1
END SUB