GIF Workshop alpha 1 - All platforms

[netmaestro]

GIF Workshop is moved to the alpha stage. There is no GUI yet and you have to hardcode your own transparent color if you want transparency but it is currently producing animated GIFs with (or without) transparency. Please test the code on all platforms, a Windows exe is included in the zip as is the full source. The code has no dependencies.

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()

;========================================================================
;
;========================================================================

[IdeasVacuum]

Erm - can't find the 'Any' key?

I get varying results.
FireFox: Fast animation, no artifacts
IE: Slow animation, no artifacts
IrfanView: Fastest animation but with a horzontal bar 'sliding' from top to bottom.

[ts-soft]

runs fine on linux

[IdeasVacuum]

...QuickTime: Similar to IE.
All players 'know' that the background should be transparent, though I would probably want to avoid that as the image is sharper with the background.

So, being able to adjust the number of milliseconds the frames are displayed for is important, and possibly reducing the number of colours as an option too.

Edit: Fred needs a fashion make-over!

[netmaestro]

Thanks for replies!

The quality of the gif isn't really an issue here because the supplied sample isn't great quality to begin with and GIGO. The background is a bright pink and there's a bit of anti-alias, which will show regardless. My main focus is that it works "everywhere".

One thing that I don't understand is that all the browsers and Paint show the animation transparent but IrfanView isn't doing that here. I tried changing the disposal method but the pink background still shows on IrfanView, no idea why. Maybe it's nothing for me to worry about.

I'm currently using local color tables and no global color table but this makes for a larger file and could be causing the IrfanView issue.

Colors are automatically reduced to use either 256 or the number of unique colors in the image, whichever is smaller.

Working on the GUI now, so individual delay times can be set and local vs. global color tables will be selectable and the transparent color (if any) will be choosable without editing sourcecode!

Thanks again for testing!

[davido]

Hi netmaestro,

Excellent work.

I tried it with:

1. Chrome - Takes two steps and then halts! Good display, though.
2. Opera - Runs (sorry walks) well. Good display.
3. Irfan - Runs fine. The red outline of the figures rather pronounced.

64 bit - core i3 graphics.

[Kwai chang caine]

What i see !!!!
A new job about my favorite file ...the GIF
Obviously i run on my pc to try it

So i have test it with :
Chrome = Perfect (Foreground white)
IE7 = Perfect but more slow (Foreground white)
Firefox 14.0.1 = Perfect (Foreground a style of brown, but the outline is visible in red)
Acdsee = Quick but alway at the same time the foreground change color 2 time (Foreground a style of brown, the outline is visible in red)
The native picture reader of XP = Very slow (Foreground white)

I have XP Pro SP3
Again thanks for your interest for the great GIF, because i know now FRED never do something to include it in PB
At this subject...do you believe a time you can create, other function copy/paste, see in a gadget...like if fred have create a UseGIFImageDecoder ???

Have a good day

[Fred]

btw, the supplied sample is Fred walking to the mailbox, picking up the PureBasic registrations

I knew I was spied !

[Lord]

1. FireFox 24.0 - walks smooth on white background, small red outline (just visible)

2. IrfanView 4.33 - walks smooth on black background, good visible red outline

3. QuickTimePlayer 7.5.5 - walks smooth on white background, small red outline (just visible)

4. IExplorer v10 - walks smooth on white background, small red outline (just visible)

Tested on Windows 7 Ultimate, 64 Bit, Core i5 760 @2.8GHz and NVidia GeForce GTX 460

[IdeasVacuum]

Hi netmaestro, what happened to the GIF Workshop?

[netmaestro]

Back in business with this one, thanks to forum users with better file management habits than I've got. The link is working again.