mirror of
https://github.com/QB64Official/qb64.git
synced 2024-08-22 11:25:08 +00:00
272 lines
11 KiB
Markdown
272 lines
11 KiB
Markdown
**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](_NEWIMAGE) screen pages with up to 256 colors and image files loaded with [_LOADIMAGE](_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]($INCLUDE) text file can be created using Notepad and is REQUIRED when the program is compiled with QB64 ONLY!
|
|
|
|
```vb
|
|
|
|
'*********************************** 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]($INCLUDE) file:*
|
|
|
|
```vb
|
|
|
|
'-----------------------------------------------------------------------------
|
|
' 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
|
|
|
|
* [_LOADIMAGE](_LOADIMAGE)
|
|
* [Bitmaps](Bitmaps), [Icons and Cursors](Icons-and-Cursors)
|