Anybody got my last Gif Workshop zip?

[netmaestro]

I lost it last year and I'd like to work on it. If you have it, could you send it to me or post a link to it? lloydgallant gmail (you know how to fill the rest in)

[idle]

got one from 17/11/13, is the right one? I'll dropbox it to you.

[netmaestro]

Yes, sounds right!

[VB6_to_PBx]

i'm pretty sure i have all your versions
heres the November 17, 2013 version

Code: Select all

;/////////////////////////////////////////////////////////////////////////////////////
;
; Project:                  GIF WORKSHOP
;
; Author:                   Lloyd Gallant (netmaestro)
;
; Collaborators:            Idle, Wilbert (optimize encoder for speed)
;                           Luis          (PureBasic port of NeuQuant)
;
; Version:                  Alpha 1.0
;
; Compiler version:         PureBasic 5.20
;
; Target platform:          Microsoft Windows all, Linux, MacOS 
; 
; Date:                     November 17, 2013
;
; 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

;========================================================================================
;{                        NEUQUANT COLORTABLE GENERATION SECTION
;========================================================================================
;
; 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 4.31-4.40 by Luis on Oct 2009 
; http://luis.no-ip.net
; The code in this include *should* be cross / platform. Tested on Windows 32/64 bit.
; Pfew! A lot or pointers' arithmetic to convert !
;
; Pseudo code usage example for PB:
;
; [ obtain a pointer to the color data bitmap in memory ]
;
; // please note the color data must be a sequence of BGRA quadruplets (32 bit/pixel) and that the A channel is ignored
; // allocated space would be = (4 * ImageWidth * ImageHeight) 
;
; NQ_InitNetwork() ; initialize network
; NQ_Learn (*ImageBuf, MemorySize(*ImageBuf), [1..30]) ; learning 
; NQ_UnbiasNetwork() ; network unbias
;
; // at this point the optimized palette has been calculated and it's in g_NQ_Network() 
; // g_NQ_Network(0..255)\iBGRC[0] ; BLUE 
; // g_NQ_Network(0..255)\iBGRC[1] ; GREEN 
; // g_NQ_Network(0..255)\iBGRC[2] ; RED 
; 
; NQ_SortNetwork() ; optimize the palette order for the lookup phase
;
; // now you loop through every pixel in the original 24/32 bit image and retrieve the palette index to be used in the 8 bit image 
; 
; [read B, G, R data from source image ]
; iIndex = NQ_LookupPalette(B, G, R) 
; [ write iIndex to the destination image ]

CompilerIf Defined(MAXLONG, #PB_Constant)=0
  #MAXLONG = $7FFFFFFF
CompilerEndIf

CompilerIf Defined(RGBQUAD, #PB_Structure)=0
  Structure RGBQUAD
    rgbBlue.b
    rgbGreen.b
    rgbRed.b
    rgbReserved.b
  EndStructure
CompilerEndIf

Structure T_RGBTRIPLE 
  rgbtBlue.a
  rgbtGreen.a
  rgbtRed.a
EndStructure

Structure T_PIXEL
  iBGRC.i[4]
EndStructure

Declare.i  _NQ_Contest (b, g, r)
Declare    _NQ_AlterSingle (alpha, i, b, g, r)
Declare    _NQ_AlterNeigh (rad, i, b, g, r)

Declare    NQ_InitNetwork ()
Declare    NQ_UnbiasNetwork()
Declare    NQ_SortNetwork()
Declare.i  NQ_LookupPalette (b,g,r)
Declare.i  NQ_Learn (*ImageBuffer.T_RGBTRIPLE, iBufferLen, iSample)

#NQ_netsize = 256  ; number of colours used

; four primes near 500 - assume no image has a length so large
; that it is divisible by all four primes 
#NQ_prime1  = 499
#NQ_prime2  = 491
#NQ_prime3  = 487
#NQ_prime4  = 503

#NQ_minpicturebytes     = 3 * #NQ_prime4 ; minimum size for input image 

; Network Definitions   
#NQ_maxnetpos           = #NQ_netsize - 1
#NQ_netbiasshift        = 4     ; bias for colour values 
#NQ_ncycles             = 100 ; no. of learning cycles 

; Defs for freq and bias
#NQ_intbiasshift        = 16 ; bias for fractions 
#NQ_intbias             = 1 << #NQ_intbiasshift
#NQ_gammashift          = 10 ; gamma = 1024 
#NQ_gamma               = 1 << #NQ_gammashift
#NQ_betashift           = 10
#NQ_beta                = #NQ_intbias >> #NQ_betashift ; beta = 1/1024 
#NQ_betagamma           = #NQ_intbias << (#NQ_gammashift - #NQ_betashift)

; defs for decreasing radius factor
#NQ_initrad             = #NQ_netsize >> 3  ; for 256 cols, radius starts 
#NQ_radiusbiasshift     = 6 ; at 32.0 biased by 6 bits
#NQ_radiusbias          = 1 << #NQ_radiusbiasshift
#NQ_initradius          = #NQ_initrad * #NQ_radiusbias 
#NQ_radiusdec           = 15 ; and decreases by a factor of 1/#NQ_radiusdec each cycle (originally was 30)

; defs for decreasing alpha factor 
#NQ_alphabiasshift      = 10 ; alpha starts at 1.0 
#NQ_initalpha           = 1 << #NQ_alphabiasshift

; radbias and alpharadbias used for radpower calculation 
#NQ_radbiasshift        = 8
#NQ_radbias             = 1 << #NQ_radbiasshift
#NQ_alpharadbshift      = #NQ_alphabiasshift + #NQ_radbiasshift
#NQ_alpharadbias        = 1 << #NQ_alpharadbshift


Global Dim g_NQ_Network.T_PIXEL (#NQ_netsize - 1)  ; the network itself 
Global Dim g_NQ_NetIndex(256 - 1)                  ; for network lookup - really 256 
Global Dim g_NQ_Bias (#NQ_netsize - 1)             ; bias and freq arrays for learning 
Global Dim g_NQ_Freq (#NQ_netsize - 1)             ; bias and freq arrays for learning 
Global Dim g_NQ_RadPower (#NQ_initrad - 1)         ; radpower for precomputation 


Procedure.i _NQ_Contest (b, g, r)
  Protected i, dist, a, biasdist, betafreq
  Protected bestpos, bestbiaspos, bestd, bestbiasd
  Protected *p.Integer, *f.Integer, *n.T_PIXEL
  
  ; finds closest neuron (min dist) and updates freq 
  ; finds best neuron (min dist-bias) and returns position 
  ; for frequently chosen neurons, g_NQ_Freq(i) is high and g_NQ_Bias(i) is negative
  ; g_NQ_Bias(i) = gamma*((1/#NQ_netsize)-g_NQ_Freq(i)) 
  
  bestd = #MAXLONG
  bestbiasd = bestd
  bestpos = -1
  bestbiaspos = bestpos
  *p = @g_NQ_Bias()
  *f = @g_NQ_Freq()
  
  For i = 0 To #NQ_netsize - 1
    *n = @g_NQ_Network(i)
    dist = *n\iBGRC[0] - b : If dist < 0 : dist = -dist : EndIf
    a = *n\iBGRC[1] - g :  If a < 0 : a = -a : EndIf
    dist + a
    a = *n\iBGRC[2] - r : If a < 0 : a = -a : EndIf  
    dist + a
    If dist < bestd : bestd = dist : bestpos = i : EndIf
    biasdist = dist - (*p\i >> (#NQ_intbiasshift - #NQ_netbiasshift))
    If biasdist < bestbiasd : bestbiasd = biasdist: bestbiaspos = i : EndIf
    betafreq = *f\i >> #NQ_betashift
    *f\i - betafreq : *f + SizeOf(Integer)
    *p\i + (betafreq << #NQ_gammashift) : *p + SizeOf(Integer)
  Next   
  
  g_NQ_Freq(bestpos) + #NQ_beta
  g_NQ_Bias(bestpos) - #NQ_betagamma
  
  ProcedureReturn bestbiaspos   
EndProcedure

; Move neuron i towards biased (b,g,r) by factor alpha
Procedure _NQ_AlterSingle (alpha, i, b, g, r)
  Protected *n.T_PIXEL = @g_NQ_Network(i) ; alter hit neuron 
  
  *n\iBGRC[0] - (alpha * (*n\iBGRC[0] - b)) / #NQ_initalpha 
  *n\iBGRC[1] - (alpha * (*n\iBGRC[1] - g)) / #NQ_initalpha
  *n\iBGRC[2] - (alpha * (*n\iBGRC[2] - r)) / #NQ_initalpha
EndProcedure

; Move adjacent neurons by precomputed alpha*(1-((i-j)^2/[r]^2)) in g_NQ_RadPower[|i-j|]
Procedure _NQ_AlterNeigh (rad, i, b, g, r)
  Protected j, k, lo, hi, a
  Protected *p.T_PIXEL, *q.Integer 
  
  lo = i - rad : If lo < -1 : lo = -1 : EndIf
  hi = i + rad : If hi > #NQ_netsize : hi = #NQ_netsize : EndIf
  
  j = i + 1 
  k = i - 1
  *q = @g_NQ_RadPower()
  
  While (j < hi) Or (k > lo) 
    *q + SizeOf(Integer) : a = *q\i
    
    If j < hi
      *p = @g_NQ_Network(j)
      *p\iBGRC[0] - (a * (*p\iBGRC[0] - b)) / #NQ_alpharadbias
      *p\iBGRC[1] - (a * (*p\iBGRC[1] - g)) / #NQ_alpharadbias
      *p\iBGRC[2] - (a * (*p\iBGRC[2] - r)) / #NQ_alpharadbias
      j + 1
    EndIf
    If k > lo
      *p = @g_NQ_Network(k)
      *p\iBGRC[0] - (a * (*p\iBGRC[0] - b)) / #NQ_alpharadbias
      *p\iBGRC[1] - (a * (*p\iBGRC[1] - g)) / #NQ_alpharadbias
      *p\iBGRC[2] - (a * (*p\iBGRC[2] - r)) / #NQ_alpharadbias
      k - 1        
    EndIf
  Wend
EndProcedure

; Initialise network in range (0,0,0) To (255,255,255) and set parameters
Procedure NQ_InitNetwork ()   
  Protected i, *p.T_PIXEL
  
  For i = 0 To #NQ_netsize - 1
    *p = @g_NQ_Network(i)
    *p\iBGRC[0] = (i << (#NQ_netbiasshift + 8)) / #NQ_netsize
    *p\iBGRC[1] = *p\iBGRC[0]
    *p\iBGRC[2] = *p\iBGRC[0]
    g_NQ_Freq(i) = #NQ_intbias/#NQ_netsize ; 1/netsize 
    g_NQ_Bias(i) = 0
  Next
EndProcedure   

; Unbias network to give byte values 0..255 and record position i to prepare for sort
Procedure NQ_UnbiasNetwork()
  Protected i, j, t
  
  For i = 0 To #NQ_netsize - 1
    For j = 0 To 2
      t = (g_NQ_Network(i)\iBGRC[j] + (1 << (#NQ_netbiasshift - 1))) >> #NQ_netbiasshift
      If (t > 255) : t = 255 : EndIf
      g_NQ_Network(i)\iBGRC[j] = t
    Next
    g_NQ_Network(i)\iBGRC[3]  = i ; record colour no
  Next
EndProcedure

; Insertion sort of network and building of g_NQ_NetIndex(0..255) (to do after unbias)
Procedure NQ_SortNetwork()
  
  Protected i, j, smallpos, smallval 
  Protected *p.T_PIXEL, *q.T_PIXEL
  Protected previouscol, startpos
  
  previouscol = 0
  startpos = 0
  
  For i = 0 To #NQ_netsize - 1
    
    *p = @g_NQ_Network(i)
    
    smallpos = i   
    smallval = *p\iBGRC[1]  ; index on g 
    
    ; find smallest in i..#NQ_netsize - 1 
    For j = i+1 To #NQ_netsize - 1
      *q = @g_NQ_Network(j)
      If *q\iBGRC[1] < smallval ; index on g 
        smallpos = j
        smallval = *q\iBGRC[1] ; index on g
      EndIf
    Next
    
    *q = @g_NQ_Network(smallpos)
    
    ; swap p (i) and q (smallpos) entries 
    If i <> smallpos       
      Swap *q\iBGRC[0], *p\iBGRC[0]
      Swap *q\iBGRC[1], *p\iBGRC[1]
      Swap *q\iBGRC[2], *p\iBGRC[2]
      Swap *q\iBGRC[3], *p\iBGRC[3]      
    EndIf
    
    ; smallval entry is now in position i 
    If smallval <> previouscol
      g_NQ_NetIndex(previouscol) = (startpos+i) >> 1
      
      For j = previouscol + 1 To smallval - 1
        g_NQ_NetIndex(j) = i
      Next
      
      previouscol = smallval        
      startpos = i        
    EndIf        
  Next
  
  g_NQ_NetIndex(previouscol) = (startpos + #NQ_maxnetpos) >> 1
  
  For j = previouscol + 1 To 255
    g_NQ_NetIndex(j) = #NQ_maxnetpos ; really 256
  Next
  
EndProcedure

; Search for BGR values 0..255 (after net is unbiased) and return colour index
Procedure.i NQ_LookupPalette (b, g, r)
  Protected i, j, dist, a, best, bestd
  Protected *p.T_PIXEL
  
  bestd = 1000 ; biggest possible dist is 256*3
  best = -1
  
  i = g_NQ_NetIndex(g) ; index on g 
  j = i - 1            ; start at g_NQ_NetIndex(g) and work outwards 
  
  While i < #NQ_netsize Or j >= 0
    
    If i < #NQ_netsize    
      *p = @g_NQ_Network(i)
      
      dist = *p\iBGRC[1] - g ; inx key 
      
      If dist >= bestd
        i = #NQ_netsize ; stop iter
      Else
        i + 1
        If dist < 0: dist = -dist : EndIf
        a = *p\iBGRC[0] - b : If a < 0 : a = -a : EndIf
        dist + a
        If dist < bestd
          a = *p\iBGRC[2] - r : If a < 0 : a = -a : EndIf
          dist + a
          If dist < bestd : bestd = dist : best = *p\iBGRC[3] : EndIf
        EndIf    
      EndIf
    EndIf
    
    If j >= 0    
      *p = @g_NQ_Network(j)
      
      dist = g - *p\iBGRC[1] ; inx key - reverse dif
      
      If dist >= bestd 
        j = -1 ; stop iter
      Else
        j - 1
        If dist < 0 : dist = -dist : EndIf
        a = *p\iBGRC[0] - b : If a < 0 : a = -a : EndIf
        dist + a
        If dist < bestd 
          a = *p\iBGRC[2] - r : If  a < 0 : a = -a : EndIf
          dist + a
          If dist < bestd : bestd = dist : best = *p\iBGRC[3] : EndIf
        EndIf
      EndIf
    EndIf
    
  Wend
  
  ProcedureReturn best
EndProcedure

; Main Learning Loop
Procedure.i NQ_Learn (*ImageBuffer.T_RGBTRIPLE, iBufferLen, iSample)
  
  Protected i, j, b, g, r
  Protected radius, rad, alpha, iStep, delta, samplepixels, alphadec 
  Protected *lim
  
  If iBufferLen < #NQ_minpicturebytes
    ProcedureReturn 0
  EndIf
  
  alphadec = 30 + ((iSample - 1) / 3)
  
  *lim = *ImageBuffer + iBufferLen
  samplepixels = iBufferLen / (4 * iSample)
  delta = samplepixels / #NQ_ncycles
  alpha = #NQ_initalpha
  radius = #NQ_initradius
  
  If samplepixels = 0 Or delta = 0 
    ProcedureReturn 0
  EndIf
  
  rad = radius >> #NQ_radiusbiasshift
  
  If rad <= 1 : rad = 0 : EndIf
  
  For i = 0 To rad - 1
    g_NQ_RadPower(i) = alpha * (((rad * rad - i * i) * #NQ_radbias) / (rad*rad))
  Next
  
  If ((iBufferLen % #NQ_prime1) <> 0) 
    iStep = 4 * #NQ_prime1 
  ElseIf ((iBufferLen % #NQ_prime2) <> 0) 
    iStep = 4 * #NQ_prime2
  ElseIf ((iBufferLen % #NQ_prime3) <> 0)
    iStep = 4 * #NQ_prime3
  Else 
    iStep = 4 * #NQ_prime4
  EndIf
  
  i = 0
  
  While (i < samplepixels) 
    b = (*ImageBuffer\rgbtBlue &$FF) << #NQ_netbiasshift
    g = (*ImageBuffer\rgbtGreen &$FF) << #NQ_netbiasshift
    r = (*ImageBuffer\rgbtRed &$FF) << #NQ_netbiasshift
    j = _NQ_Contest(b,g,r)
    
    _NQ_AlterSingle (alpha,j,b,g,r)
    
    If (rad) : _NQ_AlterNeigh(rad,j,b,g,r) : EndIf ; alter neighbours
    
    *ImageBuffer + iStep
    
    If *ImageBuffer >= *lim : *ImageBuffer - iBufferLen : EndIf
    
    i + 1
    
    If i % delta = 0
      alpha - (alpha / alphadec)
      radius - (radius / #NQ_radiusdec)
      rad = radius >> #NQ_radiusbiasshift
      
      If rad <= 1 : rad = 0 : EndIf
      
      For j = 0 To rad - 1
        g_NQ_RadPower(j) = alpha * (((rad * rad - j * j) * #NQ_radbias) / (rad*rad))
      Next        
    EndIf   
  Wend
  
  ProcedureReturn 1
  
EndProcedure

;========================================================================================
;{                           FLOYD-STEINBERG DITHERING RESIDENTS
;========================================================================================

; Copyright (c) 2009 the authors listed at the following URL, and/or
; the authors of referenced articles or incorporated external code:
; http://en.literateprograms.org/Floyd-Steinberg_dithering_(C)?action=history&offset=20080916082812
;
; Permission is hereby granted, free of charge, to any person obtaining
; a copy of this software and associated documentation files (the
; "Software"), to deal in the Software without restriction, including
; without limitation the rights to use, copy, modify, merge, publish,
; distribute, sublicense, and/or sell copies of the Software, and to
; permit persons to whom the Software is furnished to do so, subject to
; the following conditions:
;
; The above copyright notice and this permission notice shall be
; included in all copies or substantial portions of the Software.
;
; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;
; Retrieved from: http://en.literateprograms.org/Floyd-Steinberg_dithering_(C)?oldid=14630
;
; Ported to PureBasic code by Lloyd Gallant (netmaestro) on October 1, 2009
;
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

Macro plus_truncate_uchar(a, b) 
  If a+b<0 : a=0 : ElseIf  a+b>255 : a=255 : Else : a+b : EndIf
EndMacro

Macro compute_disperse(channel)
  error = (*colorbits\pixels[x + y*w]\channel - *palette\index[index]\channel ) >> 1 ; shift to soften
  If (x + 1) < w : plus_truncate_uchar(*colorbits\pixels[(x+1) + (y+0)*w]\channel, (error*7) >> 4) : EndIf
  If (y + 1) < h 
    If (x - 1) > 0
      plus_truncate_uchar(*colorbits\pixels[(x-1) + (y+1)*w]\channel, (error*3) >> 4)
      plus_truncate_uchar(*colorbits\pixels[(x+0) + (y+1)*w]\channel, (error*5) >> 4)
      If (x + 1 < w) : plus_truncate_uchar(*colorbits\pixels[(x+1)+(y+1)*w]\channel,(error*1) >> 4) : EndIf
    EndIf
  EndIf
EndMacro
;}

Procedure.i CreatePalette_NeuQuant (*ImageBuf, iQuality=10)  
  ; By luis Oct 2009
  ; Modified by netmaestro to accept buffer as
  ; parameter instead of image handle Oct 2013
  
  Protected *Palette, k
  Protected Dim tPaletteTable.RGBQUAD(256)
  
  If *ImageBuf
    NQ_InitNetwork()
    
    If NQ_Learn(*ImageBuf, MemorySize(*ImageBuf), iQuality)
      
      NQ_UnbiasNetwork()
      
      For k = 0 To 255
        With tPaletteTable(k)
          \rgbBlue  = g_NQ_Network(k)\iBGRC[0] 
          \rgbGreen = g_NQ_Network(k)\iBGRC[1] 
          \rgbRed   = g_NQ_Network(k)\iBGRC[2] 
          \rgbReserved = 0
        EndWith       
      Next
      
      *Palette = AllocateMemory (256 * SizeOf(RGBQUAD))
      CopyMemory(@tPaletteTable(), *Palette, MemorySize(*Palette))
    EndIf
  EndIf
  
  ProcedureReturn *Palette 
EndProcedure

;=============================================================
;{            Save as GIF Section
;=============================================================

Global prompt$

Structure RGB 
  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

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 WriteImageStamp(hImageIn, outputfile.i, transparency=0, transparentcolor=0)
  
  transparentcolor = RGB(254,0,150) ; <=================== temporary hardcoded value for testing
  
  Global bytes_colortable 
  Global sz_colortable    
  Global min_codesize     
  Global Dim colors.RGB(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 
    StartDrawing(ImageOutput(hImageIn))
      If w*h<1600
        *colorbits.COLORBITS_RGBQUAD = AllocateMemory(1600*4)
        FillMemory(*colorbits, 1600*4, 128, #PB_Byte)
      Else
        *colorbits.COLORBITS_RGBQUAD = AllocateMemory(w*h*4)
      EndIf
      cc=0
      For j=0 To h-1
        For i=0 To w-1
          With *colorbits\pixels[cc]
            \rgbRed   = Red(Point(i,j))
            \rgbGreen = Green(Point(i,j))
            \rgbBlue  = Blue(Point(i,j))
          EndWith
          cc+1
        Next
      Next
    StopDrawing()
    
    *palette.PALETTE = CreatePalette_NeuQuant(*colorbits)
    
    NQ_SortNetwork() ; for NQ_LookupPalette to work properly
    
    ; Set and optionally dither the colorbits
    *bits8.COLORBITS_1BYTE_PERPIXEL = AllocateMemory(w*h)
    For y = 0 To h-1
      For x = 0 To w-1
        index.a = NQ_LookupPalette (*colorbits\pixels[x + y*w]\rgbBlue, *colorbits\pixels[x + y*w]\rgbGreen, *colorbits\pixels[x + y*w]\rgbRed)
        *bits8\pixels[x + y*w] = index
        If dither
          compute_disperse(rgbRed)
          compute_disperse(rgbGreen)
          compute_disperse(rgbBlue)
        EndIf
      Next
    Next
    
    Numcolors = 256
    
    For i=0 To 255
      colors(i)\Red   = *palette\index[i]\rgbRed
      colors(i)\Green = *palette\index[i]\rgbGreen
      colors(i)\Blue  = *palette\index[i]\rgbBlue
    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 = *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)
  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, 1)
While NextElement(files())
  hImageIn=LoadImage(#PB_Any, files())
  If hImageIn
    WriteImageStamp(hImageIn, 0, 1)
    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()

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

[idle]

I'm still waiting for it to sync. in the mean time listen to my signature

[netmaestro]

Perfect, thanks a million guys!

[idle]

Perfect, thanks a million guys!

Did you get it?

[netmaestro]

Yes, I downloaded it from Dropbox, it went perfect. That's the version I need too. Thanks again. I guess you want to remove it from Dropbox, no problem as I've already reupped it to my site for the forum topic on it.

[idle]

Yes, I downloaded it from Dropbox, it went perfect. That's the version I need too. Thanks again. I guess you want to remove it from Dropbox, no problem as I've already reupped it to my site for the forum topic on it.

just wanted to make sure you got it!

[netmaestro]

I'm going to resist the temptation to go full frontal KCC here, but this seems fitting:

OK, well maybe just one more:

...chained myself to the chair so I can't go full KCC... It's contagious, pass the word or we're all done for!

[idle]

no dont go kcc on us but then why not!

[Kwai chang caine]

Too late my two friends....



I have read youuuuuuuuuuu !!!!