Packing bytes: a little help from my friends

[Little John]

Hi,

I didn't test it myself, but I vaguely recall that people said & is faster than %.
Since pos seems to be always positive here, pos & 7 should yield the same result as pos % 8.

[infratec]

Sh.. to late.

Hi,

% 8 can be replaced by & $07

Code: Select all

For i = 0 To 20
  Debug Str(i) + " % " + Str(i % 8)
  Debug Str(i) + " & " + Str(i & $07)
Next i

Bernd

I changed my code on page 1, because also one bit pattern was wrong

[netmaestro]

It works fine and a speed test here shows & running in just about 2/3 the time of %. Implemented, thanks for the tip!
(speed improvement for the encoder is not 2/3, it's actually just noticeable. But every bit helps )

[infratec]

If you replace the for statement in my program it works:

Code: Select all

For i = 0 To 7

instead of

Code: Select all

For i = 7 To 0 Step -1

I don't know if it is slower or faster.

Bernd

[netmaestro]

Not sure myself either but it's not in my program. It was just part of the testing. I'm ForEaching a linked list.

[netmaestro]

Having had a bit of time to review the construction of the SetBits macro, I think it's quite elegantly done. Very nice piece of work and thanks again for sharing it here

[wilbert]

Wait till wilbert gets his hands on it, It'll become a fraction of fraction!

Your version seems to be working fine
Of course ASM will be faster but the drawback is that you have to code both a 32 bit and a 64 bit version.

Not sure myself either but it's not in my program. It was just part of the testing. I'm ForEaching a linked list.

Is there any reason to use a linked list ?
It would probably be a lot faster to put the bits immediately in a memory buffer instead of creating a linked list first.

[netmaestro]

Of course ASM will be faster but the drawback is that you have to code both a 32 bit and a 64 bit version.

You don't have to. The 32bit code will run fine on 64 won't it? And yes, the linked list is part of the "training wheels" version while I focused on getting the encoder working properly. I find if you tackle a project like this in stages it's easier to discover why early versions are failing because there's less complexity to the program.

It would be great if you could do a 32bit asm bytepacking version in case the speed does pick up significantly But only if you have the time to spare.

[wilbert]

Here's a concept of how it could be done using 32 bit asm.
I doubt if it will be faster since it's a procedure instead of a macro.
Speed improvement is to be expected if more of the compression would be done inside one ASM routine.
Unfortunately I don't understand exactly how the code table is build.
I know every entry is supposed to be representing a pattern but I don't know if a pattern is simply a 8 bit value or can be longer (for example a sequence of 64 bytes of 0)

Code: Select all

Global *buf, pos 
*buf = AllocateMemory(16) 

Procedure Setbits(val, bitcount)
  !mov edx, [v_pos]
  !mov eax, [p.v_val]
  !mov cl, dl
  !and cl, 7
  !shl eax, cl
  !mov ecx, [p.v_bitcount]
  !add ecx, edx
  !shr edx, 3
  !add edx, [p_buf]
  !or [edx], eax
  !mov [v_pos], ecx
EndProcedure

Setbits(%0101, 4)
Setbits(%0010, 4)
Setbits(%0111, 4)
Setbits(%1111, 4)
Setbits(%01010, 5)
Setbits(%01101, 5)
Setbits(%11111, 5)
Setbits(%011011, 6) 

Debug RSet(Bin(PeekQ(*buf),#PB_Quad),pos,"0") 

Global output.s 
For a = 0 To 4 
   output + RSet(Hex(PeekA(*buf+a),#PB_Ascii),2,"0") + " " 
Next    

Debug output

[netmaestro]

Here is the (rough) code I have so far. It's the beginning of a program to create GIFs. I haven't done transparency or animation yet but I'm on it and they're coming soon. It's taking me some time to do it, mainly because I started with my original 8bit image code and ripped all the windows-specific stuff out of it and had to write a lot of parts from scratch and then merge the LZW encoding and GIF structure stuff into it. Anyway, a basic version is working here now and it uses Idle's SetBits macro for now.

Could you please test this code and see how crossplatform it is? And let me know of any bugs/failures. Just bear in mind it's very early alpha code and some freeing and cleanup probably need done. Specifically I'd like to know how it performs on MacOS and Linux. If it fails somewhere on Linux or Mac, please let me know why and make suggestions for fixing it as I don't use those OS's.

Thanks, here's the code:

Code: Select all

;========================================================================================
;{                        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
;=============================================================

Structure RGB 
  Blue.a
  Green.a
  Red.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
  Sntroducer.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

Global   *tb.long, *buf, pos=0 ; for SetBits macro

Macro Setbits(buf,value,bitcount) ; By Idle
  *tb = buf + ((pos) >> 3) 
  *tb\l | (value << (pos %8))
  pos + bitcount 
EndMacro

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
EndDataSection

UsePNGImageDecoder()
UseJPEGImageDecoder() 
UseTIFFImageDecoder()

dither = 1

pattern$ = "PNG, BMP, JPEG, TIFF|*.png;*.bmp;*.jpg;*.jpeg;*.tiff|PNG (*.png)|*.png|BMP (*.bmp)|*.bmp|JPEG (*.jpg)|*.jpg|TIFF (*.tif)|*.tif"
inpath$ = OpenFileRequester("Choose an image to convert to GIF:","",pattern$, 0)
prompt$ = RemoveString(GetFilePart(inpath$),"."+GetExtensionPart(inpath$))
prompt$ +".gif"
If FileSize(inpath$) < 1
  MessageRequester("Info:","No file selected. Ending...")
  End
EndIf

If inpath$
  hImageIn = LoadImage(#PB_Any, inpath$) 
Else
  MessageRequester("Error:", "Cannot open this image. Ending...")
  End
EndIf

w=ImageWidth(hImageIn)
h=ImageHeight(hImageIn)

StartDrawing(ImageOutput(hImageIn))
  If w*h<1600
    *colorbits.COLORBITS_RGBQUAD = AllocateMemory(1600*4)
  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)
*bits8.COLORBITS_1BYTE_PERPIXEL = AllocateMemory(w*h)

NQ_SortNetwork() ; for NQ_LookupPalette to work properly

; Set and optionally dither the colorbits
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

Dim colors.l(255)
Numcolors = 256
CopyMemory(*palette, @colors(), MemorySize(*palette))
FreeMemory(*palette)
sz_colorbits = MemorySize(*bits8)

;Count actual colors used in the image
NewMap colormap.COLORMAPINDEX()
For i=*bits8 To *bits8+sz_colorbits-1
  If AddMapElement(colormap(), RSet(Hex(PeekA(i),#PB_Byte),2,"0"), #PB_Map_ElementCheck)
    colormap(RSet(Hex(PeekA(i),#PB_Byte),2,"0"))\color = colors(PeekA(i))
  EndIf
Next
NumColors = MapSize(colormap())

;If needed, shrink colortable To actual colors used And remap the colorbits To the new table
If NumColors < 256
  Dim colors2.l(MapSize(colormap())-1)
  cc=0
  ForEach colormap()
    colors2(cc) = colormap()\color
    colormap()\newindex = cc
    cc+1
  Next
  For i=*bits8 To *bits8+sz_colorbits-1
    PokeA(i, colormap(RSet(Hex(PeekA(i),#PB_Byte),2,"0"))\newindex)
  Next
Else
  Dim colors2.l(ArraySize(colors()))
  CopyArray(colors(), colors2())
EndIf
FreeArray(colors())

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

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

*write_header.GIF_HEADER = AllocateMemory(SizeOf(GIF_HEADER))
CopyMemory(?gifheader, *write_header, SizeOf(GIF_HEADER))

WriteData(0, *write_header, MemorySize(*write_header))

*write_logical_screen_descriptor.LOGICAL_SCREEN_DESCRIPTOR = AllocateMemory(SizeOf(LOGICAL_SCREEN_DESCRIPTOR))
With *write_logical_screen_descriptor
  \width      = w
  \height     = h
  \PackedByte = $80|(sz_colortable<<4)|sz_colortable
EndWith

WriteData(0, *write_logical_screen_descriptor, MemorySize(*write_logical_screen_descriptor))

*colortable = AllocateMemory(bytes_colortable)
*writeptr.RGB = *colortable
For i=0 To ArraySize(colors2())
  *writeptr\Red   = Red(colors2(i))
  *writeptr\Green = Green(colors2(i))
  *writeptr\Blue  = Blue(colors2(i))
  *writeptr+SizeOf(RGB)
Next

WriteData(0, *colortable, MemorySize(*colortable))

*write_graphics_control_extension.GRAPHICS_CONTROL_EXTENSION = AllocateMemory(SizeOf(GRAPHICS_CONTROL_EXTENSION))
CopyMemory(?graphicscontrolextension, *write_graphics_control_extension, SizeOf(GRAPHICS_CONTROL_EXTENSION))

WriteData(0, *write_graphics_control_extension, MemorySize(*write_graphics_control_extension))

*write_application_extension = AllocateMemory(27)
CopyMemory(?applicationextension, *write_application_extension, 19)
;WriteData(0, *write_application_extension, MemorySize(*write_application_extension))

*write_image_descriptor.IMAGE_DESCRIPTOR = AllocateMemory(SizeOf(IMAGE_DESCRIPTOR))
With *write_image_descriptor
  \Separator   = $2C
  \ImageWidth  = w
  \ImageHeight = h
EndWith

WriteData(0, *write_image_descriptor, MemorySize(*write_image_descriptor))

; Encode the colorbits

NewMap CodeTable.l(10000)
For i=0 To Numcolors-1
  CodeTable(RSet(Hex(i,#PB_Long),4,"0")) = i
Next

clrcode  = bytes_colortable/3 
endcode  = clrcode+1
nextcode = endcode+1

codesize=min_codesize+1

*buf = AllocateMemory(1024*1024*10)
Setbits(*buf, clrcode, codesize)

ib.s = RSet(Hex(PeekA(*bits8),#PB_Long),4,"0")
cc=1
While cc<MemorySize(*bits8)
  k.s = RSet(Hex(PeekA(*bits8+cc),#PB_Long),4,"0") : cc+1
  If FindMapElement(CodeTable(), ib+k)
    ib+k
  Else
    CodeTable(ib+k) = nextcode 
    nextcode+1
    Setbits(*buf, codetable(ib), codesize)
    If nextcode-2=Int(Pow(2,codesize))-1
      codesize+1
      If codesize>12
        Setbits(*buf, clrcode, 12)
        nextcode=endcode+1
        ClearMap(CodeTable())
        For i=0 To Numcolors-1
          CodeTable(RSet(Hex(i,#PB_Long),4,"0"))=i
        Next
        codesize=min_codesize+1
      EndIf
    EndIf
    ib=k : k=""
  EndIf
Wend

Setbits(*buf, codetable(ib), codesize)
Setbits(*buf, endcode, codesize)

WriteByte(0, min_codesize)

pos=pos+(8-pos%8)

cctotal = *buf+pos>>3 - *buf
*readbuf.Ascii = *buf
While cctotal>255
  WriteByte(0, 255)
  For i=1 To 255
    WriteByte(0, *readbuf\a)
    *readbuf+1
  Next
  cctotal-255
Wend

WriteByte(0, cctotal)
For i=1 To cctotal
  WriteByte(0, *readbuf\a)
  *readbuf+1
Next

WriteByte(0, $00)
WriteByte(0, $3B)

CloseFile(0)

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

[wilbert]

Tested on OS X ...

Constant #MAXLONG not found
Constant #MB_ICONINFORMATION not found
Structure RGBQUAD not found

[netmaestro]

Thanks! Fixed those, could you retry?

[wilbert]

Thanks! Fixed those, could you retry?

It compiles now and can output a gif file.
The problem is that the gif file contains errors (image application can't open it).
Looking with a hex editor I don't see any obvious problems

[netmaestro]

Bummer. I have a dozen or so files here of differing sizes and depths and they all encode fine on Windows. Maybe try not writing the applicationextension bytes, see if that helps. I did have a comment extension in there before and some decoders choked on it so I took it out.

[wilbert]

Here's a dump of a generated gif file that doesn't work and it's png source image

Code: Select all

DataSection

  test_gif_start:
    ; size : 142 bytes
    Data.q $0000613938464947,$0000FF0000910000,$0000000000000000,$0000000004F92100,$5354454E0BFF2100
    Data.q $03302E3245504143,$0000000000000001,$0000002C00000000,$4402000040004000,$9CA30FEDCBA98F84
    Data.q $0FFBBCDEB38BDAB4,$EAA689E69648E286,$D74CF2C70BEEB6CA,$0FFEF7CEFAE78DF6,$4C88F1A2C4870A0C
    Data.q $4A8D09F3A6CC972A,$B76ACD8AF5AAD4A7
    Data.b $DC,$AE,$17,$50,$00,$3B
  test_gif_end:

  test_png_start:
    ; size : 172 bytes
    Data.q $0A1A0A0D474E5089,$524448490D000000,$4000000040000000,$E60B250000000208,$5845741900000089
    Data.q $72617774666F5374,$2065626F64410065,$6165526567616D49,$00003C65C9717964,$DA78544144494E00
    Data.q $030800000D31CFEC,$D24DC093345FE630,$8080808B7E76683A,$8080808080808080,$8080808080808080
    Data.q $8080808080808080,$8080808080808080,$8080808080808080,$000C02A5C0808080,$C422F9DD0140606C
    Data.q $444E454900000000
    Data.b $AE,$42,$60,$82
  test_png_end:

EndDataSection