Source file : lzh.adb
1 -- *CAUTION* : bug on the last decoded byte (see "BUG" below)
2 ---------------
3 --
4 -- Legal licensing note:
5 --
6 -- Copyright (c) 1999 .. 2009 Gautier de Montmollin
7 --
8 -- Permission is hereby granted, free of charge, to any person obtaining a copy
9 -- of this software and associated documentation files (the "Software"), to deal
10 -- in the Software without restriction, including without limitation the rights
11 -- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
12 -- copies of the Software, and to permit persons to whom the Software is
13 -- furnished to do so, subject to the following conditions:
14 --
15 -- The above copyright notice and this permission notice shall be included in
16 -- all copies or substantial portions of the Software.
17 --
18 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
19 -- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
20 -- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
21 -- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
22 -- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
23 -- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
24 -- THE SOFTWARE.
25 --
26 -- NB: this is the MIT License, as found 12-Sep-2007 on the site
27 -- http://www.opensource.org/licenses/mit-license.php
28 --
29 -- LZHUF.C English version 1.0
30 -- Based on Japanese version 29-NOV-1988
31 -- LZSS coded by Haruhiko OKUMURA
32 -- Adaptive Huffman Coding coded by Haruyasu YOSHIZAKI
33 -- Edited and translated to English by Kenji RIKITAKE
34 -- Converted to Turbo Pascal 5.0
35 -- by Peter Sawatzki with assistance of Wayne Sullivan
36 --
37 -- Translated on 14-Jan-2000 by G. de Montmollin, using (New)P2Ada
38 -- then transformed into 100% portable code (OS-,compiler- independent)
39 -- using genericity. Buffers removed - they can be implemented outside
40 -- this package if needed. Data integrity checking too.
41
42 -- 8-May-2002: Source reformatted and adapted according to Craig Carey's
43 -- (http://www.ijs.co.nz/) version and comments.
44 -- LZH is made thread-safe: only local variables, no shared
45 -- variables between Encode and Decode.
46
47 -- 29-Jan-2009: No more need to know the input length; no more feedback
48
49 -- 17-Oct-2018: BUG found and not yet fixed: in rare cases (e.g.
50 -- data = ziptest.exe compiled by GNAT for Windows x64),
51 -- the last decoded byte is missing. See test_non_zip for mass test.
52
53 package body LZH is
54
55 ----- LZSS Parameters -----
56 String_buffer_size : constant := 2**12; -- 2**12 = 4096
57 Look_Ahead : constant := 65; -- Original: 60
58 Threshold : constant := 2;
59
60 N_Char : constant := 256 - Threshold + Look_Ahead;
61 -- Character code (= 0..N_CHAR-1)
62 Max_Table : constant := N_Char * 2 - 1;
63
64 subtype Byte is Unsigned_8;
65 -- Just a nicer name. BTW, easier to modify.
66
67 type Text_Buffer is array (0 .. String_buffer_size + Look_Ahead - 1) of Byte;
68 empty_buffer : constant Text_Buffer := (others => 32); -- ' '
69
70 -- > The Huffman frequency handling is made generic so we have
71 -- one copy of the tree and of the frequency table for Encode
72 -- and one for Decode
73
74 generic
75 package Huffman is
76 --- Pointing parent nodes.
77 --- Area [Max_Table..(Max_Table + N_CHAR - 1)] are pointers for leaves
78 Parent : array (0 .. Max_Table + N_Char - 1) of Natural;
79 --- Pointing children nodes (son[], son[] + 1)
80 Son : array (0 .. Max_Table - 1) of Natural;
81
82 Root_Position : constant := Max_Table - 1; -- (can be always Son'last ?)
83
84 procedure Start;
85 procedure Update_Freq_Tree (C0 : Natural);
86 end Huffman;
87
88 package body Huffman is
89
90 Freq : array (0 .. Max_Table) of Natural; -- Cumulative freq table
91
92 Max_Freq : constant := 16#8000#;
93 -- ^-- update when cumulative frequency reaches to this value
94
95 procedure Start is
96 I : Natural;
97 begin
98 for J in 0 .. N_Char - 1 loop
99 Freq (J) := 1;
100 Son (J) := J + Max_Table;
101 Parent (J + Max_Table) := J;
102 end loop;
103
104 I := 0;
105 for J in N_Char .. Root_Position loop
106 Freq (J) := Freq (I) + Freq (I + 1);
107 Son (J) := I;
108 Parent (I) := J;
109 Parent (I + 1) := J;
110 I := I + 2;
111 end loop;
112
113 Freq (Freq'Last) := 16#FFFF#; -- ( Max_Table )
114 Parent (Root_Position) := 0;
115 end Start;
116
117 procedure Update_Freq_Tree (C0 : Natural) is
118
119 procedure Reconstruct_Freq_Tree is
120 I, J, K, F, L : Natural;
121 begin
122 -- Halven cumulative freq for leaf nodes
123 J := 0;
124 for I in 0 .. Root_Position loop
125 if Son (I) >= Max_Table then
126 Freq (J) := (Freq (I) + 1) / 2;
127 Son (J) := Son (I);
128 J := J + 1;
129 end if;
130 end loop;
131
132 -- Make a tree : first, connect children nodes
133 I := 0;
134 for J in N_Char .. Root_Position loop -- J : free nodes
135 K := I + 1;
136 F := Freq (I) + Freq (K); -- new frequency
137 Freq (J) := F;
138 K := J - 1;
139 while F < Freq (K) loop
140 K := K - 1;
141 end loop;
142
143 K := K + 1;
144 L := J - K; -- 2007: fix: was L:= (J-K)*2, memcopy parameter remain
145
146 Freq (K + 1 .. K + L) := Freq (K .. K + L - 1); -- shift by one cell right
147 Freq (K) := F;
148 Son (K + 1 .. K + L) := Son (K .. K + L - 1); -- shift by one cell right
149 Son (K) := I;
150 I := I + 2;
151 end loop;
152
153 -- Connect parent nodes
154 for I in 0 .. Max_Table - 1 loop
155 K := Son (I);
156 Parent (K) := I;
157 if K < Max_Table then
158 Parent (K + 1) := I;
159 end if;
160 end loop;
161
162 end Reconstruct_Freq_Tree;
163
164 C, I, J, K, L : Natural;
165
166 begin -- Update_Freq_Tree;
167 if Freq (Root_Position) = Max_Freq then
168 Reconstruct_Freq_Tree;
169 end if;
170 C := Parent (C0 + Max_Table);
171 loop
172 Freq (C) := Freq (C) + 1;
173 K := Freq (C);
174 -- Swap nodes to keep the tree freq-ordered
175 L := C + 1;
176 if K > Freq (L) then
177 while K > Freq (L + 1) loop
178 L := L + 1;
179 end loop;
180
181 Freq (C) := Freq (L);
182 Freq (L) := K;
183
184 I := Son (C);
185 Parent (I) := L;
186 if I < Max_Table then
187 Parent (I + 1) := L;
188 end if;
189
190 J := Son (L);
191 Son (L) := I;
192
193 Parent (J) := C;
194 if J < Max_Table then
195 Parent (J + 1) := C;
196 end if;
197 Son (C) := J;
198
199 C := L;
200 end if;
201 C := Parent (C);
202 exit when C = 0;
203 end loop; -- do it until reaching the root
204 end Update_Freq_Tree;
205
206 end Huffman;
207
208 ------------------------------------
209 ------ Encoding / Compressing ------
210 ------------------------------------
211
212 procedure Encode is
213
214 ----- Tables for encoding upper 6 bits of sliding dictionary pointer
215
216 P_Len : constant array (0 .. 63) of Positive :=
217 (3, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6,
218 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 7,
219 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
220 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8);
221
222 P_Code : constant array (0 .. 63) of Unsigned_16 :=
223 (16#00#, 16#20#, 16#30#, 16#40#, 16#50#, 16#58#, 16#60#, 16#68#,
224 16#70#, 16#78#, 16#80#, 16#88#, 16#90#, 16#94#, 16#98#, 16#9C#,
225 16#A0#, 16#A4#, 16#A8#, 16#AC#, 16#B0#, 16#B4#, 16#B8#, 16#BC#,
226 16#C0#, 16#C2#, 16#C4#, 16#C6#, 16#C8#, 16#CA#, 16#CC#, 16#CE#,
227 16#D0#, 16#D2#, 16#D4#, 16#D6#, 16#D8#, 16#DA#, 16#DC#, 16#DE#,
228 16#E0#, 16#E2#, 16#E4#, 16#E6#, 16#E8#, 16#EA#, 16#EC#, 16#EE#,
229 16#F0#, 16#F1#, 16#F2#, 16#F3#, 16#F4#, 16#F5#, 16#F6#, 16#F7#,
230 16#F8#, 16#F9#, 16#FA#, 16#FB#, 16#FC#, 16#FD#, 16#FE#, 16#FF#);
231
232 Putbuf : Unsigned_16 := 0;
233 Putlen : Natural := 0;
234 Codesize : Natural := 0;
235
236 Node_Nil : constant := String_buffer_size; -- End of tree's node
237
238 Lson, Dad : array (0 .. String_buffer_size) of Natural;
239 Rson : array (0 .. String_buffer_size + 256) of Natural;
240
241 procedure Init_Tree is
242 begin
243 for I in String_buffer_size + 1 .. Rson'Last loop
244 Rson (I) := Node_Nil;
245 end loop; -- root
246 for I in 0 .. String_buffer_size - 1 loop
247 Dad (I) := Node_Nil;
248 end loop; -- node
249 end Init_Tree;
250
251 Match_Position : Natural;
252 Match_Length : Natural;
253
254 Text_Buf : Text_Buffer := empty_buffer;
255
256 procedure Insert_Node (R : Integer) is
257 I, P : Integer;
258 Geq : Boolean := True;
259 C : Natural;
260 begin
261 P := String_buffer_size + 1 + Integer (Text_Buf (R));
262 Rson (R) := Node_Nil;
263 Lson (R) := Node_Nil;
264 Match_Length := 0;
265 loop
266 if Geq then
267 if Rson (P) = Node_Nil then
268 Rson (P) := R;
269 Dad (R) := P;
270 return;
271 end if;
272 P := Rson (P);
273 else
274 if Lson (P) = Node_Nil then
275 Lson (P) := R;
276 Dad (R) := P;
277 return;
278 end if;
279 P := Lson (P);
280 end if;
281 I := 1;
282 while I < Look_Ahead and then Text_Buf (R + I) = Text_Buf (P + I) loop
283 I := I + 1;
284 end loop;
285
286 Geq := Text_Buf (R + I) >= Text_Buf (P + I) or I = Look_Ahead;
287
288 if I > Threshold then
289 if I > Match_Length then
290 Match_Position := (R - P) mod String_buffer_size - 1;
291 Match_Length := I;
292 exit when Match_Length >= Look_Ahead;
293 end if;
294 if I = Match_Length then
295 C := (R - P) mod String_buffer_size - 1;
296 if C < Match_Position then
297 Match_Position := C;
298 end if;
299 end if;
300 end if;
301 end loop;
302
303 Dad (R) := Dad (P);
304 Lson (R) := Lson (P);
305 Rson (R) := Rson (P);
306 Dad (Lson (P)) := R;
307 Dad (Rson (P)) := R;
308 if Rson (Dad (P)) = P then
309 Rson (Dad (P)) := R;
310 else
311 Lson (Dad (P)) := R;
312 end if;
313 Dad (P) := Node_Nil; -- remove p
314 end Insert_Node;
315
316 procedure Delete_Node (P : Natural) is
317 Q : Natural;
318 begin
319 if Dad (P) = Node_Nil then -- unregistered
320 return;
321 end if;
322 if Rson (P) = Node_Nil then
323 Q := Lson (P);
324 elsif Lson (P) = Node_Nil then
325 Q := Rson (P);
326 else
327 Q := Lson (P);
328 if Rson (Q) /= Node_Nil then
329 loop
330 Q := Rson (Q);
331 exit when Rson (Q) = Node_Nil;
332 end loop;
333
334 Rson (Dad (Q)) := Lson (Q);
335 Dad (Lson (Q)) := Dad (Q);
336 Lson (Q) := Lson (P);
337 Dad (Lson (P)) := Q;
338 end if;
339 Rson (Q) := Rson (P);
340 Dad (Rson (P)) := Q;
341 end if;
342 Dad (Q) := Dad (P);
343 if Rson (Dad (P)) = P then
344 Rson (Dad (P)) := Q;
345 else
346 Lson (Dad (P)) := Q;
347 end if;
348 Dad (P) := Node_Nil;
349 end Delete_Node;
350
351 package Huffman_E is new Huffman;
352
353 procedure Put_code (Bits_To_Output : Natural; C : Unsigned_16) is
354 begin
355 Putbuf := Putbuf or Shift_Right (C, Putlen);
356 Putlen := Putlen + Bits_To_Output;
357 if Putlen >= 8 then
358 Write_byte (Byte (Shift_Right (Putbuf, 8)));
359 Putlen := Putlen - 8;
360 if Putlen >= 8 then
361 Write_byte (Byte (Putbuf and 16#FF#));
362 Codesize := Codesize + 2;
363 Putlen := Putlen - 8;
364 Putbuf := Shift_Left (C, Bits_To_Output - Putlen);
365 else
366 Putbuf := Shift_Left (Putbuf, 8);
367 Codesize := Codesize + 1;
368 end if;
369 end if;
370 end Put_code;
371
372 procedure Encode_char (C : Natural) is
373 Len, K : Natural; Code : Unsigned_16;
374 begin
375 Code := 0;
376 Len := 0;
377 K := Huffman_E.Parent (C + Max_Table);
378
379 -- Search connections from leaf node to the root
380 loop
381 Code := Code / 2;
382 -- If node's address is odd, output 1 else output 0
383 if K mod 2 = 1 then
384 Code := Code + 16#8000#;
385 end if;
386 Len := Len + 1;
387 K := Huffman_E.Parent (K);
388 exit when K = Huffman_E.Root_Position;
389 end loop;
390
391 Put_code (Len, Code);
392 Huffman_E.Update_Freq_Tree (C);
393 end Encode_char;
394
395 procedure Encode_position (C : Natural) is
396 I : constant Natural := C / 2**6;
397 begin
398 --- output upper 6 bits with encoding
399 Put_code (P_Len (I), Shift_Left (P_Code (I), 8));
400 --- output lower 6 bits directly
401 Put_code (6, Shift_Left (Unsigned_16 (C) and 16#3F#, 10));
402 end Encode_position;
403
404 procedure Encode_end is
405 begin
406 if Putlen > 0 then
407 Write_byte (Byte (Shift_Right (Putbuf, 8)));
408 Codesize := Codesize + 1;
409 end if;
410 Write_byte (0); -- Write on more dummy byte
411 end Encode_end;
412
413 I, R, S, Last_Match_Length : Natural;
414 Len : Integer;
415 C : Byte;
416 begin
417 if not More_bytes then
418 return;
419 end if;
420 Huffman_E.Start;
421 Init_Tree;
422 S := 0;
423 R := String_buffer_size - Look_Ahead;
424 Len := 0;
425 while Len < Look_Ahead and More_bytes loop
426 Text_Buf (R + Len) := Read_byte;
427 Len := Len + 1;
428 end loop;
429
430 for I in 1 .. Look_Ahead loop
431 Insert_Node (R - I);
432 end loop;
433
434 Insert_Node (R);
435
436 loop
437 if Match_Length > Len then
438 Match_Length := Len;
439 end if;
440 if Match_Length <= Threshold then
441 Match_Length := 1;
442 Encode_char (Natural (Text_Buf (R)));
443 else
444 Encode_char (255 - Threshold + Match_Length);
445 Encode_position (Match_Position);
446 end if;
447 Last_Match_Length := Match_Length;
448 I := 0;
449 while I < Last_Match_Length and More_bytes loop
450 I := I + 1;
451 Delete_Node (S);
452 C := Read_byte;
453 Text_Buf (S) := C;
454 if S < Look_Ahead - 1 then
455 Text_Buf (S + String_buffer_size) := C;
456 end if;
457 S := (S + 1) mod String_buffer_size;
458 R := (R + 1) mod String_buffer_size;
459 Insert_Node (R);
460 end loop;
461
462 while I < Last_Match_Length loop
463 I := I + 1;
464 Delete_Node (S);
465 S := (S + 1) mod String_buffer_size;
466 R := (R + 1) mod String_buffer_size;
467 Len := Len - 1;
468 if Len > 0 then
469 Insert_Node (R);
470 end if;
471 end loop;
472
473 exit when Len = 0;
474 end loop;
475
476 Encode_end;
477 end Encode;
478
479 --------------------------------------
480 ------ Decoding / Uncompressing ------
481 --------------------------------------
482
483 procedure Decode is
484
485 ----- Tables for decoding upper 6 bits of sliding dictionary pointer
486 D_Code : constant array (0 .. 255) of Natural :=
487 (16#00#, 16#00#, 16#00#, 16#00#, 16#00#, 16#00#, 16#00#, 16#00#,
488 16#00#, 16#00#, 16#00#, 16#00#, 16#00#, 16#00#, 16#00#, 16#00#,
489 16#00#, 16#00#, 16#00#, 16#00#, 16#00#, 16#00#, 16#00#, 16#00#,
490 16#00#, 16#00#, 16#00#, 16#00#, 16#00#, 16#00#, 16#00#, 16#00#,
491 16#01#, 16#01#, 16#01#, 16#01#, 16#01#, 16#01#, 16#01#, 16#01#,
492 16#01#, 16#01#, 16#01#, 16#01#, 16#01#, 16#01#, 16#01#, 16#01#,
493 16#02#, 16#02#, 16#02#, 16#02#, 16#02#, 16#02#, 16#02#, 16#02#,
494 16#02#, 16#02#, 16#02#, 16#02#, 16#02#, 16#02#, 16#02#, 16#02#,
495 16#03#, 16#03#, 16#03#, 16#03#, 16#03#, 16#03#, 16#03#, 16#03#,
496 16#03#, 16#03#, 16#03#, 16#03#, 16#03#, 16#03#, 16#03#, 16#03#,
497 16#04#, 16#04#, 16#04#, 16#04#, 16#04#, 16#04#, 16#04#, 16#04#,
498 16#05#, 16#05#, 16#05#, 16#05#, 16#05#, 16#05#, 16#05#, 16#05#,
499 16#06#, 16#06#, 16#06#, 16#06#, 16#06#, 16#06#, 16#06#, 16#06#,
500 16#07#, 16#07#, 16#07#, 16#07#, 16#07#, 16#07#, 16#07#, 16#07#,
501 16#08#, 16#08#, 16#08#, 16#08#, 16#08#, 16#08#, 16#08#, 16#08#,
502 16#09#, 16#09#, 16#09#, 16#09#, 16#09#, 16#09#, 16#09#, 16#09#,
503 16#0A#, 16#0A#, 16#0A#, 16#0A#, 16#0A#, 16#0A#, 16#0A#, 16#0A#,
504 16#0B#, 16#0B#, 16#0B#, 16#0B#, 16#0B#, 16#0B#, 16#0B#, 16#0B#,
505 16#0C#, 16#0C#, 16#0C#, 16#0C#, 16#0D#, 16#0D#, 16#0D#, 16#0D#,
506 16#0E#, 16#0E#, 16#0E#, 16#0E#, 16#0F#, 16#0F#, 16#0F#, 16#0F#,
507 16#10#, 16#10#, 16#10#, 16#10#, 16#11#, 16#11#, 16#11#, 16#11#,
508 16#12#, 16#12#, 16#12#, 16#12#, 16#13#, 16#13#, 16#13#, 16#13#,
509 16#14#, 16#14#, 16#14#, 16#14#, 16#15#, 16#15#, 16#15#, 16#15#,
510 16#16#, 16#16#, 16#16#, 16#16#, 16#17#, 16#17#, 16#17#, 16#17#,
511 16#18#, 16#18#, 16#19#, 16#19#, 16#1A#, 16#1A#, 16#1B#, 16#1B#,
512 16#1C#, 16#1C#, 16#1D#, 16#1D#, 16#1E#, 16#1E#, 16#1F#, 16#1F#,
513 16#20#, 16#20#, 16#21#, 16#21#, 16#22#, 16#22#, 16#23#, 16#23#,
514 16#24#, 16#24#, 16#25#, 16#25#, 16#26#, 16#26#, 16#27#, 16#27#,
515 16#28#, 16#28#, 16#29#, 16#29#, 16#2A#, 16#2A#, 16#2B#, 16#2B#,
516 16#2C#, 16#2C#, 16#2D#, 16#2D#, 16#2E#, 16#2E#, 16#2F#, 16#2F#,
517 16#30#, 16#31#, 16#32#, 16#33#, 16#34#, 16#35#, 16#36#, 16#37#,
518 16#38#, 16#39#, 16#3A#, 16#3B#, 16#3C#, 16#3D#, 16#3E#, 16#3F#);
519
520 D_Len : constant array (0 .. 255) of Natural :=
521 (3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
522 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
523 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
524 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
525 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
526 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
527 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
528 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
529 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
530 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
531 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
532 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
533 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
534 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
535 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
536 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8);
537
538 Getbuf : Unsigned_16 := 0;
539 Getlen : Natural := 0;
540
541 function Get_bit return Natural is
542 Result : Natural;
543 begin
544 while Getlen <= 8 loop
545 Getbuf := Getbuf or Shift_Left (Unsigned_16 (Read_byte), 8 - Getlen);
546 Getlen := Getlen + 8;
547 end loop;
548
549 Result := Natural (Shift_Right (Getbuf, 15));
550 Getbuf := Shift_Left (Getbuf, 1);
551 Getlen := Getlen - 1;
552 return Result;
553 end Get_bit;
554
555 function Get_decoded_position return Natural is
556
557 function Get_byte return Natural is
558 Result : Natural;
559 begin
560 while Getlen <= 8 loop
561 Getbuf := Getbuf or
562 Shift_Left (Unsigned_16 (Read_byte), 8 - Getlen);
563 Getlen := Getlen + 8;
564 end loop;
565
566 Result := Natural (Shift_Right (Getbuf, 8));
567 Getbuf := Shift_Left (Getbuf, 8);
568 Getlen := Getlen - 8;
569 return Result;
570 end Get_byte;
571
572 I, C : Natural;
573 begin
574 ---decode upper 6 bits from given table
575 I := Get_byte;
576 C := D_Code (I) * 2**6;
577 ---input lower 6 bits directly
578 for J in reverse 1 .. D_Len (I) - 2 loop
579 I := I * 2 + Get_bit;
580 end loop;
581
582 return C + I mod 2**6;
583 end Get_decoded_position;
584
585 package Huffman_D is new Huffman;
586
587 function Get_decoded_char return Natural is
588 C : Natural := Huffman_D.Son (Huffman_D.Root_Position);
589 -- start searching tree from the root to leaves.
590 begin
591 -- choose node #(son[]) if input bit = 0
592 -- else choose #(son[]+1) (input bit = 1)
593 while C < Max_Table loop
594 C := Huffman_D.Son (C + Get_bit);
595 end loop;
596
597 C := C - Max_Table;
598 Huffman_D.Update_Freq_Tree (C);
599 return C;
600 end Get_decoded_char;
601
602 I, J, R : Natural;
603 C8 : Byte;
604 C : Natural;
605
606 Text_Buf : Text_Buffer := empty_buffer;
607
608 begin
609 if not More_bytes then
610 return;
611 end if;
612 Huffman_D.Start;
613 R := String_buffer_size - Look_Ahead;
614 while More_bytes loop
615 C := Get_decoded_char;
616 if C < 256 then
617 C8 := Unsigned_8 (C);
618 Write_byte (C8);
619 Text_Buf (R) := C8;
620 R := (R + 1) mod String_buffer_size;
621 else
622 I := (R - Get_decoded_position - 1) mod String_buffer_size;
623 J := C - 255 + Threshold;
624 for K in 0 .. J - 1 loop
625 C8 := Text_Buf ((I + K) mod String_buffer_size);
626 Write_byte (C8);
627 Text_Buf (R) := C8;
628 R := (R + 1) mod String_buffer_size;
629 end loop;
630 end if;
631 end loop;
632 end Decode;
633
634 end LZH;
Web view of Ada source code generated by GNATHTML, project: ALI_Parse version 1.0.
Zip-Ada: Ada library for zip archive files (.zip).
Ada programming.
Some news about Zip-Ada and other Ada projects
on Gautier's blog.