home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
QBAS
/
VGX3.ZIP
/
PALCALLS.BAS
< prev
next >
Wrap
BASIC Source File
|
1993-01-06
|
11KB
|
405 lines
' PALCALLS.BAS
' some special VGA palette calls
' This file will not run by itself.
' LOAD or MERGE this program into your program.
' VGX.LIB quicklibrary is REQUIRED
' These palette routines will work ONLY in VGA SCREEN 12 mode!
DEFINT A-Z
' VEGX.LIB calls
DECLARE FUNCTION VGAPALETTE& (R%, G%, B%) ' <--- MUST DECLARE!
DECLARE FUNCTION GetMemByte% (segm%, element%) ' <-- MUST be declared!!!
DECLARE SUB SetMemByte (segm%, element%, value%)
DECLARE SUB GraySumCurrent () 'gray-sums current palette
DECLARE SUB graysumforced () 'gray-sums using forced values
DECLARE SUB BlankPal () 'all colors = black (watch out!)
DECLARE SUB ReadDACBLOCK (Pal%()) 'get the current pallete into array
DECLARE SUB SetDACBLOCK (Pal%()) 'set the current pallete using array
DECLARE SUB FadeOut () 'fades to attribute zero
DECLARE SUB Fade2Black () 'fades to black
DECLARE SUB RotatePalette (StartPal%, EndPal%, speed%, dir%)
'rotates the palette Dir=0=descending Dir=1=ascending
'need for palette and VGXINT10X
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
DIM SHARED InRegs AS RegType
DECLARE SUB VEGXint10X (InRegs AS RegType)
'DIM SHARED VGXpal(0 TO 24) AS INTEGER 'you might want some SHARED
'or COMMON palettes
SUB BlankPal
'makes all colors = black (watch out! Be sure to set colors when done.)
REDIM P(0 TO 24) AS INTEGER
InRegs.BX = 0
InRegs.CX = 16
InRegs.AX = &H1012 'set BLOCK of DAC registers
InRegs.ES = VARSEG(P(0))
InRegs.DX = VARPTR(P(0))
CALL VEGXint10X(InRegs)
ERASE P
END SUB
SUB Fade2Black
' fades each palette to Black
' remember to do a CLS:PALETTE after call if wanted
REDIM BytePal(0 TO 24)
REDIM CurrentPal(0 TO 24)
REDIM SinglePal(0 TO 47) AS SINGLE
REDIM PalRatio(0 TO 47) AS SINGLE
InRegs.CX = 16
''get the current palette
InRegs.AX = &H1017 'read BLOCK of DAC registers
InRegs.ES = VARSEG(CurrentPal(0))
CALL VEGXint10X(InRegs)
'calculate the stepping to get from current to final in 64 loops
FOR k = 0 TO 47
SinglePal(k) = GetMemByte(VARSEG(CurrentPal(0)), k + 1)
PalRatio(k) = SinglePal(k) / 64
NEXT k
'now do it!
InRegs.ES = VARSEG(BytePal(0))
FOR j = 1 TO 64
FOR k = 0 TO 47
SinglePal(k) = SinglePal(k) - PalRatio(k)
CALL SetMemByte(VARSEG(BytePal(0)), k + 1, INT(SinglePal(k)))
NEXT k
InRegs.AX = &H1012 ' <- MUST be here to prevent bug
CALL VEGXint10X(InRegs)
NEXT j
'give back memory
ERASE BytePal, SinglePal, CurrentPal, PalRatio
END SUB
SUB FadeIn (P%())
REDIM BytePal(0 TO 24) AS INTEGER
REDIM SinglePal(0 TO 47) AS SINGLE
REDIM PalRatio(0 TO 47) AS SINGLE
'get the current background color and put into BytePal
InRegs.AX = &H1017 'read BLOCK of DAC registers
InRegs.CX = 1
InRegs.ES = VARSEG(BytePal(0))
CALL VEGXint10X(InRegs)
' The VGA DAC stores the palette as 3-byte triplets (16 colors * 3 bytes =
' 48 bytes total or BASIC 24-INTEGER array.) Unfortunately, there is no
' such thing as a BYTE array in BASIC, so we have to use GetMemByte and
' SetMemByte to work with palette data in an integer array.
R = GetMemByte(VARSEG(BytePal(0)), 1)
G = GetMemByte(VARSEG(BytePal(0)), 2)
B = GetMemByte(VARSEG(BytePal(0)), 3)
FOR k = 1 TO 15
CALL SetMemByte(VARSEG(BytePal(0)), (k * 3) + 1, R)
CALL SetMemByte(VARSEG(BytePal(0)), (k * 3) + 2, G)
CALL SetMemByte(VARSEG(BytePal(0)), (k * 3) + 3, B)
NEXT k
''' FADE-IN
FOR k = 0 TO 47
R = GetMemByte(VARSEG(BytePal(0)), k + 1)
PalRatio(k) = (GetMemByte(VARSEG(P(0)), k + 1) - R) / 64
SinglePal(k) = R
NEXT k
InRegs.ES = VARSEG(BytePal(0))
InRegs.CX = 16
FOR j = 1 TO 63
FOR k = 0 TO 47
SinglePal(k) = SinglePal(k) + PalRatio(k)
CALL SetMemByte(VARSEG(BytePal(0)), k + 1, INT(SinglePal(k)))
NEXT k
InRegs.AX = &H1012 ' <- MUST be here to prevent bug
CALL VEGXint10X(InRegs)
NEXT j
'do it one last time with the original array to prevent rounding errors
InRegs.ES = VARSEG(P(0))
InRegs.AX = &H1012 ' <- MUST be here to prevent bug
CALL VEGXint10X(InRegs)
END SUB
SUB FadeOut
' fades each palette to same as color 0
' remember to do a CLS:PALETTE after call if wanted
REDIM BytePal(0 TO 24)
REDIM CurrentPal(0 TO 24)
'get the current background color and put into BytePal
InRegs.AX = &H1017 'read BLOCK of DAC registers
InRegs.CX = 1
InRegs.ES = VARSEG(BytePal(0))
CALL VEGXint10X(InRegs)
PalAddr = VARSEG(BytePal(0))
' get the individual red, blue and green values for attribute zero
R = GetMemByte(PalAddr, 1)
G = GetMemByte(PalAddr, 2)
B = GetMemByte(PalAddr, 3)
'set all the BytePal values to the same as attribute zero
FOR k = 1 TO 15
CALL SetMemByte(PalAddr, (k * 3) + 1, R)
CALL SetMemByte(PalAddr, (k * 3) + 2, G)
CALL SetMemByte(PalAddr, (k * 3) + 3, B)
NEXT k
REDIM SinglePal(0 TO 47) AS SINGLE
REDIM PalRatio(0 TO 47) AS SINGLE
InRegs.CX = 16
''get the current palette
InRegs.AX = &H1017 'read BLOCK of DAC registers
InRegs.ES = VARSEG(CurrentPal(0))
CALL VEGXint10X(InRegs)
'calculate stepping to get from current to attribute zero
FOR k = 0 TO 47
SinglePal(k) = GetMemByte(VARSEG(CurrentPal(0)), k + 1)
PalRatio(k) = (SinglePal(k) - GetMemByte(VARSEG(BytePal(0)), k + 1)) / 64
NEXT k
'Now do it!
InRegs.AX = &H1012 'set BLOCK of DAC registers
InRegs.ES = VARSEG(BytePal(0))
FOR j = 1 TO 64
FOR k = 0 TO 47
SinglePal(k) = SinglePal(k) - PalRatio(k)
CALL SetMemByte(VARSEG(BytePal(0)), k + 1, INT(SinglePal(k)))
NEXT k
InRegs.AX = &H1012 ' <- MUST be here to prevent bug
CALL VEGXint10X(InRegs)
NEXT j
ERASE BytePal, SinglePal, CurrentPal, PalRatio
END SUB
SUB GraySumCurrent
'''gray-scale summing using current values
InRegs.BX = 0
InRegs.AX = &H101B
InRegs.CX = 16
CALL VEGXint10X(InRegs)
END SUB
SUB graysumforced
'forced gray scale summing
'Does not use current values, but forces 0 as black and 15 as white
CX = 0
DX = 0
FOR k = 0 TO 15
InRegs.BX = k
InRegs.AX = &H1010 'set individual DAC register
InRegs.DX = DX
InRegs.CX = CX
CX = CX + &H404
DX = DX + &H400
CALL VEGXint10X(InRegs)
NEXT k
END SUB
SUB ReadDACBLOCK (CurrPal%())
'Saves current palette into 48 byte palette array
'InRegs MUST be SHARED
InRegs.BX = 0
InRegs.AX = &H1017 'read BLOCK of DAC registers
InRegs.CX = 16
InRegs.ES = VARSEG(CurrPal(0))
InRegs.DX = VARPTR(CurrPal(0))
CALL VEGXint10X(InRegs)
END SUB
SUB RotatePalette (StartPal, EndPal, delay, dir) 'rotates the palette
' only uses those colors in range of start and end
' startpal is first attribute to rotate
' endpal is last attribute to rotate
' delay is time to pause
' dir is direction, 0 is decending, else is ascending
' GetMemByte function *MUST* be declared in Main Module
REDIM BytePal(0 TO 24) AS INTEGER
REDIM Original(0 TO 24) AS INTEGER
PalCount = EndPal - StartPal + 1
'get the current background color and put into BytePal and StartPal
InRegs.BX = 0
InRegs.AX = &H1017 'read BLOCK of DAC registers
InRegs.CX = 16
InRegs.ES = VARSEG(BytePal(0))
InRegs.DX = VARPTR(BytePal(0))
CALL VEGXint10X(InRegs)
InRegs.BX = 0
InRegs.AX = &H1017 'read BLOCK of DAC registers
InRegs.CX = 16
InRegs.ES = VARSEG(Original(0))
InRegs.DX = VARPTR(Original(0))
CALL VEGXint10X(InRegs)
' The VGA DAC stores the palette as 3-byte triplets (16 colors * 3 bytes =
' 48 bytes total or BASIC 24-INTEGER array.) Unfortunately, there is no
' such thing as a BYTE array in BASIC, so we have to use GetMemByte and
' SetMemByte to work with palette data in an integer array.
PALSEG = VARSEG(BytePal(0))
IF dir = 0 THEN 'descending
DO
k = StartPal * 3
r1 = GetMemByte(PALSEG, k + 1)
g1 = GetMemByte(PALSEG, k + 2)
b1 = GetMemByte(PALSEG, k + 3)
FOR k = (StartPal + 1) * 3 TO EndPal * 3 STEP 3
R = GetMemByte(PALSEG, k + 1)
G = GetMemByte(PALSEG, k + 2)
B = GetMemByte(PALSEG, k + 3)
CALL SetMemByte(PALSEG, k - 2, R)
CALL SetMemByte(PALSEG, k - 1, G)
CALL SetMemByte(PALSEG, k, B)
NEXT k
CALL SetMemByte(PALSEG, EndPal * 3 + 1, r1)
CALL SetMemByte(PALSEG, EndPal * 3 + 2, g1)
CALL SetMemByte(PALSEG, EndPal * 3 + 3, b1)
InRegs.AX = &H1012 'set BLOCK of DAC registers
InRegs.BX = 0
InRegs.CX = 16
InRegs.ES = PALSEG
InRegs.DX = VARPTR(BytePal(0))
CALL VEGXint10X(InRegs)
T1! = TIMER
T2! = T1! + delay / 1000
WHILE T2! > TIMER: WEND
LOOP WHILE INKEY$ = ""
ELSE ' rotate ASCENDING
DO
k = EndPal * 3
r1 = GetMemByte(PALSEG, k + 1)
g1 = GetMemByte(PALSEG, k + 2)
b1 = GetMemByte(PALSEG, k + 3)
FOR k = (EndPal - 1) * 3 TO StartPal * 3 STEP -3
R = GetMemByte(PALSEG, k + 1)
G = GetMemByte(PALSEG, k + 2)
B = GetMemByte(PALSEG, k + 3)
CALL SetMemByte(PALSEG, k + 4, R)
CALL SetMemByte(PALSEG, k + 5, G)
CALL SetMemByte(PALSEG, k + 6, B)
NEXT k
CALL SetMemByte(PALSEG, StartPal * 3 + 1, r1)
CALL SetMemByte(PALSEG, StartPal * 3 + 2, g1)
CALL SetMemByte(PALSEG, StartPal * 3 + 3, b1)
InRegs.AX = &H1012 'set BLOCK of DAC registers
InRegs.BX = 0
InRegs.CX = 16
InRegs.ES = PALSEG
InRegs.DX = VARPTR(BytePal(0))
CALL VEGXint10X(InRegs)
T1! = TIMER
T2! = T1! + delay / 1000
WHILE T2! > TIMER: WEND
LOOP WHILE INKEY$ = ""
END IF
RP2bye:
'one last time to leave it where we started
InRegs.BX = 0
InRegs.CX = 16
InRegs.ES = VARSEG(Original(0))
InRegs.DX = VARPTR(Original(0))
InRegs.AX = &H1012 ' <- MUST be here to prevent bug
CALL VEGXint10X(InRegs)
ERASE BytePal, Original
END SUB
SUB SetDACBLOCK (P%())
'put palette array into palette memory
''InRegs MUST be SHARED
InRegs.AX = &H1012 'set BLOCK of DAC registers
InRegs.BX = 0
InRegs.CX = 16
InRegs.ES = VARSEG(P(0))
InRegs.DX = VARPTR(P(0))
CALL VEGXint10X(InRegs)
END SUB
FUNCTION VGAPALETTE& (R%, G%, B%) STATIC
VGAPALETTE& = 65536 * B + 256 * G + R
END FUNCTION