'
' NeoLib - Palette Module
'
' Features:
'  27 subs
'  3 functions
' For a total of: 30 routines
'
' Specially designed and coded for AAP's QBCPC
' Official Library of the QuickBASIC Caliber Programming Compo (Summer & Autumn 2003)
'

DECLARE FUNCTION neoPalGetRelativeCol& (ColorNumber AS INTEGER)
DECLARE FUNCTION neoPalSearch% (Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
DECLARE FUNCTION neoPalSearchIn% (PalString AS STRING, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)

DECLARE SUB neoPalSetCol (ColorNumber AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
DECLARE SUB neoPalGetCol (ColorNumber AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
DECLARE SUB neoPalOff ()
DECLARE SUB neoPalNegative ()
DECLARE SUB neoPalGrey (Amount AS INTEGER)
DECLARE SUB neoPalGet (PalString AS STRING)
DECLARE SUB neoPalSet (PalString AS STRING)
DECLARE SUB neoPalStringOff (PalString AS STRING)
DECLARE SUB neoPalStringSetCol (PalString AS STRING, ColorNumber AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
DECLARE SUB neoPalStringGetCol (PalString AS STRING, ColorNumber AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
DECLARE SUB neoPalSave (PalString AS STRING, Filename AS STRING)
DECLARE SUB neoPalLoad (PalString AS STRING, Filename AS STRING)
DECLARE SUB neoPalLoadPP256Pal (PalString AS STRING, Filename AS STRING)
DECLARE SUB neoPalSavePP256Pal (PalString AS STRING, Filename AS STRING)
DECLARE SUB neoPalFadeTo (Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
DECLARE SUB neoPalFadeStepTo (Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
DECLARE SUB neoPalFadeIn (PalString AS STRING)
DECLARE SUB neoPalFadeStepIn (PalString AS STRING)
DECLARE SUB neoPalFadeX (BeginCol AS INTEGER, EndCol AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
DECLARE SUB neoPalFadeStepX (BeginCol AS INTEGER, EndCol AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
DECLARE SUB neoPalFadePalX (PalString AS STRING, BeginCol AS INTEGER, EndCol AS INTEGER)
DECLARE SUB neoPalFadePalStepX (PalString AS STRING, BeginCol AS INTEGER, EndCol AS INTEGER)
DECLARE SUB neoPalRotateFull (Direction AS INTEGER)
DECLARE SUB neoPalRotatePart (Direction AS INTEGER, BeginCol AS INTEGER, EndCol AS INTEGER)
DECLARE SUB neoPalGradient (StartCol AS INTEGER, StartR AS INTEGER, StartG AS INTEGER, StartB AS INTEGER, EndCol AS INTEGER, EndR AS INTEGER, EndG AS INTEGER, EndB AS INTEGER)
DECLARE SUB neoPalExtractFromBMP (Filename AS STRING, PalString AS STRING)
DECLARE SUB neoPalOldSkool ()

DEFINT A-Z
'$DYNAMIC

CONST LEFT = -1, RIGHT = 1

'///////////////////////////////////////////////////////////////////////////
' FUNCTIONS
'///////////////////////////////////////////////////////////////////////////
FUNCTION neoPalGetRelativeCol& (ColorNumber AS INTEGER)
	'gets the relative color (65536 * blue + 256 * green + red)
	' ColorNumber = number of the color to retrieve relative color from

	OUT &H3C7, ColorNumber
        rel& = INP(&H3C9)
        rel& = rel& + 256& * INP(&H3C9)
        rel& = rel& + 65536& * INP(&H3C9)
        neoPalGetRelativeCol& = rel&
END FUNCTION

FUNCTION neoPalSearch (Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
	'searches the palette for the colour which most equals the colour specified
	' Red = amount of red to search for
	' Green = amount of green to search for
	' Blue = amount of blue to search for

	difcol% = 0
	mindif% = 32000
        FOR cols = 0 TO 255
		neoPalGetCol cols, aR, aG, aB
                dif% = ABS(Red - aR) + ABS(Green - aG) + ABS(Blue - aB)
                IF dif% < mindif% THEN
                	mindif% = dif%
                	difcol% = cols
                END IF
        NEXT cols
        neoPalSearch = difcol%
END FUNCTION

FUNCTION neoPalSearchIn (PalString AS STRING, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
	'searches the 768-byte palette for the colour which most equals the colour specified
	' Red = amount of red to search for
	' Green = amount of green to search for
	' Blue = amount of blue to search for

	difcol% = 0
	mindif% = 32000
        FOR cols = 0 TO 255
		neoPalStringGetCol PalString, cols, aR, aG, aB
                dif% = ABS(Red - aR) + ABS(Green - aG) + ABS(Blue - aB)
                IF dif% < mindif% THEN
                	mindif% = dif%
                	difcol% = cols
                END IF
        NEXT cols
        neoPalSearchIn = difcol%
END FUNCTION

'///////////////////////////////////////////////////////////////////////////
' SUBS
'///////////////////////////////////////////////////////////////////////////
SUB neoPalSetCol (ColorNumber AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
	'sets a specified colour to a color
	' ColorNumber = color to change (0-255)
	' Red = amount of red (0-63)
	' Green = amount of green (0-63)
	' Blue = amount of blue (0-63)

	OUT &H3C8, ColorNumber
	OUT &H3C9, Red
	OUT &H3C9, Green
	OUT &H3C9, Blue
END SUB

SUB neoPalGetCol (ColorNumber AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
	'gets a specified colour's basecolour amounts
	' ColorNumber = color to view (0-255)
	' Red = amount of red (0-63)
	' Green = amount of green (0-63)
	' Blue = amount of blue (0-63)

	OUT &H3C7, ColorNumber
	Red = INP(&H3C9)
	Green = INP(&H3C9)
	Blue = INP(&H3C9)
END SUB

SUB neoPalOff
	'sets pal to black

	OUT &H3C8, 0
	FOR I = 0 TO 767
		OUT &H3C9, 0
	NEXT I
END SUB

SUB neoPalNegative
	'sets the palette to its negative version

	aR = 0:aG = 0: aB = 0
	FOR I = 0 TO 255
		neoPalGetCol I, aR, aG, aB
		neoPalSetCol I, 63 - aR, 63 - aG, 63 - aB
	NEXT I
END SUB

SUB neoPalGrey (Amount AS INTEGER)
        'sets the whole pal to the amount of grey specified
        ' Amount = amount of grey (0-63)

	OUT &H3C8, 0
	FOR I = 0 TO 767
		OUT &H3C9, Amount
	NEXT I
END SUB

SUB neoPalGet (PalString AS STRING)
	'gets the current palette and stores it into a 768-byte string
	' PalString = string to store pal in

        PalString = ""
        FOR I = 0 TO 255
        	neoPalGetCol I, aR, aG, aB
        	PalString = PalString + CHR$(aR) + CHR$(aG) + CHR$(aB)
        NEXT I
END SUB

SUB neoPalSet (PalString AS STRING)
	'sets a palette stored in a 768-byte string
	' PalString = string to put in palette

	OUT &H3C8, 0
        FOR I = 1 TO 768
        	OUT &H3C9, ASC(MID$(PalString, I, 1))
        NEXT I
END SUB

SUB neoPalStringOff (PalString AS STRING)
	'sets a 768-byte palette string to black
	' PalString = string to set black

	PalString = STRING$(768, 0)
END SUB

SUB neoPalStringSetCol (PalString AS STRING, ColorNumber AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
        'sets a specified color in a 768-byte string palette
        ' PalString = 768-byte string palette
        ' ColorNumber = color to change (0-255)
        ' Red = amount of red (0-63)
        ' Green = amount of green (0-63)
        ' Blue = amount of blue (0-63)

        MID$(PalString, ColorNumber * 3 + 1, 3) = CHR$(Red) + CHR$(Green) + CHR$(Blue)
END SUB

SUB neoPalStringGetCol (PalString AS STRING, ColorNumber AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
	'gets a specified color in a 768-byte string palette
        ' PalString = 768-byte string palette
        ' ColorNumber = color to change (0-255)
        ' Red = amount of red (0-63)
        ' Green = amount of green (0-63)
        ' Blue = amount of blue (0-63)

        z$ = MID$(PalString, ColorNumber * 3 + 1, 3)
        Red = ASC(LEFT$(z$, 1))
        Green = ASC(MID$(z$, 2, 1))
        Blue = ASC(RIGHT$(z$, 1))
END SUB

SUB neoPalSave (PalString AS STRING, Filename AS STRING)
        'stores a 768-byte palette to a file
        ' PalString = a 768-byte palette
        ' Filename = a file to save to

        FF = FREEFILE
        OPEN Filename FOR OUTPUT AS #FF
        CLOSE #FF
        OPEN Filename FOR BINARY AS #FF
                PUT #FF, 1, PalString
        CLOSE #FF
END SUB

SUB neoPalLoad (PalString AS STRING, Filename AS STRING)
	'loads a 768-byte palette from a file
        ' PalString = a 768-byte palette
        ' Filename = a file to load from

        FF = FREEFILE
        OPEN Filename FOR BINARY AS #FF
        	PalString = SPACE$(768)
        	GET #FF, 1, PalString
        CLOSE #FF
END SUB

SUB neoPalLoadPP256Pal (PalString AS STRING, Filename AS STRING)
	'loads a pp256-palette from a file into PalString, thereby converting it to a 768-byte string instead of a 1024-byte string
	' PalString = to store pal in
	' Filename = file to load from

	FF = FREEFILE
	PalString = ""
	OPEN Filename FOR BINARY AS #FF
                FOR I = 0 TO 255
                	GET #FF, , relCol&
                	aB = relCol& \ 65536&: relCol& = relCol& - aB * 65536&
                	aG = relCol& \ 256&: relCol& = relCol& - aG * 256&
                	aR = relCol&
                	PalString = PalString + CHR$(aR) + CHR$(aG) + CHR$(aB)
                NEXT I
	CLOSE #FF
END SUB

SUB neoPalSavePP256Pal (PalString AS STRING, Filename AS STRING)
	'saves a 768-byte palstring into a file in PP256 format (1024-byte)
	' PalString = string palette to save
	' Filename = the file to save to

	FF = FREEFILE
	OPEN Filename FOR OUTPUT AS #FF
	CLOSE #FF
	OPEN Filename FOR BINARY AS #FF
		FOR I = 0 TO 255
			relCol& = neoPalGetRelativeCol&(I)
			PUT #FF, , relCol&
		NEXT I
	CLOSE #FF
END SUB

SUB neoPalFadeTo (Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
	'fades the entire palette to the specifed color amounts
	' Red = amount of red to fade to
	' Green = amount of green to fade to
	' Blue = amount of blue to fade to

        FOR I = 0 TO 63
        	ok = 0
        	FOR cols = 0 TO 255
                        neoPalGetCol cols, aR, aG, aB
                        aR = aR + SGN(Red - aR)
                        aG = aG + SGN(Green - aG)
                        aB = aB + SGN(Blue - aB)
                        neoPalSetCol cols, aR, aG, aB
                        IF aR = Red AND aG = Green AND aB = Blue THEN ok = ok + 1
        	NEXT cols
        	IF ok = 256 THEN EXIT FOR
        NEXT I
END SUB

SUB neoPalFadeStepTo (Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
	'fades the entire palette one step towards the specified color amounts
	' Red = amount of red to fade to
	' Green = amount of green to fade to
	' Blue = amount of blue to fade to

        FOR cols = 0 TO 255
    		neoPalGetCol cols, aR, aG, aB
                aR = aR + SGN(Red - aR)
                aG = aG + SGN(Green - aG)
                aB = aB + SGN(Blue - aB)
                neoPalSetCol cols, aR, aG, aB
        NEXT cols
END SUB

SUB neoPalFadeIn (PalString AS STRING)
	'fades to the palette stored in the 768-byte 'PalString'-string
	' PalString = 768-byte palette to fade into

	FOR I = 0 TO 63
		ok = 0
		FOR cols = 0 TO 255
			neoPalGetCol cols, aR, aG, aB
                        neoPalStringGetCol PalString, cols, tR, tG, tB
                        aR = aR + SGN(tR - aR)
                        aG = aG + SGN(tG - aG)
                        aB = aB + SGN(tB - aB)
                        neoPalSetCol cols, aR, aG, aB
                        IF aR = tR AND aG = tG AND aB = tB THEN ok = ok + 1
		NEXT cols
		IF ok = 256 THEN EXIT FOR
	NEXT I
END SUB

SUB neoPalFadeStepIn (PalString AS STRING)
	'fades one step into the palette stored in the 768-byte string parameter
	' PalString = 768-byte palette to fade one step into

	FOR cols = 0 TO 255
		neoPalGetCol cols, aR, aG, aB
                neoPalStringGetCol PalString, cols, tR, tG, tB
                aR = aR + SGN(tR - aR)
                aG = aG + SGN(tG - aG)
                aB = aB + SGN(tB - aB)
                neoPalSetCol cols, aR, aG, aB
        NEXT cols
END SUB

SUB neoPalFadeX (BeginCol AS INTEGER, EndCol AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
        'fades only part of the palette between the specified region to the specified color
        ' BeginCol = color to begin fading with
        ' EndCol = color the end fading with
        ' Red = amount of red to fade to
        ' Green = amount of green to fade to
        ' Blue = amount of blue to fade to

        FOR I = 0 TO 63
        	ok = 0
		FOR cols = BeginCol TO EndCol
                        neoPalGetCol cols, aR, aG, aB
                        aR = aR + SGN(Red - aR)
                        aG = aG + SGN(Green - aG)
                        aB = aB + SGN(Blue - aB)
                        neoPalSetCol cols, aR, aG, aB
                        IF aR = Red AND aG = Green AND aB = Blue THEN ok = ok + 1
		NEXT cols
		IF ok = EndCol - BeginCol + 1 THEN EXIT FOR
        NEXT I
END SUB

SUB neoPalFadeStepX (BeginCol AS INTEGER, EndCol AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
	'fades only part of the palette between the specified region to the specified color, and just one step
        ' BeginCol = color to begin fading with
        ' EndCol = color the end fading with
        ' Red = amount of red to fade to
        ' Green = amount of green to fade to
        ' Blue = amount of blue to fade to

	FOR cols = BeginCol TO EndCol
                neoPalGetCol cols, aR, aG, aB
                aR = aR + SGN(Red - aR)
                aG = aG + SGN(Green - aG)
                aB = aB + SGN(Blue - aB)
                neoPalSetCol cols, aR, aG, aB
 	NEXT cols
END SUB

SUB neoPalFadePalX (PalString AS STRING, BeginCol AS INTEGER, EndCol AS INTEGER)
        'fades only part of the palette to the specified regions in the 768-byte palette
        ' PalString = a 768-byte palette which is the palette to fade to
        ' BeginCol = the color to begin fading with
        ' EndCol = the color to end fading with

        FOR I = 0 TO 63
        	ok = 0
        	FOR cols = BeginCol TO EndCol
        		neoPalGetCol cols, aR, aG, aB
        		neoPalStringGetCol PalString, cols, tR, tG, tB
                        aR = aR + SGN(tR - aR)
                        aG = aG + SGN(tG - aG)
                        aB = aB + SGN(tB - aB)
                        neoPalSetCol cols, aR, aG, aB
                        IF aR = tR AND aG = tG AND aB = tB THEN ok = ok + 1
        	NEXT cols
        	IF ok = EndCol - BeginCol + 1 THEN EXIT FOR
        NEXT I
END SUB

SUB neoPalFadePalStepX (PalString AS STRING, BeginCol AS INTEGER, EndCol AS INTEGER)
	'fades only part of the palette to the specified regions in the 768-byte palette, and just one step
        ' PalString = a 768-byte palette which is the palette to fade to
        ' BeginCol = the color to begin fading with
        ' EndCol = the color to end fading with

        FOR cols = BeginCol TO EndCol
        	neoPalGetCol cols, aR, aG, aB
        	neoPalStringGetCol PalString, cols, tR, tG, tB
                aR = aR + SGN(tR - aR)
                aG = aG + SGN(tG - aG)
                aB = aB + SGN(tB - aB)
                neoPalSetCol cols, aR, aG, aB
        NEXT cols
END SUB

SUB neoPalRotateFull (Direction AS INTEGER)
	'rotates the full pal in a specified direction
	' Direction = the direction to rotate in, use LEFT or RIGHT

	neoPalGet nowPal$
        IF Direction = LEFT THEN
                tmp$ = LEFT$(nowPal$, 3)
                nowPal$ = RIGHT$(nowPal$, 765)
                nowPal$ = nowPal$ + tmp$
        ELSE
        	tmp$ = RIGHT$(nowPal$, 3)
        	nowPal$ = LEFT$(nowPal$, 765)
        	nowPal$ = tmp$ + nowPal$
        END IF
        neoPalSet nowPal$
END SUB

SUB neoPalRotatePart (Direction AS INTEGER, BeginCol AS INTEGER, EndCol AS INTEGER)
	'rotates only part of the palette in a specified direction
	'  Direction = use constant LEFT or RIGHT
	'  BeginCol = the rotating begin color
	'  EndCol = the rotating end color

	neoPalGet nowPal$
	sPos% = BeginCol * 3 + 1
	sLen% = (EndCol - BeginCol + 1) * 3
	z$ = MID$(nowPal$, sPos%, sLen%)
	IF Direction = LEFT THEN
		tmp$ = LEFT$(z$, 3)
		z$ = RIGHT$(z$, sLen% - 3)
                z$ = z$ + tmp$
	ELSE
                tmp$ = RIGHT$(z$, 3)
                z$ = LEFT$(z$, sLen% - 3)
                z$ = tmp$ + z$
	END IF
	MID$(nowPal$, sPos%, sLen%) = z$
	neoPalSet nowPal$
END SUB

SUB neoPalGradient (StartCol AS INTEGER, StartR AS INTEGER, StartG AS INTEGER, StartB AS INTEGER, EndCol AS INTEGER, EndR AS INTEGER, EndG AS INTEGER, EndB AS INTEGER)
	'makes a gradient from StartCol to EndCol with the specified colours
	' StartCol = gradient start color (0-255)
	' StartR = gradient start red amount (0-63)
	' StartG = gradient start green amount (0-63)
	' StartB = gradient start blue amount (0-63)
	' EndCol = gradient end color (0-255)
	' EndR = gradient end red amount (0-63)
	' EndG = gradient end green amount (0-63)
	' EndB = gradient end blue amount (0-63)

        noCols = EndCol - StartCol
        nowR# = StartR
        nowG# = StartG
        nowB# = StartB
        stepR# = CDBL(EndR - StartR) / noCols
        stepG# = CDBL(EndG - StartG) / noCols
        stepB# = CDBL(EndB - StartB) / noCols

        FOR I = StartCol TO EndCol
                neoPalSetCol I, INT(nowR#), INT(nowG#), INT(nowB#)

                nowR# = nowR# + stepR#
                nowG# = nowG# + stepG#
                nowB# = nowB# + stepB#

                IF nowR# >= 63 THEN nowR# = 63
                IF nowG# >= 63 THEN nowG# = 63
                IF nowB# >= 63 THEN nowB# = 63
                IF nowR# <= 0 THEN nowR# = 0
                IF nowG# <= 0 THEN nowG# = 0
                IF nowB# <= 0 THEN nowB# = 0
        NEXT I
END SUB

SUB neoPalExtractFromBMP (Filename AS STRING, PalString AS STRING)
        'extracts the palette from an 8-bit BMP file
        ' Filename = the bmp to extract from
        ' PalString = the string to store the palette in

    	FF = FREEFILE
    	OPEN Filename FOR BINARY AS #FF
    		IF LOF(FF) < 1 THEN CLOSE #FF: KILL Filename: neoPalStringOff PalString: EXIT SUB
    		'id header
    		iD$ = SPACE$(2)
    		GET #FF, , iD$
    		IF iD$ <> "BM" THEN CLOSE #FF: neoPalStringOff PalString: EXIT SUB

    		'12+1 times a long int
    		crap& = 0
    		FOR twelveplusone = 0 TO 12
    			GET #FF, , crap&
    		NEXT twelveplusone

    		'now there's a 1024-byte string containing the palette (stored as Blue*4,Green*4,Red*4,0)
    		palet$ = SPACE$(1024)
    		GET #FF, , palet$
                PalString = ""
                FOR cols = 0 TO 255
                        aB = ASC(MID$(palet$, cols * 4 + 1, 1)) \ 4
                        aG = ASC(MID$(palet$, cols * 4 + 2, 1)) \ 4
                        aR = ASC(MID$(palet$, cols * 4 + 3, 1)) \ 4
                        PalString = PalString + CHR$(aR) + CHR$(aG) + CHR$(aB)
                NEXT cols
    	CLOSE #FF
END SUB

SUB neoPalOldSkool
    	'greys the palette

    	FOR I = 0 TO 255
    		neoPalGetCol I, aR, aG, aB
    		aGrey = (aR + aG + aB) \ 3
    		neoPalSetCol I, aGrey, aGrey, aGrey
    	NEXT I
END SUB
