The canvas gadget will probably never support 32bit depth, for one very good reason: It would kill performance for animations dead. In order to support 32bit depths, each refresh of the gadget would have to go through all the alphablending operations needed to render the output properly and that is just way too slow for anything animated or really anything that needs updated a lot. This change was made for the Image Gadget a few years ago and everyone found out very quickly that if you need animation or a lot of fast updates you'd better have a 24bit image in there or you're going to be one sad sack indeed.
8 bit images contain a 256-entry color table of RGBQUAD values and an array of bytes each of which contains the 0-255 index location of the color to represent. There is no green or blue channel to remain unused. However, if an 8 bit image can be of use to you, and if you're using Windows, I've done some work in that area which you are welcome to use. It will convert any image to 8bit depth and/or save as BMP or GIF:
Code: Select all
;=====================================================================================
; Library commands: ConvertTo8bit(), Save8bitImage(), SaveGIF()
; Author: Lloyd Gallant (netmaestro), luis
; Date: December 12, 2008
; Target OS: Microsoft Windows All
; Target Compiler: PureBasic 4.40 and later
; License: Free, unrestricted, no warranty
;
; Usage: ConvertTo8bit(hImageIn, dither)
;
; hImageIn: Is the 16,24 or 32bit image handle to reduce to 8bit depth
; dither: boolean telling the function whether or not to
; apply Floyd-Steinberg dithering to the image
;
; Usage: Save8bitImage(image, filename$ [,memory])
;
; image: Is an 8bit image handle to save to disk or memory
; filename$: Is the name to save it to.
; memory: Is a boolean which if true, will cause the procedure to return
; a memory block containing the complete bitmap file. You may
; compress this and send it over a network or catch the image
; from the returned pointer as desired. You must free the pointer
; when you're finished to avoid a memory leak.
;
; Usage: SaveGIF(hImagein, outpath$)
;
; hImageIn: Is the handle of the image to reduce to 8bit depth and save as GIF
; outpath$ Is the pathname/filename to save it to.
;
;=====================================================================================
;/* 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 ]
Structure T_RGBTRIPLE
rgbtBlue.b
rgbtGreen.b
rgbtRed.b
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
;
; Converted 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
;}
ProcedureDLL Save8bitImage(image, filename$, memory=0)
If GetObject_(image, SizeOf(BITMAP), Bmp.BITMAP)
With BmiInfo.BITMAPINFOHEADER
\biSize = SizeOf(BITMAPINFOHEADER)
\biWidth = Bmp\bmWidth
\biHeight = Bmp\bmHeight
\biPlanes = 1
\biBitCount = 8
EndWith
Else
ProcedureReturn 0
EndIf
sz_colorbits = Bmp\bmWidthBytes*Bmp\bmHeight
*colortable = AllocateMemory(256*SizeOf(RGBQUAD))
dc = CreateDC_("DISPLAY",0,0,0)
hdc = CreateCompatibleDC_(dc)
SelectObject_(hdc, image)
NumColors = GetDIBColorTable_(hdc, 0, 256, *colortable)
DeleteDC_(dc)
DeleteDC_(hdc)
sz_image = SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER) + NumColors*SizeOf(RGBQUAD) + sz_colorbits
*rawimage = AllocateMemory(sz_image)
*fileheader.BITMAPFILEHEADER = *rawimage
*header = *rawimage + SizeOf(BITMAPFILEHEADER)
With *fileheader
\bfType = PeekW(@"BM")
\bfSize = sz_image
\bfOffBits = SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER) + NumColors*SizeOf(RGBQUAD)
EndWith
CopyMemory(BmiInfo, *header, SizeOf(BITMAPINFOHEADER))
CopyMemory(*colortable, *rawimage + SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER), NumColors*SizeOf(RGBQUAD))
CopyMemory(Bmp\bmBits, *rawimage + SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER) + NumColors*SizeOf(RGBQUAD), sz_colorbits)
FreeMemory(*colortable)
If Not memory
file = CreateFile(#PB_Any, filename$)
If file
WriteData(file,*rawimage,MemorySize(*rawimage))
CloseFile(file)
EndIf
FreeMemory(*rawimage)
ProcedureReturn 1
Else
ProcedureReturn *rawimage
EndIf
EndProcedure
Procedure Get32BitColors(pBitmap)
GetObject_(pBitmap, SizeOf(BITMAP), @bmp.BITMAP)
*bmi.BITMAPINFO = AllocateMemory(SizeOf(BITMAPINFO)+SizeOf(RGBQUAD)*255)
With *bmi\bmiHeader
\biSize = SizeOf(BITMAPINFOHEADER)
\biWidth = bmp\bmWidth
\biHeight = bmp\bmHeight
\biPlanes = 1
\biBitCount = 32
EndWith
hDC = GetWindowDC_(#Null)
GetDIBits_(hDC, pBitmap, 0, bmp\bmHeight, #Null, *bmi, #DIB_RGB_COLORS)
*pPixels = AllocateMemory(*bmi\bmiHeader\biSizeImage)
iRes = GetDIBits_(hDC, pBitmap, 0, bmp\bmHeight, *pPixels, *bmi, #DIB_RGB_COLORS)
ReleaseDC_(#Null, hDC)
FreeMemory(*bmi)
ProcedureReturn *pPixels
EndProcedure
Procedure.i CreatePalette_NeuQuant (hImage, iQuality=10)
; by luis
; return a *ptr to memory containing 256 RGBQUAD structures
; allocated memory must be freed by the caller
Protected *ImageBuf, *Palette, k
Protected Dim tPaletteTable.RGBQUAD(256)
*ImageBuf = Get32BitColors(hImage)
If *ImageBuf
NQ_InitNetwork()
If NQ_Learn(*ImageBuf, MemorySize(*ImageBuf), iQuality)
NQ_UnbiasNetwork()
FreeMemory(*ImageBuf)
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))
If *Palette
CopyMemory(@tPaletteTable(), *Palette, MemorySize(*Palette))
EndIf
Else
FreeMemory(*ImageBuf)
EndIf
EndIf
ProcedureReturn *Palette
EndProcedure
ProcedureDLL ConvertTo8bit(hImageIn, dither)
If GetObjectType_(hImageIn) <> #OBJ_BITMAP
ProcedureReturn 0 ; not a bitmap
EndIf
GetObject_(hImageIn,SizeOf(BITMAP),bmp.BITMAP)
w = bmp\bmWidth
h = bmp\bmHeight
d = bmp\bmBitsPixel
If d < 24
ProcedureReturn 0 ; depth not 24 or 32
EndIf
If w*h<1600
If w<h
tmpw=64:tmph=Round((64.0/w)*h,#PB_Round_Nearest)
ElseIf h<w
tmph=64:tmpw = Round((64.0/h)*w,#PB_Round_Nearest)
Else
tmpw=64 : tmph=64
EndIf
tmpimage = CreateImage(#PB_Any, w,h,24)
StartDrawing(ImageOutput(tmpimage))
DrawImage(hImageIn,0,0)
StopDrawing()
ResizeImage(tmpimage, tmpw,tmph, #PB_Image_Raw)
hImagetmp = ImageID(tmpimage)
*palette.PALETTE = CreatePalette_NeuQuant(hImagetmp)
FreeImage(tmpimage)
Else
*palette.PALETTE = CreatePalette_NeuQuant(hImageIn)
EndIf
hdcSrc = CreateCompatibleDC_(0)
With bmi.BITMAPINFO
\bmiHeader\biSize = SizeOf(BITMAPINFOHEADER)
\bmiHeader\biWidth = w
\bmiHeader\biHeight = h
\bmiHeader\biPlanes = 1
\bmiHeader\biBitCount = 32
EndWith
GetDIBits_(hdcSrc, hImageIn, 0, 0, #Null, @bmi, #DIB_RGB_COLORS)
*colorbits.COLORBITS_RGBQUAD = AllocateMemory(bmi\bmiHeader\biSizeImage)
GetDIBits_(hdcSrc, hImageIn, 0, h, *colorbits, @bmi, #DIB_RGB_COLORS)
With bmi8.BITMAPINFO
\bmiHeader\biSize = SizeOf(BITMAPINFOHEADER)
\bmiHeader\biWidth = w
\bmiHeader\biHeight = h
\bmiHeader\biPlanes = 1
\bmiHeader\biBitCount = 8
EndWith
hdcDest = CreateCompatibleDC_(0)
hImageOut = CreateDIBSection_(hdcDest, @bmi8, #DIB_PAL_COLORS, @*bits8.COLORBITS_1BYTE_PERPIXEL, 0, 0)
GetObject_(hImageout, SizeOf(bitmap), bmpout.bitmap)
widthbytes=bmpout\bmwidthbytes
SelectObject_(hdcDest, hImageOut)
SetDIBColorTable_(hdcDest,0,256,*palette)
szImage = widthbytes*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*widthbytes] = index
If dither
compute_disperse(rgbRed)
compute_disperse(rgbGreen)
compute_disperse(rgbBlue)
EndIf
Next
Next
DeleteDC_(hdcSrc)
DeleteDC_(hdcDest)
FreeMemory(*colorbits)
FreeMemory(*palette)
ProcedureReturn hImageOut
EndProcedure
;=============================================================
;{ Save as GIF Section
;=============================================================
Global *token, *image, lib
Prototype GdiplusStartup( *token, *input, mode )
Prototype GdipCreateBitmapFromHBITMAP(*hBitmap, *palette, *image)
Prototype GdipSetImagePalette(*image, *palette)
Prototype GdipSaveImageToFile(*image, *path, *clsid, *enc)
Prototype GdipDisposeImage( *image )
Prototype GdiplusShutdown( *token )
Global Startup.GdiplusStartup
Global CreateBitmapFromHBITMAP.GdipCreateBitmapFromHBITMAP
Global SetImagePalette.GdipSetImagePalette
Global SaveImageToFile.GdipSaveImageToFile
Global DisposeImage.GdipDisposeImage
Global Shutdown.GdiplusShutdown
CompilerIf Defined(GdiplusStartupInput, #PB_Structure) = 0
Structure GdiplusStartupInput
GdiPlusVersion.l
*DebugEventCallback.Debug_Event
SuppressBackgroundThread.l
SuppressExternalCodecs.l
EndStructure
CompilerEndIf
ProcedureDLL SaveGIF(hImageIn, outpath$)
lib = OpenLibrary(#PB_Any, "gdiplus.dll")
If Not lib
MessageRequester("Error","Required component gdiplus.dll is not found. Please install it and retry ", #MB_ICONERROR)
ProcedureReturn
EndIf
input.GdiplusStartupInput
input\GdiPlusVersion = 1
Startup.GdiplusStartup = GetFunction( lib, "GdiplusStartup" )
CreateBitmapFromHBITMAP.GdipCreateBitmapFromHBITMAP = GetFunction( lib, "GdipCreateBitmapFromHBITMAP" )
SetImagePalette.GdipSetImagePalette = GetFunction( lib, "GdipSetImagePalette" )
SaveImageToFile.GdipSaveImageToFile = GetFunction( lib, "GdipSaveImageToFile" )
DisposeImage.GdipDisposeImage = GetFunction( lib, "GdipDisposeImage" )
Shutdown.GdiplusShutdown = GetFunction( lib, "GdiplusShutdown" )
Startup( @*token, @input, #Null)
Unicode$=Space(Len(outpath$)*2+2)
PokeS(@Unicode$, outpath$, -1, #PB_Unicode)
*outpath = SysAllocString_(@Unicode$)
image8 = ConvertTo8bit(hImageIn, 1)
CreateBitmapFromHBITMAP(image8, 0, @*gdip_image_object)
If SaveImageToFile( *gdip_image_object, *outpath, ?clsid_gif, 0) = #S_OK
result = #True
Else
result = #False
EndIf
DisposeImage(*gdip_image_object)
Shutdown(*token)
CloseLibrary(lib)
ProcedureReturn result
EndProcedure
DataSection
clsid_gif: ; clsid for gif image format
Data.l $557cf402
Data.w $1a04
Data.w $11d3
Data.b $9a,$73,$00,$00,$f8,$1e,$f3,$2e
EndDataSection
;}
