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 >
BASIC Source File  |  1993-01-06  |  11KB  |  405 lines
  1. ' PALCALLS.BAS
  2. ' some special VGA palette calls
  3.  
  4. ' This file will not run by itself.
  5. ' LOAD or MERGE this program into your program.
  6.  
  7. ' VGX.LIB quicklibrary is REQUIRED
  8.  
  9. ' These palette routines will work ONLY in VGA SCREEN 12 mode!
  10.  
  11. DEFINT A-Z
  12.  
  13. ' VEGX.LIB calls
  14. DECLARE FUNCTION VGAPALETTE& (R%, G%, B%)  ' <--- MUST DECLARE!
  15. DECLARE FUNCTION GetMemByte% (segm%, element%)  ' <-- MUST be declared!!!
  16. DECLARE SUB SetMemByte (segm%, element%, value%)
  17. DECLARE SUB GraySumCurrent ()      'gray-sums current palette
  18. DECLARE SUB graysumforced ()       'gray-sums using forced values
  19. DECLARE SUB BlankPal ()            'all colors = black (watch out!)
  20. DECLARE SUB ReadDACBLOCK (Pal%())  'get the current pallete into array
  21. DECLARE SUB SetDACBLOCK (Pal%())   'set the current pallete using array
  22. DECLARE SUB FadeOut ()             'fades to attribute zero
  23. DECLARE SUB Fade2Black ()          'fades to black
  24. DECLARE SUB RotatePalette (StartPal%, EndPal%, speed%, dir%)
  25. 'rotates the palette Dir=0=descending  Dir=1=ascending
  26.  
  27. 'need for palette and VGXINT10X
  28. TYPE RegType
  29.     AX AS INTEGER
  30.     BX AS INTEGER
  31.     CX AS INTEGER
  32.     DX AS INTEGER
  33.     bp AS INTEGER
  34.     si AS INTEGER
  35.     di AS INTEGER
  36.     flags AS INTEGER
  37.     ds AS INTEGER
  38.     ES AS INTEGER
  39. END TYPE
  40. DIM SHARED InRegs AS RegType
  41.  
  42. DECLARE SUB VEGXint10X (InRegs AS RegType)
  43.  
  44. 'DIM SHARED VGXpal(0 TO 24) AS INTEGER 'you might want some SHARED
  45.                                        'or COMMON palettes
  46.  
  47. SUB BlankPal
  48.  
  49. 'makes all colors = black   (watch out!  Be sure to set colors when done.)
  50.  
  51. REDIM P(0 TO 24) AS INTEGER
  52.  
  53. InRegs.BX = 0
  54. InRegs.CX = 16
  55. InRegs.AX = &H1012      'set BLOCK of DAC registers
  56. InRegs.ES = VARSEG(P(0))
  57. InRegs.DX = VARPTR(P(0))
  58. CALL VEGXint10X(InRegs)
  59.  
  60. ERASE P
  61.  
  62. END SUB
  63.  
  64. SUB Fade2Black
  65.  
  66. ' fades each palette to Black
  67. ' remember to do a CLS:PALETTE after call if wanted
  68.  
  69. REDIM BytePal(0 TO 24)
  70. REDIM CurrentPal(0 TO 24)
  71. REDIM SinglePal(0 TO 47) AS SINGLE
  72. REDIM PalRatio(0 TO 47) AS SINGLE
  73. InRegs.CX = 16
  74.  
  75. ''get the current palette
  76. InRegs.AX = &H1017      'read BLOCK of DAC registers
  77. InRegs.ES = VARSEG(CurrentPal(0))
  78. CALL VEGXint10X(InRegs)
  79.  
  80. 'calculate the stepping to get from current to final in 64 loops
  81. FOR k = 0 TO 47
  82.    SinglePal(k) = GetMemByte(VARSEG(CurrentPal(0)), k + 1)
  83.    PalRatio(k) = SinglePal(k) / 64
  84. NEXT k
  85.  
  86. 'now do it!
  87. InRegs.ES = VARSEG(BytePal(0))
  88. FOR j = 1 TO 64
  89.    FOR k = 0 TO 47
  90.       SinglePal(k) = SinglePal(k) - PalRatio(k)
  91.       CALL SetMemByte(VARSEG(BytePal(0)), k + 1, INT(SinglePal(k)))
  92.    NEXT k
  93.    InRegs.AX = &H1012      ' <- MUST be here to prevent bug
  94.    CALL VEGXint10X(InRegs)
  95. NEXT j
  96.  
  97. 'give back memory
  98. ERASE BytePal, SinglePal, CurrentPal, PalRatio
  99.  
  100. END SUB
  101.  
  102. SUB FadeIn (P%())
  103.  
  104. REDIM BytePal(0 TO 24) AS INTEGER
  105. REDIM SinglePal(0 TO 47) AS SINGLE
  106. REDIM PalRatio(0 TO 47) AS SINGLE
  107.  
  108.  
  109. 'get the current background color and put into BytePal
  110. InRegs.AX = &H1017      'read BLOCK of DAC registers
  111. InRegs.CX = 1
  112. InRegs.ES = VARSEG(BytePal(0))
  113. CALL VEGXint10X(InRegs)
  114.  
  115. ' The VGA DAC stores the palette as 3-byte triplets (16 colors * 3 bytes =
  116. ' 48 bytes total or BASIC 24-INTEGER array.)  Unfortunately, there is no
  117. ' such thing as a BYTE array in BASIC, so we have to use GetMemByte and
  118. ' SetMemByte to work with palette data in an integer array.
  119.  
  120. R = GetMemByte(VARSEG(BytePal(0)), 1)
  121. G = GetMemByte(VARSEG(BytePal(0)), 2)
  122. B = GetMemByte(VARSEG(BytePal(0)), 3)
  123.  
  124. FOR k = 1 TO 15
  125.    CALL SetMemByte(VARSEG(BytePal(0)), (k * 3) + 1, R)
  126.    CALL SetMemByte(VARSEG(BytePal(0)), (k * 3) + 2, G)
  127.    CALL SetMemByte(VARSEG(BytePal(0)), (k * 3) + 3, B)
  128. NEXT k
  129.  
  130. ''' FADE-IN
  131. FOR k = 0 TO 47
  132.    R = GetMemByte(VARSEG(BytePal(0)), k + 1)
  133.    PalRatio(k) = (GetMemByte(VARSEG(P(0)), k + 1) - R) / 64
  134.    SinglePal(k) = R
  135. NEXT k
  136.  
  137. InRegs.ES = VARSEG(BytePal(0))
  138. InRegs.CX = 16
  139. FOR j = 1 TO 63
  140.    FOR k = 0 TO 47
  141.       SinglePal(k) = SinglePal(k) + PalRatio(k)
  142.       CALL SetMemByte(VARSEG(BytePal(0)), k + 1, INT(SinglePal(k)))
  143.    NEXT k
  144.    InRegs.AX = &H1012      ' <- MUST be here to prevent bug
  145.    CALL VEGXint10X(InRegs)
  146. NEXT j
  147.  
  148.  
  149. 'do it one last time with the original array to prevent rounding errors
  150. InRegs.ES = VARSEG(P(0))
  151. InRegs.AX = &H1012      ' <- MUST be here to prevent bug
  152. CALL VEGXint10X(InRegs)
  153.  
  154. END SUB
  155.  
  156. SUB FadeOut
  157.  
  158. ' fades each palette to same as color 0
  159. ' remember to do a CLS:PALETTE after call if wanted
  160.  
  161.  
  162. REDIM BytePal(0 TO 24)
  163. REDIM CurrentPal(0 TO 24)
  164.  
  165. 'get the current background color and put into BytePal
  166. InRegs.AX = &H1017      'read BLOCK of DAC registers
  167. InRegs.CX = 1
  168. InRegs.ES = VARSEG(BytePal(0))
  169. CALL VEGXint10X(InRegs)
  170.  
  171. PalAddr = VARSEG(BytePal(0))
  172.  
  173. ' get the individual red, blue and green values for attribute zero
  174. R = GetMemByte(PalAddr, 1)
  175. G = GetMemByte(PalAddr, 2)
  176. B = GetMemByte(PalAddr, 3)
  177.  
  178. 'set all the BytePal values to the same as attribute zero
  179. FOR k = 1 TO 15
  180.    CALL SetMemByte(PalAddr, (k * 3) + 1, R)
  181.    CALL SetMemByte(PalAddr, (k * 3) + 2, G)
  182.    CALL SetMemByte(PalAddr, (k * 3) + 3, B)
  183. NEXT k
  184.  
  185. REDIM SinglePal(0 TO 47) AS SINGLE
  186. REDIM PalRatio(0 TO 47) AS SINGLE
  187.  
  188. InRegs.CX = 16
  189.  
  190. ''get the current palette
  191. InRegs.AX = &H1017      'read BLOCK of DAC registers
  192. InRegs.ES = VARSEG(CurrentPal(0))
  193. CALL VEGXint10X(InRegs)
  194.  
  195. 'calculate stepping to get from current to attribute zero
  196. FOR k = 0 TO 47
  197.    SinglePal(k) = GetMemByte(VARSEG(CurrentPal(0)), k + 1)
  198.    PalRatio(k) = (SinglePal(k) - GetMemByte(VARSEG(BytePal(0)), k + 1)) / 64
  199. NEXT k
  200.  
  201. 'Now do it!
  202. InRegs.AX = &H1012      'set BLOCK of DAC registers
  203. InRegs.ES = VARSEG(BytePal(0))
  204. FOR j = 1 TO 64
  205.    FOR k = 0 TO 47
  206.       SinglePal(k) = SinglePal(k) - PalRatio(k)
  207.       CALL SetMemByte(VARSEG(BytePal(0)), k + 1, INT(SinglePal(k)))
  208.    NEXT k
  209.    InRegs.AX = &H1012      ' <- MUST be here to prevent bug
  210.    CALL VEGXint10X(InRegs)
  211. NEXT j
  212.  
  213. ERASE BytePal, SinglePal, CurrentPal, PalRatio
  214.  
  215. END SUB
  216.  
  217. SUB GraySumCurrent
  218.  
  219. '''gray-scale summing using current values
  220.  
  221. InRegs.BX = 0
  222. InRegs.AX = &H101B
  223. InRegs.CX = 16
  224. CALL VEGXint10X(InRegs)
  225.  
  226. END SUB
  227.  
  228. SUB graysumforced
  229.  
  230. 'forced gray scale summing
  231. 'Does not use current values, but forces 0 as black and 15 as white
  232.  
  233. CX = 0
  234. DX = 0
  235. FOR k = 0 TO 15
  236.    InRegs.BX = k
  237.    InRegs.AX = &H1010  'set individual DAC register
  238.    InRegs.DX = DX
  239.    InRegs.CX = CX
  240.    CX = CX + &H404
  241.    DX = DX + &H400
  242.    CALL VEGXint10X(InRegs)
  243. NEXT k
  244.  
  245. END SUB
  246.  
  247. SUB ReadDACBLOCK (CurrPal%())
  248.  
  249. 'Saves current palette into 48 byte palette array
  250.  
  251. 'InRegs MUST be SHARED
  252.  
  253. InRegs.BX = 0
  254. InRegs.AX = &H1017      'read BLOCK of DAC registers
  255. InRegs.CX = 16
  256. InRegs.ES = VARSEG(CurrPal(0))
  257. InRegs.DX = VARPTR(CurrPal(0))
  258. CALL VEGXint10X(InRegs)
  259.  
  260. END SUB
  261.  
  262. SUB RotatePalette (StartPal, EndPal, delay, dir) 'rotates the palette
  263.  
  264. ' only uses those colors in range of start and end
  265.  
  266. ' startpal is first attribute to rotate
  267. ' endpal is last attribute to rotate
  268. ' delay is time to pause
  269. ' dir is direction, 0 is decending, else is ascending
  270.  
  271. ' GetMemByte function *MUST* be declared in Main Module
  272.  
  273. REDIM BytePal(0 TO 24) AS INTEGER
  274. REDIM Original(0 TO 24) AS INTEGER
  275. PalCount = EndPal - StartPal + 1
  276.  
  277. 'get the current background color and put into BytePal and StartPal
  278. InRegs.BX = 0
  279. InRegs.AX = &H1017      'read BLOCK of DAC registers
  280. InRegs.CX = 16
  281. InRegs.ES = VARSEG(BytePal(0))
  282. InRegs.DX = VARPTR(BytePal(0))
  283. CALL VEGXint10X(InRegs)
  284.  
  285. InRegs.BX = 0
  286. InRegs.AX = &H1017      'read BLOCK of DAC registers
  287. InRegs.CX = 16
  288. InRegs.ES = VARSEG(Original(0))
  289. InRegs.DX = VARPTR(Original(0))
  290. CALL VEGXint10X(InRegs)
  291.  
  292.  
  293. ' The VGA DAC stores the palette as 3-byte triplets (16 colors * 3 bytes =
  294. ' 48 bytes total or BASIC 24-INTEGER array.)  Unfortunately, there is no
  295. ' such thing as a BYTE array in BASIC, so we have to use GetMemByte and
  296. ' SetMemByte to work with palette data in an integer array.
  297.  
  298. PALSEG = VARSEG(BytePal(0))
  299.  
  300. IF dir = 0 THEN 'descending
  301.  
  302.    DO
  303.       k = StartPal * 3
  304.       r1 = GetMemByte(PALSEG, k + 1)
  305.       g1 = GetMemByte(PALSEG, k + 2)
  306.       b1 = GetMemByte(PALSEG, k + 3)
  307.  
  308.       FOR k = (StartPal + 1) * 3 TO EndPal * 3 STEP 3
  309.          R = GetMemByte(PALSEG, k + 1)
  310.          G = GetMemByte(PALSEG, k + 2)
  311.          B = GetMemByte(PALSEG, k + 3)
  312.  
  313.          CALL SetMemByte(PALSEG, k - 2, R)
  314.          CALL SetMemByte(PALSEG, k - 1, G)
  315.          CALL SetMemByte(PALSEG, k, B)
  316.       NEXT k
  317.  
  318.       CALL SetMemByte(PALSEG, EndPal * 3 + 1, r1)
  319.       CALL SetMemByte(PALSEG, EndPal * 3 + 2, g1)
  320.       CALL SetMemByte(PALSEG, EndPal * 3 + 3, b1)
  321.  
  322.       InRegs.AX = &H1012      'set BLOCK of DAC registers
  323.       InRegs.BX = 0
  324.       InRegs.CX = 16
  325.       InRegs.ES = PALSEG
  326.       InRegs.DX = VARPTR(BytePal(0))
  327.       CALL VEGXint10X(InRegs)
  328.  
  329.       T1! = TIMER
  330.       T2! = T1! + delay / 1000
  331.       WHILE T2! > TIMER: WEND
  332.  
  333.    LOOP WHILE INKEY$ = ""
  334.  
  335. ELSE ' rotate ASCENDING
  336.  
  337.    DO
  338.       k = EndPal * 3
  339.       r1 = GetMemByte(PALSEG, k + 1)
  340.       g1 = GetMemByte(PALSEG, k + 2)
  341.       b1 = GetMemByte(PALSEG, k + 3)
  342.  
  343.       FOR k = (EndPal - 1) * 3 TO StartPal * 3 STEP -3
  344.          R = GetMemByte(PALSEG, k + 1)
  345.          G = GetMemByte(PALSEG, k + 2)
  346.          B = GetMemByte(PALSEG, k + 3)
  347.  
  348.          CALL SetMemByte(PALSEG, k + 4, R)
  349.          CALL SetMemByte(PALSEG, k + 5, G)
  350.          CALL SetMemByte(PALSEG, k + 6, B)
  351.       NEXT k
  352.  
  353.       CALL SetMemByte(PALSEG, StartPal * 3 + 1, r1)
  354.       CALL SetMemByte(PALSEG, StartPal * 3 + 2, g1)
  355.       CALL SetMemByte(PALSEG, StartPal * 3 + 3, b1)
  356.  
  357.       InRegs.AX = &H1012      'set BLOCK of DAC registers
  358.       InRegs.BX = 0
  359.       InRegs.CX = 16
  360.       InRegs.ES = PALSEG
  361.       InRegs.DX = VARPTR(BytePal(0))
  362.       CALL VEGXint10X(InRegs)
  363.  
  364.       T1! = TIMER
  365.       T2! = T1! + delay / 1000
  366.       WHILE T2! > TIMER: WEND
  367.  
  368.    LOOP WHILE INKEY$ = ""
  369.  
  370. END IF
  371.  
  372. RP2bye:
  373.  
  374. 'one last time to leave it where we started
  375. InRegs.BX = 0
  376. InRegs.CX = 16
  377. InRegs.ES = VARSEG(Original(0))
  378. InRegs.DX = VARPTR(Original(0))
  379. InRegs.AX = &H1012      ' <- MUST be here to prevent bug
  380. CALL VEGXint10X(InRegs)
  381.  
  382. ERASE BytePal, Original
  383.  
  384. END SUB
  385.  
  386. SUB SetDACBLOCK (P%())
  387.  
  388. 'put palette array into palette memory
  389.  
  390. ''InRegs MUST be SHARED
  391.  
  392. InRegs.AX = &H1012      'set BLOCK of DAC registers
  393. InRegs.BX = 0
  394. InRegs.CX = 16
  395. InRegs.ES = VARSEG(P(0))
  396. InRegs.DX = VARPTR(P(0))
  397. CALL VEGXint10X(InRegs)
  398.  
  399. END SUB
  400.  
  401. FUNCTION VGAPALETTE& (R%, G%, B%) STATIC
  402.    VGAPALETTE& = 65536 * B + 256 * G + R
  403. END FUNCTION
  404.  
  405.