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

Contents of /trunk/trees.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: 79412 byte(s)
initial import
1 Unit trees;
2
3 {$T-}
4 {$define ORG_DEBUG}
5 {
6 trees.c -- output deflated data using Huffman coding
7 Copyright (C) 1995-1998 Jean-loup Gailly
8
9 Pascal tranlastion
10 Copyright (C) 1998 by Jacques Nomssi Nzali
11 For conditions of distribution and use, see copyright notice in readme.paszlib
12 }
13
14 {
15 * ALGORITHM
16 *
17 * The "deflation" process uses several Huffman trees. The more
18 * common source values are represented by shorter bit sequences.
19 *
20 * Each code tree is stored in a compressed form which is itself
21 * a Huffman encoding of the lengths of all the code strings (in
22 * ascending order by source values). The actual code strings are
23 * reconstructed from the lengths in the inflate process, as described
24 * in the deflate specification.
25 *
26 * REFERENCES
27 *
28 * Deutsch, L.P.,"'Deflate' Compressed Data Format Specification".
29 * Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc
30 *
31 * Storer, James A.
32 * Data Compression: Methods and Theory, pp. 49-50.
33 * Computer Science Press, 1988. ISBN 0-7167-8156-5.
34 *
35 * Sedgewick, R.
36 * Algorithms, p290.
37 * Addison-Wesley, 1983. ISBN 0-201-06672-6.
38 }
39
40 interface
41
42 {$I zconf.inc}
43
44 uses
45 {$ifdef DEBUG}
46 strutils,
47 {$ENDIF}
48 zutil, zlib;
49
50 { ===========================================================================
51 Internal compression state. }
52
53 const
54 LENGTH_CODES = 29;
55 { number of length codes, not counting the special END_BLOCK code }
56
57 LITERALS = 256;
58 { number of literal bytes 0..255 }
59
60 L_CODES = (LITERALS+1+LENGTH_CODES);
61 { number of Literal or Length codes, including the END_BLOCK code }
62
63 D_CODES = 30;
64 { number of distance codes }
65
66 BL_CODES = 19;
67 { number of codes used to transfer the bit lengths }
68
69 HEAP_SIZE = (2*L_CODES+1);
70 { maximum heap size }
71
72 MAX_BITS = 15;
73 { All codes must not exceed MAX_BITS bits }
74
75 const
76 INIT_STATE = 42;
77 BUSY_STATE = 113;
78 FINISH_STATE = 666;
79 { Stream status }
80
81
82 { Data structure describing a single value and its code string. }
83 type
84 ct_data_ptr = ^ct_data;
85 ct_data = record
86 fc : record
87 case byte of
88 0:(freq : ush); { frequency count }
89 1:(code : ush); { bit string }
90 end;
91 dl : record
92 case byte of
93 0:(dad : ush); { father node in Huffman tree }
94 1:(len : ush); { length of bit string }
95 end;
96 end;
97
98 { Freq = fc.freq
99 Code = fc.code
100 Dad = dl.dad
101 Len = dl.len }
102
103 type
104 ltree_type = array[0..HEAP_SIZE-1] of ct_data; { literal and length tree }
105 dtree_type = array[0..2*D_CODES+1-1] of ct_data; { distance tree }
106 htree_type = array[0..2*BL_CODES+1-1] of ct_data; { Huffman tree for bit lengths }
107 { generic tree type }
108 tree_type = array[0..(MaxMemBlock div SizeOf(ct_data))-1] of ct_data;
109
110 tree_ptr = ^tree_type;
111 ltree_ptr = ^ltree_type;
112 dtree_ptr = ^dtree_type;
113 htree_ptr = ^htree_type;
114
115
116 type
117 static_tree_desc_ptr = ^static_tree_desc;
118 static_tree_desc =
119 record
120 {const} static_tree : tree_ptr; { static tree or NIL }
121 {const} extra_bits : pzIntfArray; { extra bits for each code or NIL }
122 extra_base : int; { base index for extra_bits }
123 elems : int; { max number of elements in the tree }
124 max_length : int; { max bit length for the codes }
125 end;
126
127 tree_desc_ptr = ^tree_desc;
128 tree_desc = record
129 dyn_tree : tree_ptr; { the dynamic tree }
130 max_code : int; { largest code with non zero frequency }
131 stat_desc : static_tree_desc_ptr; { the corresponding static tree }
132 end;
133
134 type
135 Pos = ush;
136 Posf = Pos; {FAR}
137 IPos = uInt;
138
139 pPosf = ^Posf;
140
141 zPosfArray = array[0..(MaxMemBlock div SizeOf(Posf))-1] of Posf;
142 pzPosfArray = ^zPosfArray;
143
144 { A Pos is an index in the character window. We use short instead of int to
145 save space in the various tables. IPos is used only for parameter passing.}
146
147 type
148 deflate_state_ptr = ^deflate_state;
149 deflate_state = record
150 strm : z_streamp; { pointer back to this zlib stream }
151 status : int; { as the name implies }
152 pending_buf : pzByteArray; { output still pending }
153 pending_buf_size : ulg; { size of pending_buf }
154 pending_out : pBytef; { next pending byte to output to the stream }
155 pending : int; { nb of bytes in the pending buffer }
156 noheader : int; { suppress zlib header and adler32 }
157 data_type : Byte; { UNKNOWN, BINARY or ASCII }
158 method : Byte; { STORED (for zip only) or DEFLATED }
159 last_flush : int; { value of flush param for previous deflate call }
160
161 { used by deflate.pas: }
162
163 w_size : uInt; { LZ77 window size (32K by default) }
164 w_bits : uInt; { log2(w_size) (8..16) }
165 w_mask : uInt; { w_size - 1 }
166
167 window : pzByteArray;
168 { Sliding window. Input bytes are read into the second half of the window,
169 and move to the first half later to keep a dictionary of at least wSize
170 bytes. With this organization, matches are limited to a distance of
171 wSize-MAX_MATCH bytes, but this ensures that IO is always
172 performed with a length multiple of the block size. Also, it limits
173 the window size to 64K, which is quite useful on MSDOS.
174 To do: use the user input buffer as sliding window. }
175
176 window_size : ulg;
177 { Actual size of window: 2*wSize, except when the user input buffer
178 is directly used as sliding window. }
179
180 prev : pzPosfArray;
181 { Link to older string with same hash index. To limit the size of this
182 array to 64K, this link is maintained only for the last 32K strings.
183 An index in this array is thus a window index modulo 32K. }
184
185 head : pzPosfArray; { Heads of the hash chains or NIL. }
186
187 ins_h : uInt; { hash index of string to be inserted }
188 hash_size : uInt; { number of elements in hash table }
189 hash_bits : uInt; { log2(hash_size) }
190 hash_mask : uInt; { hash_size-1 }
191
192 hash_shift : uInt;
193 { Number of bits by which ins_h must be shifted at each input
194 step. It must be such that after MIN_MATCH steps, the oldest
195 byte no longer takes part in the hash key, that is:
196 hash_shift * MIN_MATCH >= hash_bits }
197
198 block_start : long;
199 { Window position at the beginning of the current output block. Gets
200 negative when the window is moved backwards. }
201
202 match_length : uInt; { length of best match }
203 prev_match : IPos; { previous match }
204 match_available : boolean; { set if previous match exists }
205 strstart : uInt; { start of string to insert }
206 match_start : uInt; { start of matching string }
207 lookahead : uInt; { number of valid bytes ahead in window }
208
209 prev_length : uInt;
210 { Length of the best match at previous step. Matches not greater than this
211 are discarded. This is used in the lazy match evaluation. }
212
213 max_chain_length : uInt;
214 { To speed up deflation, hash chains are never searched beyond this
215 length. A higher limit improves compression ratio but degrades the
216 speed. }
217
218 { moved to the end because Borland Pascal won't accept the following:
219 max_lazy_match : uInt;
220 max_insert_length : uInt absolute max_lazy_match;
221 }
222
223 level : int; { compression level (1..9) }
224 strategy : int; { favor or force Huffman coding}
225
226 good_match : uInt;
227 { Use a faster search when the previous match is longer than this }
228
229 nice_match : int; { Stop searching when current match exceeds this }
230
231 { used by trees.pas: }
232 { Didn't use ct_data typedef below to supress compiler warning }
233 dyn_ltree : ltree_type; { literal and length tree }
234 dyn_dtree : dtree_type; { distance tree }
235 bl_tree : htree_type; { Huffman tree for bit lengths }
236
237 l_desc : tree_desc; { desc. for literal tree }
238 d_desc : tree_desc; { desc. for distance tree }
239 bl_desc : tree_desc; { desc. for bit length tree }
240
241 bl_count : array[0..MAX_BITS+1-1] of ush;
242 { number of codes at each bit length for an optimal tree }
243
244 heap : array[0..2*L_CODES+1-1] of int; { heap used to build the Huffman trees }
245 heap_len : int; { number of elements in the heap }
246 heap_max : int; { element of largest frequency }
247 { The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used.
248 The same heap array is used to build all trees. }
249
250 depth : array[0..2*L_CODES+1-1] of uch;
251 { Depth of each subtree used as tie breaker for trees of equal frequency }
252
253
254 l_buf : puchfArray; { buffer for literals or lengths }
255
256 lit_bufsize : uInt;
257 { Size of match buffer for literals/lengths. There are 4 reasons for
258 limiting lit_bufsize to 64K:
259 - frequencies can be kept in 16 bit counters
260 - if compression is not successful for the first block, all input
261 data is still in the window so we can still emit a stored block even
262 when input comes from standard input. (This can also be done for
263 all blocks if lit_bufsize is not greater than 32K.)
264 - if compression is not successful for a file smaller than 64K, we can
265 even emit a stored file instead of a stored block (saving 5 bytes).
266 This is applicable only for zip (not gzip or zlib).
267 - creating new Huffman trees less frequently may not provide fast
268 adaptation to changes in the input data statistics. (Take for
269 example a binary file with poorly compressible code followed by
270 a highly compressible string table.) Smaller buffer sizes give
271 fast adaptation but have of course the overhead of transmitting
272 trees more frequently.
273 - I can't count above 4 }
274
275
276 last_lit : uInt; { running index in l_buf }
277
278 d_buf : pushfArray;
279 { Buffer for distances. To simplify the code, d_buf and l_buf have
280 the same number of elements. To use different lengths, an extra flag
281 array would be necessary. }
282
283 opt_len : ulg; { bit length of current block with optimal trees }
284 static_len : ulg; { bit length of current block with static trees }
285 compressed_len : ulg; { total bit length of compressed file }
286 matches : uInt; { number of string matches in current block }
287 last_eob_len : int; { bit length of EOB code for last block }
288
289 {$ifdef DEBUG}
290 bits_sent : ulg; { bit length of the compressed data }
291 {$endif}
292
293 bi_buf : ush;
294 { Output buffer. bits are inserted starting at the bottom (least
295 significant bits). }
296
297 bi_valid : int;
298 { Number of valid bits in bi_buf. All bits above the last valid bit
299 are always zero. }
300
301 case byte of
302 0:(max_lazy_match : uInt);
303 { Attempt to find a better match only when the current match is strictly
304 smaller than this value. This mechanism is used only for compression
305 levels >= 4. }
306
307 1:(max_insert_length : uInt);
308 { Insert new strings in the hash table only if the match length is not
309 greater than this length. This saves time but degrades compression.
310 max_insert_length is used only for compression levels <= 3. }
311 end;
312
313 procedure _tr_init (var s : deflate_state);
314
315 function _tr_tally (var s : deflate_state;
316 dist : unsigned;
317 lc : unsigned) : boolean;
318
319 function _tr_flush_block (var s : deflate_state;
320 buf : pcharf;
321 stored_len : ulg;
322 eof : boolean) : ulg;
323
324 procedure _tr_align(var s : deflate_state);
325
326 procedure _tr_stored_block(var s : deflate_state;
327 buf : pcharf;
328 stored_len : ulg;
329 eof : boolean);
330
331 implementation
332
333 { #define GEN_TREES_H }
334
335 {$ifndef GEN_TREES_H}
336 { header created automatically with -DGEN_TREES_H }
337
338 const
339 DIST_CODE_LEN = 512; { see definition of array dist_code below }
340
341 { The static literal tree. Since the bit lengths are imposed, there is no
342 need for the L_CODES extra codes used during heap construction. However
343 The codes 286 and 287 are needed to build a canonical tree (see _tr_init
344 below). }
345 const
346 static_ltree : array[0..L_CODES+2-1] of ct_data = (
347 { fc:(freq, code) dl:(dad,len) }
348 (fc:(freq: 12);dl:(len: 8)), (fc:(freq:140);dl:(len: 8)), (fc:(freq: 76);dl:(len: 8)),
349 (fc:(freq:204);dl:(len: 8)), (fc:(freq: 44);dl:(len: 8)), (fc:(freq:172);dl:(len: 8)),
350 (fc:(freq:108);dl:(len: 8)), (fc:(freq:236);dl:(len: 8)), (fc:(freq: 28);dl:(len: 8)),
351 (fc:(freq:156);dl:(len: 8)), (fc:(freq: 92);dl:(len: 8)), (fc:(freq:220);dl:(len: 8)),
352 (fc:(freq: 60);dl:(len: 8)), (fc:(freq:188);dl:(len: 8)), (fc:(freq:124);dl:(len: 8)),
353 (fc:(freq:252);dl:(len: 8)), (fc:(freq: 2);dl:(len: 8)), (fc:(freq:130);dl:(len: 8)),
354 (fc:(freq: 66);dl:(len: 8)), (fc:(freq:194);dl:(len: 8)), (fc:(freq: 34);dl:(len: 8)),
355 (fc:(freq:162);dl:(len: 8)), (fc:(freq: 98);dl:(len: 8)), (fc:(freq:226);dl:(len: 8)),
356 (fc:(freq: 18);dl:(len: 8)), (fc:(freq:146);dl:(len: 8)), (fc:(freq: 82);dl:(len: 8)),
357 (fc:(freq:210);dl:(len: 8)), (fc:(freq: 50);dl:(len: 8)), (fc:(freq:178);dl:(len: 8)),
358 (fc:(freq:114);dl:(len: 8)), (fc:(freq:242);dl:(len: 8)), (fc:(freq: 10);dl:(len: 8)),
359 (fc:(freq:138);dl:(len: 8)), (fc:(freq: 74);dl:(len: 8)), (fc:(freq:202);dl:(len: 8)),
360 (fc:(freq: 42);dl:(len: 8)), (fc:(freq:170);dl:(len: 8)), (fc:(freq:106);dl:(len: 8)),
361 (fc:(freq:234);dl:(len: 8)), (fc:(freq: 26);dl:(len: 8)), (fc:(freq:154);dl:(len: 8)),
362 (fc:(freq: 90);dl:(len: 8)), (fc:(freq:218);dl:(len: 8)), (fc:(freq: 58);dl:(len: 8)),
363 (fc:(freq:186);dl:(len: 8)), (fc:(freq:122);dl:(len: 8)), (fc:(freq:250);dl:(len: 8)),
364 (fc:(freq: 6);dl:(len: 8)), (fc:(freq:134);dl:(len: 8)), (fc:(freq: 70);dl:(len: 8)),
365 (fc:(freq:198);dl:(len: 8)), (fc:(freq: 38);dl:(len: 8)), (fc:(freq:166);dl:(len: 8)),
366 (fc:(freq:102);dl:(len: 8)), (fc:(freq:230);dl:(len: 8)), (fc:(freq: 22);dl:(len: 8)),
367 (fc:(freq:150);dl:(len: 8)), (fc:(freq: 86);dl:(len: 8)), (fc:(freq:214);dl:(len: 8)),
368 (fc:(freq: 54);dl:(len: 8)), (fc:(freq:182);dl:(len: 8)), (fc:(freq:118);dl:(len: 8)),
369 (fc:(freq:246);dl:(len: 8)), (fc:(freq: 14);dl:(len: 8)), (fc:(freq:142);dl:(len: 8)),
370 (fc:(freq: 78);dl:(len: 8)), (fc:(freq:206);dl:(len: 8)), (fc:(freq: 46);dl:(len: 8)),
371 (fc:(freq:174);dl:(len: 8)), (fc:(freq:110);dl:(len: 8)), (fc:(freq:238);dl:(len: 8)),
372 (fc:(freq: 30);dl:(len: 8)), (fc:(freq:158);dl:(len: 8)), (fc:(freq: 94);dl:(len: 8)),
373 (fc:(freq:222);dl:(len: 8)), (fc:(freq: 62);dl:(len: 8)), (fc:(freq:190);dl:(len: 8)),
374 (fc:(freq:126);dl:(len: 8)), (fc:(freq:254);dl:(len: 8)), (fc:(freq: 1);dl:(len: 8)),
375 (fc:(freq:129);dl:(len: 8)), (fc:(freq: 65);dl:(len: 8)), (fc:(freq:193);dl:(len: 8)),
376 (fc:(freq: 33);dl:(len: 8)), (fc:(freq:161);dl:(len: 8)), (fc:(freq: 97);dl:(len: 8)),
377 (fc:(freq:225);dl:(len: 8)), (fc:(freq: 17);dl:(len: 8)), (fc:(freq:145);dl:(len: 8)),
378 (fc:(freq: 81);dl:(len: 8)), (fc:(freq:209);dl:(len: 8)), (fc:(freq: 49);dl:(len: 8)),
379 (fc:(freq:177);dl:(len: 8)), (fc:(freq:113);dl:(len: 8)), (fc:(freq:241);dl:(len: 8)),
380 (fc:(freq: 9);dl:(len: 8)), (fc:(freq:137);dl:(len: 8)), (fc:(freq: 73);dl:(len: 8)),
381 (fc:(freq:201);dl:(len: 8)), (fc:(freq: 41);dl:(len: 8)), (fc:(freq:169);dl:(len: 8)),
382 (fc:(freq:105);dl:(len: 8)), (fc:(freq:233);dl:(len: 8)), (fc:(freq: 25);dl:(len: 8)),
383 (fc:(freq:153);dl:(len: 8)), (fc:(freq: 89);dl:(len: 8)), (fc:(freq:217);dl:(len: 8)),
384 (fc:(freq: 57);dl:(len: 8)), (fc:(freq:185);dl:(len: 8)), (fc:(freq:121);dl:(len: 8)),
385 (fc:(freq:249);dl:(len: 8)), (fc:(freq: 5);dl:(len: 8)), (fc:(freq:133);dl:(len: 8)),
386 (fc:(freq: 69);dl:(len: 8)), (fc:(freq:197);dl:(len: 8)), (fc:(freq: 37);dl:(len: 8)),
387 (fc:(freq:165);dl:(len: 8)), (fc:(freq:101);dl:(len: 8)), (fc:(freq:229);dl:(len: 8)),
388 (fc:(freq: 21);dl:(len: 8)), (fc:(freq:149);dl:(len: 8)), (fc:(freq: 85);dl:(len: 8)),
389 (fc:(freq:213);dl:(len: 8)), (fc:(freq: 53);dl:(len: 8)), (fc:(freq:181);dl:(len: 8)),
390 (fc:(freq:117);dl:(len: 8)), (fc:(freq:245);dl:(len: 8)), (fc:(freq: 13);dl:(len: 8)),
391 (fc:(freq:141);dl:(len: 8)), (fc:(freq: 77);dl:(len: 8)), (fc:(freq:205);dl:(len: 8)),
392 (fc:(freq: 45);dl:(len: 8)), (fc:(freq:173);dl:(len: 8)), (fc:(freq:109);dl:(len: 8)),
393 (fc:(freq:237);dl:(len: 8)), (fc:(freq: 29);dl:(len: 8)), (fc:(freq:157);dl:(len: 8)),
394 (fc:(freq: 93);dl:(len: 8)), (fc:(freq:221);dl:(len: 8)), (fc:(freq: 61);dl:(len: 8)),
395 (fc:(freq:189);dl:(len: 8)), (fc:(freq:125);dl:(len: 8)), (fc:(freq:253);dl:(len: 8)),
396 (fc:(freq: 19);dl:(len: 9)), (fc:(freq:275);dl:(len: 9)), (fc:(freq:147);dl:(len: 9)),
397 (fc:(freq:403);dl:(len: 9)), (fc:(freq: 83);dl:(len: 9)), (fc:(freq:339);dl:(len: 9)),
398 (fc:(freq:211);dl:(len: 9)), (fc:(freq:467);dl:(len: 9)), (fc:(freq: 51);dl:(len: 9)),
399 (fc:(freq:307);dl:(len: 9)), (fc:(freq:179);dl:(len: 9)), (fc:(freq:435);dl:(len: 9)),
400 (fc:(freq:115);dl:(len: 9)), (fc:(freq:371);dl:(len: 9)), (fc:(freq:243);dl:(len: 9)),
401 (fc:(freq:499);dl:(len: 9)), (fc:(freq: 11);dl:(len: 9)), (fc:(freq:267);dl:(len: 9)),
402 (fc:(freq:139);dl:(len: 9)), (fc:(freq:395);dl:(len: 9)), (fc:(freq: 75);dl:(len: 9)),
403 (fc:(freq:331);dl:(len: 9)), (fc:(freq:203);dl:(len: 9)), (fc:(freq:459);dl:(len: 9)),
404 (fc:(freq: 43);dl:(len: 9)), (fc:(freq:299);dl:(len: 9)), (fc:(freq:171);dl:(len: 9)),
405 (fc:(freq:427);dl:(len: 9)), (fc:(freq:107);dl:(len: 9)), (fc:(freq:363);dl:(len: 9)),
406 (fc:(freq:235);dl:(len: 9)), (fc:(freq:491);dl:(len: 9)), (fc:(freq: 27);dl:(len: 9)),
407 (fc:(freq:283);dl:(len: 9)), (fc:(freq:155);dl:(len: 9)), (fc:(freq:411);dl:(len: 9)),
408 (fc:(freq: 91);dl:(len: 9)), (fc:(freq:347);dl:(len: 9)), (fc:(freq:219);dl:(len: 9)),
409 (fc:(freq:475);dl:(len: 9)), (fc:(freq: 59);dl:(len: 9)), (fc:(freq:315);dl:(len: 9)),
410 (fc:(freq:187);dl:(len: 9)), (fc:(freq:443);dl:(len: 9)), (fc:(freq:123);dl:(len: 9)),
411 (fc:(freq:379);dl:(len: 9)), (fc:(freq:251);dl:(len: 9)), (fc:(freq:507);dl:(len: 9)),
412 (fc:(freq: 7);dl:(len: 9)), (fc:(freq:263);dl:(len: 9)), (fc:(freq:135);dl:(len: 9)),
413 (fc:(freq:391);dl:(len: 9)), (fc:(freq: 71);dl:(len: 9)), (fc:(freq:327);dl:(len: 9)),
414 (fc:(freq:199);dl:(len: 9)), (fc:(freq:455);dl:(len: 9)), (fc:(freq: 39);dl:(len: 9)),
415 (fc:(freq:295);dl:(len: 9)), (fc:(freq:167);dl:(len: 9)), (fc:(freq:423);dl:(len: 9)),
416 (fc:(freq:103);dl:(len: 9)), (fc:(freq:359);dl:(len: 9)), (fc:(freq:231);dl:(len: 9)),
417 (fc:(freq:487);dl:(len: 9)), (fc:(freq: 23);dl:(len: 9)), (fc:(freq:279);dl:(len: 9)),
418 (fc:(freq:151);dl:(len: 9)), (fc:(freq:407);dl:(len: 9)), (fc:(freq: 87);dl:(len: 9)),
419 (fc:(freq:343);dl:(len: 9)), (fc:(freq:215);dl:(len: 9)), (fc:(freq:471);dl:(len: 9)),
420 (fc:(freq: 55);dl:(len: 9)), (fc:(freq:311);dl:(len: 9)), (fc:(freq:183);dl:(len: 9)),
421 (fc:(freq:439);dl:(len: 9)), (fc:(freq:119);dl:(len: 9)), (fc:(freq:375);dl:(len: 9)),
422 (fc:(freq:247);dl:(len: 9)), (fc:(freq:503);dl:(len: 9)), (fc:(freq: 15);dl:(len: 9)),
423 (fc:(freq:271);dl:(len: 9)), (fc:(freq:143);dl:(len: 9)), (fc:(freq:399);dl:(len: 9)),
424 (fc:(freq: 79);dl:(len: 9)), (fc:(freq:335);dl:(len: 9)), (fc:(freq:207);dl:(len: 9)),
425 (fc:(freq:463);dl:(len: 9)), (fc:(freq: 47);dl:(len: 9)), (fc:(freq:303);dl:(len: 9)),
426 (fc:(freq:175);dl:(len: 9)), (fc:(freq:431);dl:(len: 9)), (fc:(freq:111);dl:(len: 9)),
427 (fc:(freq:367);dl:(len: 9)), (fc:(freq:239);dl:(len: 9)), (fc:(freq:495);dl:(len: 9)),
428 (fc:(freq: 31);dl:(len: 9)), (fc:(freq:287);dl:(len: 9)), (fc:(freq:159);dl:(len: 9)),
429 (fc:(freq:415);dl:(len: 9)), (fc:(freq: 95);dl:(len: 9)), (fc:(freq:351);dl:(len: 9)),
430 (fc:(freq:223);dl:(len: 9)), (fc:(freq:479);dl:(len: 9)), (fc:(freq: 63);dl:(len: 9)),
431 (fc:(freq:319);dl:(len: 9)), (fc:(freq:191);dl:(len: 9)), (fc:(freq:447);dl:(len: 9)),
432 (fc:(freq:127);dl:(len: 9)), (fc:(freq:383);dl:(len: 9)), (fc:(freq:255);dl:(len: 9)),
433 (fc:(freq:511);dl:(len: 9)), (fc:(freq: 0);dl:(len: 7)), (fc:(freq: 64);dl:(len: 7)),
434 (fc:(freq: 32);dl:(len: 7)), (fc:(freq: 96);dl:(len: 7)), (fc:(freq: 16);dl:(len: 7)),
435 (fc:(freq: 80);dl:(len: 7)), (fc:(freq: 48);dl:(len: 7)), (fc:(freq:112);dl:(len: 7)),
436 (fc:(freq: 8);dl:(len: 7)), (fc:(freq: 72);dl:(len: 7)), (fc:(freq: 40);dl:(len: 7)),
437 (fc:(freq:104);dl:(len: 7)), (fc:(freq: 24);dl:(len: 7)), (fc:(freq: 88);dl:(len: 7)),
438 (fc:(freq: 56);dl:(len: 7)), (fc:(freq:120);dl:(len: 7)), (fc:(freq: 4);dl:(len: 7)),
439 (fc:(freq: 68);dl:(len: 7)), (fc:(freq: 36);dl:(len: 7)), (fc:(freq:100);dl:(len: 7)),
440 (fc:(freq: 20);dl:(len: 7)), (fc:(freq: 84);dl:(len: 7)), (fc:(freq: 52);dl:(len: 7)),
441 (fc:(freq:116);dl:(len: 7)), (fc:(freq: 3);dl:(len: 8)), (fc:(freq:131);dl:(len: 8)),
442 (fc:(freq: 67);dl:(len: 8)), (fc:(freq:195);dl:(len: 8)), (fc:(freq: 35);dl:(len: 8)),
443 (fc:(freq:163);dl:(len: 8)), (fc:(freq: 99);dl:(len: 8)), (fc:(freq:227);dl:(len: 8))
444 );
445
446
447 { The static distance tree. (Actually a trivial tree since all lens use
448 5 bits.) }
449 static_dtree : array[0..D_CODES-1] of ct_data = (
450 (fc:(freq: 0); dl:(len:5)), (fc:(freq:16); dl:(len:5)), (fc:(freq: 8); dl:(len:5)),
451 (fc:(freq:24); dl:(len:5)), (fc:(freq: 4); dl:(len:5)), (fc:(freq:20); dl:(len:5)),
452 (fc:(freq:12); dl:(len:5)), (fc:(freq:28); dl:(len:5)), (fc:(freq: 2); dl:(len:5)),
453 (fc:(freq:18); dl:(len:5)), (fc:(freq:10); dl:(len:5)), (fc:(freq:26); dl:(len:5)),
454 (fc:(freq: 6); dl:(len:5)), (fc:(freq:22); dl:(len:5)), (fc:(freq:14); dl:(len:5)),
455 (fc:(freq:30); dl:(len:5)), (fc:(freq: 1); dl:(len:5)), (fc:(freq:17); dl:(len:5)),
456 (fc:(freq: 9); dl:(len:5)), (fc:(freq:25); dl:(len:5)), (fc:(freq: 5); dl:(len:5)),
457 (fc:(freq:21); dl:(len:5)), (fc:(freq:13); dl:(len:5)), (fc:(freq:29); dl:(len:5)),
458 (fc:(freq: 3); dl:(len:5)), (fc:(freq:19); dl:(len:5)), (fc:(freq:11); dl:(len:5)),
459 (fc:(freq:27); dl:(len:5)), (fc:(freq: 7); dl:(len:5)), (fc:(freq:23); dl:(len:5))
460 );
461
462 { Distance codes. The first 256 values correspond to the distances
463 3 .. 258, the last 256 values correspond to the top 8 bits of
464 the 15 bit distances. }
465 _dist_code : array[0..DIST_CODE_LEN-1] of uch = (
466 0, 1, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8,
467 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10,
468 10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
469 11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,
470 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13,
471 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
472 13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
473 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
474 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
475 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15,
476 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
477 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
478 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 16, 17,
479 18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22,
480 23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
481 24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
482 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
483 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27,
484 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
485 27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
486 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
487 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
488 28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
489 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
490 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
491 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29
492 );
493
494 { length code for each normalized match length (0 == MIN_MATCH) }
495 _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch = (
496 0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 12, 12,
497 13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16,
498 17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19,
499 19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
500 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22,
501 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23,
502 23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
503 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
504 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
505 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26,
506 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
507 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
508 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28
509 );
510
511
512 { First normalized length for each code (0 = MIN_MATCH) }
513 base_length : array[0..LENGTH_CODES-1] of int = (
514 0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56,
515 64, 80, 96, 112, 128, 160, 192, 224, 0
516 );
517
518
519 { First normalized distance for each code (0 = distance of 1) }
520 base_dist : array[0..D_CODES-1] of int = (
521 0, 1, 2, 3, 4, 6, 8, 12, 16, 24,
522 32, 48, 64, 96, 128, 192, 256, 384, 512, 768,
523 1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576
524 );
525 {$endif}
526
527 { Output a byte on the stream.
528 IN assertion: there is enough room in pending_buf.
529 macro put_byte(s, c)
530 begin
531 s^.pending_buf^[s^.pending] := (c);
532 Inc(s^.pending);
533 end
534 }
535
536 const
537 MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1);
538 { Minimum amount of lookahead, except at the end of the input file.
539 See deflate.c for comments about the MIN_MATCH+1. }
540
541 {macro d_code(dist)
542 if (dist) < 256 then
543 := _dist_code[dist]
544 else
545 := _dist_code[256+((dist) shr 7)]);
546 Mapping from a distance to a distance code. dist is the distance - 1 and
547 must not have side effects. _dist_code[256] and _dist_code[257] are never
548 used. }
549
550 {$ifndef ORG_DEBUG}
551 { Inline versions of _tr_tally for speed: }
552
553 #if defined(GEN_TREES_H) || !defined(STDC)
554 extern uch _length_code[];
555 extern uch _dist_code[];
556 #else
557 extern const uch _length_code[];
558 extern const uch _dist_code[];
559 #endif
560
561 macro _tr_tally_lit(s, c, flush)
562 var
563 cc : uch;
564 begin
565 cc := (c);
566 s^.d_buf[s^.last_lit] := 0;
567 s^.l_buf[s^.last_lit] := cc;
568 Inc(s^.last_lit);
569 Inc(s^.dyn_ltree[cc].fc.Freq);
570 flush := (s^.last_lit = s^.lit_bufsize-1);
571 end;
572
573 macro _tr_tally_dist(s, distance, length, flush) \
574 var
575 len : uch;
576 dist : ush;
577 begin
578 len := (length);
579 dist := (distance);
580 s^.d_buf[s^.last_lit] := dist;
581 s^.l_buf[s^.last_lit] = len;
582 Inc(s^.last_lit);
583 Dec(dist);
584 Inc(s^.dyn_ltree[_length_code[len]+LITERALS+1].fc.Freq);
585 Inc(s^.dyn_dtree[d_code(dist)].Freq);
586 flush := (s^.last_lit = s^.lit_bufsize-1);
587 end;
588
589 {$endif}
590
591 { ===========================================================================
592 Constants }
593
594 const
595 MAX_BL_BITS = 7;
596 { Bit length codes must not exceed MAX_BL_BITS bits }
597
598 const
599 END_BLOCK = 256;
600 { end of block literal code }
601
602 const
603 REP_3_6 = 16;
604 { repeat previous bit length 3-6 times (2 bits of repeat count) }
605
606 const
607 REPZ_3_10 = 17;
608 { repeat a zero length 3-10 times (3 bits of repeat count) }
609
610 const
611 REPZ_11_138 = 18;
612 { repeat a zero length 11-138 times (7 bits of repeat count) }
613
614 {local}
615 const
616 extra_lbits : array[0..LENGTH_CODES-1] of int
617 { extra bits for each length code }
618 = (0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4,5,5,5,5,0);
619
620 {local}
621 const
622 extra_dbits : array[0..D_CODES-1] of int
623 { extra bits for each distance code }
624 = (0,0,0,0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10,11,11,12,12,13,13);
625
626 {local}
627 const
628 extra_blbits : array[0..BL_CODES-1] of int { extra bits for each bit length code }
629 = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,3,7);
630
631 {local}
632 const
633 bl_order : array[0..BL_CODES-1] of uch
634 = (16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15);
635 { The lengths of the bit length codes are sent in order of decreasing
636 probability, to avoid transmitting the lengths for unused bit length codes.
637 }
638
639 const
640 Buf_size = (8 * 2*sizeof(char));
641 { Number of bits used within bi_buf. (bi_buf might be implemented on
642 more than 16 bits on some systems.) }
643
644 { ===========================================================================
645 Local data. These are initialized only once. }
646
647
648 {$ifdef GEN_TREES_H)}
649 { non ANSI compilers may not accept trees.h }
650
651 const
652 DIST_CODE_LEN = 512; { see definition of array dist_code below }
653
654 {local}
655 var
656 static_ltree : array[0..L_CODES+2-1] of ct_data;
657 { The static literal tree. Since the bit lengths are imposed, there is no
658 need for the L_CODES extra codes used during heap construction. However
659 The codes 286 and 287 are needed to build a canonical tree (see _tr_init
660 below). }
661
662 {local}
663 static_dtree : array[0..D_CODES-1] of ct_data;
664 { The static distance tree. (Actually a trivial tree since all codes use
665 5 bits.) }
666
667 _dist_code : array[0..DIST_CODE_LEN-1] of uch;
668 { Distance codes. The first 256 values correspond to the distances
669 3 .. 258, the last 256 values correspond to the top 8 bits of
670 the 15 bit distances. }
671
672 _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch;
673 { length code for each normalized match length (0 == MIN_MATCH) }
674
675 {local}
676 base_length : array[0..LENGTH_CODES-1] of int;
677 { First normalized length for each code (0 = MIN_MATCH) }
678
679 {local}
680 base_dist : array[0..D_CODES-1] of int;
681 { First normalized distance for each code (0 = distance of 1) }
682
683 {$endif} { GEN_TREES_H }
684
685 {local}
686 const
687 static_l_desc : static_tree_desc =
688 (static_tree: {tree_ptr}(@(static_ltree)); { pointer to array of ct_data }
689 extra_bits: {pzIntfArray}(@(extra_lbits)); { pointer to array of int }
690 extra_base: LITERALS+1;
691 elems: L_CODES;
692 max_length: MAX_BITS);
693
694 {local}
695 const
696 static_d_desc : static_tree_desc =
697 (static_tree: {tree_ptr}(@(static_dtree));
698 extra_bits: {pzIntfArray}(@(extra_dbits));
699 extra_base : 0;
700 elems: D_CODES;
701 max_length: MAX_BITS);
702
703 {local}
704 const
705 static_bl_desc : static_tree_desc =
706 (static_tree: {tree_ptr}(NIL);
707 extra_bits: {pzIntfArray}@(extra_blbits);
708 extra_base : 0;
709 elems: BL_CODES;
710 max_length: MAX_BL_BITS);
711
712 (* ===========================================================================
713 Local (static) routines in this file. }
714
715 procedure tr_static_init;
716 procedure init_block(var deflate_state);
717 procedure pqdownheap(var s : deflate_state;
718 var tree : ct_data;
719 k : int);
720 procedure gen_bitlen(var s : deflate_state;
721 var desc : tree_desc);
722 procedure gen_codes(var tree : ct_data;
723 max_code : int;
724 bl_count : pushf);
725 procedure build_tree(var s : deflate_state;
726 var desc : tree_desc);
727 procedure scan_tree(var s : deflate_state;
728 var tree : ct_data;
729 max_code : int);
730 procedure send_tree(var s : deflate_state;
731 var tree : ct_data;
732 max_code : int);
733 function build_bl_tree(var deflate_state) : int;
734 procedure send_all_trees(var deflate_state;
735 lcodes : int;
736 dcodes : int;
737 blcodes : int);
738 procedure compress_block(var s : deflate_state;
739 var ltree : ct_data;
740 var dtree : ct_data);
741 procedure set_data_type(var s : deflate_state);
742 function bi_reverse(value : unsigned;
743 length : int) : unsigned;
744 procedure bi_windup(var deflate_state);
745 procedure bi_flush(var deflate_state);
746 procedure copy_block(var deflate_state;
747 buf : pcharf;
748 len : unsigned;
749 header : int);
750 *)
751
752 {$ifdef GEN_TREES_H}
753 {local}
754 procedure gen_trees_header;
755 {$endif}
756
757 (*
758 { ===========================================================================
759 Output a short LSB first on the stream.
760 IN assertion: there is enough room in pendingBuf. }
761
762 macro put_short(s, w)
763 begin
764 {put_byte(s, (uch)((w) & 0xff));}
765 s.pending_buf^[s.pending] := uch((w) and $ff);
766 Inc(s.pending);
767
768 {put_byte(s, (uch)((ush)(w) >> 8));}
769 s.pending_buf^[s.pending] := uch(ush(w) shr 8);;
770 Inc(s.pending);
771 end
772 *)
773
774 { ===========================================================================
775 Send a value on a given number of bits.
776 IN assertion: length <= 16 and value fits in length bits. }
777
778 {$ifdef ORG_DEBUG}
779
780 {local}
781 procedure send_bits(var s : deflate_state;
782 value : int; { value to send }
783 length : int); { number of bits }
784 begin
785 {$ifdef DEBUG}
786 Tracevv(' l '+IntToStr(length)+ ' v '+IntToStr(value));
787 Assert((length > 0) and (length <= 15), 'invalid length');
788 Inc(s.bits_sent, ulg(length));
789 {$ENDIF}
790
791 { If not enough room in bi_buf, use (valid) bits from bi_buf and
792 (16 - bi_valid) bits from value, leaving (width - (16-bi_valid))
793 unused bits in value. }
794 {$IFOPT Q+} {$Q-} {$DEFINE NoOverflowCheck} {$ENDIF}
795 {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF}
796 if (s.bi_valid > int(Buf_size) - length) then
797 begin
798 s.bi_buf := s.bi_buf or int(value shl s.bi_valid);
799 {put_short(s, s.bi_buf);}
800 s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);
801 Inc(s.pending);
802 s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;
803 Inc(s.pending);
804
805 s.bi_buf := ush(value) shr (Buf_size - s.bi_valid);
806 Inc(s.bi_valid, length - Buf_size);
807 end
808 else
809 begin
810 s.bi_buf := s.bi_buf or int(value shl s.bi_valid);
811 Inc(s.bi_valid, length);
812 end;
813 {$IFDEF NoOverflowCheck} {$Q+} {$UNDEF NoOverflowCheck} {$ENDIF}
814 {$IFDEF NoRangeCheck} {$Q+} {$UNDEF NoRangeCheck} {$ENDIF}
815 end;
816
817 {$else} { !DEBUG }
818
819
820 macro send_code(s, c, tree)
821 begin
822 send_bits(s, tree[c].Code, tree[c].Len);
823 { Send a code of the given tree. c and tree must not have side effects }
824 end
825
826 macro send_bits(s, value, length) \
827 begin int len := length;\
828 if (s^.bi_valid > (int)Buf_size - len) begin\
829 int val := value;\
830 s^.bi_buf |= (val << s^.bi_valid);\
831 {put_short(s, s.bi_buf);}
832 s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);
833 Inc(s.pending);
834 s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;
835 Inc(s.pending);
836
837 s^.bi_buf := (ush)val >> (Buf_size - s^.bi_valid);\
838 s^.bi_valid += len - Buf_size;\
839 end else begin\
840 s^.bi_buf |= (value) << s^.bi_valid;\
841 s^.bi_valid += len;\
842 end\
843 end;
844 {$endif} { DEBUG }
845
846 { ===========================================================================
847 Reverse the first len bits of a code, using straightforward code (a faster
848 method would use a table)
849 IN assertion: 1 <= len <= 15 }
850
851 {local}
852 function bi_reverse(code : unsigned; { the value to invert }
853 len : int) : unsigned; { its bit length }
854
855 var
856 res : unsigned; {register}
857 begin
858 res := 0;
859 repeat
860 res := res or (code and 1);
861 code := code shr 1;
862 res := res shl 1;
863 Dec(len);
864 until (len <= 0);
865 bi_reverse := res shr 1;
866 end;
867
868 { ===========================================================================
869 Generate the codes for a given tree and bit counts (which need not be
870 optimal).
871 IN assertion: the array bl_count contains the bit length statistics for
872 the given tree and the field len is set for all tree elements.
873 OUT assertion: the field code is set for all tree elements of non
874 zero code length. }
875
876 {local}
877 procedure gen_codes(tree : tree_ptr; { the tree to decorate }
878 max_code : int; { largest code with non zero frequency }
879 var bl_count : array of ushf); { number of codes at each bit length }
880
881 var
882 next_code : array[0..MAX_BITS+1-1] of ush; { next code value for each bit length }
883 code : ush; { running code value }
884 bits : int; { bit index }
885 n : int; { code index }
886 var
887 len : int;
888 begin
889 code := 0;
890
891 { The distribution counts are first used to generate the code values
892 without bit reversal. }
893
894 for bits := 1 to MAX_BITS do
895 begin
896 code := ((code + bl_count[bits-1]) shl 1);
897 next_code[bits] := code;
898 end;
899 { Check that the bit counts in bl_count are consistent. The last code
900 must be all ones. }
901
902 {$IFDEF DEBUG}
903 Assert (code + bl_count[MAX_BITS]-1 = (1 shl MAX_BITS)-1,
904 'inconsistent bit counts');
905 Tracev(#13'gen_codes: max_code '+IntToStr(max_code));
906 {$ENDIF}
907
908 for n := 0 to max_code do
909 begin
910 len := tree^[n].dl.Len;
911 if (len = 0) then
912 continue;
913 { Now reverse the bits }
914 tree^[n].fc.Code := bi_reverse(next_code[len], len);
915 Inc(next_code[len]);
916 {$ifdef DEBUG}
917 if (n>31) and (n<128) then
918 Tracecv(tree <> tree_ptr(@static_ltree),
919 (^M'n #'+IntToStr(n)+' '+char(n)+' l '+IntToStr(len)+' c '+
920 IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')'))
921 else
922 Tracecv(tree <> tree_ptr(@static_ltree),
923 (^M'n #'+IntToStr(n)+' l '+IntToStr(len)+' c '+
924 IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')'));
925 {$ENDIF}
926 end;
927 end;
928
929 { ===========================================================================
930 Genererate the file trees.h describing the static trees. }
931 {$ifdef GEN_TREES_H}
932
933 macro SEPARATOR(i, last, width)
934 if (i) = (last) then
935 ( ^M');'^M^M
936 else \
937 if (i) mod (width) = (width)-1 then
938 ','^M
939 else
940 ', '
941
942 procedure gen_trees_header;
943 var
944 header : system.text;
945 i : int;
946 begin
947 system.assign(header, 'trees.inc');
948 {$I-}
949 ReWrite(header);
950 {$I+}
951 Assert (IOresult <> 0, 'Can''t open trees.h');
952 WriteLn(header,
953 '{ header created automatically with -DGEN_TREES_H }'^M);
954
955 WriteLn(header, 'local const ct_data static_ltree[L_CODES+2] := (');
956 for i := 0 to L_CODES+2-1 do
957 begin
958 WriteLn(header, '((%3u),(%3u))%s', static_ltree[i].Code,
959 static_ltree[i].Len, SEPARATOR(i, L_CODES+1, 5));
960 end;
961
962 WriteLn(header, 'local const ct_data static_dtree[D_CODES] := (');
963 for i := 0 to D_CODES-1 do
964 begin
965 WriteLn(header, '((%2u),(%2u))%s', static_dtree[i].Code,
966 static_dtree[i].Len, SEPARATOR(i, D_CODES-1, 5));
967 end;
968
969 WriteLn(header, 'const uch _dist_code[DIST_CODE_LEN] := (');
970 for i := 0 to DIST_CODE_LEN-1 do
971 begin
972 WriteLn(header, '%2u%s', _dist_code[i],
973 SEPARATOR(i, DIST_CODE_LEN-1, 20));
974 end;
975
976 WriteLn(header, 'const uch _length_code[MAX_MATCH-MIN_MATCH+1]= (');
977 for i := 0 to MAX_MATCH-MIN_MATCH+1-1 do
978 begin
979 WriteLn(header, '%2u%s', _length_code[i],
980 SEPARATOR(i, MAX_MATCH-MIN_MATCH, 20));
981 end;
982
983 WriteLn(header, 'local const int base_length[LENGTH_CODES] := (');
984 for i := 0 to LENGTH_CODES-1 do
985 begin
986 WriteLn(header, '%1u%s', base_length[i],
987 SEPARATOR(i, LENGTH_CODES-1, 20));
988 end;
989
990 WriteLn(header, 'local const int base_dist[D_CODES] := (');
991 for i := 0 to D_CODES-1 do
992 begin
993 WriteLn(header, '%5u%s', base_dist[i],
994 SEPARATOR(i, D_CODES-1, 10));
995 end;
996
997 close(header);
998 end;
999 {$endif} { GEN_TREES_H }
1000
1001
1002 { ===========================================================================
1003 Initialize the various 'constant' tables. }
1004
1005 {local}
1006 procedure tr_static_init;
1007
1008 {$ifdef GEN_TREES_H}
1009 const
1010 static_init_done : boolean = FALSE;
1011 var
1012 n : int; { iterates over tree elements }
1013 bits : int; { bit counter }
1014 length : int; { length value }
1015 code : int; { code value }
1016 dist : int; { distance index }
1017 bl_count : array[0..MAX_BITS+1-1] of ush;
1018 { number of codes at each bit length for an optimal tree }
1019 begin
1020 if (static_init_done) then
1021 exit;
1022
1023 { Initialize the mapping length (0..255) -> length code (0..28) }
1024 length := 0;
1025 for code := 0 to LENGTH_CODES-1-1 do
1026 begin
1027 base_length[code] := length;
1028 for n := 0 to (1 shl extra_lbits[code])-1 do
1029 begin
1030 _length_code[length] := uch(code);
1031 Inc(length);
1032 end;
1033 end;
1034 Assert (length = 256, 'tr_static_init: length <> 256');
1035 { Note that the length 255 (match length 258) can be represented
1036 in two different ways: code 284 + 5 bits or code 285, so we
1037 overwrite length_code[255] to use the best encoding: }
1038
1039 _length_code[length-1] := uch(code);
1040
1041 { Initialize the mapping dist (0..32K) -> dist code (0..29) }
1042 dist := 0;
1043 for code := 0 to 16-1 do
1044 begin
1045 base_dist[code] := dist;
1046 for n := 0 to (1 shl extra_dbits[code])-1 do
1047 begin
1048 _dist_code[dist] := uch(code);
1049 Inc(dist);
1050 end;
1051 end;
1052 Assert (dist = 256, 'tr_static_init: dist <> 256');
1053 dist := dist shr 7; { from now on, all distances are divided by 128 }
1054 for code := 16 to D_CODES-1 do
1055 begin
1056 base_dist[code] := dist shl 7;
1057 for n := 0 to (1 shl (extra_dbits[code]-7))-1 do
1058 begin
1059 _dist_code[256 + dist] := uch(code);
1060 Inc(dist);
1061 end;
1062 end;
1063 Assert (dist = 256, 'tr_static_init: 256+dist <> 512');
1064
1065 { Construct the codes of the static literal tree }
1066 for bits := 0 to MAX_BITS do
1067 bl_count[bits] := 0;
1068 n := 0;
1069 while (n <= 143) do
1070 begin
1071 static_ltree[n].dl.Len := 8;
1072 Inc(n);
1073 Inc(bl_count[8]);
1074 end;
1075 while (n <= 255) do
1076 begin
1077 static_ltree[n].dl.Len := 9;
1078 Inc(n);
1079 Inc(bl_count[9]);
1080 end;
1081 while (n <= 279) do
1082 begin
1083 static_ltree[n].dl.Len := 7;
1084 Inc(n);
1085 Inc(bl_count[7]);
1086 end;
1087 while (n <= 287) do
1088 begin
1089 static_ltree[n].dl.Len := 8;
1090 Inc(n);
1091 Inc(bl_count[8]);
1092 end;
1093
1094 { Codes 286 and 287 do not exist, but we must include them in the
1095 tree construction to get a canonical Huffman tree (longest code
1096 all ones) }
1097
1098 gen_codes(tree_ptr(@static_ltree), L_CODES+1, bl_count);
1099
1100 { The static distance tree is trivial: }
1101 for n := 0 to D_CODES-1 do
1102 begin
1103 static_dtree[n].dl.Len := 5;
1104 static_dtree[n].fc.Code := bi_reverse(unsigned(n), 5);
1105 end;
1106 static_init_done := TRUE;
1107
1108 gen_trees_header; { save to include file }
1109 {$else}
1110 begin
1111 {$endif} { GEN_TREES_H) }
1112 end;
1113
1114 { ===========================================================================
1115 Initialize a new block. }
1116 {local}
1117
1118 procedure init_block(var s : deflate_state);
1119 var
1120 n : int; { iterates over tree elements }
1121 begin
1122 { Initialize the trees. }
1123 for n := 0 to L_CODES-1 do
1124 s.dyn_ltree[n].fc.Freq := 0;
1125 for n := 0 to D_CODES-1 do
1126 s.dyn_dtree[n].fc.Freq := 0;
1127 for n := 0 to BL_CODES-1 do
1128 s.bl_tree[n].fc.Freq := 0;
1129
1130 s.dyn_ltree[END_BLOCK].fc.Freq := 1;
1131 s.static_len := Long(0);
1132 s.opt_len := Long(0);
1133 s.matches := 0;
1134 s.last_lit := 0;
1135 end;
1136
1137 const
1138 SMALLEST = 1;
1139 { Index within the heap array of least frequent node in the Huffman tree }
1140
1141 { ===========================================================================
1142 Initialize the tree data structures for a new zlib stream. }
1143 procedure _tr_init(var s : deflate_state);
1144 begin
1145 tr_static_init;
1146
1147 s.compressed_len := Long(0);
1148
1149 s.l_desc.dyn_tree := tree_ptr(@s.dyn_ltree);
1150 s.l_desc.stat_desc := @static_l_desc;
1151
1152 s.d_desc.dyn_tree := tree_ptr(@s.dyn_dtree);
1153 s.d_desc.stat_desc := @static_d_desc;
1154
1155 s.bl_desc.dyn_tree := tree_ptr(@s.bl_tree);
1156 s.bl_desc.stat_desc := @static_bl_desc;
1157
1158 s.bi_buf := 0;
1159 s.bi_valid := 0;
1160 s.last_eob_len := 8; { enough lookahead for inflate }
1161 {$ifdef DEBUG}
1162 s.bits_sent := Long(0);
1163 {$endif}
1164
1165 { Initialize the first block of the first file: }
1166 init_block(s);
1167 end;
1168
1169 { ===========================================================================
1170 Remove the smallest element from the heap and recreate the heap with
1171 one less element. Updates heap and heap_len.
1172
1173 macro pqremove(s, tree, top)
1174 begin
1175 top := s.heap[SMALLEST];
1176 s.heap[SMALLEST] := s.heap[s.heap_len];
1177 Dec(s.heap_len);
1178 pqdownheap(s, tree, SMALLEST);
1179 end
1180 }
1181
1182 { ===========================================================================
1183 Compares to subtrees, using the tree depth as tie breaker when
1184 the subtrees have equal frequency. This minimizes the worst case length.
1185
1186 macro smaller(tree, n, m, depth)
1187 ( (tree[n].Freq < tree[m].Freq) or
1188 ((tree[n].Freq = tree[m].Freq) and (depth[n] <= depth[m])) )
1189 }
1190
1191 { ===========================================================================
1192 Restore the heap property by moving down the tree starting at node k,
1193 exchanging a node with the smallest of its two sons if necessary, stopping
1194 when the heap property is re-established (each father smaller than its
1195 two sons). }
1196 {local}
1197
1198 procedure pqdownheap(var s : deflate_state;
1199 var tree : tree_type; { the tree to restore }
1200 k : int); { node to move down }
1201 var
1202 v : int;
1203 j : int;
1204 begin
1205 v := s.heap[k];
1206 j := k shl 1; { left son of k }
1207 while (j <= s.heap_len) do
1208 begin
1209 { Set j to the smallest of the two sons: }
1210 if (j < s.heap_len) and
1211 {smaller(tree, s.heap[j+1], s.heap[j], s.depth)}
1212 ( (tree[s.heap[j+1]].fc.Freq < tree[s.heap[j]].fc.Freq) or
1213 ((tree[s.heap[j+1]].fc.Freq = tree[s.heap[j]].fc.Freq) and
1214 (s.depth[s.heap[j+1]] <= s.depth[s.heap[j]])) ) then
1215 begin
1216 Inc(j);
1217 end;
1218 { Exit if v is smaller than both sons }
1219 if {(smaller(tree, v, s.heap[j], s.depth))}
1220 ( (tree[v].fc.Freq < tree[s.heap[j]].fc.Freq) or
1221 ((tree[v].fc.Freq = tree[s.heap[j]].fc.Freq) and
1222 (s.depth[v] <= s.depth[s.heap[j]])) ) then
1223 break;
1224 { Exchange v with the smallest son }
1225 s.heap[k] := s.heap[j];
1226 k := j;
1227
1228 { And continue down the tree, setting j to the left son of k }
1229 j := j shl 1;
1230 end;
1231 s.heap[k] := v;
1232 end;
1233
1234 { ===========================================================================
1235 Compute the optimal bit lengths for a tree and update the total bit length
1236 for the current block.
1237 IN assertion: the fields freq and dad are set, heap[heap_max] and
1238 above are the tree nodes sorted by increasing frequency.
1239 OUT assertions: the field len is set to the optimal bit length, the
1240 array bl_count contains the frequencies for each bit length.
1241 The length opt_len is updated; static_len is also updated if stree is
1242 not null. }
1243
1244 {local}
1245 procedure gen_bitlen(var s : deflate_state;
1246 var desc : tree_desc); { the tree descriptor }
1247 var
1248 tree : tree_ptr;
1249 max_code : int;
1250 stree : tree_ptr; {const}
1251 extra : pzIntfArray; {const}
1252 base : int;
1253 max_length : int;
1254 h : int; { heap index }
1255 n, m : int; { iterate over the tree elements }
1256 bits : int; { bit length }
1257 xbits : int; { extra bits }
1258 f : ush; { frequency }
1259 overflow : int; { number of elements with bit length too large }
1260 begin
1261 tree := desc.dyn_tree;
1262 max_code := desc.max_code;
1263 stree := desc.stat_desc^.static_tree;
1264 extra := desc.stat_desc^.extra_bits;
1265 base := desc.stat_desc^.extra_base;
1266 max_length := desc.stat_desc^.max_length;
1267 overflow := 0;
1268
1269 for bits := 0 to MAX_BITS do
1270 s.bl_count[bits] := 0;
1271
1272 { In a first pass, compute the optimal bit lengths (which may
1273 overflow in the case of the bit length tree). }
1274
1275 tree^[s.heap[s.heap_max]].dl.Len := 0; { root of the heap }
1276
1277 for h := s.heap_max+1 to HEAP_SIZE-1 do
1278 begin
1279 n := s.heap[h];
1280 bits := tree^[tree^[n].dl.Dad].dl.Len + 1;
1281 if (bits > max_length) then
1282 begin
1283 bits := max_length;
1284 Inc(overflow);
1285 end;
1286 tree^[n].dl.Len := ush(bits);
1287 { We overwrite tree[n].dl.Dad which is no longer needed }
1288
1289 if (n > max_code) then
1290 continue; { not a leaf node }
1291
1292 Inc(s.bl_count[bits]);
1293 xbits := 0;
1294 if (n >= base) then
1295 xbits := extra^[n-base];
1296 f := tree^[n].fc.Freq;
1297 Inc(s.opt_len, ulg(f) * (bits + xbits));
1298 if (stree <> NIL) then
1299 Inc(s.static_len, ulg(f) * (stree^[n].dl.Len + xbits));
1300 end;
1301 if (overflow = 0) then
1302 exit;
1303 {$ifdef DEBUG}
1304 Tracev(^M'bit length overflow');
1305 {$endif}
1306 { This happens for example on obj2 and pic of the Calgary corpus }
1307
1308 { Find the first bit length which could increase: }
1309 repeat
1310 bits := max_length-1;
1311 while (s.bl_count[bits] = 0) do
1312 Dec(bits);
1313 Dec(s.bl_count[bits]); { move one leaf down the tree }
1314 Inc(s.bl_count[bits+1], 2); { move one overflow item as its brother }
1315 Dec(s.bl_count[max_length]);
1316 { The brother of the overflow item also moves one step up,
1317 but this does not affect bl_count[max_length] }
1318
1319 Dec(overflow, 2);
1320 until (overflow <= 0);
1321
1322 { Now recompute all bit lengths, scanning in increasing frequency.
1323 h is still equal to HEAP_SIZE. (It is simpler to reconstruct all
1324 lengths instead of fixing only the wrong ones. This idea is taken
1325 from 'ar' written by Haruhiko Okumura.) }
1326 h := HEAP_SIZE; { Delphi3: compiler warning w/o this }
1327 for bits := max_length downto 1 do
1328 begin
1329 n := s.bl_count[bits];
1330 while (n <> 0) do
1331 begin
1332 Dec(h);
1333 m := s.heap[h];
1334 if (m > max_code) then
1335 continue;
1336 if (tree^[m].dl.Len <> unsigned(bits)) then
1337 begin
1338 {$ifdef DEBUG}
1339 Trace('code '+IntToStr(m)+' bits '+IntToStr(tree^[m].dl.Len)
1340 +'.'+IntToStr(bits));
1341 {$ENDIF}
1342 Inc(s.opt_len, (long(bits) - long(tree^[m].dl.Len))
1343 * long(tree^[m].fc.Freq) );
1344 tree^[m].dl.Len := ush(bits);
1345 end;
1346 Dec(n);
1347 end;
1348 end;
1349 end;
1350
1351 { ===========================================================================
1352 Construct one Huffman tree and assigns the code bit strings and lengths.
1353 Update the total bit length for the current block.
1354 IN assertion: the field freq is set for all tree elements.
1355 OUT assertions: the fields len and code are set to the optimal bit length
1356 and corresponding code. The length opt_len is updated; static_len is
1357 also updated if stree is not null. The field max_code is set. }
1358
1359 {local}
1360 procedure build_tree(var s : deflate_state;
1361 var desc : tree_desc); { the tree descriptor }
1362
1363 var
1364 tree : tree_ptr;
1365 stree : tree_ptr; {const}
1366 elems : int;
1367 n, m : int; { iterate over heap elements }
1368 max_code : int; { largest code with non zero frequency }
1369 node : int; { new node being created }
1370 begin
1371 tree := desc.dyn_tree;
1372 stree := desc.stat_desc^.static_tree;
1373 elems := desc.stat_desc^.elems;
1374 max_code := -1;
1375
1376 { Construct the initial heap, with least frequent element in
1377 heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1].
1378 heap[0] is not used. }
1379 s.heap_len := 0;
1380 s.heap_max := HEAP_SIZE;
1381
1382 for n := 0 to elems-1 do
1383 begin
1384 if (tree^[n].fc.Freq <> 0) then
1385 begin
1386 max_code := n;
1387 Inc(s.heap_len);
1388 s.heap[s.heap_len] := n;
1389 s.depth[n] := 0;
1390 end
1391 else
1392 begin
1393 tree^[n].dl.Len := 0;
1394 end;
1395 end;
1396
1397 { The pkzip format requires that at least one distance code exists,
1398 and that at least one bit should be sent even if there is only one
1399 possible code. So to avoid special checks later on we force at least
1400 two codes of non zero frequency. }
1401
1402 while (s.heap_len < 2) do
1403 begin
1404 Inc(s.heap_len);
1405 if (max_code < 2) then
1406 begin
1407 Inc(max_code);
1408 s.heap[s.heap_len] := max_code;
1409 node := max_code;
1410 end
1411 else
1412 begin
1413 s.heap[s.heap_len] := 0;
1414 node := 0;
1415 end;
1416 tree^[node].fc.Freq := 1;
1417 s.depth[node] := 0;
1418 Dec(s.opt_len);
1419 if (stree <> NIL) then
1420 Dec(s.static_len, stree^[node].dl.Len);
1421 { node is 0 or 1 so it does not have extra bits }
1422 end;
1423 desc.max_code := max_code;
1424
1425 { The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree,
1426 establish sub-heaps of increasing lengths: }
1427
1428 for n := s.heap_len div 2 downto 1 do
1429 pqdownheap(s, tree^, n);
1430
1431 { Construct the Huffman tree by repeatedly combining the least two
1432 frequent nodes. }
1433
1434 node := elems; { next internal node of the tree }
1435 repeat
1436 {pqremove(s, tree, n);} { n := node of least frequency }
1437 n := s.heap[SMALLEST];
1438 s.heap[SMALLEST] := s.heap[s.heap_len];
1439 Dec(s.heap_len);
1440 pqdownheap(s, tree^, SMALLEST);
1441
1442 m := s.heap[SMALLEST]; { m := node of next least frequency }
1443
1444 Dec(s.heap_max);
1445 s.heap[s.heap_max] := n; { keep the nodes sorted by frequency }
1446 Dec(s.heap_max);
1447 s.heap[s.heap_max] := m;
1448
1449 { Create a new node father of n and m }
1450 tree^[node].fc.Freq := tree^[n].fc.Freq + tree^[m].fc.Freq;
1451 { maximum }
1452 if (s.depth[n] >= s.depth[m]) then
1453 s.depth[node] := uch (s.depth[n] + 1)
1454 else
1455 s.depth[node] := uch (s.depth[m] + 1);
1456
1457 tree^[m].dl.Dad := ush(node);
1458 tree^[n].dl.Dad := ush(node);
1459 {$ifdef DUMP_BL_TREE}
1460 if (tree = tree_ptr(@s.bl_tree)) then
1461 begin
1462 WriteLn(#13'node ',node,'(',tree^[node].fc.Freq,') sons ',n,
1463 '(',tree^[n].fc.Freq,') ', m, '(',tree^[m].fc.Freq,')');
1464 end;
1465 {$endif}
1466 { and insert the new node in the heap }
1467 s.heap[SMALLEST] := node;
1468 Inc(node);
1469 pqdownheap(s, tree^, SMALLEST);
1470
1471 until (s.heap_len < 2);
1472
1473 Dec(s.heap_max);
1474 s.heap[s.heap_max] := s.heap[SMALLEST];
1475
1476 { At this point, the fields freq and dad are set. We can now
1477 generate the bit lengths. }
1478
1479 gen_bitlen(s, desc);
1480
1481 { The field len is now set, we can generate the bit codes }
1482 gen_codes (tree, max_code, s.bl_count);
1483 end;
1484
1485 { ===========================================================================
1486 Scan a literal or distance tree to determine the frequencies of the codes
1487 in the bit length tree. }
1488
1489 {local}
1490 procedure scan_tree(var s : deflate_state;
1491 var tree : array of ct_data; { the tree to be scanned }
1492 max_code : int); { and its largest code of non zero frequency }
1493 var
1494 n : int; { iterates over all tree elements }
1495 prevlen : int; { last emitted length }
1496 curlen : int; { length of current code }
1497 nextlen : int; { length of next code }
1498 count : int; { repeat count of the current code }
1499 max_count : int; { max repeat count }
1500 min_count : int; { min repeat count }
1501 begin
1502 prevlen := -1;
1503 nextlen := tree[0].dl.Len;
1504 count := 0;
1505 max_count := 7;
1506 min_count := 4;
1507
1508 if (nextlen = 0) then
1509 begin
1510 max_count := 138;
1511 min_count := 3;
1512 end;
1513 tree[max_code+1].dl.Len := ush($ffff); { guard }
1514
1515 for n := 0 to max_code do
1516 begin
1517 curlen := nextlen;
1518 nextlen := tree[n+1].dl.Len;
1519 Inc(count);
1520 if (count < max_count) and (curlen = nextlen) then
1521 continue
1522 else
1523 if (count < min_count) then
1524 Inc(s.bl_tree[curlen].fc.Freq, count)
1525 else
1526 if (curlen <> 0) then
1527 begin
1528 if (curlen <> prevlen) then
1529 Inc(s.bl_tree[curlen].fc.Freq);
1530 Inc(s.bl_tree[REP_3_6].fc.Freq);
1531 end
1532 else
1533 if (count <= 10) then
1534 Inc(s.bl_tree[REPZ_3_10].fc.Freq)
1535 else
1536 Inc(s.bl_tree[REPZ_11_138].fc.Freq);
1537
1538 count := 0;
1539 prevlen := curlen;
1540 if (nextlen = 0) then
1541 begin
1542 max_count := 138;
1543 min_count := 3;
1544 end
1545 else
1546 if (curlen = nextlen) then
1547 begin
1548 max_count := 6;
1549 min_count := 3;
1550 end
1551 else
1552 begin
1553 max_count := 7;
1554 min_count := 4;
1555 end;
1556 end;
1557 end;
1558
1559 { ===========================================================================
1560 Send a literal or distance tree in compressed form, using the codes in
1561 bl_tree. }
1562
1563 {local}
1564 procedure send_tree(var s : deflate_state;
1565 var tree : array of ct_data; { the tree to be scanned }
1566 max_code : int); { and its largest code of non zero frequency }
1567
1568 var
1569 n : int; { iterates over all tree elements }
1570 prevlen : int; { last emitted length }
1571 curlen : int; { length of current code }
1572 nextlen : int; { length of next code }
1573 count : int; { repeat count of the current code }
1574 max_count : int; { max repeat count }
1575 min_count : int; { min repeat count }
1576 begin
1577 prevlen := -1;
1578 nextlen := tree[0].dl.Len;
1579 count := 0;
1580 max_count := 7;
1581 min_count := 4;
1582
1583 { tree[max_code+1].dl.Len := -1; } { guard already set }
1584 if (nextlen = 0) then
1585 begin
1586 max_count := 138;
1587 min_count := 3;
1588 end;
1589
1590 for n := 0 to max_code do
1591 begin
1592 curlen := nextlen;
1593 nextlen := tree[n+1].dl.Len;
1594 Inc(count);
1595 if (count < max_count) and (curlen = nextlen) then
1596 continue
1597 else
1598 if (count < min_count) then
1599 begin
1600 repeat
1601 {$ifdef DEBUG}
1602 Tracevvv(#13'cd '+IntToStr(curlen));
1603 {$ENDIF}
1604 send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len);
1605 Dec(count);
1606 until (count = 0);
1607 end
1608 else
1609 if (curlen <> 0) then
1610 begin
1611 if (curlen <> prevlen) then
1612 begin
1613 {$ifdef DEBUG}
1614 Tracevvv(#13'cd '+IntToStr(curlen));
1615 {$ENDIF}
1616 send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len);
1617 Dec(count);
1618 end;
1619 {$IFDEF DEBUG}
1620 Assert((count >= 3) and (count <= 6), ' 3_6?');
1621 {$ENDIF}
1622 {$ifdef DEBUG}
1623 Tracevvv(#13'cd '+IntToStr(REP_3_6));
1624 {$ENDIF}
1625 send_bits(s, s.bl_tree[REP_3_6].fc.Code, s.bl_tree[REP_3_6].dl.Len);
1626 send_bits(s, count-3, 2);
1627 end
1628 else
1629 if (count <= 10) then
1630 begin
1631 {$ifdef DEBUG}
1632 Tracevvv(#13'cd '+IntToStr(REPZ_3_10));
1633 {$ENDIF}
1634 send_bits(s, s.bl_tree[REPZ_3_10].fc.Code, s.bl_tree[REPZ_3_10].dl.Len);
1635 send_bits(s, count-3, 3);
1636 end
1637 else
1638 begin
1639 {$ifdef DEBUG}
1640 Tracevvv(#13'cd '+IntToStr(REPZ_11_138));
1641 {$ENDIF}
1642 send_bits(s, s.bl_tree[REPZ_11_138].fc.Code, s.bl_tree[REPZ_11_138].dl.Len);
1643 send_bits(s, count-11, 7);
1644 end;
1645 count := 0;
1646 prevlen := curlen;
1647 if (nextlen = 0) then
1648 begin
1649 max_count := 138;
1650 min_count := 3;
1651 end
1652 else
1653 if (curlen = nextlen) then
1654 begin
1655 max_count := 6;
1656 min_count := 3;
1657 end
1658 else
1659 begin
1660 max_count := 7;
1661 min_count := 4;
1662 end;
1663 end;
1664 end;
1665
1666 { ===========================================================================
1667 Construct the Huffman tree for the bit lengths and return the index in
1668 bl_order of the last bit length code to send. }
1669
1670 {local}
1671 function build_bl_tree(var s : deflate_state) : int;
1672 var
1673 max_blindex : int; { index of last bit length code of non zero freq }
1674 begin
1675 { Determine the bit length frequencies for literal and distance trees }
1676 scan_tree(s, s.dyn_ltree, s.l_desc.max_code);
1677 scan_tree(s, s.dyn_dtree, s.d_desc.max_code);
1678
1679 { Build the bit length tree: }
1680 build_tree(s, s.bl_desc);
1681 { opt_len now includes the length of the tree representations, except
1682 the lengths of the bit lengths codes and the 5+5+4 bits for the counts. }
1683
1684 { Determine the number of bit length codes to send. The pkzip format
1685 requires that at least 4 bit length codes be sent. (appnote.txt says
1686 3 but the actual value used is 4.) }
1687
1688 for max_blindex := BL_CODES-1 downto 3 do
1689 begin
1690 if (s.bl_tree[bl_order[max_blindex]].dl.Len <> 0) then
1691 break;
1692 end;
1693 { Update opt_len to include the bit length tree and counts }
1694 Inc(s.opt_len, 3*(max_blindex+1) + 5+5+4);
1695 {$ifdef DEBUG}
1696 Tracev(^M'dyn trees: dyn %ld, stat %ld {s.opt_len, s.static_len}');
1697 {$ENDIF}
1698
1699 build_bl_tree := max_blindex;
1700 end;
1701
1702 { ===========================================================================
1703 Send the header for a block using dynamic Huffman trees: the counts, the
1704 lengths of the bit length codes, the literal tree and the distance tree.
1705 IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4. }
1706
1707 {local}
1708 procedure send_all_trees(var s : deflate_state;
1709 lcodes : int;
1710 dcodes : int;
1711 blcodes : int); { number of codes for each tree }
1712 var
1713 rank : int; { index in bl_order }
1714 begin
1715 {$IFDEF DEBUG}
1716 Assert ((lcodes >= 257) and (dcodes >= 1) and (blcodes >= 4),
1717 'not enough codes');
1718 Assert ((lcodes <= L_CODES) and (dcodes <= D_CODES)
1719 and (blcodes <= BL_CODES), 'too many codes');
1720 Tracev(^M'bl counts: ');
1721 {$ENDIF}
1722 send_bits(s, lcodes-257, 5); { not +255 as stated in appnote.txt }
1723 send_bits(s, dcodes-1, 5);
1724 send_bits(s, blcodes-4, 4); { not -3 as stated in appnote.txt }
1725 for rank := 0 to blcodes-1 do
1726 begin
1727 {$ifdef DEBUG}
1728 Tracev(^M'bl code '+IntToStr(bl_order[rank]));
1729 {$ENDIF}
1730 send_bits(s, s.bl_tree[bl_order[rank]].dl.Len, 3);
1731 end;
1732 {$ifdef DEBUG}
1733 Tracev(^M'bl tree: sent '+IntToStr(s.bits_sent));
1734 {$ENDIF}
1735
1736 send_tree(s, s.dyn_ltree, lcodes-1); { literal tree }
1737 {$ifdef DEBUG}
1738 Tracev(^M'lit tree: sent '+IntToStr(s.bits_sent));
1739 {$ENDIF}
1740
1741 send_tree(s, s.dyn_dtree, dcodes-1); { distance tree }
1742 {$ifdef DEBUG}
1743 Tracev(^M'dist tree: sent '+IntToStr(s.bits_sent));
1744 {$ENDIF}
1745 end;
1746
1747 { ===========================================================================
1748 Flush the bit buffer and align the output on a byte boundary }
1749
1750 {local}
1751 procedure bi_windup(var s : deflate_state);
1752 begin
1753 if (s.bi_valid > 8) then
1754 begin
1755 {put_short(s, s.bi_buf);}
1756 s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);
1757 Inc(s.pending);
1758 s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;
1759 Inc(s.pending);
1760 end
1761 else
1762 if (s.bi_valid > 0) then
1763 begin
1764 {put_byte(s, (Byte)s^.bi_buf);}
1765 s.pending_buf^[s.pending] := Byte(s.bi_buf);
1766 Inc(s.pending);
1767 end;
1768 s.bi_buf := 0;
1769 s.bi_valid := 0;
1770 {$ifdef DEBUG}
1771 s.bits_sent := (s.bits_sent+7) and (not 7);
1772 {$endif}
1773 end;
1774
1775 { ===========================================================================
1776 Copy a stored block, storing first the length and its
1777 one's complement if requested. }
1778
1779 {local}
1780 procedure copy_block(var s : deflate_state;
1781 buf : pcharf; { the input data }
1782 len : unsigned; { its length }
1783 header : boolean); { true if block header must be written }
1784 begin
1785 bi_windup(s); { align on byte boundary }
1786 s.last_eob_len := 8; { enough lookahead for inflate }
1787
1788 if (header) then
1789 begin
1790 {put_short(s, (ush)len);}
1791 s.pending_buf^[s.pending] := uch(ush(len) and $ff);
1792 Inc(s.pending);
1793 s.pending_buf^[s.pending] := uch(ush(len) shr 8);;
1794 Inc(s.pending);
1795 {put_short(s, (ush)~len);}
1796 s.pending_buf^[s.pending] := uch(ush(not len) and $ff);
1797 Inc(s.pending);
1798 s.pending_buf^[s.pending] := uch(ush(not len) shr 8);;
1799 Inc(s.pending);
1800
1801 {$ifdef DEBUG}
1802 Inc(s.bits_sent, 2*16);
1803 {$endif}
1804 end;
1805 {$ifdef DEBUG}
1806 Inc(s.bits_sent, ulg(len shl 3));
1807 {$endif}
1808 while (len <> 0) do
1809 begin
1810 Dec(len);
1811 {put_byte(s, *buf++);}
1812 s.pending_buf^[s.pending] := buf^;
1813 Inc(buf);
1814 Inc(s.pending);
1815 end;
1816 end;
1817
1818
1819 { ===========================================================================
1820 Send a stored block }
1821
1822 procedure _tr_stored_block(var s : deflate_state;
1823 buf : pcharf; { input block }
1824 stored_len : ulg; { length of input block }
1825 eof : boolean); { true if this is the last block for a file }
1826
1827 begin
1828 send_bits(s, (STORED_BLOCK shl 1)+ord(eof), 3); { send block type }
1829 s.compressed_len := (s.compressed_len + 3 + 7) and ulg(not Long(7));
1830 Inc(s.compressed_len, (stored_len + 4) shl 3);
1831
1832 copy_block(s, buf, unsigned(stored_len), TRUE); { with header }
1833 end;
1834
1835 { ===========================================================================
1836 Flush the bit buffer, keeping at most 7 bits in it. }
1837
1838 {local}
1839 procedure bi_flush(var s : deflate_state);
1840 begin
1841 if (s.bi_valid = 16) then
1842 begin
1843 {put_short(s, s.bi_buf);}
1844 s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);
1845 Inc(s.pending);
1846 s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;
1847 Inc(s.pending);
1848
1849 s.bi_buf := 0;
1850 s.bi_valid := 0;
1851 end
1852 else
1853 if (s.bi_valid >= 8) then
1854 begin
1855 {put_byte(s, (Byte)s^.bi_buf);}
1856 s.pending_buf^[s.pending] := Byte(s.bi_buf);
1857 Inc(s.pending);
1858
1859 s.bi_buf := s.bi_buf shr 8;
1860 Dec(s.bi_valid, 8);
1861 end;
1862 end;
1863
1864
1865 { ===========================================================================
1866 Send one empty static block to give enough lookahead for inflate.
1867 This takes 10 bits, of which 7 may remain in the bit buffer.
1868 The current inflate code requires 9 bits of lookahead. If the
1869 last two codes for the previous block (real code plus EOB) were coded
1870 on 5 bits or less, inflate may have only 5+3 bits of lookahead to decode
1871 the last real code. In this case we send two empty static blocks instead
1872 of one. (There are no problems if the previous block is stored or fixed.)
1873 To simplify the code, we assume the worst case of last real code encoded
1874 on one bit only. }
1875
1876 procedure _tr_align(var s : deflate_state);
1877 begin
1878 send_bits(s, STATIC_TREES shl 1, 3);
1879 {$ifdef DEBUG}
1880 Tracevvv(#13'cd '+IntToStr(END_BLOCK));
1881 {$ENDIF}
1882 send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len);
1883 Inc(s.compressed_len, Long(10)); { 3 for block type, 7 for EOB }
1884 bi_flush(s);
1885 { Of the 10 bits for the empty block, we have already sent
1886 (10 - bi_valid) bits. The lookahead for the last real code (before
1887 the EOB of the previous block) was thus at least one plus the length
1888 of the EOB plus what we have just sent of the empty static block. }
1889 if (1 + s.last_eob_len + 10 - s.bi_valid < 9) then
1890 begin
1891 send_bits(s, STATIC_TREES shl 1, 3);
1892 {$ifdef DEBUG}
1893 Tracevvv(#13'cd '+IntToStr(END_BLOCK));
1894 {$ENDIF}
1895 send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len);
1896 Inc(s.compressed_len, Long(10));
1897 bi_flush(s);
1898 end;
1899 s.last_eob_len := 7;
1900 end;
1901
1902 { ===========================================================================
1903 Set the data type to ASCII or BINARY, using a crude approximation:
1904 binary if more than 20% of the bytes are <= 6 or >= 128, ascii otherwise.
1905 IN assertion: the fields freq of dyn_ltree are set and the total of all
1906 frequencies does not exceed 64K (to fit in an int on 16 bit machines). }
1907
1908 {local}
1909 procedure set_data_type(var s : deflate_state);
1910 var
1911 n : int;
1912 ascii_freq : unsigned;
1913 bin_freq : unsigned;
1914 begin
1915 n := 0;
1916 ascii_freq := 0;
1917 bin_freq := 0;
1918
1919 while (n < 7) do
1920 begin
1921 Inc(bin_freq, s.dyn_ltree[n].fc.Freq);
1922 Inc(n);
1923 end;
1924 while (n < 128) do
1925 begin
1926 Inc(ascii_freq, s.dyn_ltree[n].fc.Freq);
1927 Inc(n);
1928 end;
1929 while (n < LITERALS) do
1930 begin
1931 Inc(bin_freq, s.dyn_ltree[n].fc.Freq);
1932 Inc(n);
1933 end;
1934 if (bin_freq > (ascii_freq shr 2)) then
1935 s.data_type := Byte(Z_BINARY)
1936 else
1937 s.data_type := Byte(Z_ASCII);
1938 end;
1939
1940 { ===========================================================================
1941 Send the block data compressed using the given Huffman trees }
1942
1943 {local}
1944 procedure compress_block(var s : deflate_state;
1945 var ltree : array of ct_data; { literal tree }
1946 var dtree : array of ct_data); { distance tree }
1947 var
1948 dist : unsigned; { distance of matched string }
1949 lc : int; { match length or unmatched char (if dist == 0) }
1950 lx : unsigned; { running index in l_buf }
1951 code : unsigned; { the code to send }
1952 extra : int; { number of extra bits to send }
1953 begin
1954 lx := 0;
1955 if (s.last_lit <> 0) then
1956 repeat
1957 dist := s.d_buf^[lx];
1958 lc := s.l_buf^[lx];
1959 Inc(lx);
1960 if (dist = 0) then
1961 begin
1962 { send a literal byte }
1963 {$ifdef DEBUG}
1964 Tracevvv(#13'cd '+IntToStr(lc));
1965 Tracecv((lc > 31) and (lc < 128), ' '+char(lc)+' ');
1966 {$ENDIF}
1967 send_bits(s, ltree[lc].fc.Code, ltree[lc].dl.Len);
1968 end
1969 else
1970 begin
1971 { Here, lc is the match length - MIN_MATCH }
1972 code := _length_code[lc];
1973 { send the length code }
1974 {$ifdef DEBUG}
1975 Tracevvv(#13'cd '+IntToStr(code+LITERALS+1));
1976 {$ENDIF}
1977 send_bits(s, ltree[code+LITERALS+1].fc.Code, ltree[code+LITERALS+1].dl.Len);
1978 extra := extra_lbits[code];
1979 if (extra <> 0) then
1980 begin
1981 Dec(lc, base_length[code]);
1982 send_bits(s, lc, extra); { send the extra length bits }
1983 end;
1984 Dec(dist); { dist is now the match distance - 1 }
1985 {code := d_code(dist);}
1986 if (dist < 256) then
1987 code := _dist_code[dist]
1988 else
1989 code := _dist_code[256+(dist shr 7)];
1990
1991 {$IFDEF DEBUG}
1992 Assert (code < D_CODES, 'bad d_code');
1993 {$ENDIF}
1994
1995 { send the distance code }
1996 {$ifdef DEBUG}
1997 Tracevvv(#13'cd '+IntToStr(code));
1998 {$ENDIF}
1999 send_bits(s, dtree[code].fc.Code, dtree[code].dl.Len);
2000 extra := extra_dbits[code];
2001 if (extra <> 0) then
2002 begin
2003 Dec(dist, base_dist[code]);
2004 send_bits(s, dist, extra); { send the extra distance bits }
2005 end;
2006 end; { literal or match pair ? }
2007
2008 { Check that the overlay between pending_buf and d_buf+l_buf is ok: }
2009 {$IFDEF DEBUG}
2010 Assert(s.pending < s.lit_bufsize + 2*lx, 'pendingBuf overflow');
2011 {$ENDIF}
2012 until (lx >= s.last_lit);
2013
2014 {$ifdef DEBUG}
2015 Tracevvv(#13'cd '+IntToStr(END_BLOCK));
2016 {$ENDIF}
2017 send_bits(s, ltree[END_BLOCK].fc.Code, ltree[END_BLOCK].dl.Len);
2018 s.last_eob_len := ltree[END_BLOCK].dl.Len;
2019 end;
2020
2021
2022 { ===========================================================================
2023 Determine the best encoding for the current block: dynamic trees, static
2024 trees or store, and output the encoded block to the zip file. This function
2025 returns the total compressed length for the file so far. }
2026
2027 function _tr_flush_block (var s : deflate_state;
2028 buf : pcharf; { input block, or NULL if too old }
2029 stored_len : ulg; { length of input block }
2030 eof : boolean) : ulg; { true if this is the last block for a file }
2031 var
2032 opt_lenb, static_lenb : ulg; { opt_len and static_len in bytes }
2033 max_blindex : int; { index of last bit length code of non zero freq }
2034 begin
2035 max_blindex := 0;
2036
2037 { Build the Huffman trees unless a stored block is forced }
2038 if (s.level > 0) then
2039 begin
2040 { Check if the file is ascii or binary }
2041 if (s.data_type = Z_UNKNOWN) then
2042 set_data_type(s);
2043
2044 { Construct the literal and distance trees }
2045 build_tree(s, s.l_desc);
2046 {$ifdef DEBUG}
2047 Tracev(^M'lit data: dyn %ld, stat %ld {s.opt_len, s.static_len}');
2048 {$ENDIF}
2049
2050 build_tree(s, s.d_desc);
2051 {$ifdef DEBUG}
2052 Tracev(^M'dist data: dyn %ld, stat %ld {s.opt_len, s.static_len}');
2053 {$ENDIF}
2054 { At this point, opt_len and static_len are the total bit lengths of
2055 the compressed block data, excluding the tree representations. }
2056
2057 { Build the bit length tree for the above two trees, and get the index
2058 in bl_order of the last bit length code to send. }
2059 max_blindex := build_bl_tree(s);
2060
2061 { Determine the best encoding. Compute first the block length in bytes}
2062 opt_lenb := (s.opt_len+3+7) shr 3;
2063 static_lenb := (s.static_len+3+7) shr 3;
2064
2065 {$ifdef DEBUG}
2066 Tracev(^M'opt %lu(%lu) stat %lu(%lu) stored %lu lit %u '+
2067 '{opt_lenb, s.opt_len, static_lenb, s.static_len, stored_len,'+
2068 's.last_lit}');
2069 {$ENDIF}
2070
2071 if (static_lenb <= opt_lenb) then
2072 opt_lenb := static_lenb;
2073
2074 end
2075 else
2076 begin
2077 {$IFDEF DEBUG}
2078 Assert(buf <> pcharf(NIL), 'lost buf');
2079 {$ENDIF}
2080 static_lenb := stored_len + 5;
2081 opt_lenb := static_lenb; { force a stored block }
2082 end;
2083
2084 { If compression failed and this is the first and last block,
2085 and if the .zip file can be seeked (to rewrite the local header),
2086 the whole file is transformed into a stored file: }
2087
2088 {$ifdef STORED_FILE_OK}
2089 {$ifdef FORCE_STORED_FILE}
2090 if eof and (s.compressed_len = Long(0)) then
2091 begin { force stored file }
2092 {$else}
2093 if (stored_len <= opt_lenb) and eof and (s.compressed_len=Long(0))
2094 and seekable()) do
2095 begin
2096 {$endif}
2097 { Since LIT_BUFSIZE <= 2*WSIZE, the input data must be there: }
2098 if (buf = pcharf(0)) then
2099 error ('block vanished');
2100
2101 copy_block(buf, unsigned(stored_len), 0); { without header }
2102 s.compressed_len := stored_len shl 3;
2103 s.method := STORED;
2104 end
2105 else
2106 {$endif} { STORED_FILE_OK }
2107
2108 {$ifdef FORCE_STORED}
2109 if (buf <> pchar(0)) then
2110 begin { force stored block }
2111 {$else}
2112 if (stored_len+4 <= opt_lenb) and (buf <> pcharf(0)) then
2113 begin
2114 { 4: two words for the lengths }
2115 {$endif}
2116 { The test buf <> NULL is only necessary if LIT_BUFSIZE > WSIZE.
2117 Otherwise we can't have processed more than WSIZE input bytes since
2118 the last block flush, because compression would have been
2119 successful. If LIT_BUFSIZE <= WSIZE, it is never too late to
2120 transform a block into a stored block. }
2121
2122 _tr_stored_block(s, buf, stored_len, eof);
2123
2124 {$ifdef FORCE_STATIC}
2125 end
2126 else
2127 if (static_lenb >= 0) then
2128 begin { force static trees }
2129 {$else}
2130 end
2131 else
2132 if (static_lenb = opt_lenb) then
2133 begin
2134 {$endif}
2135 send_bits(s, (STATIC_TREES shl 1)+ord(eof), 3);
2136 compress_block(s, static_ltree, static_dtree);
2137 Inc(s.compressed_len, 3 + s.static_len);
2138 end
2139 else
2140 begin
2141 send_bits(s, (DYN_TREES shl 1)+ord(eof), 3);
2142 send_all_trees(s, s.l_desc.max_code+1, s.d_desc.max_code+1,
2143 max_blindex+1);
2144 compress_block(s, s.dyn_ltree, s.dyn_dtree);
2145 Inc(s.compressed_len, 3 + s.opt_len);
2146 end;
2147 {$ifdef DEBUG}
2148 Assert (s.compressed_len = s.bits_sent, 'bad compressed size');
2149 {$ENDIF}
2150 init_block(s);
2151
2152 if (eof) then
2153 begin
2154 bi_windup(s);
2155 Inc(s.compressed_len, 7); { align on byte boundary }
2156 end;
2157 {$ifdef DEBUG}
2158 Tracev(#13'comprlen %lu(%lu) {s.compressed_len shr 3,'+
2159 's.compressed_len-7*ord(eof)}');
2160 {$ENDIF}
2161
2162 _tr_flush_block := s.compressed_len shr 3;
2163 end;
2164
2165
2166 { ===========================================================================
2167 Save the match info and tally the frequency counts. Return true if
2168 the current block must be flushed. }
2169
2170 function _tr_tally (var s : deflate_state;
2171 dist : unsigned; { distance of matched string }
2172 lc : unsigned) : boolean; { match length-MIN_MATCH or unmatched char (if dist=0) }
2173 var
2174 {$IFDEF DEBUG}
2175 MAX_DIST : ush;
2176 {$ENDIF}
2177 code : ush;
2178 {$ifdef TRUNCATE_BLOCK}
2179 var
2180 out_length : ulg;
2181 in_length : ulg;
2182 dcode : int;
2183 {$endif}
2184 begin
2185 s.d_buf^[s.last_lit] := ush(dist);
2186 s.l_buf^[s.last_lit] := uch(lc);
2187 Inc(s.last_lit);
2188 if (dist = 0) then
2189 begin
2190 { lc is the unmatched char }
2191 Inc(s.dyn_ltree[lc].fc.Freq);
2192 end
2193 else
2194 begin
2195 Inc(s.matches);
2196 { Here, lc is the match length - MIN_MATCH }
2197 Dec(dist); { dist := match distance - 1 }
2198
2199 {macro d_code(dist)}
2200 if (dist) < 256 then
2201 code := _dist_code[dist]
2202 else
2203 code := _dist_code[256+(dist shr 7)];
2204 {$IFDEF DEBUG}
2205 {macro MAX_DIST(s) <=> ((s)^.w_size-MIN_LOOKAHEAD)
2206 In order to simplify the code, particularly on 16 bit machines, match
2207 distances are limited to MAX_DIST instead of WSIZE. }
2208 MAX_DIST := ush(s.w_size-MIN_LOOKAHEAD);
2209 Assert((dist < ush(MAX_DIST)) and
2210 (ush(lc) <= ush(MAX_MATCH-MIN_MATCH)) and
2211 (ush(code) < ush(D_CODES)), '_tr_tally: bad match');
2212 {$ENDIF}
2213 Inc(s.dyn_ltree[_length_code[lc]+LITERALS+1].fc.Freq);
2214 {s.dyn_dtree[d_code(dist)].Freq++;}
2215 Inc(s.dyn_dtree[code].fc.Freq);
2216 end;
2217
2218 {$ifdef TRUNCATE_BLOCK}
2219 { Try to guess if it is profitable to stop the current block here }
2220 if (s.last_lit and $1fff = 0) and (s.level > 2) then
2221 begin
2222 { Compute an upper bound for the compressed length }
2223 out_length := ulg(s.last_lit)*Long(8);
2224 in_length := ulg(long(s.strstart) - s.block_start);
2225 for dcode := 0 to D_CODES-1 do
2226 begin
2227 Inc(out_length, ulg(s.dyn_dtree[dcode].fc.Freq *
2228 (Long(5)+extra_dbits[dcode])) );
2229 end;
2230 out_length := out_length shr 3;
2231 {$ifdef DEBUG}
2232 Tracev(^M'last_lit %u, in %ld, out ~%ld(%ld%%) ');
2233 { s.last_lit, in_length, out_length,
2234 Long(100) - out_length*Long(100) div in_length)); }
2235 {$ENDIF}
2236 if (s.matches < s.last_lit div 2) and (out_length < in_length div 2) then
2237 begin
2238 _tr_tally := TRUE;
2239 exit;
2240 end;
2241 end;
2242 {$endif}
2243 _tr_tally := (s.last_lit = s.lit_bufsize-1);
2244 { We avoid equality with lit_bufsize because of wraparound at 64K
2245 on 16 bit machines and because stored blocks are restricted to
2246 64K-1 bytes. }
2247 end;
2248
2249 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