GIF89a File Format

[Petr]

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

[SMcNeill]

GIFs only ever have 256 color as a max.

https://short-fact.com/how-many-colours-...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. 

[bplus]

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!

[a740g]

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.

[Petr]

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

[Petr]

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!

[a740g]

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.