[Back to ARCHIVES SWAG index] [Back to Main SWAG index] [Original]

    (*
    From: IAN HUNTER
    Subj: LZW Compression Unit
    *)

    Unit IHLZW;
      {- Unit to handle data compression }
    Interface
    Const
      StackOverFlow = 1;
      DeniedWrite = 2;
    Type
      GetCharFunc = Function (Var Ch : Char) : Boolean;
      PutCharProc = Procedure (Ch : Char);
      LZW = Object
              GetChar : GetCharFunc;
              PutChar : PutCharProc;
              LastError : Word;
              Constructor Init;
              Function Get_Hash_Code (PrevC, FollC : Integer) : Integer;
              Procedure Make_Table_Entry (PrevC, FollC: Integer);
              Procedure Initialize_String_Table;
              Procedure Initialize;
              Function Lookup_String (PrevC, FollC : Integer) : Integer;
              Procedure Get_Char (Var C : Integer);
              Procedure Put_Char (C : Integer);
              Procedure Compress;
              Procedure Decompress;
              End;

    Implementation
    Const
      MaxTab   = 4095;
      No_Prev  = $7FFF;
      EOF_Char = -2;
      End_List = -1;
      Empty    = -3;

    Type
      AnyStr = String;
      String_Table_Entry = Record
        Used : Boolean;
        PrevChar : Integer;
        FollChar : Integer;
        Next : Integer;
        End;

    Var
      String_Table : Array [0..MaxTab] Of String_Table_Entry;
      Table_Used     : Integer;
      Output_Code    : Integer;
      Input_Code     : Integer;
      If_Compressing : Boolean;

    Constructor LZW.Init;
    Begin
      LastError := 0;
    End;

    Function LZW.Get_Hash_Code (PrevC, FollC : Integer) : Integer;
    Var
      Index  : Integer;
      Index2 : Integer;
    Begin
      Index := ((PrevC SHL 5) XOR FollC) AND MaxTab;
      If (Not String_Table [Index].Used)
        Then
          Get_Hash_Code := Index
        Else
          Begin
            While (String_Table[Index].Next <> End_List) Do
              Index := String_Table[Index].Next;
            Index2 := (Index + 101) And MaxTab;
            While (String_Table[Index2].Used) Do
              Index2 := Succ (Index2) AND MaxTab;
            String_Table[Index].Next := Index2;
            Get_Hash_Code := Index2;
          End;
    End;

    Procedure LZW.Make_Table_Entry (PrevC, FollC: Integer);
    Begin
      If (Table_Used <= MaxTab )
        Then
          Begin
             With String_Table [Get_Hash_Code (PrevC , FollC)] Do
               Begin
                 Used     := True;
                 Next     := End_List;
                 PrevChar := PrevC;
                 FollChar := FollC;
               End;
             Inc (Table_Used);
    (*
             IF ( Table_Used > ( MaxTab + 1 ) ) THEN
                BEGIN
                   WRITELN('Hash table full.');
                END;
    *)
          End;
    End;

    Procedure LZW.Initialize_String_Table;
    Var
      I : Integer;
    Begin
      Table_Used := 0;
      For I := 0 to MaxTab Do
        With String_Table[I] Do
          Begin
            PrevChar := No_Prev;
            FollChar := No_Prev;
            Next := -1;
            Used := False;
          End;
      For I := 0 to 255 Do
        Make_Table_Entry (No_Prev, I);
    End;

    Procedure LZW.Initialize;
    Begin
      Output_Code := Empty;
      Input_Code := Empty;
      Initialize_String_Table;
    End;

    Function LZW.Lookup_String (PrevC, FollC: Integer) : Integer;
    Var
      Index  : Integer;
      Index2 : Integer;
      Found  : Boolean;
    Begin
      Index := ((PrevC Shl 5) Xor FollC) And MaxTab;
      Lookup_String := End_List;
      Repeat
        Found := (String_Table[Index].PrevChar = PrevC) And
                 (String_Table[Index].FollChar = FollC);
        If (Not Found)
          Then
            Index := String_Table [Index].Next;
      Until Found Or (Index = End_List);
      If Found
        Then
          Lookup_String := Index;
    End;

    Procedure LZW.Get_Char (Var C : Integer);
    Var
      Ch : Char;
    Begin
      If Not GetChar (Ch)
        Then
          C := EOF_Char
        Else
          C := Ord (Ch);
    End;

    Procedure LZW.Put_Char (C : Integer);
    Var
      Ch : Char;
    Begin
      Ch := Chr (C);
      PutChar (Ch);
    End;

    Procedure LZW.Compress;
      Procedure Put_Code (Hash_Code : Integer);
      Begin
        If (Output_Code = Empty)
          Then
            Begin
              Put_Char ((Hash_Code Shr 4) And $FF);
              Output_Code := Hash_Code And $0F;
            End
          Else
            Begin
              Put_Char (((Output_Code Shl 4) And $FF0) +
                       ((Hash_Code Shr 8) And $00F));
              Put_Char (Hash_Code And $FF);
              Output_Code := Empty;
            End;
      End;

      Procedure Do_Compression;
      Var
        C : Integer;
        WC : Integer;
        W : Integer;
      Begin
        Get_Char (C);
        W := Lookup_String (No_Prev, C);
        Get_Char (C);
        While (C <> EOF_Char) Do
          Begin
            WC := Lookup_String (W, C);
            If (WC = End_List)
              Then
                Begin
                  Make_Table_Entry (W, C );
                  Put_Code (W);
                  W := Lookup_String (No_Prev, C);
                End
              Else
                W := WC;
            Get_Char( C );
          End;
        Put_Code (W);
      End;

    Begin
      If_Compressing := True;
      Initialize;
      Do_Compression;
    End;

    Procedure LZW.Decompress;
    Const
      MaxStack = 4096;
    Var
      Stack : Array [1..MaxStack] Of Integer;
      Stack_Pointer : Integer;

      Procedure Push (C : Integer);
      Begin
        Inc (Stack_Pointer);
        Stack [Stack_Pointer] := C;
        If (Stack_Pointer >= MaxStack)
          Then
            Begin
              LastError := 1;
              Exit;
            End;
      End;

      Procedure Pop (Var C : Integer);
      Begin;
        If (Stack_Pointer > 0)
          Then
            Begin
              C := Stack [Stack_Pointer];
              Dec (Stack_Pointer);
            End
          Else
            C := Empty;
      End;

      Procedure Get_Code (Var Hash_Code : Integer);
      Var
        Local_Buf : Integer;
      Begin
        If (Input_Code = Empty)
          Then
            Begin
              Get_Char (Local_Buf);
              If (Local_Buf = EOF_Char)
                Then
                  Begin
                    Hash_Code := EOF_Char;
                    Exit;
                  End;
              Get_Char (Input_Code);
              If (Input_Code = EOF_Char)
                Then
                  Begin
                    Hash_Code := EOF_Char;
                    Exit;
                  End;
              Hash_Code := ((Local_Buf Shl 4) And $FF0) +
                           ((Input_Code Shr 4) And $00F);
              Input_Code := Input_Code And $0F;
            End
          Else
            Begin
              Get_Char (Local_Buf);
              If (Local_Buf = EOF_Char)
                Then
                  Begin
                    Hash_Code := EOF_Char;
                    Exit;
                  End;
              Hash_Code := Local_Buf + ((Input_Code Shl 8) And $F00);
              Input_Code := Empty;
            End;
      End;

      Procedure Do_Decompression;
      Var
        C : Integer;
        Code : Integer;
        Old_Code : Integer;
        Fin_Char : Integer;
        In_Code : Integer;
        Last_Char : Integer;
        Unknown : Boolean;
        Temp_C : Integer;
      Begin
        Stack_Pointer := 0;
        Unknown := False;
        Get_Code (Old_Code);
        Code := Old_Code;
        C := String_Table[Code].FollChar;
        Put_Char (C);
        Fin_Char := C;
        Get_Code (In_Code);
        While (In_Code <> EOF_Char) Do
          Begin
            Code := In_Code;
            If (Not String_Table [Code].Used)
              Then
                Begin
                  Last_Char := Fin_Char;
                  Code := Old_Code;
                  Unknown := TRUE;
                End;
            While (String_Table [Code].PrevChar <> No_Prev) Do
              With String_Table[Code] Do
                Begin
                  Push (FollChar);
                  If (LastError <> 0)
                    Then
                      Exit;
                  Code := PrevChar;
                End;
            Fin_Char := String_Table [Code].FollChar;
            Put_Char (Fin_Char);
            Pop (Temp_C);
            While (Temp_C <> Empty) Do
              Begin
                Put_Char (Temp_C);
                Pop (Temp_C);
              End;
            If Unknown
              Then
                Begin
                  Fin_Char := Last_Char;
                  Put_Char (Fin_Char);
                  Unknown := FALSE;
                End;
            Make_Table_Entry (Old_Code, Fin_Char);
            Old_Code := In_Code;
            Get_Code( In_Code );
          End;
      End;

    Begin
      If_Compressing := False;
      Initialize;
      Do_Decompression;
    End;

    End.

    (* *****************************     TEST PROGRAM    ****************** *)

    Program LZWTest;
    { program to demo/test the LZW object }
    Uses
      IHLZW;  { Only needs this }
    Var
      C : LZW; { The Star of the Show; the Compression Object }

    {$F+} Function GetTheChar (Var Ch : Char) : Boolean; {$F-}
    { Make your GetChar routine's declaration look exactly like this }

    Begin
      If Not Eof (Input) { End of Input? }
        Then
          Begin
            Read (Input, Ch); { Then read one character into Ch and ... }
            GetTheChar := True; { ... Return True }
          End
        Else
          GetTheChar := False; { Otherwise return False }
    End;

    {$F+} Procedure PutTheChar (Ch : Char); {$F-}
    { Make your PutChar routine's declaration look exactly like this }

    Begin
      Write (Output, Ch); { Write Ch to Output file }
    End;

    Begin
      { Open data files }
      Assign (Input, ''); { Standard Input; requires redirection to be useful }
      Assign (Output, ''); { Standard Output; requires redirection to be useful }
      Reset (Input);
      Rewrite (Output);
      { Can't fail yet -- maybe a descendant could, though... }
      If not C.Init
        Then
          Halt;
      { Assign I/O routines }
      C.GetChar := GetTheChar; { Set LZW's GetChar to routine GetTheChar }
      C.PutChar := PutTheChar; { Set LZW's PutChar to routine PutTheChar }
      { are we compressing or decompressing? }
      If (ParamCount = 0)
        Then
          C.Compress { compress }
        Else
          C.Decompress; { decompress }
      { All Done! }
    End.

[Back to ARCHIVES SWAG index] [Back to Main SWAG index] [Original]