Difference between revisions of "GIF Creation"

From QB64 Wiki
Jump to navigation Jump to search
imported>Clippy
m
m (Text replacement - "Qbasic" to "QBasic")
 
(One intermediate revision by one other user not shown)
Line 1: Line 1:
<center>'''GIF File Creator'''</center>
<center>'''GIF File Creator'''</center>
The following routine can be used with Qbasic or QB64 to create a Graphic Information File image of a program screen.   
The following routine can be used with QBasic or QB64 to create a Graphic Information File image of a program screen.   


* Accommodates [[_NEWIMAGE]] screen pages with up to 256 colors and image files loaded with [[_LOADIMAGE]].  
* Accommodates [[_NEWIMAGE]] screen pages with up to 256 colors and image files loaded with [[_LOADIMAGE]].  
Line 21: Line 21:
{{Cl|NEXT}}
{{Cl|NEXT}}


MakeGIF "GIFtemp.gif", 0, 0, {{Cl|_WIDTH (function)|_WIDTH}} - 1, {{Cl|_HEIGHT}} - 1, 256  'use 319 and 199 in Qbasic
MakeGIF "GIFtemp.gif", 0, 0, {{Cl|_WIDTH (function)|_WIDTH}} - 1, {{Cl|_HEIGHT}} - 1, 256  'use 319 and 199 in QBasic
'Use the include file in QB64 only! Hard code the SUB in Qbasic.
'Use the include file in QB64 only! Hard code the SUB in QBasic.
'{{Cl|$INCLUDE}}: 'GIFcreate.BM'  
'{{Cl|$INCLUDE}}: 'GIFcreate.BM'  


Line 263: Line 263:
''See also:''
''See also:''
* [[_LOADIMAGE]]
* [[_LOADIMAGE]]
* [[Bitmaps]], [[Icons and Cursors]], [[JPG Images]]
* [[Bitmaps]], [[Icons and Cursors]]




{{PageNavigation}}
{{PageNavigation}}

Latest revision as of 13:10, 10 February 2021

GIF File Creator

The following routine can be used with QBasic or QB64 to create a Graphic Information File image of a program screen.

  • Accommodates _NEWIMAGE screen pages with up to 256 colors and image files loaded with _LOADIMAGE.
  • The maximum screen coordinates are always one pixel LESS than the screen mode's resolution! (SCREEN 13's are 319 and 199)
  • The $INCLUDE text file can be created using Notepad and is REQUIRED when the program is compiled with QB64 ONLY!


'*********************************** DEMO CODE ********************************** 'Save code as a BAS file! Includes the GIFcreate.BI and BM text files. Demo by CodeGuy DEFINT A-Z SCREEN 13 RANDOMIZE TIMER 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 MakeGIF "GIFtemp.gif", 0, 0, _WIDTH - 1, _HEIGHT - 1, 256 'use 319 and 199 in QBasic 'Use the include file in QB64 only! Hard code the SUB in QBasic. '$INCLUDE: 'GIFcreate.BM' '************************************ END DEMO *********************************

GIFcreate.BM text $INCLUDE file:

