Title : Save animated GIFs
Author : Pineapple
Posted : 1+ years ago
Description : Dependencies:
pine.heap: <a href="codearcs544e.html?code=2970" target="_blank">http://blitzbasic.com/codearcs/codearcs.php?code=2970</a> - required for automatic palette creation
pine.HashTable: <a href="../Community/posts6a58.html?topic=97992#1141947" target="_blank">http://blitzbasic.com/Community/posts.php?topic=97992#1141947</a> - required for lzw compression algorithm
log2.bmx: <a href="codearcsc919.html?code=2965" target="_blank">http://blitzbasic.com/codearcs/codearcs.php?code=2965</a> - required for writing various bits of the GIF file format
Code :
' --+-----------------------------------------------------------------------------------------+--
' | This code was originally written by Sophie Kirschner (sophiek@pineapplemachine.com) |
' | It is released as public domain. Please don't interpret that as liberty to claim credit |
' | that isn't yours, or to sell this code when it could otherwise be obtained for free |
' | because that would be a really shitty thing of you to do. |
' --+-----------------------------------------------------------------------------------------+--
SuperStrict
Import brl.stream
Import brl.math
Import brl.pixmap
Import pine.HashTable ' http://blitzbasic.com/Community/posts.php?topic=97992#1141947
Import pine.heap ' http://blitzbasic.com/codearcs/codearcs.php?code=2970
Import "log2.bmx" ' http://blitzbasic.com/codearcs/codearcs.php?code=2965
' Example code
Rem
Local t:TPixmap[4]
For Local i%=0 To 3
t[i]=CreatePixmap(128,128,pf_rgb888)
Next
ClearPixels t[0],$ff0000
ClearPixels t[1],$00ff00
ClearPixels t[2],$0070ff
ClearPixels t[3],$eeee00
SavePixmapsGIF t,"test.gif",100
EndRem
Rem
bbdoc: Save a Pixmap in GIF format
EndRem
Function SavePixmapGIF%(pix:TPixmap,url:Object,maxcolorcount%=256,tolerance%=-1,sub%=1,add%=2)
If tolerance=-1 Then tolerance=768/maxcolorcount
Local pal%[]=MakePalFromPixmap([pix],maxcolorcount,tolerance,sub,add,0)
Local f:TStream=WriteStream(url)
If Not f Then Return False
WriteGif f,[pix],pal
CloseStream f
Return True
End Function
Rem
bbdoc: Save multiple pixmaps as an animation in GIF format
EndRem
Function SavePixmapsGIF%(pix:TPixmap[],url:Object,framedelay%,maxcolorcount%=256,tolerance%=-1,sub%=1,add%=2)
If tolerance=-1 Then tolerance=768/maxcolorcount
Local pal%[]=MakePalFromPixmap(pix,maxcolorcount,tolerance,sub,add,0)
Local f:TStream=WriteStream(url)
If Not f Then Return False
WriteGif f,pix,pal,[framedelay]
CloseStream f
Return True
End Function
Rem
bbdoc: Automatically generate a palette from one or more pixmaps.
about:
images:TPixmap[] is an array containing one or more pixmaps from which to operate
maxcolorcount% is the maximum number of colors allowed - set to 0 to return a basic palette of 8 colors.
tolerance% is a variable controlling how different two colors should be in order to be counted as separate
sub%, add% control how colors are prioritized and their precise effect can be very arbitrary. experimentation with different values for these and tolerance is highly recommended.
note: sub:add is treated as a ratio - sub=1,add=2 will produce the same result as sub=2,add=4.
transparency% specifies whether colors which are fully transparent should be ignored
EndRem
Global basicpal%[]=[$ffffff,$ff0000,$00ff00,$0000ff,$ffff00,$ff00ff,$00ffff,$000000,$808080]
Function MakePalFromPixmap%[](images:TPixmap[],maxcolorcount%=256,tolerance%=64,sub%=1,add%=2,transparency%=0)
If maxcolorcount=0 Then Return basicpal
Local colors:TList=CreateList(),rgb%
For Local p:TPixmap=EachIn images
If Not p Then Continue
For Local x%=0 To PixmapWidth(p)-1
For Local y%=0 To PixmapHeight(p)-1
If (y Mod 4) Then Continue
rgb=ReadPixel(p,x,y)
If transparency And Not (rgb & $ff000000) Then Continue
Local this:_cdata=New _cdata
this.r=rgb Shr 16
this.g=rgb Shr 8
this.b=rgb
Local found:TLink=Null,foundd%=0
Local on:TLink=colors._head._succ,c:_cdata
While on<>on._value
c=_cdata(on._value)
Local fd%=c.distance(this)
If fd<=tolerance Then
If (Not found) Or fd<=foundd
found=on
foundd=fd
_cdata(found._value).pop:-sub
If fd=0 Then Exit
EndIf
EndIf
on=on._succ
Wend
If found
_cdata(found._value).pop:+add
movelinktofront found,colors
Else
colors.addfirst this
EndIf
Next
Next
Next
Local cheap:THeap=CreateHeap()
For Local c:_cdata=EachIn colors
HeapInsert cheap,c
Next
Local ret%[]=New Int[Min(maxcolorcount,CountHeap(cheap))]
For Local x%=0 To ret.length-1
Local c:_cdata=_cdata(HeapRemove(cheap))
ret[x]=$ff000000|(c.r Shl 16)|(c.g Shl 8)|c.b
Next
Return ret
End Function
Rem
bbdoc: Write an array of pixmaps to a stream as an animated GIF
about:
f:TStream is the stream to which the GIF will be written
pixmaps:TPixmap[] is an array containing each frame as an individual pixmap
pal%[] is an array containing up to 256 colors and will be used as the palette
animdelay%[] is an array containing the duration (in 100ths of a second) of each frame. if this array is shorter than the pixmaps array then the frame delay to be used is the value in the index of the current frame modulo the number of frame delays defined.
looptimes% is how many times the animation should loop when viewed. $ffff indicates that it should loop forever.
transparentcolor% defines which index of the palette should be flagged as the transparent background color. -1 indicates that there is no transparent color.
animwidth% is the width of the animation. -1 indicates that it should be determined automatically as the maximum width of all the frames.
animheight% is the height of the animation. -1 indicates that it should be determined automatically as the maximum height of all the frames.
EndRem
Function WriteGIF(f:TStream,pixmaps:TPixmap[],pal%[],animdelay%[]=Null,looptimes%=$ffff,transparentcolor%=-1,animwidth%=-1,animheight%=-1)
Assert f,"Encountered null stream."
Assert pal,"Encountered null palette."
Assert pixmaps,"Encountered null pixmap array."
Assert pal.length<=256,"Palette too long. (GIF supports sizes only up to 256)"
Local logical_width%=animwidth,logical_height%=animheight
Local detw%=animwidth=-1,deth%=animheight=-1
For Local pix:TPixmap=EachIn pixmaps
Assert pix,"Encountered null pixmap."
If detw logical_width=Max(pix.width,logical_width)
If deth logical_height=Max(pix.height,logical_height)
Next
' header
WriteString f,"GIF89a"
' logical screen descriptor
WriteShort f,logical_width
WriteShort f,logical_height
Local lbits%=%11110000 | ((clog2(pal.length)-1))
WriteByte f,lbits
WriteByte f,0
WriteByte f,0
' global color table
gifwritepalette f,pal
' application extension block
WriteByte f,$21
WriteByte f,$ff
WriteByte f,11
WriteString f,"NETSCAPE"
WriteString f,"2.0"
WriteByte f,3
WriteByte f,1
WriteShort f,looptimes
WriteByte f,0
' write frames
Local di%=0
For Local pix:TPixmap=EachIn pixmaps
Local del%=1
If animdelay Then del=animdelay[di Mod animdelay.length]
WriteGIFFrame f,pix,pal,del,0,0,transparentcolor,False
di:+1
Next
WriteByte f,$3b
End Function
Rem
bbdoc: Writes an individual pixmap to a stream as the frame of a GIF image.
f:TStream is the stream to which the GIF will be written
pix:TPixmap is the pixmap to write
pal%[] is an array containing up to 256 colors and will be used as the palette
framedelay% is how long in 100ths of a second the frame should last when animating
xcorner% is the x offset (left toward right) of this frame in the animation
ycorner% is the y offset (top toward bottom) of this frame in the animation
transparentcolor% defines which index of the palette should be flagged as the transparent background color. -1 indicates that there is no transparent color.
localtable% is a flag that decides whether the palette should be considered unique to this frame of the GIF animation
EndRem
Function WriteGIFFrame(f:TStream,pix:TPixmap,pal%[],framedelay%=50,xcorner%=0,ycorner%=0,transparentcolor%=-1,localtable%=True)
' graphic control exension
WriteByte f,$21
WriteByte f,$f9
WriteByte f,$04
Local hastransparentcolor%=(transparentcolor>-1)
WriteByte f,hastransparentcolor
WriteShort f,framedelay
WriteByte f,transparentcolor*hastransparentcolor
WriteByte f,$00
' image descriptor
WriteByte f,$2c
WriteShort f,xcorner ' location of x corner
WriteShort f,ycorner ' y corner
WriteShort f,pix.width
WriteShort f,pix.height
If localtable Then
WriteByte f,%10000000 | ((clog2(pal.length)-1) Shl 4)
gifwritepalette f,pal
Else
WriteByte f,0
EndIf
Local bpp%=Max(clog2(pal.length),2)
WriteByte f,bpp
' lzw-compress the data
Local minsize%=bpp+1
Const maxsize%=12
Local clearcode%=1 Shl bpp
Local endcode%=clearcode+1
Local startoncode%=endcode+1
Local oncode%=startoncode
Local currentsize%=minsize
Local firstcode:lzwc=lzwc.Create(currentsize,clearcode)
Local thiscode:lzwc=firstcode
Local c$="",ck$,k$
Local bitlength%=currentsize
Local table:HashTable=_lzwtable(minsize)
Local yv%=0
For Local y%=0 Until pix.height
For Local x%=0 Until pix.width
Local val%=gifgetclosestpalcolor(pix.ReadPixel(x,y),pal,pal.length)
k=Chr(val);ck=c+k
If table.find(ck)
c=ck
Else
thiscode.succ=lzwc.Create(currentsize,lzwi(table.find(c)).value)
bitlength:+currentsize
thiscode=thiscode.succ
table.insert ck,lzwi.Create(oncode);oncode:+1
c=k
If clog2(oncode)>currentsize Then
If currentsize=maxsize Then
thiscode.succ=lzwc.Create(currentsize,clearcode)
thiscode=thiscode.succ
bitlength:+currentsize
currentsize=minsize
oncode=startoncode
table=_lzwtable(minsize)
Else
currentsize:+1
EndIf
EndIf
EndIf
Next
yv:+pix.width
Next
thiscode.succ=lzwc.Create(currentsize,lzwi(table.find(c)).value)
thiscode.succ.succ=lzwc.Create(currentsize,endcode)
bitlength:+currentsize+currentsize
' turn into an array of bytes
Local data@[Ceil(bitlength/8.0)],onbit%=0
thiscode=firstcode;firstcode=Null
While thiscode
For Local i%=0 Until thiscode.bits
Local di%=onbit Shr 3
Local thisbit%=(((thiscode.value Shr i)&1) Shl (onbit&7))
data[di]=data[di] | thisbit
onbit:+1
Next
Local n:lzwc=thiscode.succ;thiscode.succ=Null;thiscode=n
Wend
' write the bytes
For Local i%=0 Until data.length
If (i Mod 255)=0 Then
Local chunksize%=Min(255,data.length-i)
WriteByte f,chunksize
EndIf
WriteByte f,data[i]
Next
WriteByte f,$00
End Function
' Writes a palette for a GIF image
Function gifwritepalette(f:TStream,pal%[])
For Local i%=0 Until (1 Shl clog2(pal.length))
If i<pal.length
WriteByte f,(pal[i] Shr 16) '& $ff
WriteByte f,(pal[i] Shr 8) '& $ff
WriteByte f,(pal[i]) '& $ff
Else
WriteByte f,0;WriteByte f,0;WriteByte f,0
EndIf
Next
End Function
' Finds the closest color in a palette to a given color
Global cachedcolor%=0
Function gifgetclosestpalcolor%(argb%,pal% Ptr,pallength%)
' note: ignores alpha
Local besti%=cachedcolor,bestdist%=gifgetcolordistance(argb,pal[cachedcolor])
For Local i%=0 Until pallength
Local d%=gifgetcolordistance(argb,pal[i])
If d<bestdist Then
besti=i;bestdist=d
EndIf
If bestdist=0 Exit
Next
Return besti
End Function
' Gets the distance from one color to another, slightly adjusted to account for luminosity
Function gifgetcolordistance%(argb1%,argb2%)
Local r1%=(argb1 Shr 16)&$ff
Local g1%=(argb1 Shr 8)&$ff
Local b1%=(argb1)&$ff
Local r2%=(argb2 Shr 16)&$ff
Local g2%=(argb2 Shr 8)&$ff
Local b2%=(argb2)&$ff
Return (Abs(r1-r2) Shl 1)+(Abs(g1-g2) Shl 2)+Abs(b1-b2)
End Function
Private
' Returns a new hash table to be used as the string table in lzw compression
Function _lzwtable:HashTable(minsize%)
Local ret:HashTable=CreateHash(1 Shl minsize,_lzwhash)
For Local i%=0 Until (1 Shl minsize)
ret.insert Chr(i),lzwi.Create(i)
Next
Return ret
End Function
' Hash function, should be faster and well-suited to the specific data going in from the lzw compression
Function _lzwhash%(str$)
Local ret%=str.length
For Local i%=0 Until str.length
ret:+(str[i] Shl ((i&7) Shl 4))
Next
Return ret
End Function
' integer container object because I couldn't be arsed to write a hash table specifically for the lzw compression algorithm (and pine.hash can only contain objects)
Type lzwi
Field value%
Function Create:lzwi(value%)
Local n:lzwi=New lzwi
n.value=value
Return n
End Function
End Type
' lzw code object containing a value, the number of bits needed to represent that value, and the next code in the series
Type lzwc
Field bits%
Field value%
Field succ:lzwc
Function Create:lzwc(bits%,value%)
Local n:lzwc=New lzwc
n.bits=bits
n.value=value
Return n
End Function
End Type
' object used for constructing a limited palette from a pixmap
Type _cdata
Field r@,g@,b@
Field pop%=1
Function Create:_cdata(r%,g%,b%)
Local c:_cdata=New _cdata
c.r=r;c.g=g;c.b=b
Return c
End Function
Method distance%(o:_cdata)
Return (Abs(r-o.r) Shl 1)+(Abs(g-o.g) Shl 2)+Abs(b-o.b)
End Method
Method compare%(o1:Object)
If pop>_cdata(o1).pop Return 1
Return -1
End Method
End Type
' moves a TLink to the front of a TList
Function movelinktofront(link:TLink,list:TList)
If link=list.firstlink() Then Return
link._succ._pred=link._pred
link._pred._succ=link._succ
link._pred=list._head
link._succ=list._head._succ
link._succ._pred=link
list._head._succ=link
End Function
Comments : none...