'=========================================================================== ' Subject: MAKE GIF FILE Date: Year of 1992 (00:00) ' Author: Rich Geldreich Code: QB, PDS ' Keys: MAKE,GIF,FILE Packet: GRAPHICS.ABC '=========================================================================== ' '----------------------------------------------------------------------------- ' PDS 7.1 & QB4.5 GIF Compression Routine v1.01 By Rich Geldreich 1992 '----------------------------------------------------------------------------- 'QuickBASIC 4.5 & QBASIC users: Use search and replace and change all of the '"SSEG" strings to "VARSEG" strings for this program to work properly. ' 'If anybody finds any problems with this routine, or has any questions, 'then write/call: 'Rich Geldreich '410 Market St. 'Gloucester City, NJ 08030 '(609)-742-8752 or (609)-456-0721 ' 'This routine is in the public domain... do what you want with it! Just 'give credit where credit is due! Thanks! ' 'NOTE: This version does not currently support EGA palettes. 'V1.01- fixed up VGA palette messups with some VGA's DEFINT A-Z DECLARE SUB BufferWrite (A%) DECLARE FUNCTION GetByte% () DECLARE SUB MakeGIF (A$, ScreenX%, ScreenY%, Xstart%, YStart%, Xend%, Yend%, NumColors%, AdaptorType%) DECLARE SUB PutByte (A%) DECLARE SUB PutCode (A%) CONST True = -1, False = 0 DIM SHARED OutBuffer$, OStartAddress, OAddress, OEndAddress, Oseg DIM SHARED CodeSize, CurrentBit, Char&, BlockLength DIM SHARED Shift(7) AS LONG DIM SHARED x, y, Minx, MinY, MaxX, MaxY, Done, GIFFile, LastLoc& ShiftTable: DATA 1,2,4,8,16,32,64,128 '-------------- Only for testing purposes: SCREEN 13 FOR A = 1 TO 40 x = RND * 320 y = RND * 200 c = RND * 256 CIRCLE (x, y), RND * 80, c PAINT (x, y), RND * 256, c NEXT FOR A = 1 TO 1000: LINE -(RND * 320, RND * 200), RND * 256: NEXT LINE (0, 0)-(0, 199), 14 MakeGIF "temp.gif", 320, 200, 0, 0, 319, 199, 256, 2 'Puts a byte into the disk buffer... when the disk buffer is full it is 'dumped to disk. SUB BufferWrite (A) STATIC IF OAddress = OEndAddress THEN 'are we at the end of the buffer? PUT GIFFile, , OutBuffer$ ' yup, write it out and OAddress = OStartAddress ' start all over END IF POKE OAddress, A 'put byte in buffer OAddress = OAddress + 1 'increment position END SUB 'This routine gets one pixel from the display. FUNCTION GetByte STATIC GetByte = POINT(x, y) 'get the "byte" x = x + 1 'increment X coordinate IF x > MaxX THEN 'are we too far? LINE (Minx, y)-(MaxX, y), 0 'a pacifier for impatient users x = Minx 'go back to start y = y + 1 'increment Y coordinate IF y > MaxY THEN 'are we too far down? Done = True ' yup, flag it then END IF END IF END FUNCTION ' '----------------------------------------------------------------------------- ' PDS 7.1 & QB4.5 GIF Compression Routine v1.00 By Rich Geldreich 1992 '----------------------------------------------------------------------------- ' 'A$ = output filename 'ScreenX = X resolution of screen(320, 640, etc.) 'ScreenY = Y resolution of screen(200, 350, 480, etc.) 'XStart = <-upper left hand corner of area to encode 'YStart = < " " 'Xend = <-lower right hand corner of area to encode 'Yend = < " " 'NumColors = # of colors on screen(2, 16, 256) 'AdaptorType = 1 for EGA 2 for VGA 'NOTE: EGA palettes are not supported in this version of MakeGIF. ' SUB MakeGIF (A$, ScreenX, ScreenY, Xstart, YStart, Xend, Yend, NumColors, AdaptorType) 'hash table's size - must be a prime number! CONST Table.Size = 7177 DIM Prefix(Table.Size - 1), Suffix(Table.Size - 1), Code(Table.Size - 1) 'The shift table contains the powers of 2 needed by the 'PutCode routine. This is done for speed. (much faster to 'look up an integer than to perform calculations...) RESTORE ShiftTable FOR A = 0 TO 7: READ Shift(A): NEXT 'MinX, MinY, MaxX, MaxY have the encoding window Minx = Xstart: MinY = YStart MaxX = Xend: MaxY = Yend 'Open GIF output file GIFFile = FREEFILE 'use next free file OPEN A$ FOR BINARY AS GIFFile 'Put GIF87a header at beginning of file B$ = "GIF87a" PUT GIFFile, , B$ 'See how many colors are in this image... SELECT CASE NumColors CASE 2 'monochrome image BitsPixel = 1 '1 bit per pixel StartSize = 3 'first LZW code is 3 bits StartCode = 4 'first free code StartMax = 8 'maximum code in 3 bits CASE 16 '16 colors images BitsPixel = 4 '4 bits per pixel StartSize = 5 'first LZW code is 5 bits StartCode = 16 'first free code StartMax = 32 'maximum code in 5 bits CASE 256 '256 color images BitsPixel = 8 '8 bits per pixel StartSize = 9 'first LZW code is 9 bits StartCode = 256 'first free code StartMax = 512 'maximum code in 9 bits END SELECT 'This following routine probably isn't needed- I've never 'had to use the "ColorBits" variable... With the EGA, you 'have 2 bits for Red, Green, & Blue. With VGA, you have 6 bits. SELECT CASE AdaptorType CASE 1 ColorBits = 2 'EGA CASE 2 ColorBits = 6 'VGA END SELECT PUT GIFFile, , ScreenX 'put screen's dimensions PUT GIFFile, , ScreenY 'pack colorbits and bits per pixel A = 128 + (ColorBits - 1) * 16 + (BitsPixel - 1) PUT GIFFile, , A 'throw a zero into the GIF file A$ = CHR$(0) PUT GIFFile, , A$ 'Get the RGB palette from the screen and put it into the file... SELECT CASE AdaptorType CASE 1 STOP 'EGA palette routine not implemented yet CASE 2 OUT &H3C7, 0 FOR A = 0 TO NumColors - 1 'Note: a BIOS call could be used here, but then we have to use 'the messy CALL INTERRUPT subs... R = (INP(&H3C9) * 65280) \ 16128 'C=R * 4.0476190(for 0-255) G = (INP(&H3C9) * 65280) \ 16128 B = (INP(&H3C9) * 65280) \ 16128 A$ = CHR$(R): PUT GIFFile, , A$ A$ = CHR$(G): PUT GIFFile, , A$ A$ = CHR$(B): PUT GIFFile, , A$ NEXT END SELECT 'write out an image descriptor... A$ = "," '"," is image seperator PUT GIFFile, , A$ 'write it PUT GIFFile, , Minx 'write out the image's location PUT GIFFile, , MinY ImageWidth = (MaxX - Minx + 1) 'find length & width of image ImageHeight = (MaxY - MinY + 1) PUT GIFFile, , ImageWidth 'store them into the file PUT GIFFile, , ImageHeight A$ = CHR$(BitsPixel - 1) '# bits per pixel in the image PUT GIFFile, , A$ A$ = CHR$(StartSize - 1) 'store the LZW minimum code size PUT GIFFile, , A$ 'Initialize the vars needed by PutCode CurrentBit = 0: Char& = 0 MaxCode = StartMax 'the current maximum code size CodeSize = StartSize 'the current code size ClearCode = StartCode 'ClearCode & EOF code are the EOFCode = StartCode + 1 ' first two entries StartCode = StartCode + 2 'first free code that can be used NextCode = StartCode 'the current code OutBuffer$ = STRING$(5000, 32) 'output buffer; for speedy disk writes A& = SADD(OutBuffer$) 'find address of buffer A& = A& - 65536 * (A& < 0) Oseg = VARSEG(OutBuffer$) + (A& \ 16) 'get segment + offset >> 4 OAddress = A& AND 15 'get address into segment OEndAddress = OAddress + 5000 'end of disk buffer OStartAddress = OAddress 'current location in disk buffer DEF SEG = Oseg GOSUB ClearTree 'clear the tree & output a PutCode ClearCode ' clear code x = Xstart: y = YStart 'X & Y have the current pixel Prefix = GetByte 'the first pixel is a special case Done = False 'True when image is complete DO 'while there are more pixels to encode DO 'until we have a new string to put into the table IF Done THEN 'write out the last pixel, clear the disk buffer 'and fix up the last block so its count is correct PutCode Prefix 'write last pixel PutCode EOFCode 'send EOF code IF CurrentBit <> 0 THEN PutCode 0 'flush out the last code... END IF PutByte 0 OutBuffer$ = LEFT$(OutBuffer$, OAddress - OStartAddress) PUT GIFFile, , OutBuffer$ A$ = ";" + STRING$(8, &H1A) 'the 8 EOF chars is not standard, 'but many GIF's have them, so how 'much could it hurt? PUT GIFFile, , A$ A$ = CHR$(255 - BlockLength) 'correct the last block's count PUT GIFFile, LastLoc&, A$ CLOSE GIFFile EXIT SUB ELSE 'get a pixel from the screen and see if we can find 'the new string in the table Suffix = GetByte GOSUB Hash 'is it there? IF Found = True THEN Prefix = Code(Index) 'yup, replace the 'prefix:suffix string with whatever 'code represents it in the table END IF LOOP WHILE Found 'don't stop unless we find a new string PutCode Prefix 'output the prefix to the file Prefix(Index) = Prefix 'put the new string in the table Suffix(Index) = Suffix Code(Index) = NextCode 'we've got to keep track if what code this is! Prefix = Suffix 'Prefix=the last pixel pulled from the screen NextCode = NextCode + 1 'get ready for the next code IF NextCode = MaxCode + 1 THEN 'can an output code ever exceed 'the current code size? 'yup, increase the code size MaxCode = MaxCode * 2 'Note: The GIF89a spec mentions something about a deferred clear 'code. When the clear code is deferred, codes are not entered 'into the hash table anymore. When the compression of the image 'starts to fall below a certain threshold, the clear code is 'sent and the hash table is cleared. The overall result is 'greater compression, because the table is cleared less often. 'This version of MakeGIF doesn't support this, because some GIF 'decoders crash when they attempt to enter too many codes 'into the string table. IF CodeSize = 12 THEN 'is the code size too big? PutCode ClearCode 'yup; clear the table and GOSUB ClearTree 'start over NextCode = StartCode CodeSize = StartSize MaxCode = StartMax ELSE CodeSize = CodeSize + 1 'just increase the code size if END IF 'it's not too high( not > 12) END IF LOOP 'while we have more pixels ClearTree: FOR A = 0 TO Table.Size - 1 'clears the hashing table Prefix(A) = -1 '-1 = invalid entry Suffix(A) = -1 Code(A) = -1 NEXT RETURN 'this is only one of a plethora of ways to search the table for 'a match! I used a binary tree first, but I switched to hashing 'cause it's quicker(perhaps the way I implemented the tree wasn't 'optimal... who knows!) Hash: 'hash the prefix & suffix(there are also many ways to do this...) '?? is there a better formula? Index = ((Prefix * 256&) XOR Suffix) MOD Table.Size ' '(Note: the table size(7177 in this case) must be a prime number, or 'else there's a chance that the routine will hang up... hate when 'that happens!) ' 'Calculate an offset just in case we don't find what we want on the 'first try... IF Index = 0 THEN 'can't have Table.Size-0 ! Offset = 1 ELSE Offset = Table.Size - Index END IF DO 'until we (1) find an empty entry or (2) find what we're lookin for IF Code(Index) = -1 THEN 'is this entry blank? Found = False 'yup- we didn't find the string RETURN 'is this entry the one we're looking for? ELSEIF Prefix(Index) = Prefix AND Suffix(Index) = Suffix THEN 'yup, congrats you now understand hashing!!! Found = True RETURN ELSE 'shoot! we didn't find anything interesting, so we must 'retry- this is what slows hashing down. I could of used 'a bigger table, that would of speeded things up a little 'because this retrying would not happen as often... Index = Index - Offset IF Index < 0 THEN 'too far down the table? 'wrap back the index to the end of the table Index = Index + Table.Size END IF END IF LOOP END SUB 'Puts a byte into the GIF file & also takes care of each block. SUB PutByte (A) STATIC BlockLength = BlockLength - 1 'are we at the end of a block? IF BlockLength <= 0 THEN ' yup, BlockLength = 255 'block length is now 255 LastLoc& = LOC(1) + 1 + (OAddress - OStartAddress) 'remember the pos. BufferWrite 255 'for later fixing END IF BufferWrite A 'put a byte into the buffer END SUB 'Puts an LZW variable-bit code into the output file... SUB PutCode (A) STATIC Char& = Char& + A * Shift(CurrentBit) 'put the char were it belongs; CurrentBit = CurrentBit + CodeSize ' shifting it to its proper place DO WHILE CurrentBit > 7 'do we have a least one full byte? PutByte Char& AND 255 ' yup! mask it off and write it out Char& = Char& \ 256 'shift the bit buffer right 8 bits CurrentBit = CurrentBit - 8 'now we have 8 less bits LOOP 'until we don't have a full byte END SUB