'----------------------------------------------------------------------------- ' GIFcreate.BM Compression Routine v1.00 By Rich Geldreich 1992 ' Converted into one SUB Library routine by Ted Weissgerber 2011 '----------------------------------------------------------------------------- ' For 1 BPP, 4 BPP or 8 BPP images only! 'file$ = save image output filename 'XStart = <-left hand column of area to encode 'YStart = <-upper row of area to encode 'Xend = <-right hand column of area to encode 'Yend = <-lowest row of area to encode " 'NumColors = # of colors on screen: 2(Black & White), 16(SCREEN 12), 256(SCREEN13) ' SUB MakeGIF (file$, Xstart, YStart, Xend, Yend, NumColors) CONST True = -1, False = 0 CONST Table.size = 7177 'hash table's size - must be a prime number! DIM Prefix(Table.size - 1), Suffix(Table.size - 1), Code(Table.size - 1) DIM Shift(7) AS LONG FOR i = 0 TO 7: Shift(i) = 2 ^ i: NEXT 'create exponent array for speed. PWidth% = ABS(Xend - Xstart) + 1 PDepth% = ABS(Yend - Ystart) + 1 'MinX, MinY, MaxX, MaxY are maximum and minimum image coordinates IF Xstart > Xend THEN MaxX = Xstart: MinX = Xend ELSE MaxX = Xend: MinX = Xstart IF Ystart > Xend THEN MaxY = Ystart: MinY = Yend ELSE MaxY = Yend: MinY = Ystart 'Open GIF output file GIF = FREEFILE 'use next free file OPEN file$ FOR BINARY AS #GIF B$ = "GIF87a": PUT #GIF, , B$ 'Put GIF87a header at beginning of file SELECT CASE NumColors 'get color settings CASE 2 'monochrome (B&W) 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 SCREENS 7, 8, 9, 12, 13 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 SCREEN 13 or _NEWIMAGE 256 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 'ColorBits = 2 'for EGA ColorBits = 6 'VGA monitors ONLY PUT #GIF, , PWidth% 'put screen's dimensions PUT #GIF, , PDepth% CP = 128 + (ColorBits - 1) * 16 + (BitsPixel - 1) 'pack colorbits and bits per pixel PUT #GIF, , CP Zero$ = CHR$(0) 'PUT a zero into the GIF file PUT #GIF, , Zero$ OUT &H3C7, 0 'start read at color 0 FOR c = 0 TO NumColors - 1 'Get the RGB palette from the screen and put into file R = (INP(&H3C9) * 65280) \ 16128 'C = R * 4.0476190(for 0-255) G = (INP(&H3C9) * 65280) \ 16128 B = (INP(&H3C9) * 65280) \ 16128 red$ = CHR$(R): PUT #GIF, , red$ grn$ = CHR$(G): PUT #GIF, , grn$ blu$ = CHR$(B): PUT #GIF, , blu$ NEXT 'write out an image descriptor sep$ = "," 'image separator PUT #GIF, , sep$ 'write it PUT #GIF, , Minx 'image start locations PUT #GIF, , MinY PUT #GIF, , PWidth% 'store them into the file PUT #GIF, , PDepth% A$ = CHR$(BitsPixel - 1) '# bits per pixel in the image PUT #GIF, , A$ A$ = CHR$(StartSize - 1) 'store the LZW minimum code size PUT #GIF, , A$ CurrentBit = 0: Char& = 0 'Initialize the vars needed by PutCode 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 Buff& = SADD(OutBuffer$) 'find address of buffer Buff& = Buff& - 65536 * (Buff& < 0) Oseg = VARSEG(OutBuffer$) + (Buff& \ 16) 'get segment + offset >> 4 OAddress = Buff& 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 PC = ClearCode: GOSUB PutCode 'clear code x = Xstart: y = YStart 'X & Y have the current pixel GOSUB GetByte: Prefix = GB '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 PC = Prefix: GOSUB PutCode 'write last pixel PC = EOFCode: GOSUB PutCode 'send EOF code IF CurrentBit <> 0 THEN PC = 0: GOSUB PutCode 'flush out the last code... PB = 0: GOSUB PutByte OutBuffer$ = LEFT$(OutBuffer$, OAddress - OStartAddress) PUT #GIF, , OutBuffer$ A$ = ";" + STRING$(8, &H1A) 'the 8 EOF chars is not standard, PUT #GIF, , A$ A$ = CHR$(255 - BlockLength) 'correct the last block's count PUT #GIF, LastLoc&, A$ CLOSE #GIF: EXIT SUB '<<<<<<<<<<< End of procedure ELSE 'get a pixel from the screen and find the new string in table GOSUB GetByte: Suffix = GB GOSUB Hash 'is it in hash table? IF Found = True THEN Prefix = Code(Index) 'replace prefix:suffix string with code in table END IF LOOP WHILE Found 'don't stop unless we find a new string PC = Prefix: GOSUB PutCode '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 of code! Prefix = Suffix 'Prefix = the last pixel pulled from the screen NextCode = NextCode + 1 'get ready for the next code IF NextCode = MaxCode + 1 THEN 'increase the code size MaxCode = MaxCode * 2 'Note: The GIF89a spec mentions something about a deferred clear code IF CodeSize = 12 THEN 'is the code size too big? PC = ClearCode: GOSUB PutCode 'yup; clear the table and GOSUB ClearTree 'start over NextCode = StartCode CodeSize = StartSize MaxCode = StartMax ELSE CodeSize = CodeSize + 1 'increase code size if not too high (not > 12) END IF END IF LOOP 'while we have more pixels ' 'GOSUB ROUTINES 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 Hash: 'hash the prefix & suffix(there are also many ways to do this...) Index = ((Prefix * 256&) XOR Suffix) MOD Table.size ' Note: the table size(7177 in this case) must be a prime number ' Calculate an offset just in case we don't find what we want first try... IF Index = 0 THEN 'cannot have Table.Size 0! Offset = 1 ELSE Offset = Table.size - Index END IF DO 'loop until we find an empty entry or find what we're lookin for IF Code(Index) = -1 THEN 'is this entry blank? Found = False ' didn't find the string RETURN ELSEIF Prefix(Index) = Prefix AND Suffix(Index) = Suffix THEN Found = True 'found the string RETURN ELSE 'didn't find anything, must retry - this slows hashing down. Index = Index - Offset IF Index < 0 THEN 'too far down the table? wrap back the index to end of table Index = Index + Table.size END IF END IF LOOP PutByte: 'Puts a byte into the GIF file & also takes care of each block. BlockLength = BlockLength - 1 'are we at the end of a block? IF BlockLength <= 0 THEN 'end of block BlockLength = 255 'block length is now 255 LastLoc& = LOC(GIF) + 1 + (OAddress - OStartAddress) 'remember the position BW = 255: GOSUB BufferWrite 'for later fixing END IF BW = PB: GOSUB BufferWrite RETURN BufferWrite: 'Puts a byte into the buffer IF OAddress = OEndAddress THEN 'are we at the end of the buffer? PUT #GIF, , OutBuffer$ 'write it out and OAddress = OStartAddress 'start all over END IF POKE OAddress, BW 'put byte in buffer OAddress = OAddress + 1 'increment position RETURN GetByte: 'This routine gets one pixel from the display GB = POINT(x, y) 'get the "byte" x = x + 1 'increment X coordinate IF x > MaxX THEN 'are we too far? x = Minx 'go back to start y = y + 1 'increment Y coordinate IF y > MaxY THEN Done = True 'flag if too far down END IF RETURN PutCode: 'Puts an LZW variable-bit code into the output file... Char& = Char& + PC * 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? PB = Char& AND 255: GOSUB PutByte '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 'loop until we don't have a full byte RETURN END SUB


See also:



Navigation:
Keyword Reference - Alphabetical
Keyword Reference - By Usage
Main Wiki Page