03-02-2025, 12:12 PM
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.
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