This code focuses on converting images to the GIF format and saving them, with multiple frames for animation and transparency both supported. I think it makes a good pairing with Localmotion34's decoding code and a GUI built around both should make for a complete GIF manipulation tool. Hence the name GIF Workshop.
For now there is no support for lists of images of differing sizes. They must all be the same.
Special thanks goes to these kind folks:
Luis - providing a crackerjack PB port for NeuQuant
Idle - providing code for byte packing
Wilbert - providing faster yet code for byte packing
Without their help this project would not be what it is at all.
How to use:
1) Place one or some images in a folder and run the program.
2) Select the folder with your images
3) Select an output path
4) That's it, when the program says it's finished, surf over to your created file and open it in a browser.
Here's the zip for testing (and making great suggestions): http://lloydsplace.com/GIF%20Workshop.zip
Thanks!
btw, the supplied sample is Fred walking to the mailbox, picking up the PureBasic registrations
February 1, 2017: Modified the code to use the NeuQuant port from Wilbert, which is much faster.
Also posting the code on the forum so it won't be lost again.
Code: Select all
;/////////////////////////////////////////////////////////////////////////////////////
;
; Project: GIF WORKSHOP
;
; Author: Lloyd Gallant (netmaestro)
;
; Collaborators: Idle, Wilbert (optimize encoder for speed, PureBasic port of NeuQuant)
;
; Version: Alpha 1.0
;
; Compiler version: PureBasic 5.50, 5.60b1
;
; Target platform: Microsoft Windows all, Linux, MacOS
;
; Date: November 17, 2013
; February 1, 2017
;
; License: Free to use or modify with one condition:
; The Author stamp must appear in all written
; GIF files. Removal of this information renders
; your license agreement void.
;
; No warranty expressed or implied.
;
;/////////////////////////////////////////////////////////////////////////////////////
; // TODO: Build a GUI around it to facilitate selection of files and options
DeclareModule NeuQuant; v1.0.3
;/* NeuQuant Neural-Net Quantization Algorithm
; * Copyright (c) 1994 Anthony Dekker
; *
; * NEUQUANT Neural-Net quantization algorithm by Anthony Dekker, 1994.
; * See "Kohonen neural networks for optimal colour quantization"
; * in "Network: Computation in Neural Systems" Vol. 5 (1994) pp 351-367.
; * for a discussion of the algorithm.
; * See also http://members.ozemail.com.au/~dekker/NEUQUANT.HTML
; *
; * Any party obtaining a copy of these files from the author, directly or
; * indirectly, is granted, free of charge, a full and unrestricted irrevocable,
; * world-wide, paid up, royalty-free, nonexclusive right and license to deal
; * in this software and documentation files (the "Software"), including without
; * limitation the rights to use, copy, modify, merge, publish, distribute, sublicense,
; * and/or sell copies of the Software, and to permit persons who receive
; * copies from any such party to do so, with the only requirement being
; * that this copyright notice remain intact.
; */
; Ported to PureBasic ASM by Wilbert (SSE2 required)
Declare InitNet()
Declare UnbiasNet(*palette)
Declare.i InxBuild(reserveTransparent = #False)
Declare.i InxSearch(rgb.l)
Declare Learn(image.i, sample = 10)
; helper procedures not part of actual NeuQuant
Declare InxBuildFromPalette(Array palette(1))
Declare.l PointOrdDith(x, y)
EndDeclareModule
Module NeuQuant
CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
; 64 bit Macros
#x64 = #True
Macro LoadPtrNQ
!mov rdx, [neuquant.p_NQ]
EndMacro
Macro LoadXMM(xmm_reg)
!movdqa xmm_reg, [rdx]
EndMacro
Macro SaveXMM(xmm_reg)
!movdqa [rdx], xmm_reg
EndMacro
Macro SaveDWord(dwrd)
!mov dword [rdx], dwrd
EndMacro
CompilerElse
; 32 bit Macros
#x64 = #False
Macro LoadPtrNQ
!mov edx, [neuquant.p_NQ]
EndMacro
Macro LoadXMM(xmm_reg)
!movdqa xmm_reg, [edx]
EndMacro
Macro SaveXMM(xmm_reg)
!movdqa [edx], xmm_reg
EndMacro
Macro SaveDWord(dwrd)
!mov dword [edx], dwrd
EndMacro
CompilerEndIf
Structure Pixel
StructureUnion
w.w[8]
l.l[4]
q.q[2]
EndStructureUnion
EndStructure
Structure NQ
network.Pixel[256] ; offset 0
freq.l[256] ; offset 4096
bias.l[256] ; offset 5120
netindex.l[256] ; offset 6144
radpower.l[32] ; offset 7168
EndStructure
Global *NQ_ = AllocateMemory(SizeOf(NQ) + 65536, #PB_Memory_NoClear)
Global *NQ.NQ = *NQ_ & -65536 + 65536
Procedure InitNet()
LoadPtrNQ
!xor ecx, ecx ; ecx = index
!neuquant.l_initnet0: ; init network values
!movd xmm0, ecx
!pslld xmm0, 4
!pshufd xmm0, xmm0, 0xc0
SaveXMM(xmm0)
!add dx, 16
!inc cl
!jnz neuquant.l_initnet0
!neuquant.l_initnet1: ; init freq values
SaveDWord(256)
!add dx, 4
!inc cl
!jnz neuquant.l_initnet1
!neuquant.l_initnet2: ; init bias values
SaveDWord(0)
!add dx, 4
!inc cl
!jnz neuquant.l_initnet2
EndProcedure
Procedure UnbiasNet(*palette)
; Modified version of UnbiasNet.
; Outputs 8 words idx-0-g-0-0-b-g-r
; Modification made to make search faster
LoadPtrNQ
!pcmpeqd xmm1, xmm1
!psrld xmm1, 31
!pslld xmm1, 3
!pcmpeqd xmm2, xmm2
!psrlw xmm2, 8
!psrlq xmm2, 16
!pshufhw xmm2, xmm2, 0xf7
!pcmpeqd xmm3, xmm3
!pslld xmm3, 24
CompilerIf #x64
!mov rax, [p.p_palette]
CompilerElse
!mov eax, [p.p_palette]
CompilerEndIf
!xor ecx, ecx ; ecx = index
!neuquant.l_unbiasnet0:
LoadXMM(xmm0)
!paddd xmm0, xmm1
!psrld xmm0, 4
!packssdw xmm0, xmm0
!pminsw xmm0, xmm2 ; limit to 255 max
!pinsrw xmm0, ecx, 7 ; insert index
SaveXMM(xmm0)
!packuswb xmm0, xmm0 ; output palette value
!por xmm0, xmm3
CompilerIf #x64
!movd [rax], xmm0
!add rax, 4
CompilerElse
!movd [eax], xmm0
!add eax, 4
CompilerEndIf
!add dx, 16
!inc cl
!jnz neuquant.l_unbiasnet0
EndProcedure
Macro AlterNeighASM
!shl dx, 2
CompilerIf #x64
!movd xmm2, [rdx + 7168] ; *NQ\radpower
CompilerElse
!movd xmm2, [edx + 7168] ; *NQ\radpower
CompilerEndIf
!pshufd xmm2, xmm2, 0xc0
!mov dx, cx
!shl dx, 4
LoadXMM(xmm0)
!movdqa xmm3, xmm0
!psubd xmm3, xmm1 ; px.rgb - rgb
!pshufd xmm5, xmm3, 0xf5
!pmuludq xmm5, xmm2
!pmuludq xmm3, xmm2
!psllq xmm5, 32
!por xmm3, xmm5 ; a*(px.rgb - rgb)
!movdqa xmm5, xmm3 ; add sign bit
!psrld xmm5, 31 ; so negative values
!paddd xmm3, xmm5 ; divide okay
!psrad xmm3, 18 ; a*(px.rgb - rgb)/alpharadbias
!psubd xmm0, xmm3 ; px.rgb - a*(px.rgb - rgb)/alpharadbias
SaveXMM(xmm0)
EndMacro
Procedure ContestAndAlter(alpha, rad, rgb.l)
!movd xmm1, [p.v_rgb] ; expand color
!pxor xmm5, xmm5
!punpcklbw xmm1, xmm5
!punpcklwd xmm1, xmm5
!pslld xmm1, 4 ; rgb << 4
; contest
LoadPtrNQ
!pcmpeqd xmm4, xmm4 ; xmm4 = bestbiasd, bestbiaspos, bestd, bestpos
!psrlq xmm4, 1 ; xmm4 = init xmm4 to (0x7fffffff, -1, 0x7fffffff, -1)
!xor ecx, ecx ; ecx = index
!neuquant.l_contest0:
!mov dx, cx
!shl dx, 4
LoadXMM(xmm0) ; load network[index] into xmm0
!psubw xmm0, xmm1 ; subtract pixel
!pxor xmm5, xmm5
!psubw xmm5, xmm0
!pmaxsw xmm0, xmm5 ; convert difference to absolute
!pshufd xmm5, xmm0, 2 ; add 3 abs diffs together
!paddw xmm0, xmm5
!psllq xmm5, 32
!paddw xmm0, xmm5
!pinsrw xmm0, ecx, 0 ; insert index
!pshufd xmm0, xmm0, 0x44 ; xmm0 = dist, index, dist, index
!shr dx, 2
!add dx, 4096
CompilerIf #x64
!mov eax, [rdx] ; eax = *NQ\freq[i]
!sar eax, 10
!sub [rdx], eax ; *NQ\freq[i] - betafreq
!add dx, 1024
!movd xmm5, [rdx]
!psrad xmm5, 12
!pshufd xmm5, xmm5, 0x15
!sal eax, 10
!add [rdx], eax ; *NQ\bias[i] + betafreq << 10
CompilerElse
!mov eax, [edx] ; eax = *NQ\freq[i]
!sar eax, 10
!sub [edx], eax ; *NQ\freq[i] - betafreq
!add dx, 1024
!movd xmm5, [edx]
!psrad xmm5, 12
!pshufd xmm5, xmm5, 0x15
!sal eax, 10
!add [edx], eax ; *NQ\bias[i] + betafreq << 10
CompilerEndIf
!psubd xmm0, xmm5 ; xmm0 = biasdist, index, dist, index
!movdqa xmm5, xmm4 ; update best values
!pcmpgtd xmm5, xmm0
!pxor xmm0, xmm4
!pshufd xmm5, xmm5, 0xf5
!pand xmm0, xmm5
!pxor xmm4, xmm0
!inc cl
!jnz neuquant.l_contest0
!pextrw eax, xmm4, 0
!mov dx, ax
!shl dx, 2
CompilerIf #x64
!add dword [rdx + 4096], 0x40
!sub dword [rdx + 5120], 0x10000
CompilerElse
!add dword [edx + 4096], 0x40
!sub dword [edx + 5120], 0x10000
CompilerEndIf
; alter single
!movd xmm2, [p.v_alpha]
!pshufd xmm2, xmm2, 0
!pextrw eax, xmm4, 4 ; bestbiaspos
!mov dx, ax
!shl dx, 4
LoadXMM(xmm0)
!movdqa xmm3, xmm0
!psubw xmm3, xmm1 ; px.rgb - rgb
!movdqa xmm5, xmm3
!pmullw xmm3, xmm2
!pmulhw xmm5, xmm2
!pslld xmm5, 16
!por xmm3, xmm5 ; alpha*(px.rgb - rgb)
!movdqa xmm5, xmm3 ; add sign bit
!psrld xmm5, 31 ; so negative values
!paddd xmm3, xmm5 ; divide okay
!psrad xmm3, 10 ; alpha*(px.rgb - rgb)/initalpha
!psubd xmm0, xmm3 ; px.rgb - alpha*(px.rgb - rgb)/initalpha
SaveXMM(xmm0)
; alter neighbours
!mov ecx, [p.v_rad]
!and ecx, ecx
!jz neuquant.l_alter4
CompilerIf #x64
!mov r8, rbx
CompilerElse
!movd xmm4, ebx
CompilerEndIf
!mov ebx, eax
!mov ecx, eax
!add eax, [p.v_rad]
!cmp eax, 256
!jle neuquant.l_alter1
!mov eax, 256
!jmp neuquant.l_alter1
!neuquant.l_alter0:
!mov dx, cx
!sub dx, bx
AlterNeighASM
!neuquant.l_alter1:
!inc ecx
!cmp ecx, eax
!jl neuquant.l_alter0
!mov eax, ebx
!mov ecx, eax
!sub eax, [p.v_rad]
!cmp eax, -1
!jge neuquant.l_alter3
!mov eax, -1
!jmp neuquant.l_alter3
!neuquant.l_alter2:
!mov dx, bx
!sub dx, cx
AlterNeighASM
!neuquant.l_alter3:
!dec ecx
!cmp ecx, eax
!jg neuquant.l_alter2
CompilerIf #x64
!mov rbx, r8
CompilerElse
!movd ebx, xmm4
CompilerEndIf
!neuquant.l_alter4:
EndProcedure
; Search for RGB value (after net is unbiased) and return colour index
Procedure.i InxSearch(rgb.l)
!movd xmm1, [p.v_rgb]
!pcmpeqd xmm4, xmm4
!punpcklbw xmm1, xmm1
!psrlw xmm4, 8
!psrlq xmm4, 16
!pshufd xmm1, xmm1, 0x44
!pshufhw xmm4, xmm4, 0xf7
!pand xmm1, xmm4
LoadPtrNQ
!movzx ecx, byte [p.v_rgb + 1]
CompilerIf #x64
!push rbx
!mov cl, [rdx + rcx * 4 + 6144]
CompilerElse
!push ebx
!mov cl, [edx + ecx * 4 + 6144]
CompilerEndIf
!sub cl, 1
!adc cl, 1
!mov ch, cl
!dec ch
!mov eax, 0x300 ; eax = bestd
!movd xmm2, eax
!pshufd xmm2, xmm2, 0x44
!neuquant.l_search0:
!cmp cl, 0
!jz neuquant.l_search2
!movzx dx, cl
!shl dx, 4
LoadXMM(xmm0)
!pand xmm0, xmm4
!psadbw xmm0, xmm1 ; dist
!movdqa xmm5, xmm2
!pcmpgtw xmm5, xmm0 ; bestd > dist ?
!pmovmskb ebx, xmm5
!shr ebx, 1
!jnc neuquant.l_search1
CompilerIf #x64
!movzx eax, word [rdx + 14]
CompilerElse
!movzx eax, word [edx + 14]
CompilerEndIf
!pshufd xmm2, xmm0, 0x44
!neuquant.l_search1:
!inc cl
!sar bl, 7
!and cl, bl
!neuquant.l_search2:
!cmp ch, 0xff
!jz neuquant.l_search4
!movzx dx, ch
!shl dx, 4
LoadXMM(xmm0)
!pand xmm0, xmm4
!psadbw xmm0, xmm1 ; dist
!movdqa xmm5, xmm2
!pcmpgtw xmm5, xmm0 ; bestd > dist ?
!pmovmskb ebx, xmm5
!shr ebx, 1
!jnc neuquant.l_search3
CompilerIf #x64
!movzx eax, word [rdx + 14]
CompilerElse
!movzx eax, word [edx + 14]
CompilerEndIf
!pshufd xmm2, xmm0, 0x44
!neuquant.l_search3:
!sar bl, 7
!and ch, bl
!dec ch
!neuquant.l_search4:
!cmp cx, 0xff00
!jnz neuquant.l_search0
CompilerIf #x64
!pop rbx
CompilerElse
!pop ebx
CompilerEndIf
ProcedureReturn
EndProcedure
; Insertion sort of network and building of *NQ\netindex[0..255] (to do after unbias)
Procedure.i InxBuild(reserveTransparent = #False)
Protected.i i, j, smallpos, smallval
Protected.i previouscol, startpos, transparent
previouscol = 0
startpos = 0
For i = 0 To 255
smallpos = i
smallval = *NQ\network[i]\w[1]; index on g
; find smallest in i..255
For j = i + 1 To 255
If *NQ\network[j]\w[1] < smallval
smallpos = j
smallval = *NQ\network[j]\w[1]
EndIf
Next
; swap if smallpos <> i
If i <> smallpos
Swap *NQ\network[i]\q[0], *NQ\network[smallpos]\q[0]
Swap *NQ\network[i]\q[1], *NQ\network[smallpos]\q[1]
EndIf
; smallval entry is now in position i
If smallval <> previouscol
*NQ\netindex[previouscol] = (startpos + i) >> 1
j = previouscol + 1 : While j < smallval
*NQ\netindex[j] = i
j + 1 : Wend
previouscol = smallval
startpos = i
EndIf
Next
*NQ\netindex[previouscol] = (startpos + 255) >> 1
For j = previouscol + 1 To 255 : *NQ\netindex[j] = 255 : Next
If reserveTransparent
transparent = *NQ\network[1]\w[7]
*NQ\network[1]\w[7] = *NQ\network[0]\w[7]
EndIf
ProcedureReturn transparent
EndProcedure
; Main Learning Loop
Procedure Learn(image.i, sample = 10)
Protected.i i, j, x, y, width, height, step_x, step_y
Protected.i radius, rad, alpha, delta, totalpixels, samplepixels, alphadec
alphadec = 30 + (sample - 1) / 3
If IsImage(Image)
width = ImageWidth(Image)
height = ImageHeight(Image)
totalpixels = width * height
samplepixels = totalpixels / sample
delta = samplepixels / 100
alpha = 1024
radius = 2048
rad = radius >> 6
If rad <= 1 : rad = 0 : EndIf
i = 0 : While i < rad
*NQ\radpower[i] = alpha * (rad*rad - i*i) << 8 / (rad*rad)
i + 1 : Wend
If totalpixels % 499
If totalpixels > 499
step_y = 499 / width
step_x = 499 - step_y * width
Else
samplepixels = totalpixels
delta = samplepixels / 100
If totalpixels > 7
step_y = 7 / width
step_x = 7 - step_y * width
Else
step_x = 1
EndIf
EndIf
ElseIf totalpixels % 491
step_y = 491 / width
step_x = 491 - step_y * width
ElseIf totalpixels % 487
step_y = 487 / width
step_x = 487 - step_y * width
Else
step_y = 503 / width
step_x = 503 - step_y * width
EndIf
i = 0
StartDrawing(ImageOutput(Image))
While samplepixels
ContestAndAlter(alpha, rad, Point(x, y))
x + step_x
If x >= width : x - width : y + 1 : EndIf
y + step_y
If y >= height : y - height : EndIf
!inc dword [p.v_i]
If i = delta
alpha - alpha / alphadec
radius - radius / 15
rad = radius >> 6
If rad <= 1 : rad = 0 : EndIf
j = 0 : While j < rad
*NQ\radpower[j] = alpha * (rad*rad - j*j) << 8 / (rad*rad)
j + 1 : Wend
i = 0
EndIf
!dec dword [p.v_samplepixels]
Wend
StopDrawing()
EndIf
EndProcedure
Procedure InxBuildFromPalette(Array palette.l(1))
Protected.i i, c, s = ArraySize(palette())
FillMemory(*NQ, 4096)
While i <= s
c = palette(i)
*NQ\network[i]\w[0] = c & $ff
*NQ\network[i]\w[1] = c >> 8 & $ff
*NQ\network[i]\w[2] = c >> 16 & $ff
*NQ\network[i]\w[5] = *NQ\network[i]\w[1]
*NQ\network[i]\w[7] = i
i + 1
Wend
While i < 256
*NQ\network[i]\q[0] = $000000ff00ff00ff
*NQ\network[i]\q[1] = $00ff000000ff0000
i + 1
Wend
InxBuild()
i = s + 1
c = *NQ\network[s]\w[7]
While i < 256
*NQ\network[i]\w[7] = c
i + 1
Wend
EndProcedure
Procedure.l PointOrdDith(x, y)
Protected.l c = Point(x, y)
!movd xmm0, [p.v_c]
!mov al, [p.v_x]
!mov ah, [p.v_y]
!shl al, 6
!and eax, 0x3c0
!shr ax, 3
!punpcklbw xmm0, xmm0
CompilerIf #x64
!lea rdx, [neuquant.l_pointorddith]
!movq xmm1, [rdx + rax]
CompilerElse
!movq xmm1, [neuquant.l_pointorddith + eax]
CompilerEndIf
!psrlw xmm0, 8
!paddw xmm0, xmm1
!packuswb xmm0, xmm0
!movd eax, xmm0
ProcedureReturn
!neuquant.l_pointorddith:
!dq 0xfff9fff9fff9, 0x000100010001, 0xfffbfffbfffb, 0x000300030003
!dq 0x000500050005, 0xfffdfffdfffd, 0x000700070007, 0xffffffffffff
!dq 0xfffcfffcfffc, 0x000400040004, 0xfffafffafffa, 0x000200020002
!dq 0x000800080008, 0x000000000000, 0x000600060006, 0xfffefffefffe
EndProcedure
EndModule
;=============================================================
;{ Save as GIF Section
;=============================================================
Structure RGBQUAD_U ; Unsigned char RGBQUAD
rgbBlue.a
rgbGreen.a
rgbRed.a
rgbReserved.a
EndStructure
Structure PALETTE ; Used to index the colortable
index.RGBQUAD_U[256]
EndStructure
Structure COLORBITS_RGBQUAD ; Used to index the source colorbits
pixels.RGBQUAD_U[0]
EndStructure
Structure COLORBITS_1BYTE_PERPIXEL ; Used to index the target colorbits
pixels.a[0]
EndStructure
Structure RGB_24
Red.a
Green.a
Blue.a
EndStructure
Structure COLORMAPINDEX
color.l
newindex.a
EndStructure
Structure GIF_HEADER
bytes.a[6]
EndStructure
Structure LOGICAL_SCREEN_DESCRIPTOR
Width.w
Height.w
PackedByte.a
BackgroundColorIndex.a
PixelAspectRatio.a
EndStructure
Structure GRAPHICS_CONTROL_EXTENSION
Introducer.a
Label.a
BlockSize.a
PackedByte.a
DelayTime.w
TransparentColorIndex.a
BlockTerminator.a
EndStructure
Structure IMAGE_DESCRIPTOR
Separator.a
ImageLeft.w
ImagTop.w
ImageWidth.w
ImageHeight.w
PackedByte.a
EndStructure
Structure code
code.l
size.l
EndStructure
DataSection
gifheader:
Data.a $47, $49, $46, $38, $39, $61
graphicscontrolextension:
Data.a $21, $F9, $04, $00, $00, $00, $00, $00
applicationextension:
Data.b $21, $FF, $0B, $4E, $45, $54, $53, $43, $41, $50, $45, $32, $2E, $30, $03, $01, $00, $00, $00
author: ; This section must appear in the written file for authorized use of this encoder
Data.b $21,$FE,$2D,$20,$45,$6E,$63,$6F,$64,$65,$72,$20,$62,$79,$20,$4C,
$6C,$6F,$79,$64,$20,$47,$61,$6C,$6C,$61,$6E,$74,$20,$43,$6F,$70,
$79,$72,$69,$67,$68,$74,$20,$28,$63,$29,$20,$32,$30,$31,$33,$20,$00
authorend:
EndDataSection
Global prompt$
UsePNGImageDecoder()
UseJPEGImageDecoder()
UseTIFFImageDecoder()
Procedure.s GetSavePath()
pattern$ = "GIF (*.gif)|*.gif;"
outpath$ = SaveFileRequester("Choose a path to save the .gif file:",prompt$,pattern$, 0)
outpath$ = RemoveString(outpath$, ".gif")
If outpath$
outpath$ + ".gif"
If Not CreateFile(0, outpath$)
MessageRequester("Error:","Problem creating image file... ending.")
End
EndIf
Else
MessageRequester("","No save location chosen... ending.")
End
EndIf
ProcedureReturn outpath$
EndProcedure
Procedure RGBAtoBGRA(pixel) ; Currently unused
!mov eax, [p.v_pixel]
!bswap eax
!ror eax, 8
ProcedureReturn
EndProcedure
Procedure WriteImageStamp(hImageIn, outputfile.i, transparency=0, transparentcolor=0)
transparentcolor = RGB(254,0,150) ; <=================== temporary hardcoded value for testing
Protected bytes_colortable.i
Protected sz_colortable.i
Protected min_codesize.i
Protected Dim colors.RGB_24(255)
#SizeOf2Char = SizeOf(character) << 1
Structure TwoChar
StructureUnion
s.s{2}
CompilerIf #PB_Compiler_Unicode
cc.l
CompilerElse
cc.w
CompilerEndIf
EndStructureUnion
EndStructure
Dim hex_bytes.TwoChar(255)
NewMap CodeTable.l(4096)
Protected ib.s{8192}
Protected *buf_.Long, *ib.TwoChar, *bits8end
Protected.l i, l, bitpos, codesize, clrcode, endcode, nextcode
Protected *buf.Long = AllocateMemory(1024*1024*4)
Protected dither = 1
w=ImageWidth(hImageIn)
h=ImageHeight(hImageIn)
NewMap testcolors.l(1024*1024)
StartDrawing(ImageOutput(hImageIn))
For j=0 To h-1
For i=0 To w-1
color$ = RSet(Hex(Point(i,j),#PB_Long),8)
testcolors(color$) = Point(i,j)
Next
Next
StopDrawing()
Numcolors = MapSize(testcolors())
If Numcolors <= 256 ; No need for neural network to generate color table
ReDim colors(Numcolors-1) ; we will create index stream & color table now
cc=0
ForEach testcolors()
colors(cc)\Red = Red(testcolors())
colors(cc)\Green = Green(testcolors())
colors(cc)\Blue = Blue(testcolors())
cc+1
Next
*bits8.COLORBITS_1BYTE_PERPIXEL = AllocateMemory(w*h)
StartDrawing(ImageOutput(hImageIn))
For j=0 To h-1
For i=0 To w-1
For k=0 To numcolors-1
If Red(Point(i,j)) = colors(k)\Red And Green(Point(i,j)) = colors(k)\Green And Blue(Point(i,j)) = colors(k)\Blue
*bits8\pixels[w*j+i] = k
Break
EndIf
Next
Next
Next
StopDrawing()
Else ; More than 256 colors found in image, use neural network
Dim palette.l(255)
w = ImageWidth(hImageIn)
h = ImageHeight(hImageIn)
NeuQuant::InitNet()
NeuQuant::Learn(hImageIn)
NeuQuant::UnbiasNet(@palette())
NeuQuant::InxBuild()
; Set and optionally dither the colorbits
StartDrawing(ImageOutput(hImageIn))
*bits8.COLORBITS_1BYTE_PERPIXEL = AllocateMemory(w*h)
For y = 0 To h-1
For x = 0 To w-1
index.a = NeuQuant::InxSearch(NeuQuant::PointOrdDith(x, y))
*bits8\pixels[x + y*w] = index
Next
Next
StopDrawing()
Numcolors = 256
For i=0 To 255
colors(i)\Red = Red(palette(i))
colors(i)\Green = Green(palette(i))
colors(i)\Blue = Blue(palette(i))
Next
FreeMemory(*palette)
EndIf
FreeMap(testcolors())
sz_colorbits = MemorySize(*bits8)
*ib.TwoChar = @ib
*bits8end = *bits8 + MemorySize(*bits8)
*bits_8.Ascii = *bits8
Select NumColors
Case 1 To 3
bytes_colortable = 12
sz_colortable = 1
min_codesize = 2
Case 4 To 7
bytes_colortable = 24
sz_colortable = 2
min_codesize = 3
Case 8 To 15
bytes_colortable = 48
sz_colortable = 3
min_codesize = 4
Case 16 To 31
bytes_colortable = 96
sz_colortable = 4
min_codesize = 5
Case 32 To 63
bytes_colortable = 192
sz_colortable = 5
min_codesize = 6
Case 64 To 127
bytes_colortable = 384
sz_colortable = 6
min_codesize = 7
Case 128 To 256
bytes_colortable = 768
sz_colortable = 7
min_codesize = 8
EndSelect
clrcode = 1 << min_codesize
endcode = clrcode + 1
nextcode = clrcode + 2
If hex_bytes(0)\cc = 0
For i = 0 To 255
hex_bytes(i)\s = Right(Hex(i|256), 2)
Next
EndIf
CodeTable("00") = $1000
codesize = min_codesize + 1
i = 1
While i < numcolors
CodeTable(hex_bytes(i)\s) = i
i + 1
Wend
*buf\l = clrcode
bitpos = codesize
While *bits_8 < *bits8end
*ib\cc = hex_bytes(*bits_8\a)\cc
*ib + #SizeOf2Char
*ib\cc = 0
i = CodeTable(ib)
If i = 0
*buf_ = *buf + bitpos >> 3
*buf_\l | l << (bitpos & 7)
bitpos + codesize
CodeTable(ib) = nextcode
*ib = @ib
l = *bits_8\a
*ib\cc = hex_bytes(l)\cc
*ib + #SizeOf2Char
*ib\cc = 0
codesize + nextcode >> codesize
nextcode + 1
If codesize > 12
*buf_ = *buf + bitpos >> 3
*buf_\l | clrcode << (bitpos & 7)
bitpos + 12
nextcode = endcode + 1
ClearMap(CodeTable())
CodeTable("00") = $1000
codesize = min_codesize + 1
i = 1
While i < numcolors
CodeTable(hex_bytes(i)\s) = i
i + 1
Wend
EndIf
Else
l = i & $fff
EndIf
*bits_8 + 1
Wend
*buf_ = *buf + bitpos >> 3
*buf_\l | l << (bitpos & 7)
bitpos + codesize
*buf_ = *buf + bitpos >> 3
*buf_\l | endcode << (bitpos & 7)
bitpos + codesize
cctotal = ((bitpos + 7) & -8) >> 3
If transparency
For i=0 To ArraySize(colors())
If colors(i)\Red = Red(transparentcolor) And colors(i)\Green = Green(transparentcolor) And colors(i)\Blue = Blue(transparentcolor)
transcolor_index = i
Break
EndIf
Next
EndIf
*write_application_extension = AllocateMemory(19)
CopyMemory(?applicationextension, *write_application_extension, 19)
WriteData(outputfile, *write_application_extension, MemorySize(*write_application_extension))
FreeMemory(*write_application_extension)
; Write graphics control extension
*write_graphics_control_extension.GRAPHICS_CONTROL_EXTENSION = AllocateMemory(SizeOf(GRAPHICS_CONTROL_EXTENSION))
CopyMemory(?graphicscontrolextension, *write_graphics_control_extension, SizeOf(GRAPHICS_CONTROL_EXTENSION))
*write_graphics_control_extension\DelayTime = 3 ; <================ This is the delay time where 100 = 1 second. You can use a different one for each frame
If transparency
*write_graphics_control_extension\PackedByte = 13 ; <============ This value means there is a transparent color and the disposal method is "clear"
*write_graphics_control_extension\TransparentColorIndex = transcolor_index
EndIf
WriteData(outputfile, *write_graphics_control_extension, MemorySize(*write_graphics_control_extension))
FreeMemory(*write_graphics_control_extension)
; Write image descriptor
*write_image_descriptor.IMAGE_DESCRIPTOR = AllocateMemory(SizeOf(IMAGE_DESCRIPTOR))
With *write_image_descriptor
\Separator = $2C
\ImageWidth = w
\ImageHeight = h
\PackedByte = $80|sz_colortable
EndWith
WriteData(outputfile, *write_image_descriptor, MemorySize(*write_image_descriptor))
FreeMemory(*write_image_descriptor)
; Write local colortable
*colortable = AllocateMemory(bytes_colortable)
*writeptr.RGB_24 = *colortable
For i=0 To ArraySize(colors())
*writeptr\Red = colors(i)\Red
*writeptr\Green = colors(i)\Green
*writeptr\Blue = colors(i)\Blue
*writeptr+SizeOf(RGB_24)
Next
WriteData(outputfile, *colortable, MemorySize(*colortable))
FreeMemory(*colortable)
; Write encoded image data
*readbuf = *buf
WriteByte(outputfile, min_codesize)
While cctotal > 255
WriteByte(outputfile, 255)
WriteData(outputfile, *readbuf, 255)
*readbuf + 255
cctotal - 255
Wend
WriteByte(outputfile, cctotal)
WriteData(outputfile, *readbuf, cctotal)
WriteByte(outputfile, $00)
FreeMemory(*buf)
EndProcedure
NewList files.s()
InitialPath$ = GetPathPart(GetCurrentDirectory()) ; set initial path to display (could also be blank)
Path$ = PathRequester("Please choose your path", InitialPath$)
If Path$
ExamineDirectory(0,path$,"")
While NextDirectoryEntry(0)
If DirectoryEntryType(0) = #PB_DirectoryEntry_File
ext$ = GetExtensionPart(DirectoryEntryName(0))
Select UCase(ext$)
Case "PNG", "BMP", "JPG", "TIF"
AddElement(files())
files() = Path$ + DirectoryEntryName(0)
EndSelect
EndIf
Wend
FinishDirectory(0)
EndIf
If ListSize(files())>0
FirstElement(files())
Else
MessageRequester("Error:", "No files selected. Ending...")
EndIf
hImageIn=LoadImage(#PB_Any, files())
GetSavePath()
If IsImage(hImageIn)
w=ImageWidth(hImageIn)
h=ImageHeight(hImageIn)
EndIf
; Write header
*write_header.GIF_HEADER = AllocateMemory(SizeOf(GIF_HEADER))
CopyMemory(?gifheader, *write_header, SizeOf(GIF_HEADER))
WriteData(0, *write_header, MemorySize(*write_header))
FreeMemory(*write_header)
; Write logical screen descriptor
*write_logical_screen_descriptor.LOGICAL_SCREEN_DESCRIPTOR = AllocateMemory(SizeOf(LOGICAL_SCREEN_DESCRIPTOR))
With *write_logical_screen_descriptor
\width = w
\height = h
EndWith
WriteData(0, *write_logical_screen_descriptor, MemorySize(*write_logical_screen_descriptor))
FreeMemory(*write_logical_screen_descriptor)
OpenConsole()
Print("Working.")
WriteImageStamp(hImageIn, 0, 0)
While NextElement(files())
hImageIn=LoadImage(#PB_Any, files())
If hImageIn
WriteImageStamp(hImageIn, 0, 0)
Print(".")
EndIf
Wend
*write_author_extension = AllocateMemory(?authorend-?author)
CopyMemory(?author, *write_author_extension, ?authorend-?author)
WriteData(0, *write_author_extension, MemorySize(*write_author_extension))
FreeMemory(*write_author_extension)
WriteByte(0, $3B)
CloseFile(0)
PrintN("")
PrintN("")
Print("Done! Any key to exit")
Input()
;========================================================================
;
;========================================================================