pngwrite.pas

   1 {pngwrite.pas}\r
   2 {plugwashes png write code}\r
   3 \r
   4 { Copyright (C) 2005 Bas Steendijk and Peter Green\r
   5   For conditions of distribution and use, see copyright notice in zlib_license.txt\r
   6     which is included in the package\r
   7       ----------------------------------------------------------------------------- }\r
   8 \r
   9 unit pngwrite;\r
  10 \r
  11 interface\r
  12 uses\r
  13   zlib,zdeflate,zutil,classes,sysutils,pgtypes,\r
  14   {$ifdef win32}\r
  15     winsock;\r
  16   {$else}\r
  17     sockets;\r
  18   {$endif}\r
  19 {$i uint32.inc}\r
  20 \r
  21 type\r
  22 \r
  23   tcolortype=(ctgreyscale,ctpallette,ctbgr,ctrgb,ct8bp);\r
  24 \r
  25 // There are two types of color types\r
  26 //\r
  27 // native types result in direct output of the apps data to the png file\r
  28 // theese are\r
  29 // ctgreyscale : grey scale data all png supported depths should work\r
  30 // ctpallette : palletted data all png supported depths should work\r
  31 // ctrgb : currently 24 bit only\r
  32 //\r
  33 // Processed types are processed before data is output to the png file\r
  34 // ctbgr : truecolor data in bgr order usefull with tbitmap.\r
  35 // ct8bp : data from app is 8 bits per sample palletted but data is saved as\r
  36 //         a lower depth palletted format (the app MUST only use the first\r
  37 //         2^bitdepth pallette entries\r
  38 \r
  39   tpngwrite=record\r
  40     destination : tstream;\r
  41     lines : integer;\r
  42     cols : integer;\r
  43     deflatestream : z_stream;\r
  44     chunkstart : integer; //used to fill in chunk length later\r
  45     chunkbytes : integer;\r
  46     chunkcrc   : uint32;\r
  47     crc_table : array[byte] of uint32;\r
  48     colortype:tcolortype;\r
  49     colordepth        : byte;\r
  50     bufferingchunkdata : boolean;\r
  51     bufferedchunkdata : tstringlist;\r
  52   end;\r
  53 \r
  54 procedure pngstart(var f : tpngwrite;destination : tstream;colordepth : integer;colortype:tcolortype;lines : integer;cols : integer);\r
  55 procedure pngwritescanline(var f : tpngwrite;scanline: pointer);\r
  56 \r
  57 \r
  58 procedure pngwritepal(var f : tpngwrite;p:pointer;entrys : integer);\r
  59 procedure pngstartdata(var f : tpngwrite);\r
  60 procedure pngfinishdata(var f : tpngwrite);\r
  61 procedure pngfinish(var f : tpngwrite);\r
  62 \r
  63 \r
  64 \r
  65 implementation\r
  66 \r
  67 \r
  68 procedure make_crc_table(var f:tpngwrite);\r
  69 var\r
  70   c: uint32;\r
  71   n,k : integer;\r
  72 begin\r
  73   with f do begin\r
  74 \r
  75 //        unsigned long c;\r
  76 //        int n, k;\r
  77 //        for (n = 0; n < 256; n++)\r
  78     for n := 0 to 255 do begin\r
  79 //          c = (unsigned long) n;\r
  80       c := n;\r
  81 //          for (k = 0; k < 8; k++)\r
  82       for k := 0 to 7 do begin\r
  83 //            if (c & 1)\r
  84         if (c and 1) <> 0 then begin\r
  85 //              c = 0xedb88320L ^ (c >> 1);\r
  86           c := $edb88320 xor (c shr 1);\r
  87 //            else\r
  88         end else begin\r
  89 //              c = c >> 1;\r
  90           c := c shr 1;\r
  91 //\r
  92         end;\r
  93       end;\r
  94 //          crc_table[n] = c;\r
  95       crc_table[n] := c;\r
  96 //\r
  97     end;\r
  98 //        crc_table_computed = 1;\r
  99   end;\r
 100 end;\r
 101 (*\r
 102    unsigned long update_crc(unsigned long crc, unsigned char *buf,\r
 103                                int len)\r
 104       {\r
 105         unsigned long c = crc;\r
 106         int n;\r
 107 \r
 108         if (!crc_table_computed)\r
 109           make_crc_table();\r
 110         for (n = 0; n < len; n++) {\r
 111           c = crc_table[(c ^ buf[n]) & 0xff] ^ (c >> 8);\r
 112         }\r
 113         return c;\r
 114       }\r
 115 *)\r
 116 procedure update_crc(var f : tpngwrite;buf : string);\r
 117 \r
 118 var\r
 119   n : integer;\r
 120 begin\r
 121   with f do begin\r
 122     for n := 1 to length(buf) do begin\r
 123       chunkcrc := crc_table[(chunkcrc xor byte(buf[n])) and $ff] xor (chunkcrc shr 8);\r
 124     end;\r
 125   end;\r
 126 end;\r
 127 \r
 128 procedure writetochunk(var f : tpngwrite;buf : string);\r
 129 begin\r
 130   if length(buf)=0 then raise exception.create('attempt to write zero length block to chunk');\r
 131   \r
 132   with f do begin\r
 133     if bufferingchunkdata then begin\r
 134       bufferedchunkdata.Add(buf);\r
 135     end else begin\r
 136       destination.Write(buf[1],length(buf));\r
 137     end;\r
 138     update_crc(f,buf);\r
 139     inc(chunkbytes,length(buf));\r
 140   end;\r
 141 end;\r
 142 \r
 143 \r
 144 procedure startchunk(var f : tpngwrite;chunktype : string);\r
 145 var\r
 146   outputdata : string;\r
 147 begin\r
 148   with f do begin\r
 149     try\r
 150       chunkstart := destination.Position;\r
 151       // 4 btye dummy for length we will insert this later.\r
 152       outputdata := '    ';\r
 153       destination.WriteBuffer(pchar(outputdata)^,4);\r
 154     except\r
 155       bufferingchunkdata := true;\r
 156       bufferedchunkdata := tstringlist.create;\r
 157     end;\r
 158     chunkbytes := -4;\r
 159     chunkcrc := $FFFFFFFF;\r
 160 \r
 161     writetochunk(f,chunktype);\r
 162 \r
 163 \r
 164   end;\r
 165 end;\r
 166 \r
 167 \r
 168 \r
 169 \r
 170 procedure stopchunk(var f:tpngwrite);\r
 171 var\r
 172   currentpos : integer;\r
 173   i : integer;\r
 174 begin\r
 175   with f do begin\r
 176     if not bufferingchunkdata then begin\r
 177 \r
 178       currentpos := destination.Position;\r
 179       destination.position := chunkstart;\r
 180     end;\r
 181     chunkbytes := htonl(chunkbytes);\r
 182     destination.WriteBuffer(chunkbytes,4);\r
 183     if bufferingchunkdata then begin\r
 184 //      writeln('begin write of buffered chunk data');\r
 185       for i := 0 to bufferedchunkdata.Count-1 do begin\r
 186         destination.Write(bufferedchunkdata[i][1],length(bufferedchunkdata[i]));\r
 187       end;\r
 188       bufferedchunkdata.Free;\r
 189 //      writeln('end write of buffered chunk data');\r
 190     end else begin\r
 191       destination.position := currentpos;\r
 192     end;\r
 193     chunkcrc := htonl(chunkcrc)     ;\r
 194     chunkcrc := chunkcrc xor $FFFFFFFF;\r
 195     destination.WriteBuffer(chunkcrc,4);\r
 196 \r
 197   end;\r
 198 end;\r
 199 \r
 200 type\r
 201   tihdr=packed record\r
 202     width             : uint32;\r
 203     height            : uint32;\r
 204     Bitdepth          : byte;\r
 205     Colortype         : byte;\r
 206     Compressionmethod : byte;\r
 207     Filtermethod      : byte;\r
 208     Interlacemethod   : byte;\r
 209   end;\r
 210   pihdr=^tihdr;\r
 211 procedure pngstart(var f : tpngwrite;destination : tstream;colordepth : integer;colortype:tcolortype;lines : integer;cols : integer);\r
 212 var\r
 213   tempstring : string;\r
 214   ihdr : pihdr;\r
 215 begin\r
 216   fillchar(f,sizeof(f),#0);\r
 217   f.destination := destination;\r
 218   f.lines := lines;\r
 219   f.cols := cols;\r
 220   f.colortype := colortype;\r
 221   f.colordepth := colordepth;\r
 222   make_crc_table(f);\r
 223   with f do begin\r
 224     //file header\r
 225     destination.Write(pchar(#137'PNG'#13#10#26#10)^,8);\r
 226 \r
 227     startchunk(f,'IHDR');\r
 228     setlength(tempstring,sizeof(tihdr));\r
 229     ihdr := pihdr(tempstring);\r
 230     ihdr.width := htonl(cols);\r
 231     ihdr.height := htonl(lines);\r
 232     case colortype of\r
 233       ctgreyscale : begin\r
 234         ihdr.Bitdepth := colordepth;\r
 235         ihdr.Colortype := 0;\r
 236       end;\r
 237       ctpallette,ct8bp : begin\r
 238         ihdr.Bitdepth := colordepth;\r
 239         ihdr.Colortype := 3;\r
 240       end;\r
 241 \r
 242       ctrgb,ctbgr : begin\r
 243         ihdr.Bitdepth := 8;\r
 244         ihdr.Colortype := 2;\r
 245       end;\r
 246     end;\r
 247 \r
 248     ihdr.Compressionmethod := 0;\r
 249     ihdr.Filtermethod := 0;\r
 250     ihdr.Interlacemethod := 0;\r
 251     writetochunk(f,tempstring);\r
 252     stopchunk(f);\r
 253 \r
 254   end;\r
 255 end;\r
 256 \r
 257 procedure pngwritepal(var f : tpngwrite;p:pointer;entrys : integer);\r
 258 var\r
 259   tempstring : string;\r
 260 begin\r
 261   with f do begin\r
 262     startchunk(f,'PLTE');\r
 263     setlength(tempstring,entrys*3);\r
 264     move(p^,tempstring[1],entrys*3);\r
 265     writetochunk(f,tempstring);\r
 266     stopchunk(f);\r
 267   end;\r
 268 end;\r
 269 \r
 270 procedure pngstartdata(var f : tpngwrite);\r
 271 begin\r
 272   with f do begin\r
 273     startchunk(f,'IDAT');\r
 274     deflateInit(deflatestream,9);\r
 275     //writeln('test');\r
 276 \r
 277   end;\r
 278 end;\r
 279 \r
 280 \r
 281 \r
 282 type\r
 283   tlinedata = array[0..0] of byte;\r
 284   plinedata = ^tlinedata;\r
 285 function divup(a,b:integer):integer;\r
 286 begin\r
 287   result := (a div b)+ord((a mod b)<>0);\r
 288 end;\r
 289 \r
 290 \r
 291 procedure pngwritescanline(var f : tpngwrite;scanline: pointer);\r
 292 var\r
 293   outputstr : string;\r
 294   nullchar : char;\r
 295   scanlineb : plinedata absolute scanline;\r
 296   rearrangebuf : plinedata;\r
 297   counter : integer;\r
 298   pixelsperbyte : integer;\r
 299   samplevalue : byte;\r
 300 begin\r
 301   with f do begin\r
 302     //writeln('about to write starter byte');\r
 303     if cols > 127 then begin\r
 304       setlength(outputstr,cols*6);\r
 305     end else begin\r
 306       setlength(outputstr,768);\r
 307     end;\r
 308     deflatestream.next_out := pbytef(outputstr);\r
 309     deflatestream.avail_out := length(outputstr);\r
 310 //    writeln(deflatestream.avail_out,' ',deflatestream.avail_in);\r
 311     nullchar := #0;\r
 312     deflatestream.next_in := @nullchar;\r
 313     deflatestream.avail_in :=1;\r
 314     //writeln('about to start deflation');\r
 315     deflate(deflatestream,0);\r
 316     //writeln('deflation complete deflatestream.avail_out=',deflatestream.avail_out);\r
 317 //    writeln(deflatestream.avail_out,' ',deflatestream.avail_in);\r
 318     while deflatestream.avail_out = 0 do begin\r
 319       deflatestream.next_out := pbytef(taddrint(deflatestream.next_out) - taddrint(outputstr));\r
 320       deflatestream.avail_out := length(outputstr);\r
 321       setlength(outputstr,length(outputstr)*2);\r
 322       deflatestream.next_out := pbytef(taddrint(deflatestream.next_out) + taddrint(outputstr));\r
 323       deflate(deflatestream,0);\r
 324     end;\r
 325     //writeln('extra deflation done');\r
 326     if deflatestream.avail_in <> 0 then raise exception.create('compression problem');\r
 327     //writeln('about to write main data');\r
 328     case colortype of\r
 329 \r
 330       ctbgr : begin\r
 331         getmem(rearrangebuf,cols*3);\r
 332 \r
 333         for counter := 0 to cols-1 do begin\r
 334           rearrangebuf[(counter*3)  ] := scanlineb[(counter*3)+2];\r
 335           rearrangebuf[(counter*3)+1] := scanlineb[(counter*3)+1];\r
 336           rearrangebuf[(counter*3)+2] := scanlineb[(counter*3)  ];\r
 337         end;\r
 338         deflatestream.next_in := pointer(rearrangebuf);\r
 339         deflatestream.avail_in := cols*3;\r
 340         deflate(deflatestream,0);\r
 341         if deflatestream.avail_in <> 0 then raise exception.create('compression problem');\r
 342         freemem(rearrangebuf);\r
 343 \r
 344       end;\r
 345       ct8bp : begin\r
 346         rearrangebuf := allocmem(divup(cols* colordepth,  8));\r
 347         pixelsperbyte := 8 div colordepth;\r
 348         for counter := 0 to cols-1 do begin\r
 349           //shift sample value into most significant bits (which has the nice side effect of removing any garbage bits)\r
 350           samplevalue := scanlineb[counter] shl (8-colordepth);\r
 351           //shift sample value into correct place for pixel in question.\r
 352           samplevalue := samplevalue shr ((counter mod pixelsperbyte)*colordepth);\r
 353           rearrangebuf[counter div pixelsperbyte] := rearrangebuf[counter div pixelsperbyte] or samplevalue;\r
 354         end;\r
 355         deflatestream.next_in := pointer(rearrangebuf);\r
 356         deflatestream.avail_in := divup(cols* colordepth,  8);\r
 357         deflate(deflatestream,0);\r
 358         if deflatestream.avail_in <> 0 then raise exception.create('compression problem');\r
 359         freemem(rearrangebuf);\r
 360       end;\r
 361 \r
 362       else begin\r
 363         deflatestream.next_in := scanline;\r
 364 \r
 365         deflatestream.avail_in := divup(cols* colordepth,  8);\r
 366 \r
 367         deflate(deflatestream,0);\r
 368         while deflatestream.avail_out = 0 do begin\r
 369           deflatestream.next_out := pbytef(taddrint(deflatestream.next_out) - taddrint(outputstr));\r
 370           deflatestream.avail_out := length(outputstr);\r
 371           setlength(outputstr,length(outputstr)*2);\r
 372           deflatestream.next_out := pbytef(taddrint(deflatestream.next_out) + taddrint(outputstr));\r
 373           deflate(deflatestream,0);\r
 374         end;\r
 375         if deflatestream.avail_in <> 0 then raise exception.create('compression problem');\r
 376       end;\r
 377     end;\r
 378 \r
 379     setlength(outputstr,length(outputstr)-deflatestream.avail_out);\r
 380     //deflate doesn't always produce output when its given input, if this is the case no point pushing it any further\r
 381     if length(outputstr) > 0 then writetochunk(f,outputstr);\r
 382 //    writeln;\r
 383   end;\r
 384 end;\r
 385 \r
 386 procedure pngfinishdata(var f : tpngwrite);\r
 387 var\r
 388   outputstr : string;\r
 389   deflateresult : integer;\r
 390 begin\r
 391   with f do begin\r
 392     repeat\r
 393       setlength(outputstr,512);\r
 394       deflatestream.next_out := pbytef(outputstr);\r
 395       deflatestream.avail_out := length(outputstr);\r
 396       deflateresult := deflate(deflatestream,Z_FINISH);\r
 397       setlength(outputstr,length(outputstr)-deflatestream.avail_out);\r
 398       writetochunk(f,outputstr);\r
 399 \r
 400     until deflateresult=Z_STREAM_END;\r
 401     deflateEnd(deflatestream);\r
 402     stopchunk(f);\r
 403 \r
 404   end;\r
 405 end;\r
 406 \r
 407 \r
 408 procedure pngfinish(var f : tpngwrite);\r
 409 \r
 410 begin\r
 411   with f do begin\r
 412     //setlength(outputstr,512);\r
 413     startchunk(f,'IEND');\r
 414 \r
 415     stopchunk(f);\r
 416   end;\r
 417 \r
 418 end;\r
 419 \r
 420 \r
 421 \r
 422 \r
 423 end.\r