Back to... Zip-Ada

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.