/[pngwrite]/trunk/pngwrite.pas
ViewVC logotype

Annotation of /trunk/pngwrite.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (hide annotations)
Sun Apr 13 19:38:04 2008 UTC (12 years, 9 months ago) by plugwash
File size: 12079 byte(s)
initial import

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

Properties

Name Value
svn:executable

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.26