'=========================================================================== ' Subject: FADING PROGRAM Date: 01-02-96 (16:41) ' Author: Scott Mitchell Code: QB, QBasic, PDS ' Origin: FidoNet QUIK_BAS Echo Packet: GRAPHICS.ABC '=========================================================================== 'Here is a fading program. First, let me say that I make no promises 'that this program is 100% safe. I have tested it on my computer and it 'runs fine, but don't complain if your computer blows up or something. I 'would like to explain how this works first. 'First, to change the palette, we tinker with the ports &H3C7, &H3C8, and '&H3C9. You can see exactly how we change it in my GetPal and Pal 'procedures. For Pal, you are setting the Palette: ' PAL(colornumbertochange,red_intensity,Green_intensity,Blue_intensity) 'GetPal just returns the current values of intensity for the color 'specified. SetUpPalArray stores all of the default values in an array '(PalArray) so that when you're done fading out, you can restore what the 'previous default was. RestorePalette simply restores you old palette 'that you saved with SetUpPalArray. 'Scott Mitchell, 1996... 'Use at your own risk, but, heh, have fun ' 'Fading program... DECLARE SUB RestorePalette () DECLARE SUB fadeout () DECLARE SUB GetPal (col%, r%, g%, b%) DECLARE SUB SetUpPalArray () DECLARE SUB Pal (col%, r%, g%, b%) DEFINT A-Z 'MaxColors=the max colors per screen (255 in SCREEN 13 (0 - 255)) CONST MaxColors = 255, false = 0, true = NOT false TYPE PalType r AS INTEGER g AS INTEGER b AS INTEGER END TYPE DIM SHARED PalArray(MaxColors) AS PalType DIM SHARED AlreadyHandled(MaxColors) SetUpPalArray SCREEN 13 RANDOMIZE TIMER DO PSET (320 * RND, 200 * RND), 256 * RND LOOP UNTIL INKEY$ <> "" CALL fadeout SLEEP 1 RestorePalette END '------------------------------------------------------------------ SUB fadeout completed = 0 count = 0 FOR x = 0 TO MaxColors AlreadyHandled(x) = 0 NEXT DO done = true IF AlreadyHandled(count) <> 0 THEN DO count = count + 1 IF count > MaxColors THEN count = 0 LOOP UNTIL AlreadyHandled(count) = 0 END IF CALL GetPal(count, r, g, b) IF r > 0 THEN r = r - 1 done = false END IF IF g > 0 THEN g = g - 1 done = false END IF IF b > 0 THEN b = b - 1 done = false END IF CALL Pal(count, r, g, b) IF done THEN completed = completed + 1 AlreadyHandled(count) = 1 END IF count = count + 1: IF count > MaxColors THEN count = 0 LOOP UNTIL completed >= 255 END SUB '-------------------------------------------------------------------- SUB GetPal (col, r, g, b) OUT &H3C7, col r = INP(&H3C9) g = INP(&H3C9) b = INP(&H3C9) END SUB '-------------------------------------------------------------------- SUB Pal (col, r, g, b) OUT &H3C8, col OUT &H3C9, r OUT &H3C9, g OUT &H3C9, b END SUB '-------------------------------------------------------------------- SUB RestorePalette FOR x = 0 TO MaxColors CALL Pal(x, PalArray(x).r, PalArray(x).g, PalArray(x).b) NEXT END SUB '-------------------------------------------------------------------- SUB SetUpPalArray FOR x = 0 TO MaxColors CALL GetPal(x, PalArray(x).r, PalArray(x).g, PalArray(x).b) NEXT END SUB