'=========================================================================== ' Subject: SHOW .BMP FOR PB Date: 06-22-98 (14:04) ' Author: Don Schullian Code: PB ' Origin: d83@ath.forthnet.gr Packet: PB.ABC '=========================================================================== $if 0 fShowBMP% by Don Schullian d83@ath.forthnet.gr www.basicguru.com If you're not using PowerBASIC v3.5 and/or my VESA library then you'll need to do a bit of tweaking. There are 3 routines called from these two functions that are included in DAS-VS01.PBL: DACreadARR ( DAC?(), Colors% ) DACwriteARR ( DAC?(), Colors% ) VESAput ( X%, Y%, D%(), PutMode? ) The first two read and write the DAC registers from/into an array. VESAput is simply a graphics PUT routine and can be quickly replaced here by your own PUT routine or you can even stuff each pixel individually. '==================================================================== Each of these routines is called only once and I've put some BIG remark lines around them so they should be easy to spot. '==================================================================== fShowBMP% will display: 2 color non-encoded files 16 color non-encoded files 256 color non-encoded files 16 color RLE encoded files 256 color RLE encoded files and will display them 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 BMPs. 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 fShowBMP% 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 .BMPs 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-16.BMP" t! = timer fShowBMP% 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 1, 4 and 8 bit BMP files with or without RLE encoding ' 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 BMPheaderTYPE Ident AS INTEGER ' 19778 = CVI("BM") if .BMP format Fsize AS LONG ' File size in bytes Reserved AS STRING * 4 ' junk Offset AS LONG ' file offset to start of data Version AS LONG ' 40 = Windows 3.x 12 = OS/2 Cols AS LONG ' width in pixel columns Rows AS LONG ' height in pixel rows Planes AS INTEGER ' number of color planes ClrBits AS INTEGER ' number of bits per color Packed AS LONG ' 0 if not packed PackSize AS LONG ' actual length of data ''''''''''''''''''''''''''' OS/2 stops here Xscale AS LONG ' Yscale AS LONG ' Colors AS LONG ' actual # of colors used ImpColors AS LONG ' important colors used 0 = all END TYPE ' [ 54 bytes ] FUNCTION fShowBMP ( BYVAL Xstart AS INTEGER, _ BYVAL Ystart AS INTEGER, _ BYVAL Xend AS INTEGER, _ BYVAL Yend AS INTEGER, _ SEG FileSpec AS STRING , _ BYVAL FileNo AS INTEGER ) LOCAL PUBLIC AS INTEGER DIM tBMP AS LOCAL BMPheaderTYPE 'BMP header DIM BMPerror AS LOCAL INTEGER 'local error number DIM BperRow AS LOCAL INTEGER 'bytes per row of data DIM Chunk AS LOCAL INTEGER 'max data buffer $ size DIM Cidx AS LOCAL BYTE '1 byte read from buffer DIM Close_File AS LOCAL INTEGER 'opened file flag DIM Colour AS LOCAL INTEGER 'DAC color value to PUT DIM I AS LOCAL INTEGER 'loop counter & temp DIM J AS LOCAL INTEGER 'loop counter & temp DIM Ldata(MIN,1) AS LOCAL INTEGER '1 scan line to be PUT DIM L_ptr AS LOCAL BYTE PTR ' pointer to above DIM Lidx AS LOCAL INTEGER ' offset index to above DIM Pidx(255) AS LOCAL BYTE 'local palette index DIM Repeat AS LOCAL INTEGER 'times to repeat a color DIM Temp AS LOCAL STRING 'temp & data buffer DIM Tidx AS LOCAL INTEGER ' pointer to above DIM T_ptr AS LOCAL BYTE PTR ' offset index to above DIM Xcount AS LOCAL INTEGER 'xfactor counter DIM Xfactor AS LOCAL INTEGER 'x aspect @ pixel DIM Ycount AS LOCAL INTEGER 'yfactor counter DIM Yfactor AS LOCAL INTEGER 'y aspect @ row ' ON LOCAL ERROR GOTO ShowBMPoops 'set local error trap ' IF LEN(FileSpec$) > 0 THEN 'if a file name is given IF LEN(DIR$(FileSpec$)) = 0 THEN ERROR 53 ' check for existence IF FileNo% < 1 THEN FileNo% = FREEFILE ' if no file # given Close_File% = -1 ' set local open flag OPEN "B", #FileNo%, FileSpec$ ' open the file ELSE ' Offset& = SEEK(FileNo%) 'set RES file offset END IF ' ' GET #FileNo%, , tBMP 'read the header IF tBMP.Ident <> 19778 THEN ERROR 1 '19778 = CVI("BM") IF tBMP.Version <> 40 THEN ERROR 1 'must be O/S encoded IF tBMP.ClrBits > 8 THEN ERROR 1 'can 't handle this one IF tBMP.ClrBits = 0 THEN ERROR 1 'or this one! IF tBMP.Planes <> 1 THEN ERROR 1 'not doing 4 plane work! IF tBMP.Packed > 2 THEN ERROR 1 'invalid value ' INCR tBMP.Offset, Offset& 'set RES file offset X% = tBMP.Colors * 4 'read palette data GET$ #FileNo%, X%, Temp$ ' SEEK #FileNo%, tBMP.Offset 'start of image data fStuffPalette tBMP.Colors, Temp$, Pidx?(), 321 'stuff/convert new clrs ' 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) \ tBMP.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) \ tBMP.Rows ' height factor IF Xend% = 0 THEN Xfactor% = Yfactor% ' maintain aspect ratio END IF ' END IF ' I% = CLNG(tBMP.Cols * Xfactor%) \ 1000 'actual screen width J% = ( I% + 11 ) \ 2 'a few extra els for safety DIM Ldata%(J%) 'dim line buffer Ldata%(0) = I% 'set column width Ldata%(1) = 1 ' L_ptr = VARPTR32( Ldata%(2) ) ' Chunk% = FRE(-4) ' maximum string length Tidx% = Chunk% ' so we load the buffer I% = CLNG(tBMP.Rows * Yfactor%) \ 1000 'actual screen rows Yend% = Ystart% + I% - 1 ' BperRow% = tBMP.Cols + ( tBMP.Cols MOD 4 ) ' bytes per data line ' IF tBMP.Packed = 1 THEN 'RLE8bit (256 color) DO ' DO ' GOSUB ShowBMPloadB : Repeat% = Cidx? ' repeat pixel count GOSUB ShowBMPloadB ' next byte IF Repeat% > 0 THEN ' we have a count Colour% = Pidx?(Cidx?) ' DO ' GOSUB ShowBMPstufPixel ' DECR Repeat% ' LOOP UNTIL Repeat% = 0 ' ELSEif Cidx? > 2 THEN ' absolute mode Repeat% = Cidx? ' absolute pixel count I% = ( Repeat% AND 1 ) ' DO ' GOSUB ShowBMPloadB ' Colour% = Pidx?(Cidx?) ' GOSUB ShowBMPstufPixel ' DECR Repeat% ' LOOP UNTIL Repeat% = 0 ' IF I% THEN GOSUB ShowBMPloadB ' word boundry alignment ELSEif Cidx? = 0 THEN ' end of line EXIT LOOP ' ELSE ' end of image or EXIT, EXIT ' a 'movement' command END IF ' LOOP ' GOSUB ShowBMPputline ' LOOP UNTIL tBMP.Rows < 1 ' ELSEif tBMP.Packed = 2 THEN 'RLE4bit (16 color) DO ' DO ' GOSUB ShowBMPloadB : Repeat% = Cidx? ' repeat pixel count GOSUB ShowBMPloadB ' next byte IF Repeat% > 0 THEN ' we have a count Colour% = Pidx?(Cidx? \ 16) ' set the DAC value J% = Pidx?(Cidx? AND 15) ' DO ' do it GOSUB ShowBMPstufPixel ' SWAP Colour%, J% ' DECR Repeat% ' LOOP UNTIL Repeat% = 0 ' ELSEif Cidx? > 2 THEN ' absolute mode Repeat% = Cidx? ' absolute pixel count I% = ( Repeat% MOD 4 ) ' an alignment byte? DO ' GOSUB ShowBMPloadB ' Colour% = Pidx?( Cidx? \ 16 ) ' GOSUB ShowBMPstufPixel ' IF Repeat% > 0 THEN ' Colour% = Pidx?( Cidx? AND 15 ) ' GOSUB ShowBMPstufPixel ' END IF ' DECR Repeat%, 2 ' LOOP UNTIL Repeat% < 1 ' IF (I% > 0) THEN GOSUB ShowBMPloadB ' word boundry alignment ELSEif Cidx? = 0 THEN ' end of line EXIT LOOP ' ELSE ' end of image or tBMP.Rows = 0 ' EXIT ' a 'movement' command END IF ' LOOP ' IF (Tidx% AND 1) THEN GOSUB ShowBMPloadB ' GOSUB ShowBMPputline ' LOOP UNTIL tBMP.Rows < 1 ' ELSEif tBMP.ClrBits = 8 THEN '256 color (no packing) DO ' FOR I% = BperRow% TO 1 STEP -1 ' GOSUB ShowBMPloadB ' Colour% = Pidx?(Cidx?) ' GOSUB ShowBMPstufPixel ' NEXT ' GOSUB ShowBMPputline ' LOOP UNTIL tBMP.Rows = 0 ' ELSEif tBMP.ClrBits = 4 THEN '16 color 4 bits per pixel DO ' FOR I% = BperRow% TO 1 STEP -2 ' GOSUB ShowBMPloadB ' FOR J% = 0 TO 1 ' ROTATE RIGHT Cidx?, 4 ' Colour% = Pidx?( Cidx? AND 15 ) ' GOSUB ShowBMPstufPixel ' NEXT ' NEXT ' GOSUB ShowBMPputline ' LOOP UNTIL tBMP.Rows = 0 ' ELSEif tBMP.ClrBits = 1 THEN ' 2 color 1 bit per pixel DO ' FOR I% = BperRow% TO 1 STEP -8 ' GOSUB ShowBMPloadB ' FOR J% = 7 TO 0 STEP -1 ' ROTATE LEFT Cidx?, 1 ' Colour% = Pidx?(Cidx? AND 1) ' GOSUB ShowBMPstufPixel ' NEXT ' NEXT ' GOSUB ShowBMPputline ' LOOP UNTIL tBMP.Rows = 0 ' END IF ' ' ShowBMPexit: 'we're outta here IF Close_File% AND _ ' if opened locally FILEATTR(FileNo%, 0) THEN CLOSE FileNo% ' and is truly open FUNCTION = BMPerror% ' RETURN any error # EXIT FUNCTION ' bail out! ' ShowBMPstufPixel: 'stuff a pixel into buf INCR Xcount%, Xfactor% ' bump Xcounter WHILE Xcount% > 1000 ' if a full pixel or more @L_ptr[Lidx%] = Colour% ' put a pixel in buf INCR Lidx% ' bump buffer position DECR Xcount%, 1000 ' decr Xcounter WEND ' RETURN ' ' ShowBMPputline: 'put a line to the screen Lidx% = 0 ' reset buffer index Xcount% = 0 ' reset Xcounter DECR tBMP.Rows ' decr row counter INCR Ycount%, Yfactor% ' bump Ycounter WHILE Ycount% > 1000 ' if a whole line or more '================================================='======================== VESAput Xstart%, Yend%, Ldata%(0), 3 ' put a line '================================================='======================== DECR Ycount%, 1000 ' decr Ycounter DECR Yend% ' decr screen row WEND ' RETURN ' ' ShowBMPloadB: 'load next data byte IF Tidx% => Chunk% THEN ' if at end of data buf GET$ #FileNo%, Chunk%, Temp$ ' load more data to buf T_ptr = STRPTR32( Temp$ ) ' reset byte pointer Tidx% = 0 ' reset pointer index END IF ' Cidx? = @T_ptr[Tidx%] ' load next byte INCR Tidx% ' bump pointer index RETURN ' ' ShowBMPoops: 'local error trap BMPerror% = ERR ' set returning value RESUME ShowBMPexit ' ' 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$(0), = P$, TO Y% ' search for exising clr IF Y% > 0 THEN ' yep! found one DECR Y% ' drop back to 0 start ELSE ' nope, gotta new 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 '