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

Contents of /trunk/pngwrite.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Sun Apr 13 19:38:04 2008 UTC (9 years, 8 months ago) by plugwash
File size: 12079 byte(s)
initial import
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.5