December 03, 2020, 08:45:36 PM

Author Topic: [bmx] Save animated GIFs by Pineapple [ 1+ years ago ]  (Read 759 times)

Offline BlitzBot

  • Jr. Member
  • **
  • Posts: 1
[bmx] Save animated GIFs by Pineapple [ 1+ years ago ]
« on: June 29, 2017, 12:28:42 AM »
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[/url] - 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[/url] - required for lzw compression algorithm
log2.bmx: <a href="codearcsc919.html?code=2965" target="_blank">http://blitzbasic.com/codearcs/codearcs.php?code=2965[/url] - required for writing various bits of the GIF file format


Code :
Code: BlitzMax
  1. '       --+-----------------------------------------------------------------------------------------+--
  2. '         |   This code was originally written by Sophie Kirschner (sophiek@pineapplemachine.com)   |  
  3. '         | It is released as public domain. Please don't interpret that as liberty to claim credit |  
  4. '         |   that isn't yours, or to sell this code when it could otherwise be obtained for free   |  
  5. '         |                because that would be a really shitty thing of you to do.                |
  6. '       --+-----------------------------------------------------------------------------------------+--
  7.  
  8.  
  9. SuperStrict
  10.  
  11. Import brl.stream
  12. Import brl.math
  13. Import brl.pixmap
  14. Import pine.HashTable ' http://blitzbasic.com/Community/posts.php?topic=97992#1141947
  15. Import pine.heap ' http://blitzbasic.com/codearcs/codearcs.php?code=2970
  16. Import "log2.bmx" ' http://blitzbasic.com/codearcs/codearcs.php?code=2965
  17.  
  18.  
  19. ' Example code
  20. Rem
  21. Local t:TPixmap[4]
  22. For Local i%=0 To 3
  23.         t[i]=CreatePixmap(128,128,pf_rgb888)
  24. Next
  25. ClearPixels t[0],$ff0000
  26. ClearPixels t[1],$00ff00
  27. ClearPixels t[2],$0070ff
  28. ClearPixels t[3],$eeee00
  29. SavePixmapsGIF t,"test.gif",100
  30. EndRem
  31.  
  32.  
  33. Rem
  34. bbdoc: Save a Pixmap in GIF format
  35. EndRem
  36. Function SavePixmapGIF%(pix:TPixmap,url:Object,maxcolorcount%=256,tolerance%=-1,sub%=1,add%=2)
  37.         If tolerance=-1 Then tolerance=768/maxcolorcount
  38.         Local pal%[]=MakePalFromPixmap([pix],maxcolorcount,tolerance,sub,add,0)
  39.         Local f:TStream=WriteStream(url)
  40.         If Not f Then Return False
  41.         WriteGif f,[pix],pal
  42.         CloseStream f
  43.         Return True
  44. End Function
  45.  
  46. Rem
  47. bbdoc: Save multiple pixmaps as an animation in GIF format
  48. EndRem
  49. Function SavePixmapsGIF%(pix:TPixmap[],url:Object,framedelay%,maxcolorcount%=256,tolerance%=-1,sub%=1,add%=2)
  50.         If tolerance=-1 Then tolerance=768/maxcolorcount
  51.         Local pal%[]=MakePalFromPixmap(pix,maxcolorcount,tolerance,sub,add,0)
  52.         Local f:TStream=WriteStream(url)
  53.         If Not f Then Return False
  54.         WriteGif f,pix,pal,[framedelay]
  55.         CloseStream f
  56.         Return True
  57. End Function
  58.  
  59. Rem
  60. bbdoc: Automatically generate a palette from one or more pixmaps.
  61. about:
  62. images:TPixmap[] is an array containing one or more pixmaps from which to operate
  63. maxcolorcount% is the maximum number of colors allowed - set to 0 to return a basic palette of 8 colors.
  64. tolerance% is a variable controlling how different two colors should be in order to be counted as separate
  65. 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.
  66. note: sub:add is treated as a ratio - sub=1,add=2 will produce the same result as sub=2,add=4.
  67. transparency% specifies whether colors which are fully transparent should be ignored
  68. EndRem
  69. Global basicpal%[]=[$ffffff,$ff0000,$00ff00,$0000ff,$ffff00,$ff00ff,$00ffff,$000000,$808080]
  70. Function MakePalFromPixmap%[](images:TPixmap[],maxcolorcount%=256,tolerance%=64,sub%=1,add%=2,transparency%=0)
  71.         If maxcolorcount=0 Then Return basicpal
  72.         Local colors:TList=CreateList(),rgb%
  73.         For Local p:TPixmap=EachIn images
  74.                 If Not p Then Continue
  75.                 For Local x%=0 To PixmapWidth(p)-1
  76.                 For Local y%=0 To PixmapHeight(p)-1
  77.                         If (y Mod 4) Then Continue
  78.                         rgb=ReadPixel(p,x,y)
  79.                         If transparency And Not (rgb & $ff000000) Then Continue
  80.                         Local this:_cdata=New _cdata
  81.                         this.r=rgb Shr 16
  82.                         this.g=rgb Shr 8
  83.                         this.b=rgb
  84.                         Local found:TLink=Null,foundd%=0
  85.                         Local on:TLink=colors._head._succ,c:_cdata
  86.                         While on<>on._value
  87.                                 c=_cdata(on._value)
  88.                                 Local fd%=c.distance(this)
  89.                                 If fd<=tolerance Then
  90.                                         If (Not found) Or fd<=foundd
  91.                                                 found=on
  92.                                                 foundd=fd
  93.                                                 _cdata(found._value).pop:-sub
  94.                                                 If fd=0 Then Exit
  95.                                         EndIf
  96.                                 EndIf
  97.                                 on=on._succ
  98.                         Wend
  99.                         If found
  100.                                 _cdata(found._value).pop:+add
  101.                                 movelinktofront found,colors
  102.                         Else
  103.                                 colors.addfirst this
  104.                         EndIf
  105.                 Next
  106.                 Next
  107.         Next
  108.         Local cheap:THeap=CreateHeap()
  109.         For Local c:_cdata=EachIn colors
  110.                 HeapInsert cheap,c
  111.         Next
  112.         Local ret%[]=New Int[Min(maxcolorcount,CountHeap(cheap))]
  113.         For Local x%=0 To ret.length-1
  114.                 Local c:_cdata=_cdata(HeapRemove(cheap))
  115.                 ret[x]=$ff000000|(c.r Shl 16)|(c.g Shl 8)|c.b
  116.         Next
  117.         Return ret
  118. End Function
  119.  
  120. Rem
  121. bbdoc: Write an array of pixmaps to a stream as an animated GIF
  122. about:
  123. f:TStream is the stream to which the GIF will be written
  124. pixmaps:TPixmap[] is an array containing each frame as an individual pixmap
  125. pal%[] is an array containing up to 256 colors and will be used as the palette
  126. 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.
  127. looptimes% is how many times the animation should loop when viewed. $ffff indicates that it should loop forever.
  128. transparentcolor% defines which index of the palette should be flagged as the transparent background color. -1 indicates that there is no transparent color.
  129. animwidth% is the width of the animation. -1 indicates that it should be determined automatically as the maximum width of all the frames.
  130. animheight% is the height of the animation. -1 indicates that it should be determined automatically as the maximum height of all the frames.
  131. EndRem
  132. Function WriteGIF(f:TStream,pixmaps:TPixmap[],pal%[],animdelay%[]=Null,looptimes%=$ffff,transparentcolor%=-1,animwidth%=-1,animheight%=-1)
  133.         Assert f,"Encountered null stream."
  134.         Assert pal,"Encountered null palette."
  135.         Assert pixmaps,"Encountered null pixmap array."
  136.         Assert pal.length<=256,"Palette too long. (GIF supports sizes only up to 256)"
  137.         Local logical_width%=animwidth,logical_height%=animheight
  138.         Local detw%=animwidth=-1,deth%=animheight=-1
  139.         For Local pix:TPixmap=EachIn pixmaps
  140.                 Assert pix,"Encountered null pixmap."
  141.                 If detw logical_width=Max(pix.width,logical_width)
  142.                 If deth logical_height=Max(pix.height,logical_height)
  143.         Next
  144.         ' header
  145.         WriteString f,"GIF89a"
  146.         ' logical screen descriptor
  147.         WriteShort f,logical_width
  148.         WriteShort f,logical_height
  149.         Local lbits%=%11110000 | ((clog2(pal.length)-1))
  150.         WriteByte f,lbits
  151.         WriteByte f,0
  152.         WriteByte f,0
  153.         ' global color table
  154.         gifwritepalette f,pal
  155.         ' application extension block
  156.         WriteByte f,$21
  157.         WriteByte f,$ff
  158.         WriteByte f,11
  159.         WriteString f,"NETSCAPE"
  160.         WriteString f,"2.0"
  161.         WriteByte f,3
  162.         WriteByte f,1
  163.         WriteShort f,looptimes
  164.         WriteByte f,0
  165.         ' write frames
  166.         Local di%=0
  167.         For Local pix:TPixmap=EachIn pixmaps
  168.                 Local del%=1
  169.                 If animdelay Then del=animdelay[di Mod animdelay.length]
  170.                 WriteGIFFrame f,pix,pal,del,0,0,transparentcolor,False
  171.                 di:+1
  172.         Next
  173.         WriteByte f,$3b
  174. End Function
  175. Rem
  176. bbdoc: Writes an individual pixmap to a stream as the frame of a GIF image.
  177. f:TStream is the stream to which the GIF will be written
  178. pix:TPixmap is the pixmap to write
  179. pal%[] is an array containing up to 256 colors and will be used as the palette
  180. framedelay% is how long in 100ths of a second the frame should last when animating
  181. xcorner% is the x offset (left toward right) of this frame in the animation
  182. ycorner% is the y offset (top toward bottom) of this frame in the animation
  183. transparentcolor% defines which index of the palette should be flagged as the transparent background color. -1 indicates that there is no transparent color.
  184. localtable% is a flag that decides whether the palette should be considered unique to this frame of the GIF animation
  185. EndRem
  186. Function WriteGIFFrame(f:TStream,pix:TPixmap,pal%[],framedelay%=50,xcorner%=0,ycorner%=0,transparentcolor%=-1,localtable%=True)
  187.         ' graphic control exension
  188.         WriteByte f,$21
  189.         WriteByte f,$f9
  190.         WriteByte f,$04
  191.         Local hastransparentcolor%=(transparentcolor>-1)
  192.         WriteByte f,hastransparentcolor
  193.         WriteShort f,framedelay
  194.         WriteByte f,transparentcolor*hastransparentcolor
  195.         WriteByte f,$00
  196.         ' image descriptor
  197.         WriteByte f,$2c
  198.         WriteShort f,xcorner ' location of x corner
  199.         WriteShort f,ycorner ' y corner
  200.         WriteShort f,pix.width
  201.         WriteShort f,pix.height
  202.         If localtable Then
  203.                 WriteByte f,%10000000 | ((clog2(pal.length)-1) Shl 4)
  204.                 gifwritepalette f,pal
  205.         Else
  206.                 WriteByte f,0
  207.         EndIf
  208.         Local bpp%=Max(clog2(pal.length),2)
  209.         WriteByte f,bpp
  210.         ' lzw-compress the data
  211.         Local minsize%=bpp+1
  212.         Const maxsize%=12
  213.         Local clearcode%=1 Shl bpp
  214.         Local endcode%=clearcode+1
  215.         Local startoncode%=endcode+1
  216.         Local oncode%=startoncode
  217.         Local currentsize%=minsize
  218.         Local firstcode:lzwc=lzwc.Create(currentsize,clearcode)
  219.         Local thiscode:lzwc=firstcode
  220.         Local c$="",ck$,k$
  221.         Local bitlength%=currentsize
  222.         Local table:HashTable=_lzwtable(minsize)
  223.         Local yv%=0
  224.         For Local y%=0 Until pix.height
  225.                 For Local x%=0 Until pix.width
  226.                         Local val%=gifgetclosestpalcolor(pix.ReadPixel(x,y),pal,pal.length)
  227.                         k=Chr(val);ck=c+k
  228.                         If table.find(ck)
  229.                                 c=ck
  230.                         Else
  231.                                 thiscode.succ=lzwc.Create(currentsize,lzwi(table.find(c)).value)
  232.                                 bitlength:+currentsize
  233.                                 thiscode=thiscode.succ
  234.                                 table.insert ck,lzwi.Create(oncode);oncode:+1
  235.                                 c=k
  236.                                 If clog2(oncode)>currentsize Then
  237.                                         If currentsize=maxsize Then
  238.                                                 thiscode.succ=lzwc.Create(currentsize,clearcode)
  239.                                                 thiscode=thiscode.succ
  240.                                                 bitlength:+currentsize
  241.                                                 currentsize=minsize
  242.                                                 oncode=startoncode
  243.                                                 table=_lzwtable(minsize)
  244.                                         Else
  245.                                                 currentsize:+1
  246.                                         EndIf
  247.                                 EndIf
  248.                         EndIf
  249.                 Next
  250.                 yv:+pix.width
  251.         Next
  252.         thiscode.succ=lzwc.Create(currentsize,lzwi(table.find(c)).value)
  253.         thiscode.succ.succ=lzwc.Create(currentsize,endcode)
  254.         bitlength:+currentsize+currentsize
  255.         ' turn into an array of bytes
  256.         Local data@[Ceil(bitlength/8.0)],onbit%=0
  257.         thiscode=firstcode;firstcode=Null
  258.         While thiscode
  259.                 For Local i%=0 Until thiscode.bits
  260.                         Local di%=onbit Shr 3
  261.                         Local thisbit%=(((thiscode.value Shr i)&1) Shl (onbit&7))
  262.                         data[di]=data[di] | thisbit
  263.                         onbit:+1
  264.                 Next
  265.                 Local n:lzwc=thiscode.succ;thiscode.succ=Null;thiscode=n
  266.         Wend
  267.         ' write the bytes
  268.         For Local i%=0 Until data.length
  269.                 If (i Mod 255)=0 Then
  270.                         Local chunksize%=Min(255,data.length-i)
  271.                         WriteByte f,chunksize
  272.                 EndIf
  273.                 WriteByte f,data[i]
  274.         Next
  275.         WriteByte f,$00
  276. End Function
  277. ' Writes a palette for a GIF image
  278. Function gifwritepalette(f:TStream,pal%[])
  279.         For Local i%=0 Until (1 Shl clog2(pal.length))
  280.                 If i<pal.length
  281.                         WriteByte f,(pal[i] Shr 16) '& $ff
  282.                         WriteByte f,(pal[i] Shr 8) '& $ff
  283.                         WriteByte f,(pal[i]) '& $ff
  284.                 Else
  285.                         WriteByte f,0;WriteByte f,0;WriteByte f,0
  286.                 EndIf
  287.         Next
  288. End Function
  289. ' Finds the closest color in a palette to a given color
  290. Global cachedcolor%=0
  291. Function gifgetclosestpalcolor%(argb%,pal% Ptr,pallength%)
  292.         ' note: ignores alpha
  293.         Local besti%=cachedcolor,bestdist%=gifgetcolordistance(argb,pal[cachedcolor])
  294.         For Local i%=0 Until pallength
  295.                 Local d%=gifgetcolordistance(argb,pal[i])
  296.                 If d<bestdist Then
  297.                         besti=i;bestdist=d
  298.                 EndIf
  299.                 If bestdist=0 Exit
  300.         Next
  301.         Return besti
  302. End Function
  303. ' Gets the distance from one color to another, slightly adjusted to account for luminosity
  304. Function gifgetcolordistance%(argb1%,argb2%)
  305.         Local r1%=(argb1 Shr 16)&$ff
  306.         Local g1%=(argb1 Shr 8)&$ff
  307.         Local b1%=(argb1)&$ff
  308.         Local r2%=(argb2 Shr 16)&$ff
  309.         Local g2%=(argb2 Shr 8)&$ff
  310.         Local b2%=(argb2)&$ff
  311.         Return (Abs(r1-r2) Shl 1)+(Abs(g1-g2) Shl 2)+Abs(b1-b2)
  312. End Function
  313.  
  314. Private
  315. ' Returns a new hash table to be used as the string table in lzw compression
  316. Function _lzwtable:HashTable(minsize%)
  317.         Local ret:HashTable=CreateHash(1 Shl minsize,_lzwhash)
  318.         For Local i%=0 Until (1 Shl minsize)
  319.                 ret.insert Chr(i),lzwi.Create(i)
  320.         Next
  321.         Return ret
  322. End Function
  323. ' Hash function, should be faster and well-suited to the specific data going in from the lzw compression
  324. Function _lzwhash%(str$)
  325.         Local ret%=str.length
  326.         For Local i%=0 Until str.length
  327.                 ret:+(str[i] Shl ((i&7) Shl 4))
  328.         Next
  329.         Return ret
  330. End Function
  331. ' 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)
  332. Type lzwi
  333.         Field value%
  334.         Function Create:lzwi(value%)
  335.                 Local n:lzwi=New lzwi
  336.                 n.value=value
  337.                 Return n
  338.         End Function
  339. End Type
  340. ' lzw code object containing a value, the number of bits needed to represent that value, and the next code in the series
  341. Type lzwc
  342.         Field bits%
  343.         Field value%
  344.         Field succ:lzwc
  345.         Function Create:lzwc(bits%,value%)
  346.                 Local n:lzwc=New lzwc
  347.                 n.bits=bits
  348.                 n.value=value
  349.                 Return n
  350.         End Function
  351. End Type
  352. ' object used for constructing a limited palette from a pixmap
  353. Type _cdata
  354.         Field r@,g@,b@
  355.         Field pop%=1
  356.         Function Create:_cdata(r%,g%,b%)
  357.                 Local c:_cdata=New _cdata
  358.                 c.r=r;c.g=g;c.b=b
  359.                 Return c
  360.         End Function
  361.         Method distance%(o:_cdata)
  362.                 Return (Abs(r-o.r) Shl 1)+(Abs(g-o.g) Shl 2)+Abs(b-o.b)
  363.         End Method
  364.         Method compare%(o1:Object)
  365.                 If pop>_cdata(o1).pop Return 1
  366.                 Return -1
  367.         End Method
  368. End Type
  369. ' moves a TLink to the front of a TList
  370. Function movelinktofront(link:TLink,list:TList)
  371.         If link=list.firstlink() Then Return
  372.         link._succ._pred=link._pred
  373.         link._pred._succ=link._succ
  374.         link._pred=list._head
  375.         link._succ=list._head._succ
  376.         link._succ._pred=link
  377.         list._head._succ=link
  378. End Function


Comments : none...

 

SimplePortal 2.3.6 © 2008-2014, SimplePortal