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...
Here is a program for extracting 8-bit chunks from a 32-bit image
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
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