+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: Petr (https://qb64phoenix.com/forum/forumdisplay.php?fid=52)
+---- Thread: GIF89a File Format (/showthread.php?tid=3506)
GIF89a File Format - Petr - 03-02-2025
First thing I'll tell you about this. If @SMcNeill hadn't left the default program and his program for SaveGif in his thread, I would have ended up with an uncompressed version. Thank God Steve published his work with comments! That's the only reason I got further! It's possible that there will still be a bug in my program (which I can't find), but the comment in the SaveGif thread says: Some decoders will crash if you leave too many comments in the dictionary! And that was the main reason! This comment made this program work. Compression is really happening now, probably not as high as it could be, but the program works. Of course, this is the first version, more work will still be done on it, at least in the direction that the number of frames in the file will be calculated differently than according to fixed parameters (according to the size of the input field).
I'm publishing this version as it is because the next versions will be even more complicated and so I assume that people will be better oriented in this version.
This version is currently limited to 256 color images, GIF uses a global palette (in this version!) and therefore all images must have the same palette, otherwise they will be displayed painted in a different color. Of course, all input images must have the same width and height. In this version, the input parameters of the images are not monitored, so it will easily lead to a program crash if you do not respect these conditions.
I will continue to work on the program.
Code: (Select All)
'==============================================================================
' Animated GIF creation using _NEWIMAGE, palette extraction,
' and minimal LZW compression (each pixel => one code) or with compression,
' compression is set as default. For change see row 229, 230 (SUB AddGifFrame).
'==============================================================================
' --- Constants for GIF ---
Const GIF_HEADER$ = "GIF89a"
Const TRAILER = &H3B
Const INIT_CODE_SIZE = 8 ' => actually 9-bit codes
Const CLEAR_CODE = 256
Const END_CODE = 257
' --- Dimensions ---
Const MY_WIDTH = 320
Const MY_HEIGHT = 240
' --- Global arrays for palette and frames ---
Dim Shared globPal(0 To 255, 0 To 2) As Integer
Dim Shared frameA(0 To MY_WIDTH * MY_HEIGHT - 1) As Integer
Dim Shared frameB(0 To MY_WIDTH * MY_HEIGHT - 1) As Integer
Dim Shared frameC(0 To MY_WIDTH * MY_HEIGHT - 1) As Integer
'==============================================================================
' Main Program
'==============================================================================
Cls
Randomize Timer
' 1) Create three 256-color images
Dim img1 As Long, img2 As Long, img3 As Long
img1 = _NewImage(MY_WIDTH, MY_HEIGHT, 256)
img2 = _NewImage(MY_WIDTH, MY_HEIGHT, 256)
img3 = _NewImage(MY_WIDTH, MY_HEIGHT, 256)
' 2) Draw something in each image
Call DrawToImage(img1, 1)
Call DrawToImage(img2, 2)
Call DrawToImage(img3, 3)
' 3) Get the palette from img1 (it will be the same for the others if settings match)
Call GetPaletteFromImage(img1, globPal())
' 4) Copy pixel data from each image into an array
Call CopyImageToArray(img1, frameA(), MY_WIDTH, MY_HEIGHT)
Call CopyImageToArray(img2, frameB(), MY_WIDTH, MY_HEIGHT)
Call CopyImageToArray(img3, frameC(), MY_WIDTH, MY_HEIGHT)
' 5) Frame delay
Dim framePause As Integer
framePause = 100
' 6) Create animated GIF
Call SaveAnimatedGIF("animated.gif", MY_WIDTH, MY_HEIGHT, frameA(), frameB(), frameC(), globPal(), framePause)
Print "Animated GIF created to file 'animated.gif') "
_FreeImage img1
_FreeImage img2
_FreeImage img3
Sleep
End
'==============================================================================
' SUB DrawToImage – Draws something into a 256-color image
'==============================================================================
Sub DrawToImage (img As Long, num As Integer)
img = _NewImage(MY_WIDTH, MY_HEIGHT, 256)
d = _Dest
_Dest img
Cls
' ima = _LoadImage("6.jpg", 256) 'hard test for LZW (a week ago caused total program crash...)
Select Case num
Case 1
' Horizontal gradient
Dim x As Integer, y As Integer
For x = 0 To MY_WIDTH - 1
Dim c As Integer
c = (x * 256) \ MY_WIDTH
Line (x, 0)-(x, MY_HEIGHT - 1), c
Next x
' _PutImage , ima, img 'so now works!!!
Case 2
' Black background + circle + cross
Cls , 0
Dim centerX As Integer, centerY As Integer, rd As Integer
centerX = MY_WIDTH \ 2
centerY = MY_HEIGHT \ 2
rd = 80
Circle (centerX, centerY), rd, 200
Line (0, 0)-(MY_WIDTH - 1, MY_HEIGHT - 1), 150
Line (MY_WIDTH - 1, 0)-(0, MY_HEIGHT - 1), 220
' _PutImage , imb, img
Case 3
' White background + rectangle + "text"
Cls , 1
Dim x1 As Integer, x2 As Integer, y1 As Integer, y2 As Integer
x1 = 10: x2 = 70: y1 = 10: y2 = 70
' _PutImage , imc, img
Line (x1, y1)-(x2, y2), 15, B
Color 14, 1
_PrintString (18, 12), "QB64PE"
_PrintString (18, 28), "GIF89a"
_PrintString (18, 44), " Test"
End Select
_Dest d
End Sub
'==============================================================================
' SUB CopyImageToArray – Reads 8-bit pixel data from _MEMIMAGE into a one-dimensional array
'==============================================================================
Sub CopyImageToArray (img As Long, arr() As Integer, w As Integer, h As Integer)
Dim mem As _MEM
mem = _MemImage(img)
Dim x As Long, y As Long
Dim offset As Long
Dim idx As Long
Dim j As Long
j = 0
idx = 0
For y = 0 To h - 1
For x = 0 To w - 1
arr(idx) = _MemGet(mem, mem.OFFSET + j, _Unsigned _Byte)
offset = offset + 1
idx = idx + 1
j = j + 1
Next x
Next y
_MemFree mem
End Sub
'==============================================================================
' SUB GetPaletteFromImage – Retrieves the 256-color palette using _PaletteColor
'==============================================================================
Sub GetPaletteFromImage (img As Long, pal() As Integer)
Dim i As Integer
For i = 0 To 255
Dim col32 As _Unsigned Long
col32 = _PaletteColor(i, img)
' Format: AARRGGBB
Dim bVal As Integer
Dim gVal As Integer
Dim rVal As Integer
bVal = (col32 And &HFF)
gVal = _ShR(col32, 8) And &HFF
rVal = _ShR(col32, 16) And &HFF
pal(i, 0) = rVal
pal(i, 1) = gVal
pal(i, 2) = bVal
Next i
End Sub
'==============================================================================
' SUB SaveAnimatedGIF – Assembles an animated GIF and writes it to a file
'==============================================================================
Sub SaveAnimatedGIF (fileName$, width As Integer, height As Integer, frame1() As Integer, frame2() As Integer, frame3() As Integer, pal( ,) As Integer, pause As Integer)
Dim gifOut As String
gifOut$ = ""
' Header
gifOut$ = gifOut$ + GIF_HEADER$
' Logical Screen Descriptor
gifOut$ = gifOut$ + Chr$(width Mod 256) + Chr$(width \ 256)
gifOut$ = gifOut$ + Chr$(height Mod 256) + Chr$(height \ 256)
Dim packed As Integer
packed = 128 + (7 * 16) + 7
gifOut$ = gifOut$ + Chr$(packed)
gifOut$ = gifOut$ + Chr$(0) + Chr$(0)
' Global Color Table
Dim c As Integer
For c = 0 To 255
gifOut$ = gifOut$ + Chr$(pal(c, 0)) + Chr$(pal(c, 1)) + Chr$(pal(c, 2))
Next c
' Netscape Extension (loop)
gifOut$ = gifOut$ + Chr$(33) + Chr$(255) + Chr$(11)
gifOut$ = gifOut$ + "NETSCAPE2.0"
gifOut$ = gifOut$ + Chr$(3) + Chr$(1) + Chr$(0) + Chr$(0) + Chr$(0)
' Three frames
Call AddGIFFrame(gifOut$, frame1(), width, height, pause)
Call AddGIFFrame(gifOut$, frame2(), width, height, pause)
Call AddGIFFrame(gifOut$, frame3(), width, height, pause)
' Trailer
gifOut$ = gifOut$ + Chr$(TRAILER)
' Write file
Dim vysledek As String
vysledek$ = gifOut$
Open fileName$ For Binary As #1
Put #1, , vysledek$
Close #1
End Sub
'==============================================================================
' SUB AddGIFFrame – Adds one frame to the GIF string (using minimal LZW)
'==============================================================================
Sub AddGIFFrame (gifOut As String, pixels() As Integer, w As Integer, h As Integer, pause As Integer)
' Graphic Control Extension
gifOut$ = gifOut$ + Chr$(33) + Chr$(249) + Chr$(4)
' disposal=2 => 4 in the packed byte
gifOut$ = gifOut$ + Chr$(4)
gifOut$ = gifOut$ + Chr$(pause Mod 256) + Chr$(pause \ 256)
gifOut$ = gifOut$ + Chr$(0) + Chr$(0)
' Image Descriptor
gifOut$ = gifOut$ + Chr$(44)
gifOut$ = gifOut$ + Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0)
gifOut$ = gifOut$ + Chr$(w Mod 256) + Chr$(w \ 256)
gifOut$ = gifOut$ + Chr$(h Mod 256) + Chr$(h \ 256)
gifOut$ = gifOut$ + Chr$(0)
' LZW data: MinimalLZWCompress$ (each pixel => one code)
gifOut$ = gifOut$ + Chr$(INIT_CODE_SIZE)
Dim compStr As String
'compStr$ = MinimalLZWCompress$(pixels(), w * h) '1 052 463 bytes (640x480)
compStr$ = FullLZW$(pixels(), w * h) ' 300 643 bytes (640x480) 'program run correctly also with compression, BUT LIMIT FOR DICTIONARY MUST BE SET!!!!!
' ==========================================
' Debugging: ==========================================
' ff = FreeFile
' Open "compstr.dat" For Binary As ff
' Put ff, , compStr$
' Close ff
' Split into sub-blocks
Dim pIndex As Long, blockSize As Long
pIndex = 1
Dim compLen As Long
compLen = Len(compStr$)
Do
blockSize = MinNum&(255, compLen - pIndex + 1)
If blockSize <= 0 Then Exit Do
gifOut$ = gifOut$ + Chr$(blockSize) + Mid$(compStr$, pIndex, blockSize)
pIndex = pIndex + blockSize
Loop While pIndex <= compLen
' Sub-block terminator
gifOut$ = gifOut$ + Chr$(0)
End Sub
'==============================================================================
' FUNCTION MinNum& – Returns the smaller of two LONG values
'==============================================================================
Function MinNum& (a As Long, b As Long)
If a < b Then
MinNum& = a
Else
MinNum& = b
End If
End Function
Sub WriteCode (k As Integer)
Call WriteMinimalCodeGlobal(k, bitBuf, bitCnt, outStr$)
End Sub
'===================================================================================
' FUNCTION MinimalLZWCompress$ – "LZW" without a dictionary (each pixel => one code)
'===================================================================================
Function MinimalLZWCompress$ (pArr() As Integer, nLen As Long)
Dim outStr As String
outStr$ = ""
Dim bitBuf As Long
bitBuf = 0
Dim bitCnt As Integer
bitCnt = 0
' Send CLEAR code
Call WriteMinimalCodeGlobal(CLEAR_CODE, bitBuf, bitCnt, outStr$)
Dim cCount As Long
cCount = 0
Dim iPos As Long
For iPos = 0 To nLen - 1
Call WriteMinimalCodeGlobal(pArr(iPos), bitBuf, bitCnt, outStr$)
cCount = cCount + 1
' Every 100 codes => send CLEAR
If cCount >= 100 Then
Call WriteMinimalCodeGlobal(CLEAR_CODE, bitBuf, bitCnt, outStr$)
cCount = 0
End If
Next iPos
' Send END code
Call WriteMinimalCodeGlobal(END_CODE, bitBuf, bitCnt, outStr$)
' Flush
If bitCnt > 0 Then
outStr$ = outStr$ + Chr$(bitBuf And (_ShL(1, bitCnt) - 1))
End If
MinimalLZWCompress$ = outStr$
End Function
'==============================================================================
' SUB WriteMinimalCodeGlobal – Writes one code into bitBuf (fixed 9-bit)
'==============================================================================
Sub WriteMinimalCodeGlobal (k As Integer, bitBuf As Long, bitCnt As Integer, outStr As String)
Dim codeSize As Integer
codeSize = 9
bitBuf = bitBuf Or (k * _ShL(1, bitCnt))
bitCnt = bitCnt + codeSize
Do While bitCnt >= 8
outStr = outStr + Chr$(bitBuf And 255)
bitBuf = bitBuf \ 256
bitCnt = bitCnt - 8
Loop
End Sub
'------------------------------------------------------------------------------
' SUB WriteCodeGlobalDynamic
' Helper subroutine for writing a code with variable code size (codeSize).
' bitBuf and bitCnt maintain state and outStr is appended with bytes.
'------------------------------------------------------------------------------
Sub WriteCodeGlobalDynamic (k As Integer, codeSize As Integer, bitBuf As Long, bitCnt As Integer, outStr As String)
' Add code k to bitBuf at the position given by bitCnt
bitBuf = bitBuf Or (k * _ShL(1, bitCnt))
bitCnt = bitCnt + codeSize
' While there are at least 8 bits in bitBuf, extract one byte and append to outStr
Do While bitCnt >= 8
outStr = outStr + Chr$(bitBuf And 255)
bitBuf = bitBuf \ 256
bitCnt = bitCnt - 8
Loop
End Sub
'============================================================
' LZW compression for GIF89a – module extracted from the original code
' (only the LZW algorithm, without image or file handling)
'
' Input: pArr() - array of pixels (0-255), nLen - number of pixels
' Output: A string containing the bit-packed LZW codes
'
' Adapted from Rich Geldreich / QB4.5 routine and from
' SMcNeill SaveGif routine here:
' https://qb64phoenix.com/forum/showthread.php?tid=287
'============================================================
'============================================================
' Full LZW algorithm for GIF89a with additional dictionary reset
' after 240 new entries (CLEAR code) - otherwise it crash...
'
' Input: pArr() – array of pixels (0–255), nLen – number of pixels
' Output: A string containing the bit-packed LZW codes
'============================================================
Function FullLZW$ (pArr() As Integer, nLen As Long)
' Constants according to GIF specification
Const TABLE_SIZE = 7177 ' Size of the hash table (prime number)
Const CLEAR_CODE = 256 ' CLEAR code
Const EOF_CODE = 257 ' EOF code
Const INITIAL_CODE_SIZE = 9 ' Initial code size (in bits)
Const MAX_DICT_SIZE = 4096 ' 12-bit dictionary (0..4095)
Const RESET_THRESHOLD = 240 ' Number of new entries before dictionary reset
' Initialize code size
Dim CodeSize As Integer
CodeSize = INITIAL_CODE_SIZE
Dim MaxCodeForSize As Integer
MaxCodeForSize = (2 ^ CodeSize) - 1
' Dictionary – hash table for combinations
Dim DictPrefix(0 To TABLE_SIZE - 1) As Integer
Dim DictSuffix(0 To TABLE_SIZE - 1) As Integer
Dim DictCode(0 To TABLE_SIZE - 1) As Integer
Dim i As Long
For i = 0 To TABLE_SIZE - 1
DictPrefix(i) = -1
DictSuffix(i) = -1
DictCode(i) = -1
Next i
' Basic dictionary – codes 0 to 255 are defined
For i = 0 To 255
' In the dictionary store: no prefix defined, Suffix = pixel value,
' and code equals the value.
DictPrefix(i) = -1
DictSuffix(i) = i
DictCode(i) = i
Next i
' Next free code starts at 258 (256 = CLEAR, 257 = EOF)
Dim NextCode As Integer
NextCode = 258
Dim CurrentCodeSize As Integer
CurrentCodeSize = CodeSize ' dynamically increases up to 12
Dim CurrentMaxCode As Integer
CurrentMaxCode = (2 ^ CurrentCodeSize) - 1
' Variables for bit packing output
Dim bitBuf As Long, bitCnt As Integer
bitBuf = 0: bitCnt = 0
Dim outStr As String
outStr = ""
' Send CLEAR code – start compression
PutCode CLEAR_CODE, CurrentCodeSize, bitBuf, bitCnt, outStr
' Initialize prefix – first pixel as code
Dim w As Integer
w = pArr(0)
' Counter for new dictionary entries – when RESET_THRESHOLD is reached, reset dictionary
Dim dictCount As Integer
dictCount = 0
Dim poss As Long
For poss = 1 To nLen - 1
Dim k As Integer
k = pArr(poss)
Dim hashIndex As Long, foundFlag As Integer
foundFlag = HashLookup(w, k, TABLE_SIZE, DictPrefix(), DictSuffix(), DictCode(), NextCode, hashIndex)
If foundFlag = -1 Then
' Combination (w, k) found – set w to the corresponding code
w = DictCode(hashIndex)
Else
' Combination not found – write code for w and add new entry to dictionary
PutCode w, CurrentCodeSize, bitBuf, bitCnt, outStr
DictPrefix(hashIndex) = w
DictSuffix(hashIndex) = k
DictCode(hashIndex) = NextCode
NextCode = NextCode + 1
dictCount = dictCount + 1
' Increase code size if necessary
If NextCode > CurrentMaxCode And CurrentCodeSize < 12 Then
CurrentCodeSize = CurrentCodeSize + 1
CurrentMaxCode = (2 ^ CurrentCodeSize) - 1
End If
' If RESET_THRESHOLD new entries have been added, reset the dictionary
If dictCount >= RESET_THRESHOLD Then
PutCode CLEAR_CODE, CurrentCodeSize, bitBuf, bitCnt, outStr
' Clear the entire hash table
For i = 0 To TABLE_SIZE - 1
DictPrefix(i) = -1
DictSuffix(i) = -1
DictCode(i) = -1
Next i
' Reinitialize basic dictionary
For i = 0 To 255
DictPrefix(i) = -1
DictSuffix(i) = i
DictCode(i) = i
Next i
NextCode = 258
CurrentCodeSize = INITIAL_CODE_SIZE
CurrentMaxCode = (2 ^ CurrentCodeSize) - 1
dictCount = 0
End If
w = k
End If
Next poss
' Write out the last code and then the EOF code
PutCode w, CurrentCodeSize, bitBuf, bitCnt, outStr
PutCode EOF_CODE, CurrentCodeSize, bitBuf, bitCnt, outStr
' Flush – if any bits remain, append the last byte
If bitCnt > 0 Then
outStr = outStr + Chr$(bitBuf And ((2 ^ bitCnt) - 1))
End If
FullLZW$ = outStr
End Function
'------------------------------------------------------------------------------------------
' Function HashLookup
' Searches the hash table for the combination (prefix, suffix).
' Returns -1 if the combination is found (hashIndex indicates the found entry's position),
' or 1 if a free slot is found (hashIndex indicates the free position).
'------------------------------------------------------------------------------------------
Function HashLookup ( prefix As Integer, suffix As Integer, TableSize As Long, _
DictPrefix() As Integer, DictSuffix() As Integer, _
DictCode() As Integer, NextCode As Integer, _
hashIndex As Long)
Dim index As Long
index = ((prefix * 256) Xor suffix) Mod TableSize
Dim offset As Long
If index = 0 Then
offset = 1
Else
offset = TableSize - index
End If
Do
If DictCode(index) = -1 Then
hashIndex = index
HashLookup = 1
Exit Function
ElseIf DictPrefix(index) = prefix And DictSuffix(index) = suffix Then
hashIndex = index
HashLookup = -1
Exit Function
Else
index = index - offset
If index < 0 Then index = index + TableSize
End If
Loop
End Function
'-------------------------------------------------------------------------------------
' Sub PutCode
' Packs one code (k) into the bit buffer with the given code size (codeSize)
' and progressively "extracts" bytes into the output string outStr.
'-------------------------------------------------------------------------------------
Sub PutCode (k As Integer, codeSize As Integer, bitBuf As Long, bitCnt As Integer, outStr As String)
bitBuf = bitBuf Or (k * _ShL(1, bitCnt))
bitCnt = bitCnt + codeSize
Do While bitCnt >= 8
outStr = outStr + Chr$(bitBuf And 255)
bitBuf = bitBuf \ 256
bitCnt = bitCnt - 8
Loop
End Sub
RE: GIF89a File Format - SMcNeill - 03-02-2025
GIFs only ever have 256 color as a max.
https://short-fact.com/how-many-colours-can-a-gif-store/
If you need more than 256 colors, then you have to basically store the image in multiple gifs and then stitch them together, and that just gets way too messy. If you're going that route, just use a different image format and be done with it.
RE: GIF89a File Format - bplus - 03-02-2025
(03-02-2025, 12:12 PM)Petr Wrote: First thing I'll tell you about this. If @SMcNeill hadn't left the default program and his program for SaveGif in his thread, I would have ended up with an uncompressed version. Thank God Steve published his work with comments! That's the only reason I got further! It's possible that there will still be a bug in my program (which I can't find), but the comment in the SaveGif thread says: Some decoders will crash if you leave too many comments in the dictionary! And that was the main reason! This comment made this program work. Compression is really happening now, probably not as high as it could be, but the program works. Of course, this is the first version, more work will still be done on it, at least in the direction that the number of frames in the file will be calculated differently than according to fixed parameters (according to the size of the input field).
I'm publishing this version as it is because the next versions will be even more complicated and so I assume that people will be better oriented in this version.
This version is currently limited to 256 color images, GIF uses a global palette (in this version!) and therefore all images must have the same palette, otherwise they will be displayed painted in a different color. Of course, all input images must have the same width and height. In this version, the input parameters of the images are not monitored, so it will easily lead to a program crash if you do not respect these conditions.
I will continue to work on the program.
... {code}
Don't know WTH all this is about but:
+1 I encourage this! Animated GIF's Yeah!
RE: GIF89a File Format - a740g - 03-03-2025
Very nice!
Like Steve said, you can generate animated GIFs where each frame uses its own local palette. You can also optimize the GIF using subframe and use frame disposition code. That way you can have an animation with > 256 colors. The animation must be rendered to a 32-bit surface in these cases.
My GIFPlay library can load and show these animations.
RE: GIF89a File Format - Petr - 03-03-2025
Hello,
Here's another version. What's new:
1) Fixed a dictionary error. That was the error I wrote about yesterday. It wasn't actually a bug in the decoders. No. The error was in the program. If the dictionary was supposed to switch from 9-bit to 10-bit, then when the limit was reached it went to 11 and then to 12, BUT it was still running ALWAYS hard in 9 bits. Of course, the decoder, which was expecting a different data entry, then destroyed the animation. My fix yesterday actually only prevented the 9-bit limit from being exceeded. For this reason, compression is now running properly (and you can tell by the file sizes).
2) You now insert images in the form of an array, you don't have to list them in the parameters
3) Transparency support. Can be turned off or on
4) Transparent color. Just leave one index for the transparent color when composing the image and set it as transparent (this program will show you how it works)
5) Setting the image disposal mode. I'm not entirely sure if everything works as it should here, but two modes can be seen directly. One - the image remains and can be redrawn, the second - each image is deleted before the next one is drawn. Another option should be to display the previous image, but I haven't tried that
6) Variable timing can be set. Simply, each image can be displayed for a different length of time. The time is supplied to the program in the form of an array and is in hundredths of a second.
Attached are the broken pieces of the 32-bit image in PNG files. PNG supports transparency. So that you can assemble the animation (and see how I did it), I also attach the second source code. This is nothing like GIF89a, it's just a small thing that takes 255 colors from the 32-bit image, puts them in indexes 1 to 255 (index 0 is left for _RGBA32 (0,0,0,0) - transparent color) and then puts all the pixels in the 32-bit image that match the mask of the 8-bit image into the 8-bit image. The completed pixels are then marked as completed in the 32-bit image. The 8-bit image is then saved as a PNG file. The whole thing is repeated until all the pixels of the 32-bit image are used up.
So that's one way for now. I'm still thinking about how to do it better. It is certain that the maximum number of frames in a GIF file is 256 and this method uses a lot of them. Another option is high-quality dithering to 256 colors. This of course means a significant slowdown in the process of creating a GIF file.
Damn, this makes me want to work in a network (as LocalHost) to parallelize tasks...
The animated gif here shows what to expect if you create a GIF89a from the attached files. Yeah, this is my test image...
Code: (Select All)
'==============================================================================
' Animated GIF creation with multiple images and dynamic LZW compression (9-12 bits)
' using an array of image handles. SaveAnimatedGIF now accepts five new parameters:
' useGlobalPalette - 1 = use global palette, 0 = use local palette for each frame
' useTransparency - 1 = use transparency, 0 = no transparency
' transparencyIndex - index of the color to be used as transparent
' disposalMethod - disposal method for the frame (0–7) according to GIF spec
' And an additional parameter: an array of delays for individual frames.
'==============================================================================
'--- Constants ---
Const GIF_HEADER$ = "GIF89a"
Const TRAILER = &H3B
Const CLEAR_CODE = 256
Const END_CODE = 257
Const INIT_CODE_SIZE = 8 ' for writing the minimum LZW code size
'--- Image dimensions ---
Const MY_WIDTH = 320
Const MY_HEIGHT = 240
'--- SaveAnimatedGIF parameters ---
Const TRANSPARENCY = 1
Const NOT_TRANSPARENCY = 0
Const OVERWRITE = 1
Const STAY = 2
Const GLOBAL_PALETTE = 1
Const LOCAL_PALETTE = 0
'--- Global variables ---
Dim Shared videoFrames(0 To 98) As Long
'==============================================================================
' Main Program
'==============================================================================
Cls
Randomize Timer
For f = 0 To 98
num$ = Str$(f)
filename$ = "Video" + String$(8 - Len(num$), "0") + LTrim$(num$) + ".png"
videoFrames(f) = _NewImage(MY_WIDTH, MY_HEIGHT, 256)
Print "Loading "; filename$; " ";
k& = _LoadImage(filename$, 256)
Print k&
_PutImage , k&, videoFrames(f)
_FreeImage k&
_Delay .01
Next
Print "Frames loaded. Now building GIF89a..."
Print "Be patient if you have set the resolution too high."
' Array of delays for individual frames (in hundredths of a second)
Dim frameDelays(0 To 98) As Integer
For f = 0 To 97
frameDelays(f) = 1
Next f
frameDelays(98) = 150
' Create animated GIF with new parameters:
' Use global palette: 1, Use transparency: 1, Transparent index: 0, disposal method: 2,
' and an array of delays for each frame.
Call SaveAnimatedGIF("animated2.gif", MY_WIDTH, MY_HEIGHT, videoFrames(), GLOBAL_PALETTE, TRANSPARENCY, 0, STAY, frameDelays()) 'try set other color index than 0, create gif and look what occur...
Print "File created. - saved as 'animated2.gif'"
Sleep
'==============================================================================
' Subprograms and Functions
'==============================================================================
'---------------------------------------------------------------------
' SUB CopyImageToArray Reads 8-bit pixel data from _MemImage into a one-dimensional array
'---------------------------------------------------------------------
Sub CopyImageToArray (img As Long, arr() As Integer, w As Integer, h As Integer)
Dim mem As _MEM
mem = _MemImage(img)
Dim x As Long, y As Long, idx As Long, j As Long
idx = 0
For y = 0 To h - 1
For x = 0 To w - 1
arr(idx) = _MemGet(mem, mem.OFFSET + j, _Unsigned _Byte) ' PITCH = 1 for 8-bit images
idx = idx + 1
j = j + 1
Next x
Next y
_MemFree mem
End Sub
'---------------------------------------------------------------------
' SUB GetPaletteFromImage Retrieves a 256-color palette using _PaletteColor
'---------------------------------------------------------------------
Sub GetPaletteFromImage (img As Long, pal( ,) As Integer)
Dim i As Integer
For i = 0 To 255
Dim col32 As _Unsigned Long
col32 = _PaletteColor(i, img)
Dim rVal As Integer, gVal As Integer, bVal As Integer
bVal = (col32 And &HFF)
gVal = _ShR(col32, 8) And &HFF
rVal = _ShR(col32, 16) And &HFF
pal(i, 0) = rVal
pal(i, 1) = gVal
pal(i, 2) = bVal
Next i
End Sub
'---------------------------------------------------------------------
' SUB SaveAnimatedGIF Assembles an animated GIF and writes it to a file.
' In this version, it obtains its own palette based on the value of useGlobalPalette,
' and it accepts an array of delays for each frame.
'---------------------------------------------------------------------
Sub SaveAnimatedGIF (fileName$, width As Integer, height As Integer, imgs() As Long, useGlobalPalette As Integer, useTransparency As Integer, transparencyIndex As Integer, disposalMethod As Integer, delays() As Integer)
Dim gifOut As String
gifOut$ = ""
Dim pal(0 To 255, 0 To 2) As Integer
If useGlobalPalette <> 0 Then
Call GetPaletteFromImage(imgs(0), pal())
Else
Dim i As Integer
For i = 0 To 255
pal(i, 0) = 0: pal(i, 1) = 0: pal(i, 2) = 0
Next i
End If
' GIF Header
gifOut$ = gifOut$ + GIF_HEADER$
' Logical Screen Descriptor
gifOut$ = gifOut$ + Chr$(width Mod 256) + Chr$(width \ 256)
gifOut$ = gifOut$ + Chr$(height Mod 256) + Chr$(height \ 256)
Dim packed As Integer
If useGlobalPalette <> 0 Then
packed = 128 + (7 * 16) + 7 ' global palette present
Else
packed = (7 * 16) + 7 ' no global palette
End If
gifOut$ = gifOut$ + Chr$(packed)
gifOut$ = gifOut$ + Chr$(0) + Chr$(0)
' Global Color Table (written only if global palette is used)
If useGlobalPalette <> 0 Then
Dim c As Integer
For c = 0 To 255
gifOut$ = gifOut$ + Chr$(pal(c, 0)) + Chr$(pal(c, 1)) + Chr$(pal(c, 2))
Next c
End If
' Netscape Extension (loop)
gifOut$ = gifOut$ + Chr$(33) + Chr$(255) + Chr$(11)
gifOut$ = gifOut$ + "NETSCAPE2.0"
gifOut$ = gifOut$ + Chr$(3) + Chr$(1) + Chr$(0) + Chr$(0) + Chr$(0)
' Process each frame, using the corresponding delay from the delays array
For i = LBound(imgs) To UBound(imgs)
Dim framePixels As Integer
ReDim framePixels(0 To width * height - 1) As Integer
Call CopyImageToArray(imgs(i), framePixels(), width, height)
Dim handleForPalette As Long
If useGlobalPalette <> 0 Then
handleForPalette = 0
Else
handleForPalette = imgs(i)
End If
Call AddGIFFrame(gifOut$, framePixels(), width, height, delays(i), useGlobalPalette, useTransparency, transparencyIndex, disposalMethod, handleForPalette)
Next i
' Trailer
gifOut$ = gifOut$ + Chr$(TRAILER)
' Write to file
Dim vysledek As String
vysledek$ = gifOut$
Open fileName$ For Binary As #1
Put #1, , vysledek$
Close #1
End Sub
'---------------------------------------------------------------------
' SUB AddGIFFrame Adds one frame to the GIF stream.
' If local palette is used, it writes the local palette after the image descriptor.
' The parameters useTransparency, transparencyIndex and disposalMethod are
' written into the Graphic Control Extension.
' delay is the delay for this frame.
'---------------------------------------------------------------------
Sub AddGIFFrame (gifOut As String, pixels() As Integer, w As Integer, h As Integer, delay As Integer, useGlobalPalette As Integer, useTransparency As Integer, transparencyIndex As Integer, disposalMethod As Integer, imgHandle As Long)
' Graphic Control Extension
gifOut$ = gifOut$ + Chr$(33) + Chr$(249) + Chr$(4)
Dim gcePacked As Integer
gcePacked = (disposalMethod And 7) * 16
If useTransparency <> 0 Then
gcePacked = gcePacked Or 1
End If
gifOut$ = gifOut$ + Chr$(gcePacked)
gifOut$ = gifOut$ + Chr$(delay Mod 256) + Chr$(delay \ 256)
gifOut$ = gifOut$ + Chr$(transparencyIndex) + Chr$(0)
' Image Descriptor
gifOut$ = gifOut$ + Chr$(44)
gifOut$ = gifOut$ + Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0)
gifOut$ = gifOut$ + Chr$(w Mod 256) + Chr$(w \ 256)
gifOut$ = gifOut$ + Chr$(h Mod 256) + Chr$(h \ 256)
Dim localFlag As Integer
If useGlobalPalette = 0 Then
localFlag = 128 Or 7
Else
localFlag = 0
End If
gifOut$ = gifOut$ + Chr$(localFlag)
' If local palette is used, obtain and write it immediately after the image descriptor
If useGlobalPalette = 0 Then
Dim localPal(0 To 255, 0 To 2) As Integer
Call GetPaletteFromImage(imgHandle, localPal())
Dim i As Integer
For i = 0 To 255
gifOut$ = gifOut$ + Chr$(localPal(i, 0)) + Chr$(localPal(i, 1)) + Chr$(localPal(i, 2))
Next i
End If
' LZW data: Write INIT_CODE_SIZE and the compressed data
gifOut$ = gifOut$ + Chr$(INIT_CODE_SIZE)
Dim compStr As String
compStr$ = BasicLZWCompress$(pixels(), w * h)
Dim pIndex As Long, blockSize As Long
pIndex = 1
Dim compLen As Long
compLen = Len(compStr$)
Do
blockSize = MinNum&(255, compLen - pIndex + 1)
If blockSize <= 0 Then Exit Do
gifOut$ = gifOut$ + Chr$(blockSize) + Mid$(compStr$, pIndex, blockSize)
pIndex = pIndex + blockSize
Loop While pIndex <= compLen
gifOut$ = gifOut$ + Chr$(0)
End Sub
'---------------------------------------------------------------------
' FUNCTION MinNum& Returns the smaller of two values (Long)
'---------------------------------------------------------------------
Function MinNum& (a As Long, b As Long)
If a < b Then
MinNum& = a
Else
MinNum& = b
End If
End Function
'---------------------------------------------------------------------
' FUNCTION BasicLZWCompress$ LZW compression with dynamic code size expansion
' (from 9 to 12 bits, sending CLEAR reset when 4096 entries are reached)
'---------------------------------------------------------------------
Function BasicLZWCompress$ (pArr() As Integer, nLen As Long)
Dim outStr As String
outStr$ = ""
Dim bitBuf As Long
bitBuf = 0
Dim bitCnt As Integer
bitCnt = 0
Dim dict(0 To 4095) As String
Dim i As Integer
For i = 0 To 255
dict(i) = Chr$(i)
Next i
Dim nextCode As Integer
nextCode = 258
Dim currCodeSize As Integer
currCodeSize = 9
Dim maxCode As Long
maxCode = _ShL(1, currCodeSize) ' 2^9 = 512
Call WriteMinimalCodeGlobal(CLEAR_CODE, currCodeSize, bitBuf, bitCnt, outStr$)
Dim w As String
If nLen <= 0 Then
Call WriteMinimalCodeGlobal(END_CODE, currCodeSize, bitBuf, bitCnt, outStr$)
GoTo FlushBits
End If
w$ = Chr$(pArr(0))
Dim poss As Long
For poss = 1 To nLen - 1
Dim k As String
k$ = Chr$(pArr(poss))
Dim testStr As String
testStr$ = w$ + k$
Dim foundCode As Integer
foundCode = -1
Dim j As Integer
For j = 0 To nextCode - 1
If dict(j) = testStr$ Then
foundCode = j
Exit For
End If
Next j
If foundCode <> -1 Then
w$ = testStr$
Else
Dim codeW As Integer
codeW = -1
For j = 0 To nextCode - 1
If dict(j) = w$ Then
codeW = j
Exit For
End If
Next j
If codeW <> -1 Then
Call WriteMinimalCodeGlobal(codeW, currCodeSize, bitBuf, bitCnt, outStr$)
End If
If nextCode < maxCode Then
dict(nextCode) = testStr$
nextCode = nextCode + 1
Else
If currCodeSize < 12 Then
currCodeSize = currCodeSize + 1
maxCode = _ShL(1, currCodeSize)
dict(nextCode) = testStr$
nextCode = nextCode + 1
Else
Call WriteMinimalCodeGlobal(CLEAR_CODE, currCodeSize, bitBuf, bitCnt, outStr$)
Dim r As Integer
For r = 0 To 255
dict(r) = Chr$(r)
Next r
nextCode = 258
currCodeSize = 9
maxCode = _ShL(1, currCodeSize)
End If
End If
w$ = k$
End If
Next poss
If w$ <> "" Then
Dim codeLast As Integer
codeLast = -1
Dim j2 As Integer
For j2 = 0 To nextCode - 1
If dict(j2) = w$ Then
codeLast = j2
Exit For
End If
Next j2
If codeLast <> -1 Then
Call WriteMinimalCodeGlobal(codeLast, currCodeSize, bitBuf, bitCnt, outStr$)
End If
End If
Call WriteMinimalCodeGlobal(END_CODE, currCodeSize, bitBuf, bitCnt, outStr$)
FlushBits:
If bitCnt > 0 Then
outStr$ = outStr$ + Chr$(bitBuf And (_ShL(1, bitCnt) - 1))
End If
BasicLZWCompress$ = outStr$
End Function
'---------------------------------------------------------------------
' SUB WriteMinimalCodeGlobal Writes one code with variable length (codeSize bits)
'---------------------------------------------------------------------
Sub WriteMinimalCodeGlobal (k As Integer, codeSize As Integer, bitBuf As Long, bitCnt As Integer, outStr As String)
bitBuf = bitBuf Or (k * _ShL(1, bitCnt))
bitCnt = bitCnt + codeSize
Do While bitCnt >= 8
outStr = outStr + Chr$(bitBuf And 255)
bitBuf = bitBuf \ 256
bitCnt = bitCnt - 8
Loop
End Sub
Here is a program for extracting 8-bit chunks from a 32-bit image
Code: (Select All)
'rem program for converting a 32-bit image into a series of 256-color images
'In order not to unnecessarily increase the GIF size, I propose the following:
'1) Load a 32-bit image
'2) Retrieve 255 (colors 1 to 255) different colors
'3) Traverse the entire image and, wherever colors 1 to 255 are found, mark those pixels in an array with the index number of the mask of that frame (1 to 255)
'4) Save that frame along with its mask (set the palette and save the selected points) ---> resulting in an 8-bit image
'5) In the original image, mark all points that were saved in the frame as 0 (i.e. transparent) (this is color 0 of all masks)
'6) Continue from step 2 to the end of the image
'What to add: A function that returns, in an array, up to 255 colors in _unsigned long format from the 32-bit image
img32a = _LoadImage("6.jpg", 32)
img32 = _NewImage(320, 240, 32)
_PutImage , img32a, img32
_FreeImage img32a
W = _Width(img32)
H = _Height(img32)
my = _NewImage(W, H, 32)
Screen my
Dim Shared Image32(W * H - 1) As _Unsigned Long 'array containing the unsigned long pixel colors of the image
Dim Shared Image8(W * H - 1) As _Unsigned _Byte 'temporary array for creating the 8-bit image
Dim Shared MaskColors(255) As _Unsigned Long 'array containing UP TO 255 colors of the 32-bit image, index 0 is reserved for the transparent color
Dim Shared TotalPixels As Long
Dim Shared Pixelu
Dim As _MEM m32, m8
m32 = _MemImage(img32)
m8 = _Mem(Image32())
_MemCopy m32, m32.OFFSET, m32.SIZE To m8, m8.OFFSET
_MemFree m8
ReDim Images8(0) As Long
Dim clr As _Unsigned Long
Dim As _MEM m3, m4
Dim As Long m3s, sze
m4 = _MemImage(my)
Do Until TotalPixels = W * H - 1
Get255Colors Image32()
Images8(j) = Create8BitPart&(Image32(), W, H)
m3 = _MemImage(Images8(j))
m3s = 0
Do Until m3s = m3.SIZE
Pixel8 = _MemGet(m3, m3.OFFSET + m3s, _Unsigned _Byte)
If Pixel8 > 0 Then
clr = _PaletteColor(Pixel8, Images8(j))
_MemPut m4, m4.OFFSET + m3s * 4, clr As _UNSIGNED LONG
End If
m3s = m3s + 1
Loop
_MemFree m3
j = j + 1
ReDim _Preserve Images8(j) As Long
Locate 1
Print "Done: "; Int(TotalPixels / (W * H) * 100); "%"
Print "8 bit images created: "; j
Loop
For f = 0 To j - 1
num$ = Str$(f)
filename$ = "Video" + String$(8 - Len(num$), "0") + LTrim$(num$) + ".png"
If _FileExists(filename$) Then Kill filename$
_SaveImage filename$, Images8(f)
Next
Do
Cls
For f = 0 To j - 1
_ClearColor 0, Images8(f)
_PutImage (0, 0), Images8(f)
_Limit 220
Next
Cls
For f = j - 1 To 0 Step -1
_ClearColor 0, Images8(f)
_PutImage (0, 0), Images8(f)
_Limit 220
Next
Loop
Sub Get255Colors (Image() As _Unsigned Long) 'retrieve up to 255 colors (or fewer) from the image
Do Until m = UBound(Image) Or ClrCount = 255
If Image(m) > 0 Then
ClrCount = ClrCount + 1
MaskColors(ClrCount) = Image(m)
' Print Image(m);
End If
m = m + 1
Loop
End Sub
Function Create8BitPart& (image() As _Unsigned Long, Width, Height) 'creates a partial image based on the pixel colors
'determine the number of colors in the mask
m = 255
Do Until MaskColors(m) > 0
m = m - 1
Loop
Pixelu = 0
Dim mask As _Unsigned Long
n = 1
minO = 0
First = 1
Do Until n = m 'from 0 to 255
mask = MaskColors(n)
'ms = 0
Do Until image(ms) <> _RGBA32(0, 0, 0, 0) Or ms > UBound(image) - 20000
ms = ms + 1
Loop
o = ms
' Locate 6: Print ms
Do Until o = UBound(image)
If image(o) = mask Then
image(o) = _RGBA32(0, 0, 0, 0) 'set the 32-bit image array value to 0 - this pixel has already been processed
Image8(o) = n 'set the value in the 8-bit image array to the mask index
'Print Image8(o), image(o), mask
TotalPixels = TotalPixels + 1
Pixelu = Pixelu + 1
End If
'If image(o) = _RGBA32(0, 0, 0, 0) Then Image8(o) = 0
o = o + 1
Loop
n = n + 1
Loop
'MaskColors(0) = _RGBA32(0, 0, 0, 0)
img8 = _NewImage(Width, Height, 256)
Dim As _MEM c, d
c = _Mem(Image8())
d = _MemImage(img8)
_MemCopy c, c.OFFSET, c.SIZE To d, d.OFFSET
_MemFill c, c.OFFSET, c.SIZE, 0 As _UNSIGNED _BYTE
For m = 0 To 255
_PaletteColor m, MaskColors(m), img8
Next m
Print "Found pixels "; Pixelu; "to 1 run"
_MemFree c
_MemFree d
Create8BitPart& = _CopyImage(img8, 256)
_FreeImage img8
End Function
I won't post the resulting image here because the internet browser renders it differently than the windows photo viewer. In it the gif shows as intended, but in the browser it draws incorrectly. More research!
Repaired in source code - CONST STAY set to 2, CONST OVERWRITE set to 1
RE: GIF89a File Format - Petr - 03-03-2025
Thanks for the link @a740g. Have you considered releasing GifPlayer as a standalone feature? Because for example, you don't need the inform environment for games, just the animation. And thank you again. @Dav posted the FLI player in your thread, awesome stuff! Both are awesome!
RE: GIF89a File Format - a740g - 03-04-2025
(03-03-2025, 06:31 PM)Petr Wrote: Thanks for the link @a740g. Have you considered releasing GifPlayer as a standalone feature? Because for example, you don't need the inform environment for games, just the animation. And thank you again. @Dav posted the FLI player in your thread, awesome stuff! Both are awesome!
You can use it as a standalone library. I designed it to work both independently and with InForm-PE. I included a standalone example here. Doc is here. Dav's FLI/FLC code is neat. I actually want to use bits of it to make some kind of animation library. Eventually, I want something that can use GIF, FLI, FLC, ANI, LBM/ANIM, Aseprite formats using a unified API.
Big plans... little time.