'=========================================================================== ' Subject: SHOW .GIF FOR PB Date: 06-25-98 (13:57) ' Author: Don Schullian Code: PB ' Origin: d83@ath.forthnet.gr Packet: PB.ABC '=========================================================================== $if 0 fShowGIF% by Don Schullian d83@ath.forthnet.gr www.basicguru.com ********************************************************************* ** The Graphics Interchange Format (c) is the Copyright property ** ** of CompuServe Incorporated. ** ** GIF (sm) is a Service Mark property of CompuServe Inc. ** ********************************************************************* Before we get started here I'd like to advise you that if disk space is not at a premium and you have control over what file type you're going to be using the forget GIFs! They take about 6 times longer to process than, say, a PCX or a BMP. There is also MUCH more that can go wrong with these files as the can contain more than one image, notes, imbedded text, and if one byte is out of place the whole thing will blow up. BMPs are the safest but the largest and PCXs, IMHO, provide a good middle ground for speed (as fast as BMPs and only a bit larger than GIFs). This code was based on work done by Dave Navarro, our resident PowerBASIC guru! d;) If you're not using PowerBASIC v3.5 and/or my VESA library then you'll need to do a LOT of tweaking. To be honest, there are some capabilities of the GIF file that I've been unable to test 'cause I can't find/create a file with those attributes! Anyhow, the primary purpose for rebuilding this routine was to display static, non-interlaced GIFs for a kid's game I'm working on so all the other stuff has been kind'a brushed over. What works, works, but..... There are also several lines of code that have been REMed out. Some of them load variables that I've not used but are available while others demonstrate procedures that I'm not using either. There are 6 routines called from these two functions that are included in DAS-VS01.PBL: DACreadARR ( DAC?(), Colors% ) DACwriteARR ( DAC?(), Colors% ) Mdelay ( Milliseconds% ) VESAput ( X1%, Y1%, D%(), PutMode? ) VESAget ( X1%, Y1%, X2%, Y2%, D%() ) VESAprint ( X1%, Y1%, Text$, PutMode?, Fgrnd?, Bgrnd? ) The first two read and write the DAC registers from/into an array. Mdelay pauses the machine for n/1000ths of a second. VESAput/VESAget are simply a graphics PUT & GET routines and can be quickly replaced here by your own PUT routine or you can even stuff each pixel individually. If, however, the image is transparent then you'll have to deal with that seperately. VESAput can do this. VESAprint prints text to the screen from a pre-loaded character set. '==================================================================== Most of these routines are called only once and I've put some BIG remark lines around them so they should be easy to spot. '==================================================================== fShowGIF% will display: interlaced static images you may force the X aspect but the Y aspect will remain 1 (I worked on the variable Y aspect for 2 days couldn't get it 100% ) non-interlaced static images multi-image files transparent (sprite) files and will display them (non-interlaced only) at the original size whatever X or Y size and maintain the aspect ratio of the missing size compute/use both X and Y aspect ratios and can display more than one file on the screen at the same time as long as the combined number of unique colors does not exceed the number of open (0,0,0) DAC positions you will create got all that? Before you start using this function you'll need to 'create' some holes in the DAC for the new, incoming colors. DAC$ = fReadDAC$(0,48) ' or whatever DAC$ = DAC$ + STRING$(624,0) ' the 'holes' WriteDAC 0, 256 ' or whatever fStuffPalette% expects to find these holes starting with color #48 allowing you 48 'constant' colors for your code to use and 208 'holes' for use by the GIFs. The function will also NOT use color #0 as this value is used to indicated the background color of a sprite. You can, of course, get into the function and adjust these values. Existing colors are used as they are found so you can get quite a few files on the screen at the same time without too much hassle. Oh, the 'funny' stuff with the FileSpec$, FileNo%, and Offset& are all there in case you're using a RESource file to hold all the image files instead of having 832 graphics files all over the disk. (Can't stand that myself!) If fShowGIF% opens a file it will close it before exiting but if it finds it open ( FileSpec$ = "" and FileNo% > 0 ) then it will leave it open even if an error occurs. To test this routine I used Paint Shop Pro v4 to create the five file types supported. If you've run into trouble with .GIFs from other programs, PLEASE send one to me so I can have a look at it. TIA Give me a shout if you run into trouble and/or have any comments. C'ya, d83 $endif ' -------------------------------------------------------------------- ' -------------- test code ------------------------------------ ' ------------- for DAS-VS01.PBL ----------------------------------- ' -------------------------------------------------------------------- $INCLUDE "DAS-VS01.INC" ON ERROR GOTO Oops RANDOMIZE TIMER TheMode?? = &h103 IF NOT fVESAprintSetup%( "VS-FNT16.850", 0 ) THEN BEEP : END IF fVESAsetup?( TheMode?? ) = 0 THEN BEEP : END DELAY 2 DIM DYNAMIC P?(2,255) DACreadARR P?(0,0), 48 DACwriteARR P?(0,0), 256 ERASE P? FileSpec$ = "YAK.GIF" t! = timer fShowGIF% 0, 0, 0, 0, FileSpec$, 0 t! = timer - t! VESAprint 0, 550, USING$( "##.###", T! ), 3, 14, 0 WHILE NOT INSTAT : WEND VESAend CLS END '.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø ' ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ' PURPOSE: Display GIF files in all their glory ' PARAMS: Xstart%, Ystart% top left corner of image ' Xend% , Yend% bottom right corner of image ' if Xend% and Yend% are ZERO then ' the image size will be determined by ' image data ' if either is > ZERO then the other will ' maintain the aspect ratio ' if both are > ZERO then the image's aspect ' ratio will be altered to fit in the params ' FileSpec$ file name ' if not NULL then the file is opened/closed ' FileNo% file number to use ' if none given FREEFILE is used ' RETURNS: ZERO if image was displayed fully ' 1 if file does not conform to BMP format ' n PB error number '.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø ' ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø TYPE GIFheaderTYPE 'Image header Signature AS STRING * 3 ' "GIF" is the only acceptable value Version AS STRING * 3 ' "87a" and "89a" are only 2 acceptable Cols AS WORD ' Rows AS WORD ' PkFlds AS BYTE ' (see below) BGidx AS BYTE ' index to background color Aspect AS BYTE ' IF > 0 THEN Asp! = ( ( t.Aspect + 15 ) / 64 ) END TYPE ' ' TYPE GIFimageTYPE 'Image descriptor Xoffset AS WORD ' Yoffset AS WORD ' Cols AS WORD ' Rows AS WORD ' PkFlds AS BYTE ' END TYPE ' ' TYPE GIFcontrolTYPE 'Image control block BlockSize AS BYTE ' = &h04 or not correct (following 4 bytes) PkFlds AS BYTE ' DelayTime AS WORD ' TransIdx AS BYTE ' Terminator AS BYTE ' = 0 or not correct END TYPE ' ' TYPE GIFtextTYPE 'text messages BlockSize AS BYTE ' = &h0C or not correct Col AS WORD ' relative column position in image Row AS WORD ' relative row position in image Wide AS WORD ' pixel width of text High AS WORD ' pixel height of text CharWide AS BYTE ' pixel width of one character CharHigh AS BYTE ' pixel heigth of one character Fgrnd AS BYTE ' foreground color of text Bgrnd AS BYTE ' background color of text END TYPE ' ' -------------------------------------------------------------------------- FUNCTION fShowGif ( BYVAL Xstart AS INTEGER, _ BYVAL Ystart AS INTEGER, _ BYVAL Xend AS INTEGER, _ BYVAL Yend AS INTEGER, _ BYVAL FileSpec AS STRING, _ BYVAL FileNo AS INTEGER ) LOCAL PUBLIC AS INTEGER DIM B AS LOCAL BYTE ' disposable DIM BitMask AS LOCAL INTEGER ' LZW decoding DIM B_ptr AS LOCAL STRING PTR*255 ' DIM Block(254) AS LOCAL BYTE ' DIM BlockLen AS LOCAL INTEGER ' DIM BlockIdx AS LOCAL INTEGER ' ' DIM BperPixel AS LOCAL BYTE ' bits per pixel color DIM ClearCode AS LOCAL INTEGER ' LZW decoding DIM ClrNo AS LOCAL BYTE ' DIM Close_File AS LOCAL INTEGER ' file was locally opened DIM CodeSize AS LOCAL INTEGER ' LZW decoding DIM CurCode AS LOCAL INTEGER ' LZW decoding DIM EOFcode AS LOCAL INTEGER ' LZW decoding DIM FinChar AS LOCAL INTEGER ' LZW decoding DIM FirstFree AS LOCAL INTEGER ' LZW decoding DIM FreeCode AS LOCAL INTEGER ' LZW decoding DIM GIFerror AS LOCAL INTEGER ' local error DIM I AS LOCAL INTEGER ' disposable DIM tICB AS LOCAL GIFcontrolTYPE ' DIM Ilaced AS LOCAL INTEGER ' interlaced next row DIM tIMG AS LOCAL GIFimageTYPE ' DIM InCode AS LOCAL INTEGER ' LZW decoding DIM InitCodeSize AS LOCAL INTEGER ' LZW decoding DIM J AS LOCAL INTEGER ' disposable DIM K AS LOCAL INTEGER ' disposable DIM Ldata (MIN,1) AS LOCAL INTEGER ' 1 line array DIM L_ptr AS LOCAL BYTE PTR ' array pointer DIM Lidx AS LOCAL INTEGER ' array index counter DIM tLSD AS LOCAL GIFheaderTYPE ' DIM MaxCode AS LOCAL INTEGER ' LZW decoding DIM OldCode AS LOCAL INTEGER ' LZW decoding DIM OutCode (1024) AS LOCAL INTEGER ' LZW decoding DIM OutCnt AS LOCAL INTEGER ' LZW decoding DIM PalGBL (MIN,1) AS LOCAL BYTE ' global palette index DIM PalLOCAL (MIN,1) AS LOCAL BYTE ' local palette index DIM P_ptr AS LOCAL BYTE PTR ' pointer to whichever palette DIM Pmode AS LOCAL BYTE ' put mode & transparent DIM Prefix (4096) AS LOCAL INTEGER ' LZW decoding DIM Sbuf (MIN,1) AS LOCAL INTEGER ' save buffer ' DIM Sorted AS LOCAL BYTE ' if palette is sorted DIM Suffix (4096) AS LOCAL INTEGER ' LZW decoding DIM Temp AS LOCAL STRING ' DIM Temp2 AS LOCAL STRING ' DIM TheCode AS LOCAL INTEGER ' LZW decoding DIM tTXT AS LOCAL GIFtextTYPE ' DIM Xcount AS LOCAL INTEGER ' DIM Xfactor AS LOCAL INTEGER ' DIM Y AS LOCAL INTEGER ' current screen row DIM Ycount AS LOCAL INTEGER ' DIM Yfactor AS LOCAL INTEGER ' DIM Yoffset AS LOCAL INTEGER ' offset to next row start ' ON ERROR GOTO ShowGIFoops ' local error trap ' B_ptr = VARPTR32( Block?(0) ) ' set pointer to our buffer IF LEN(FileSpec$) > 0 THEN ' if file name was given IF LEN(DIR$(FileSpec$)) = 0 THEN ERROR 53 ' oops! no file available IF FileNo% < 1 THEN FileNo% = FREEFILE ' if no file no was given Close_File% = -1 ' set local open flag OPEN "B", #FileNo%, FileSpec$ ' open the file END IF ' '-----------------------------------------------'-------------------------- '----- GLOBAL VALUES -------------------------'-------------------------- '-----------------------------------------------'-------------------------- GET #FileNo%, , tLSD ' IF tLSD.Signature <> "GIF" THEN ERROR 1 ' IF VAL( tLSD.Version ) < 87 THEN ERROR 1 ' IF ( tLSD.PkFlds AND &b10000000 ) THEN ' gbl color table follows I% = ( tLSD.PkFlds AND &b0000111 ) ' J% = 2 ' SHIFT LEFT J%, I% ' number of palette colors BitMask% = (J% - 1) ' set color mask REDIM PalGBL?(BitMask%) ' global palette index P_ptr = VARPTR32( PalGBL?(0) ) ' set pointer GET$ #FileNo%, ( J% * 3 ), Temp$ ' read palette info fStuffPalette J%, Temp$, PalGBL?(), 0 ' set-up local palette ' Sorted? = (tLSD.PkFlds AND &b00001000) ' color idx in descending ' BperPxl? = (tLSD.PkFlds AND &b01110000) ' bits per pixel ' SHIFT RIGHT BperPxl?, 4 ' ' INCR BperPxl? ' END IF ' IF tLSD.Aspect > 0 THEN ' image's aspect ratio tLSD.Aspect = ( tLSD.Aspect + 15 ) \ 64 ' ELSE ' tLSD.Aspect = 1 ' END IF ' ' IF ( Xend% = 0 ) AND ( Yend% = 0 ) THEN 'if original size requested Xfactor% = 1000 ' Yfactor% = 1000 ' ELSE ' IF ( Xend% > 0 ) THEN 'if requested width I% = ( Xend% - Xstart% + 1 ) ' screen width Xfactor% = (CLNG(I% * 1000) \ tLSD.Cols) ' width factor IF Yend% = 0 THEN Yfactor% = Xfactor% ' maintain aspect ratio END IF ' IF Yend% > 0 THEN 'if requested height I% = (Yend% - Ystart% + 1) ' screen height Yfactor% = (CLNG(I% * 1000) \ tLSD.Rows) ' height factor IF Xend% = 0 THEN Xfactor% = Yfactor% ' maintain aspect ratio END IF ' END IF ' I% = ( CLNG(tLSD.Cols * Xfactor%) \ 1000 ) 'actual screen width J% = ( I% + 11 ) \ 2 'a few extra els for safty DIM Ldata%(J%) 'dim line buffer Ldata%(0) = I% 'set column width Ldata%(1) = 1 ' L_ptr = VARPTR32( Ldata%(2) ) ' Pmode? = 3 ' PSET default '-----------------------------------------------'-------------------------- '----- IMAGE DATA ----------------------------'-------------------------- '-----------------------------------------------'-------------------------- DO 'start processing image(s) DO ' check for control blocks GET #FileNo%, , B? ' SELECT CASE B? ' CASE &h2C : GOSUB GIFimageDesc ' we're ready to roll EXIT LOOP ' CASE &h21 : GET #FileNo%, , B? ' a control block SELECT CASE B? ' CASE &h01 :GOSUB GIFtext ' CASE &hF9 :GOSUB GIFcontrol ' CASE &hFE :GOSUB GIFremarks ' CASE &hFF :GOSUB GIFapp ' CASE ELSE :ERROR 1 ' END SELECT ' CASE ELSE : EXIT, EXIT ' END SELECT ' LOOP ' '---------------------------------------------'-------------------------- '----- LZW Decoder -------------------------'-------------------------- '---------------------------------------------'-------------------------- GET #FileNo%, , B? ' LZW control byte CodeSize% = B? ' BIT SET ClearCode%, CodeSize% ' EOFCode% = ClearCode% + 1 ' FirstFree% = ClearCode% + 2 ' FreeCode% = FirstFree% ' INCR CodeSize% ' InitCodeSize% = CodeSize% ' BIT SET Maxcode%, InitCodeSize% ' BlockIdx% = BlockLen% ' force a code read Xend% = 0 ' Y% = Ystart% ' Yend% = 0 ' Yoffset% = 0 ' Lidx% = 0 ' IF Ilaced% > 0 THEN Yfactor% = 1000 ' IF Pmode? = 4 THEN @P_ptr[tICB.TransIdx] = 0 ' IF tICB.Terminator > 1 THEN ' save background I% = CLNG( tLSD.Cols * Xfactor% ) \ 1000 ' J% = CLNG( tLSD.Rows * Yfactor% ) \ 1000 ' K% = 2 + ( ( I% * J% ) \ 2 ) ' INCR I%, Xstart% - 1 ' INCR J%, Xstart% - 1 ' REDIM Sbuf%(K%) ' '================================================='========================== VESAget Xstart%, Ystart%, I%, J%, Sbuf%(0) ' '================================================='========================== END IF ' ' DO ' decompression loop GOSUB ReadCode ' believe it or not I IF TheCode% = EOFCode% THEN EXIT LOOP ' just about understand IF TheCode% = ClearCode% THEN ' all this but couldn't CodeSize% = InitCodeSize% ' explain it to you in MaxCode% = 0 ' a million years! BIT SET Maxcode%, CodeSize% ' FreeCode% = FirstFree% ' GOSUB ReadCode ' CurCode% = TheCode% ' OldCode% = TheCode% ' FinChar% = ( TheCode% AND Bitmask% ) ' ClrNo? = @P_ptr[FinChar%] ' GOSUB NextPixelPos ' ELSE ' CurCode% = TheCode% ' InCode% = TheCode% ' IF TheCode% >= FreeCode% THEN ' CurCode% = OldCode% ' Outcode%(OutCnt%) = FinChar% ' INCR OutCnt% ' END IF ' IF CurCode% > Bitmask% THEN ' DO ' Outcode%(OutCnt%)=Suffix%(CurCode%) ' INCR OutCnt% ' CurCode% = Prefix%(CurCode%) ' LOOP UNTIL CurCode% <= Bitmask% ' END IF ' FinChar% = ( CurCode% AND Bitmask% ) ' Outcode%(OutCnt%) = FinChar% ' FOR I% = OutCnt% TO 0 STEP -1 ' ClrNo? = @P_ptr[OutCode%(I%)] ' GOSUB NextPixelPos ' NEXT ' OutCnt% = 0 ' Prefix%(FreeCode%) = OldCode% ' Suffix%(FreeCode%) = FinChar% ' OldCode% = InCode% ' INCR FreeCode% ' IF FreeCode% >= Maxcode% THEN ' IF CodeSize% < 12 THEN ' INCR CodeSize% ' SHIFT LEFT Maxcode%, 1 ' END IF ' END IF ' END IF ' LOOP ' IF tICB.DelayTime > 0 THEN ' '================================================='========================== Mdelay tICB.DelayTime ' '================================================='========================== END IF ' IF tICB.Terminator > 1 THEN ' '================================================='========================== VESAput Xstart%, Ystart%, Sbuf%(0), 3 ' restore background '================================================='========================== END IF ' IF BIT(tICB.PkFlds, 1) THEN ' pause for user input BEEP ' WHILE INSTAT : Temp$ = INKEY$ : WEND ' WHILE NOT INSTAT : WEND ' END IF ' GET #FileNo%, , B? ' LOOP ' ' ShowGIFexit: ' IF Close_File% AND _ ' FILEATTR(FileNo%,0) THEN CLOSE #FileNo% ' FUNCTION = GIFerror% ' EXIT FUNCTION ' ' ShowGIFoops: ' GIFerror% = ERR ' RESUME ShowGIFexit ' '-----------------------------------------------'-------------------------- '----- Local SUBs ----------------------------'-------------------------- '-----------------------------------------------'-------------------------- ReadCode: ' TheCode% = 0 ' clear code buffer FOR I% = 0 TO CodeSize% - 1 ' IF BlockIdx% = BlockLen% THEN ' GET #FileNo%, , B? ' bytes in this block GET$ #FileNo%, B?, @B_ptr ' load data block BlockLen% = ( B? * 8 ) ' bits in block BlockIdx% = 0 ' reset bit index END IF ' IF BIT(Block?(0),BlockIdx%) THEN ' BIT SET TheCode%,I% ' END IF ' INCR BlockIdx% ' NEXT ' RETURN ' ' NextPixelPos: ' INCR Xcount%, Xfactor% ' WHILE Xcount% => 1000 ' @L_ptr[Lidx%] = ClrNo? ' DECR Xcount%, 1000 ' INCR Lidx% ' WEND ' INCR Xend% ' code column counter IF Xend% < tIMG.Cols THEN RETURN ' if not end of a row Xend% = 0 ' Lidx% = 0 ' Xcount% = 0 ' INCR Ycount%, Yfactor% ' WHILE Ycount% => 1000 ' '================================================='========================== VESAput Xstart%, Y%, Ldata%(0), Pmode? ' '================================================='========================== DECR Ycount%, 1000 ' INCR Y% ' WEND ' IF Ilaced% = 0 THEN RETURN ' INCR Y% , Ilaced% - 1 ' INCR Yend%, Ilaced% ' IF ( Yend% < tIMG.Rows ) THEN RETURN ' SELECT CASE Yoffset% ' CASE 0 : Yoffset% = 4 ' CASE 4 : Yoffset% = 2 : Ilaced% = 4 ' CASE 2 : Yoffset% = 1 : Ilaced% = 2 ' END SELECT ' Yend% = Yoffset% ' back to the top Y% = Yoffset% + Ystart% ' RETURN ' '-----------------------------------------------'------------------------- '----- CONTROL BLOCKS ------------------------'------------------------- '-----------------------------------------------'------------------------- GIFimageDesc: ' GET #FileNo%, , tIMG ' IF BIT(tIMG.PkFlds,7) THEN ' I% = ( tIMG.PkFlds AND &b0000111 ) ' J% = 2 ' SHIFT LEFT J%, I% ' number of palette colors REDIM PalLocal?(J%-1) ' GET$ #FileNo%, (J% * 3), Temp$ ' read palette info fStuffPalette J%, Temp$, PalLOCAL?(), 0 ' set-up local palette P_ptr = VARPTR32( PalLOCAL?(0) ) ' END IF ' Ilaced% = BIT (tIMG.PkFlds,6) * 8 ' interlaced image ' Sorted? = BIT (tIMG.PkFlds,5) ' Ldata%(0) = CLNG(tIMG.Cols * Xfactor%) \ 1000 ' screen columns RETURN ' ' GIFcontrol: 'read image control block GET #FileNo%, , tICB ' IF tICB.BlockSize <> &h04 THEN ERROR 1 ' IF tICB.Terminator <> &h00 THEN ERROR 1 ' tICB.DelayTime = (tICB.DelayTime * 10 ) ' 1000ths of a second tICB.Terminator = (tICB.PkFlds AND 28) \ 4 ' disposal method Pmode? = 3 + BIT(tICB.PkFlds,0) ' transparent flag RETURN ' ' GIFtext: 'imbedded visible text GET #FileNo%, , tTXT ' there's no way I'm IF tTXT.BlockSize <> 11 THEN ERROR 1 ' messing with this one! GOSUB GIFremarks ' the code here is only IF LEN(Temp$) = 0 THEN RETURN ' to demonstrate what ' INCR tTXT.Col, Xstart% - 1 ' could be done! ' INCR tTXT.Row, Ystart% - 1 ' '================================================='========================== ' VESAprint tTXT.Col, tTXT.Row, Temp$, 3, _ ' ' TXT.Fgrnd, tTXT.Bgrnd ' '================================================='========================== RETURN ' ' GIFapp: ' 11 byte string GET$ #FileNo%, 12, Temp$ ' 8 byte name IF ASC(Temp$) <> 11 THEN ERROR 1 ' 3 byte identifier GIFremarks: 'read remarks Temp$ = "" ' DO ' GET #FileNo%, , B? ' block size IF B? = 0 THEN EXIT LOOP ' GET$ #FileNo%, B?, Temp2$ ' Temp$ = Temp$ + Temp2$ ' LOOP ' RETURN ' ' END FUNCTION ' '.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø ' ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ' PURPOSE: Put new colors into the Palette and provide an index to their ' position ' PARAMS: Colors% the number of color triplets being sent ' RGB$ the color triplets ' Pidx?(1) the array to hold the DAC index numbers ' RGBI% if = 0 then incoming palette is in RGB format ' if > 0 then incoming palette is in RGBI format and ' the Intensity byte is skipped ' if = 321 then the incoming palette is in BGRI format ' and bytes 3 and 1 are swapped to create an RGB ' NOTE: BMP palettes are in this format ' RETURNS: the number of NEW, unique colors '.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø.ø ' ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø ø FUNCTION fStuffPalette ( BYVAL Colors AS INTEGER, _ SEG RGB AS STRING , _ SEG Pidx() AS BYTE , _ BYVAL RGBI AS INTEGER ) LOCAL PUBLIC AS INTEGER DIM Count AS LOCAL INTEGER ' new color counter DIM Pal(255) AS LOCAL STRING * 3 ' local RGB strings DIM P_ptr AS LOCAL DWORD ' pointer to RGB strings DIM P AS LOCAL STRING * 3 ' new RGB string DIM R_ptr AS LOCAL BYTE PTR ' pointer to new data DIM Ridx AS LOCAL INTEGER ' new data ptr index DIM X AS LOCAL INTEGER ' loop counter DIM Y AS LOCAL INTEGER ' loop counter & temp DIM Zero AS LOCAL STRING * 3 ' search $ for a 'hole' ' P_ptr = VARPTR32( Pal$(0) ) 'pointer to index arr R_ptr = STRPTR32( RGB$ ) 'pointer to pal string Zero$ = STRING$(3,0) 'clear string ' '==================================================='======================== DACreadARR BYVAL P_ptr, 256 'load current DAC info '==================================================='======================== FOR X% = 0 TO Colors% -1 'start processing pal FOR Y% = 1 TO 3 ' get triplets ASC(P$,Y%) = ( @R_ptr[Ridx%] \ 4 ) ' divide RGB value by 4 INCR Ridx% ' next incoming pal byte NEXT ' IF RGBI% <> 0 THEN ' if RGBI encoded INCR Ridx% ' skip 4th 'I' byte IF RGBI% = 321 THEN ' if BGR encoded Y% = ASC(P$,1) ' swap B and G ASC(P$,1) = ASC(P$,3) ' ASC(P$,3) = Y% ' END IF ' END IF ' ARRAY SCAN Pal$(1), = P$, TO Y% ' search for exising clr IF Y% = 0 THEN ' yep! found one ARRAY SCAN Pal$(48) FOR 207, = Zero$, TO Y% ' find an open hole IF Y% = 0 THEN EXIT FOR ' oops! full up INCR Y%, 47 ' set actual DAC posn END IF ' Pidx?(X%) = Y% ' set index value IF (Y% > 47) THEN ' if a unique color Pal$(Y%) = P$ ' stuff into pal data INCR Count% ' END IF ' NEXT ' '==================================================='======================== DACwriteARR BYVAL P_ptr, 256 'write new DAC info '==================================================='======================== ' FUNCTION = Count% ' RETURN new color count ' END FUNCTION '