Solved

Implementing huffman coding for file compression

Posted on 1999-01-17
2
396 Views
Last Modified: 2008-02-20
I am currently doing an assignment in pascal to implement the huffman algorithm for the file compression, but i do not know how to start.The program takes a paragraph of text as input from the keyboard or a file. The outputs includes a frequency table, a coding for each character appeared in the text and a report of saving percentage of the coding compared with normal ASCII coding. The algorithm can be descibe as follows:
 
1. Constuct a frequency table (including spaces);
2. Create a forest of code trees, one for each character. Each code tree consists of a single node labelled by a character and frequency. The weight of each tree is the sum of the frequencies of the leaves.
3. Iteration until there is only one tree:
Select the two trees T1 and T2 of smallest weight, form a tree with subtrees T1 and T2. Assign the weight of the new tree, which is the sum of the weights of T1 AND T2, and update the frequency table.
4. Start at the root and trace down to every leaf to the final tree; mark O for the left branch and 1 for the right.
 
Example:
File Compression
1. Input text
2. Frequency Table
3. Huffman coding pattern
4. Display Compressed file
5. Saving percentage
6. Quit
 
Enter your choice >1
Input The text to compress file > BILL BEATS BEN.
 
Enter your choice > 2
 
Char        Freq
B            3
L            2
E            2
SP        2
I            1
A           1
T            1
A            1
T            1
S            1
N            1
.            1
Total      15
 
Press any key  to return to main program >
Enter your choice > 3
I     0000
A    0001
S    0010
T    0011
N    0100
.    0111
L    011
E    100
SP  101
B    11
 
Press any key to return to main program >
Enter your choice > 4
111000100101111000001001000111011100000110110101
 
Press any key to return to main program >
Enter your choice >5
 
You have saved 60% compared with a 8-bit coding.
 
Press any key to return to main program >
Enter your choice > 6
 
Impelementation requirment
Use linked lists, tree structures,feasible and efficient sorting algorithms  
 
I need the source code for my assigment very urgently as my dateline for the assignment is 26 Jan 99. Appreciate your help. Please email to me as soon as possible so that i can have sufficient time to finish my documentation and report.
 
Thank you very much

Liver
0
Comment
Question by:Liver
  • 2
2 Comments
 
LVL 3

Accepted Solution

by:
Ronald Buster earned 200 total points
Comment Utility
Hi Liver,

Here is some code I wrote about 6 years ago, for a local archiver. It contains all the stuff
you want,

regards,

Cono


<----------------->

{$A+,B-,G-,D+,E-,F-,I+,L+,N-,O-,R-,S-,V-,X-}
{$M 12384,0,255360}
{
============================================================
=                       UNIT LHJAM V1.11                   =
============================================================
= Author(s) : Ronald Buster                                =
============================================================
= Date's    : 02-12-1993 - Start with unit architecture    =
=             03-12-1993 - Start with LH77 implementation  =
=             04-12-1993 - Added binary tree routines to   =
=                          LH77 strange it shouldn't work  =
=                          with LH77 but it does.          =
=             06-12-1993 - LHJAM routine works now without =
=                          any problems.                   =
============================================================
=          (c)1993 Kickback Software Development           =
============================================================
}
unit lhjam;

interface

CONST
  TEXTSEARCH = 1000; {1000}  { Max strings to search in text file}
                       { smaller -> Faster compression}
  BINSEARCH  =  200; {200} { Max strings to search in binary file }
  TEXTNEXT   =   50; {50} { Max search at next character in text file}
                       { Smaller -> better compression }
  BINNEXT    =   20; {20} { Max search at next character in binary file }
  MAXFREQ    = 2000;   { Max frequency count before table reset }
  MINCOPY    =    3;   { Shortest string COPYING length }
  MAXCOPY    =   64;   { Longest string COPYING length }
  SHORTRANGE =    3;   { Max distance range for shortest length COPYING }
  COPYRANGES =    6;   { Number of string COPYING distance bit ranges @@@}
  CopyBits : Array[0..PRED(COPYRANGES)] OF INTEGER = (4,6,8,10,12,14);
                       { Distance bits }
  CODESPERRANGE = (MAXCOPY - MINCOPY + 1);

  NUL = -1;                    { End of linked list marker }
  HASHSIZE = 16384; {16384}    { Number of entries in hash table }
  HASHMASK = (HASHSIZE - 1);   { Mask for hash key wrap }

{
==================================
=   Adaptive Huffman variables   =
==================================
}
  TERMINATE = 256;             { EOF code }
  FIRSTCODE = 257;             { First code for COPYING lengths }
  MAXCHAR = (FIRSTCODE+COPYRANGES*CODESPERRANGE-1);
  SUCCMAX = (MAXCHAR+1);
  TWICEMAX = (2*MAXCHAR+1);
  ROOT = 1;
  MAXBUF = 16384; {4096;}

{
==================================
=      Bit packing routines      =
==================================
}
  Input_Bit_Count : WORD = 0;    { Input bits buffered }
  Input_Bit_Buffer: WORD = 0;    { Input buffer }
  Output_Bit_Count: WORD = 0;    { Output bits buffered }
  Output_Bit_Buffer : WORD = 0;  { Output buffer }
  Bytes_Out : Longint = 0;       { File size counters }
  Bytes_In : LongINT = 0;

  OutBufCount : INTEGER = 0;
  InBufCount  : INTEGER = 0;


TYPE
     JHeader = record
                 Name  : string[12];
                 Meth  : byte;            {0 - stored}
                                          {1 - jammed}
                 OSiz  ,
                 PSiz  ,
                 PosF  ,
                 PosN  : longint;
                 Ver   ,
                 MVer  : byte;
               end;


  Copy_Type = Array[0..PRED(CopyRanges)] OF Integer;


CONST
  CopyMin : Copy_Type = (0,16,80,336,1360,5456);
  CopyMax : Copy_Type = (15,79,335,1359,5455,21839);
  MaxDistance : Integer = 21839;
  MaxSize = 21839 + MAXCOPY;


TYPE
  HashType = Array[0..PRED(HashSize)] OF Integer;
  Hash_Ptr = ^HashType;
  ListType = Array[0..MaxSize] OF Integer;
  List_Ptr = ^ListType;
  Buffer_Type = Array[0..MaxSize] OF BYTE;
  Buffer_Ptr = ^Buffer_Type;
  HTree_Type = Array[0..MaxChar] OF WORD;
  THTree_Type = Array[0..TwiceMax] OF WORD;
  BufType = Array[0..PRED(MAXBUF)] OF BYTE;
  BufPtr = ^BufType;
  WDBufType = Array[0..PRED(MAXBUF)] OF WORD;
  WDBufPtr = ^WDBufType;


VAR
  JH          : JHeader;
  Head, Tail : Hash_Ptr;         { Hash table }
  Next, Prev : List_Ptr;       { Doubly linked lists }
  Buffer : Buffer_Ptr;           { Text buffer }
  Distance, Insrt, DictFile, Binary : Integer;
  LeftC, RightC : HTree_Type;  { Huffman tree }
  Parent,Freq : THTree_Type;
  InBuf,OutBuf : BufPtr;
  WDBuf : WDBufPtr;
  InFIle,OutFile : FILE;
  kappuh : boolean;

{================================================================}

procedure Jam;
procedure UnJam;
procedure showbar(x1,y1,x2,y2,percent,fc,bc,fc1,bc1,j:byte);

{================================================================}

implementation
uses crt,cgswin;

procedure showbar(x1,y1,x2,y2,percent,fc,bc,fc1,bc1,j:byte);
var i       : byte;
    ta      : Byte;
begin
 ta := TextAttr;
 {vretrace;}
 TextBackground({bc}1);
 Textcolor(fc);
 Gotoxy(x1+((x2-x1) div 2)-5,y1+1+j);
 write(Percent:3,'% done');
 TextColor(fc1);
 TextBackground(bc1);
 for i := 1 to 50 do
 begin
   if i <= (percent div 2) then
     mem[scrseg:(y1*160)+((x1+i+1)*2)+1] := $90 or fc
   else
     mem[scrseg:(y1*160)+((x1+i+1)*2)+1] := $10 or fc;
 end;
 TextAttr := Ta;
end;

{================================================================}
Procedure initialize;
VAR
   I, J : Integer;
BEGIN
  FOR I := 2 TO TWICEMAX DO
    BEGIN
      Parent[I] := I DIV 2;
      Freq[I] := 1;
    END;
  FOR I := 1 TO MAXCHAR DO
    BEGIN
      LeftC[I] := 2*I;
      RightC[I] := 2*I+1;
    END;
END;
{================================================================}
Procedure Output_Bit(Bit: Integer);
BEGIN
  Output_Bit_Buffer := Output_Bit_Buffer SHL 1;
  IF Boolean(Bit) THEN Output_Bit_Buffer := Output_Bit_Buffer OR 1;
  INC(OutPut_Bit_Count);
  IF (Output_Bit_Count = 16) THEN
    BEGIN
      WdBuf^[OutBufCount] := Output_Bit_Buffer;
      INC(OutBufCount);
      Output_Bit_Count := 0;
      INC(Bytes_Out,2);
      IF OutBufCount = MAXBUF THEN
        BEGIN
          BlockWrite(OutFile,WdBuf^,MAXBUF*2);
          OutBufCount := 0;
        END;
    END;
END;
{================================================================}
Procedure Output_Code(Code, Bits : Integer);
VAR
  I : Integer;
BEGIN
  FOR I := 0 TO PRED(Bits) DO
    BEGIN
      Output_Bit(Code AND $1);
      Code := Code SHR 1;
    END;
END;
{================================================================}
Procedure Flush_Bits;
BEGIN
  IF (Output_Bit_Count > 0) THEN
    BEGIN
      Output_Bit_Buffer := Output_Bit_Buffer SHL (16-Output_Bit_Count);
      WdBuf^[OutBufCount] := Output_Bit_Buffer;
      INC(OutBufCount);
      Output_Bit_Count := 0;
      INC(Bytes_Out,2);
    END;
  BlockWrite(OutFile,WdBuf^,OutBufCount*2);
END;
{================================================================}
Procedure Update_Freq(A,B : Integer);
BEGIN
  REPEAT
    Freq[Parent[A]] := Freq[A] + Freq[B];
    A := Parent[A];
    IF (A <> ROOT) THEN
      BEGIN
        IF (LeftC[Parent[A]] = A) THEN
          B := RightC[Parent[A]]
        ELSE B := LeftC[Parent[A]];
      END;
  UNTIL A = ROOT;

  { Periodically scale frequencies down by half to avoid overflow }
  { This also provides some local adaption and better compression }

  IF (Freq[ROOT] = MAXFREQ) THEN
    FOR A := 1 TO TWICEMAX DO
      Freq[a] := Freq[a] SHR 1;
END;
{================================================================}
Procedure Update_Model(Code : Integer);
VAR
  A, B, C, Ua, Uua : Integer;

BEGIN
  A := Code + SUCCMAX;
  INC(Freq[A]);
  IF (Parent[A] <> ROOT) THEN
    BEGIN
      ua := Parent[a];
      IF (LeftC[ua] = a) THEN update_freq(a,RightC[ua])
      ELSE update_freq(a,LeftC[ua]);
      REPEAT
        uua := Parent[ua];
        IF (LeftC[uua] = ua) THEN
          b := RightC[uua]
        ELSE b := LeftC[uua];

        { IF high Freq lower in tree, swap nodes }
        IF Freq[a] > Freq[b] THEN
          BEGIN
            IF LeftC[Uua] = ua THEN
              RightC[Uua] := A
            ELSE LeftC[Uua] := A;
            IF (LeftC[ua] = a) THEN
              BEGIN
                LeftC[Ua] := B;
                C := RightC[ua];
              END
            ELSE
              BEGIN
                RightC[Ua] := B;
                C := LeftC[Ua];
              END;
            Parent[b] := Ua;
            Parent[a] := Uua;
            Update_Freq(B,C);
            A := B;
          END;
        A := Parent[A];
        Ua := Parent[A];
      UNTIL Ua = ROOT;
    END;
END;
{================================================================}
Procedure Compress(code: Integer);
VAR
  a, sp : Integer;
  Stack : Array[0..49] OF Integer;
BEGIN
  Sp := 0;
  A := Code + SUCCMAX;
  REPEAT
    Stack[Sp] := Integer(RightC[Parent[A]] = A);
    INC(Sp);
    A := Parent[A];
  UNTIL (A = ROOT);

  REPEAT
    DEC(Sp);
    Output_Bit(Stack[Sp]);
  UNTIL sp = 0;
  Update_Model(Code);
END;
{================================================================}
Procedure Add_Node(N: Integer);
VAR
  Key :  Integer;

BEGIN
{ Define hash key function using MINCOPY characters of string prefix }
  Key := (Buffer^[N] XOR (Buffer^[(N+1) MOD MaxSize] SHL 4)) XOR
                   (Buffer^[(N+2) MOD Maxsize] SHL 8) AND HASHMASK;
  IF (Head^[Key] = NUL) THEN
    BEGIN
      Tail^[Key] := N;
      Next^[N] := NUL;
    END
  ELSE
    BEGIN
      Next^[N] := Head^[Key];
      Prev^[Head^[Key]] := N;
    END;
  Head^[Key] := N;
  Prev^[N] := NUL;
END;
{================================================================}
Procedure Delete_Node(N : Integer);
VAR
  K : Real;
  Key :  Integer;

BEGIN
{ Define hash key function using MINCOPY characters of string prefix }
  Key := (Buffer^[N] XOR (Buffer^[(N+1) MOD MaxSize] SHL 4)) XOR
                   (Buffer^[(N+2) MOD Maxsize] SHL 8) AND HASHMASK;
  IF (Head^[Key] = Tail^[Key]) THEN
    Head^[Key] := NUL
  ELSE
    BEGIN
      Next^[Prev^[Tail^[Key]]] := NUL;
      Tail^[Key] := Prev^[Tail^[Key]];
    END;
END;
{================================================================}
Function Match(N,Depth: Integer): Integer;
LABEL 1;
VAR
   I, J, Index, Key, Dist, Len, Best, Count  : Integer;
BEGIN
  Best := 0;
  Count := 0;

  IF (N = MaxSize) THEN
    N := 0;

{ Define hash key function using MINCOPY characters of string prefix }
  Key := (Buffer^[N] XOR (Buffer^[(N+1) MOD MaxSize] SHL 4)) XOR
                   (Buffer^[(N+2) MOD Maxsize] SHL 8) AND HASHMASK;
  Index := Head^[Key];
  WHILE (Index <> NUL) DO
    BEGIN
      INC(Count);
      IF (Count > Depth) THEN Goto 1;     { Quit IF depth exceeded }
      IF (Buffer^[(N+Best) MOD MaxSize] = Buffer^[(Index+Best) MOD MaxSize]) THEN
        BEGIN
          Len := 0;
          I := N;
          J := Index;
          WHILE (Buffer^[I] = Buffer^[J]) AND (Len<MAXCOPY) AND ((J<>N) AND (I<>Insrt)) DO
            BEGIN
              INC(Len);
              INC(I);
              IF (I = MaxSize) THEN
                I := 0;
              INC(J);
              IF (J = MaxSize) THEN
                J := 0;
            END;
          Dist := N - Index;
          IF (Dist < 0) THEN
            Dist := Dist + MaxSize;
          Dist := Dist - Len;
      { IF dict file, quit at shortest distance range }
          IF (DictFile AND Dist > CopyMax[0]) THEN Goto 1;
          IF (Len > Best) AND (Dist <= MaxDistance) THEN
            BEGIN     { Update best match }
              IF (Len > MINCOPY) OR (Dist <= CopyMax[SHORTRANGE+Binary]) THEN
                BEGIN
                  Best := Len;
                  Distance := Dist;
                END;
            END;
        END;
      Index := Next^[Index];
    END;
1: Match := Best;
END;

{** Finite Window compression routines **}

CONST
  IDLE = 0;    { Not processing a COPYING }
  COPYING = 1;    { Currently processing COPYING }

{ Check first buffer for ordered dictionary file }
{ Better compression using short distance copies }

Procedure Dictionary;
VAR
  i, j, k, count : Integer;
BEGIN
  I := 0;
  J := 0;
  Count := 0;

  { Count matching chars at start of adjacent lines }
  INC(J);
  WHILE (J < MINCOPY+MAXCOPY) DO
    BEGIN
      IF (Buffer^[J-1] = 10) THEN
        BEGIN
          K := J;
          WHILE (Buffer^[I] = Buffer^[K]) DO
            BEGIN
              INC(I);
              INC(K);
              INC(count);
            END;
          I := J;
        END;
      INC(J);
    END;
  { IF matching line prefixes > 25% assume dictionary }
  IF (Count > (MINCOPY+MAXCOPY) DIV 4) THEN
    DictFile := 1;
END;
{================================================================}
{ Encode file from input to output }
Procedure Jam;
LABEL 1,2;

VAR
  C, I, N, Addpos, Len, Full, State, Nextlen, Result: Integer;

BEGIN
  N := MINCOPY;
  Addpos := 0;
  Len := 0;
  Full := 0;
  State := IDLE;
  C := 0;
  initialize;
  New(InBuf);
  New(WdBuf);
  GetMem(Head,HASHSIZE*Sizeof(INTEGER));
  GetMem(Tail,HASHSIZE*Sizeof(INTEGER));
  GetMem(Next,MaxSize*Sizeof(INTEGER));
  GetMem(Prev,MaxSize*Sizeof(INTEGER));
  GetMem(Buffer,MaxSize*Sizeof(BYTE));
  IF (head=NIL) OR (Tail=NIL) OR (Next=NIL) OR (Prev=NIL) OR (Buffer=NIL) THEN
    BEGIN
      Writeln('Memory Allocation Error');
      Halt(1);
    END;

  { Initialize hash table to empty }
  FOR I := 0 TO PRED(HASHSIZE) DO
    BEGIN
      Head^[I] := NUL;
    END;

  BlockRead(InFile,InBuf^,MAXBUF,Result);

  { Compress first few characters using Huffman }
  FOR I := 0 TO PRED(MINCOPY) DO
    BEGIN
      C := InBuf^[InBufCount];
      INC(InBufCount);
      IF InBufCount = Result THEN
        BEGIN
          Compress(TERMINATE);
          Flush_bits;
          FreeMem(Head,HASHSIZE*Sizeof(INTEGER));
          FreeMem(Tail,HASHSIZE*Sizeof(INTEGER));
          FreeMem(Next,MaxSize*Sizeof(INTEGER));
          FreeMem(Prev,MaxSize*Sizeof(INTEGER));
          FreeMem(buffer,MaxSize*Sizeof(BYTE));
          Dispose(Wdbuf);
          Dispose(InBuf);
          Exit;
        END;
      Compress(C);
      INC(Bytes_In);
      Buffer^[I] := C;
    END;


  { Preload next few characters into lookahead buffer }
  FOR I := 0 To PRED(MAXCOPY) DO
    BEGIN
      C := InBuf^[InBufCount];
      INC(InBufCount);
      IF InBufCount = Result THEN Goto 1;
      Buffer^[Insrt] := C;
      INC(Insrt);
      INC(Bytes_In);
      IF (C > 127) THEN
        Binary := 1;     { Binary file ? }
    END;

1:
  Dictionary;  { Check for dictionary file }

  WHILE (N <> Insrt) Do
    BEGIN
    { Check compression to insure really a dictionary file }
      IF (Boolean(dictfile) AND ((Bytes_In MOD MAXCOPY) = 0)) THEN
        IF (Bytes_In/Bytes_Out < 2) THEN
          Dictfile := 0;     { Oops, not a dictionary file ! }

    { Update nodes in hash table lists }
      IF BOOLEAN(Full)  THEN Delete_Node(Insrt);
      Add_node(Addpos);

    { IF doing COPYING, process character, ELSE check for new COPYING }
      IF (State = COPYING) THEN
        BEGIN
          DEC(Len);
          IF (len = 1) THEN
            State := IDLE;
        END
      ELSE
        BEGIN

      { Get match length at next character and current char }
          IF BOOLEAN(binary) THEN
            BEGIN
              Nextlen := Match(N+1,BINNEXT);
              Len := Match(N,BINSEARCH);
            END
          ELSE
            BEGIN
              Nextlen := Match(N+1,TEXTNEXT);
              Len := Match(N,TEXTSEARCH);
            END;

      { IF long enough and no better match at next char, start COPYING }
          IF (Len >= MINCOPY) AND (len >= NextLen) THEN
            BEGIN
              State := COPYING;

        { Look up minimum bits to encode distance }
              FOR I := 0 To PRED(COPYRANGES) DO
                BEGIN
                  IF (distance <= CopyMax[i]) THEN
                    BEGIN
                      Compress(FIRSTCODE-MINCOPY+Len+I*CODESPERRANGE);
                      Output_code(Distance-CopyMin[I],CopyBits[I]);
                      Goto 2;
                    END;
                END;
2:
            END
          ELSE   { ELSE output single literal character }
            Compress(Buffer^[N]);
        END;

    { Advance buffer pointers }
      INC(N);
      IF (N = MaxSize) THEN
        N := 0;
      INC(Addpos);
      IF (Addpos = MaxSize) THEN
        Addpos := 0;

    { Add next input character to buffer }
      IF InBufCount < Result THEN
        BEGIN
          C := InBuf^[InBufCount];
          INC(InBufCount);
          IF InBufCount = MAXBUF THEN
            BEGIN
              BlockRead(InFile,InBuf^,MAXBUF,Result);
              InBufCount := 0;
            END;
          Buffer^[Insrt] := C;
          Inc(Insrt);
          INC(Bytes_In);
          IF (Insrt = MaxSize) THEN
            BEGIN
              Insrt := 0;
              Full := 1;
            END;
        END
      ELSE Full := 0;
    END;

  { Output EOF code and free memory }
  compress(TERMINATE);
  Flush_Bits;
  FreeMem(Head,HASHSIZE*Sizeof(INTEGER));
  FreeMem(Tail,HASHSIZE*Sizeof(INTEGER));
  FreeMem(Next,MaxSize*Sizeof(INTEGER));
  FreeMem(Prev,MaxSize*Sizeof(INTEGER));
  FreeMem(buffer,MaxSize*Sizeof(BYTE));
  Dispose(WDBuf);
  Dispose(InBuf);
END;
{================================================================}
{ Read multibit code from input file }
Function Input_Code(Bits:Integer): WORD;
CONST
  Bit : Array[1..14] OF WORD = (1,2,4,8,16,32,64,128,256,512,1024,
                                2048,4096,8192);
VAR
  I, Code, Result : WORD;
BEGIN
  Code := 0;
  FOR I := 1 TO Bits DO
    BEGIN
      IF (Input_Bit_Count = 0) THEN
        BEGIN
          IF (InBufCount = MAXBUF) THEN
            BEGIN
              BlockRead(InFile,WdBuf^,MAXBUF*2,Result);
              INC(Bytes_In,Result);
              InBufCount := 0;
              IF (Result = 0) THEN
                BEGIN
                  Writeln('Unexpected end of file');
                  HALT(1);
                END;
            END;
          Input_Bit_Buffer := Wdbuf^[InBufCount];
          INC(InBufCount);
          Input_Bit_Count := 15;
        END
      ELSE DEC(Input_Bit_Count);
      IF Input_Bit_Buffer > $7FFF THEN Code := Code OR Bit[I];
      Input_Bit_Buffer :=  Input_Bit_Buffer SHL 1;
    END;
  Input_Code := Code;
END;
{================================================================}
{ Uncompress a character code from input stream }
Function Uncompress: WORD;
LABEL
 TOP,AFT,OVER,NOREAD;
VAR
  Result : WORD;
BEGIN
  ASM
    MOV BX, 1
    MOV DX, Input_Bit_Count
    MOV CX, Input_Bit_Buffer
    MOV AX, InBufCount
TOP:                           { REPEAT                               }
    OR   DX, DX                {  IF Input_Bit_Count <> 0 THEN        }
    JNE  AFT                   {    BEGIN                             }
    CMP  AX, MAXBUF            {      IF InBufCount = MAXBUF THEN     }
    JNE  NOREAD                {        BEGIN                         }
    PUSH BX
    PUSH CX
    PUSH DX
  END;
  BlockRead(InFile,WdBuf^,MAXBUF*2,Result);

  INC(Bytes_In,Result);
  IF (Result = 0) THEN
    BEGIN
      Writeln('Unexpected end of file');
      HALT(1);
    END;
  ASM
    POP DX
    POP CX
    POP BX
    XOR AX, AX                 {          InBufCount := 0;            }
NOREAD:                        {        END;                          }
    SHL AX,1                   {      Input_Bit_Buffer := InBuf^[InBufCount];}
    LES DI,[WdBuf]
    ADD DI,AX
    SHR AX,1
    MOV CX,ES:[DI]
    INC AX                     {      INC(InBufCount);                }
    MOV DX,$F                  {      Input_Bit_Count := 15;          }
    JMP OVER                   {    END                               }
AFT:
    DEC DX                     {  ELSE DEC(Input_Bit_Count);          }
OVER:
    CMP CX,$7FFF               {  IF Input_Bit_Buffer > $7FFF THEN    }
    JBE @Less
    MOV DI,BX                  {    A := RightC[A];                   }
    SHL DI,1
    MOV BX,[DI+OFFSET RightC]
    JMP @After
@Less:
    MOV DI,BX                  {  ELSE A := LeftC[A];                 }
    SHL DI,1
    MOV BX,[DI+OFFSET LeftC]
@After:
    SHL  CX,1                  {  Input_BitBuffer := Input_Bit_Buffer SHL 1;}
    CMP  BX, MAXCHAR           { UNTIL A > MAXCHAR;                   }
    JLE  TOP
    SUB  BX, SUCCMAX           { DEC(A,SUCCMAX);                      }
    MOV  Input_Bit_Count, DX
    MOV  Input_Bit_Buffer, CX
    MOV  InBufCount, AX
    PUSH BX
    PUSH BX
    CALL UPDATE_MODEL          { Model_Update(A);                     }
    POP  AX
    MOV  [BP-2],AX             { Uncompress := A;                     }
  END;
END;
{================================================================}
{ Decode file from input to output }
Procedure UnJam;
var outd : Longint;

 procedure showdone;
 var ch : Char;
 begin
   ShowBar(12,12,70,13,Round((Outd/JH.Osiz)*100),15,7,9,1,1);
   If Keypressed then
   begin
    ch := readkey;
    if ch = #27 then kappuh := true;
   end;
 end;

VAR
  I, J, Dist, Len, Index, K, T : INTEGER;
  N, Result, C : WORD;
  L1,L2 : Longint;
BEGIN
  New(WDBuf);
  New(OutBuf);
  N := 0;
  InBufCount := MAXBUF;
  initialize;
  kappuh := false;
  outd := 0;
  GetMem(Buffer,MaxSize*Sizeof(BYTE));
  IF (Buffer = NIL) THEN
    BEGIN
      Writeln('Error allocating memory');
      HALT(1);
    END;
  C := Uncompress;
  move(Mem[scrseg:0],Mem[scrseg:16000],8000);
  MakeWindow(12,12,68,15,15,7,1,'UnJamming '+JH.Name,1,0,false);
  WHILE (C <> TERMINATE) and not Kappuh DO
    BEGIN
      Showdone;
      IF (C < 256) THEN
        BEGIN     { Single literal character ? }
          OutBuf^[OutBufCount] := C;
          INC(OutBufCount);
          inc(outd);
          IF OutBufCount = MAXBUF THEN
            BEGIN
              BlockWrite(OutFile,OutBuf^,MAXBUF,Result);
              OutBufCount := 0;
              INC(Bytes_Out,Result);
            END;
          if outd mod (65535) = 0 then showdone;
          Buffer^[N] := C;
          INC(N);
          IF (N = MaxSize) THEN
            N := 0;
        END
      ELSE
        BEGIN            { ELSE string copy length/distance codes }
          T := C - FIRSTCODE;
          Index := (T) DIV CODESPERRANGE;
          Len := T + MINCOPY - Index*CODESPERRANGE;
          Dist := Input_Code(CopyBits[Index]) + Len + CopyMin[Index];
          J := N;
          K := N - Dist;
          IF (K < 0) THEN
            INC(K,MaxSize);
          FOR i := 0 To PRED(Len) DO
            BEGIN
              OutBuf^[OutBufCount] := Buffer^[K];
              INC(OutBufCount);
              inc(outd);
              IF OutBufCount = MAXBUF THEN
                BEGIN
                  BlockWrite(OutFile,OutBuf^,MAXBUF,Result);
                  OutBufCount := 0;
                  INC(Bytes_Out,Result);
                END;
              if outd mod (65535) = 0 then ShowDone;
              Buffer^[J] := Buffer^[K];
              INC(J);
              INC(K);
              IF (J = Maxsize) THEN J := 0;
              IF (K = Maxsize) THEN K := 0;
            END;
          INC(N,Len);
          IF (N >= Maxsize) THEN
            DEC(N,MaxSize);
        END;
      C := Uncompress;
    END;
  BlockWrite(OutFile,OutBuf^,OutBufCount,Result);
  INC(Bytes_Out, Result);
  FreeMem(buffer,MaxSize*Sizeof(BYTE));
  Dispose(OutBuf);
  Dispose(WdBuf);
  move(Mem[scrseg:16000],Mem[scrseg:0],8000);
END;
{================================================================}

end.



0
 
LVL 3

Expert Comment

by:Ronald Buster
Comment Utility
Hi Liver,

Here is some sample code to use the unit,

regards,

Cono

<----------------------------------->

{
============================================================
=                   JAM ARCHIVE PROGRAM                    =
============================================================
= Author(s) : Ronald Buster                                =
=             Jo-Rien Steenbergen                          =
============================================================
= Date's   : -Version 1.00                                 =
=             10-12-1993 - Start with program architecture =
=                                                          =
=            -Version 1.01                                 =
=             12-12-1993 - Start with adding to archive    =
=                                                          =
=            -Version 1.02                                 =
=             13-12-1993 - Added viewing archive           =
=                        - Bugs fixed                      =
=                                                          =
=            -Version 1.03                                 =
=             14-12-1993 - Added extracting from archive   =
=                                                          =
=            -Version 1.04                                 =
=             15-12-1993 - Fixed bug in storing method     =
=                          cause the extractor was getting =
=                          wrong information from original =
=                        - Fixed bug cause of too many fi- =
=                          les open error.                 =
=                        - Started with adding filelist    =
=                          to viewing routine.             =
=                                                          =
=            -Version 1.05                                 =
=             16-12-1993 - Fixed viewing routine.          =
=                          All param are now included.     =
=                                                          =
=            -Version 1.06                                 =
=             17-12-1993 - Extracting routine also works   =
=                          with a filelist.                =
============================================================
=          (c)1993 Kickback Software Development           =
============================================================}
const EX = 0;
      LI = 1;

var  JamVer      ,
     JamVerM     : byte;

     DoWhat      : word;

     TotBytesIn  ,
     TotBytesOut : longint;
     TotFiles    : integer;

     TN1         ,
     TN2         ,
     TN3         : real;

     Pat         : PathStr;
     Dir         : DirStr;
     Nam         : NameStr;
     Ext         : ExtStr;

     PackNam     : string[8];
     SearchName  : string[12];

     FH          : SearchRec;

{===========================================================}
procedure ListSupplement1(e:string;m:byte);forward;
procedure ListSupplement2;forward;
{procedure BeginJam;forward;}
{===========================================================}

procedure JamInit;
begin
  JamVer  := 106;
  JamVerM := 106;
  Insrt := MinCopy;  {MinCopy}
  Dictfile := 0;
  Binary := 0;
  OutBufCount := 0;
  InBufCount  := 0;
  Input_Bit_Count := 0;
  Input_Bit_Buffer := 0;
  Output_Bit_Count := 0;
  Output_Bit_Buffer := 0;
  Bytes_In := 0;
  Bytes_Out := 0;
end;
{===========================================================}
function FormStr(st:string;lenfld:byte):string;
var t,i : byte;
    tstr : string;
begin
  tstr := '';
  t := length(st);
  if t = lenfld then
    formstr := st;
  if t < lenfld then
    begin
      for i := 1 to (lenfld-t) do
        tstr := tstr + ' ';
      tstr := tstr + st;
      formstr := tstr;
    end;
end;
{===========================================================}
function FileExists(Filename:string):boolean;
var F : File;
begin
  {$I-}
  assign(F,Filename);
  Reset(F);
  Close(F);
  {$I+}
  Fileexists := (IoResult = 0) and (Filename <> '');
end;

{===========================================================}
{= Extracting routine                                      =}
{===========================================================}
procedure ExtrJam;
var StoreBuf : array[1..2048] of byte;
    SFile : file of byte;
    SFCount : longint;
    SBCount : word;
    Ch      : Char;
begin
  jaminit;
  if JH.Meth = 1 then
    begin
      Assign(Outfile,JH.Name);
      rewrite(outfile,1);
      UnJam;
      close(outfile);
    end
  else
    begin
      Assign(Outfile,JH.Name);
      rewrite(outfile,1);
      assign(SFile,PackNam+'.jam');
      {$i-} reset(SFile); {$I+}
      Writeln(IOResult);
      readkey;
      seek(SFile,JH.PosF-1);

      fillchar(StoreBuf,sizeof(StoreBuf),0);

      SFCount := 1;
      SBCount := 1;
      read(SFile,StoreBuf[SFCount]);
      While (SFCount <= JH.OSiz) do
        begin
          read(SFile,StoreBuf[SBCount]);
          if (SBCount = 2048) or (SFCount = JH.OSiz) then
            begin
              BlockWrite(outfile,storeBuf,SBCount);
              SBCount := 0;
            end;
          inc(SFCount);
          inc(SBCount);
        end;
      close(sfile);
      close(outfile);
    end;
end;

{===========================================================}
{= Parameter filelist checker 1.                           =}
{===========================================================}
{= Mode 0 : Parameterlist is available.                    =}
{= Mode 1 : All files in archive.                          =}
{===========================================================}
{= Works only with : Viewing,Extracting                    =}
{=                                                         =}
{===========================================================}
{= Only 20 parameters available in parameterlist           =}
{===========================================================}

procedure ListJam1(mode:byte);

var LparN  : array[3..23] of string[8];
    LparE  : array[3..23] of string[4];
    ParamFound ,
    Count      ,
    i          ,
    dummy      ,
    TCount     : byte;

begin
 {===================================}

  Fillchar(LparN,Sizeof(LparN),0);      {parse commline from param 3 to ?}
  Fillchar(LparE,Sizeof(LparE),0);
  for Count := 3 to Paramcount do
    begin
      FSplit(paramstr(Count), Dir, Nam, Ext);
      LparN[Count] := Nam;
      LparE[Count] := Ext;
    end;

 {===================================}

  if mode = 0 then
    TCount := paramcount - 2
  else
    TCount := 1;
  Count := 3;
  for i := 1 to TCount do
    begin
      dummy := 0;
      seek(infile,0);
      blockread(infile,JH,sizeof(JH));
      repeat
        if (TCount > 0) and (Mode = 0) then
          begin
            if JH.Name = upcasestr(LParN[Count]+LParE[Count]) then
              ParamFound := 0
            else
              begin
                FSplit(JH.Name, Dir, Nam, Ext);
                if (LParN[Count] = '*') and
                   (Ext = upcasestr(LParE[Count])) then
                  begin
                    ParamFound := 0;
                    ListSupplement1(LParE[Count],0);
                    Dummy := 1;
                    inc(count);
                  end
                else
                  begin
                    if (LParE[Count] = '.*') and
                      (Nam = upcasestr(LParN[Count])) then
                      begin
                        ParamFound := 0;
                        ListSupplement1(LParN[Count],1);
                        Dummy := 1;
                        inc(count);
                      end
                    else
                      begin
                        if (LParE[Count] = '.*') and
                           (LParN[Count] = '*') then
                          begin
                            ParamFound := 0;
                            ListSupplement1('',2);
                            Dummy := 1;
                            inc(count);
                          end
                        else
                          ParamFound := 1;
                      end;
                  end;
              end;
          end;
        if (TCount = 1) and (Mode = 1) then
          ParamFound := 0;

        if (ParamFound = 0) and (Dummy = 0) then
          begin
            case DoWhat of
              LI : ListSupplement2;
              EX : ExtrJam;
            end;

            inc(totfiles);
            inc(Count);
            if (mode = 0) then
              Dummy := 1;
          end;
        {$I-}
        seek(infile,JH.PosN);
        blockread(infile,JH,sizeof(JH));
      until (IOresult <> 0) or (Dummy = 1) or (Kappuh);
        {$I+}

      if ParamFound = 1 then
        begin
          gotoxy(2,wherey);
          write(upcasestr(LParN[Count]+LParE[Count]));
          gotoxy(58,wherey);
          write('Not found'#13#10);
          Inc(Count);
        end;

    end;
end;

{======================================================}
{= ListSupplement1                                    =}
{======================================================}
{= Handles *.??? , ????????.* , *.* in filelist.      =}
{======================================================}

  procedure ListSupplement1(e:string;m:byte);
    begin
      seek(infile,0);
      blockread(infile,JH,sizeof(JH));
      repeat
        FSplit(JH.Name, Dir, Nam, Ext);
        if (Ext = upcasestr(E)) and (m=0) then
          begin
            case DoWhat of
              LI : ListSupplement2;
              EX : ExtrJam;
            end;
            inc(totfiles);
          end;
        write('Huh!');
        if (Nam = upcasestr(E)) and (m=1) then
          begin
            case DoWhat of
              LI : ListSupplement2;
              EX : ExtrJam;
            end;
            inc(totfiles);
          end;
        if (e = '') and (m=2) then
          begin
            case DoWhat of
              LI : ListSupplement2;
              EX : ExtrJam;
            end;
            inc(totfiles);
          end;
      {$I-}
        seek(infile,JH.PosN);
        blockread(infile,JH,sizeof(JH));
      until (IOresult <> 0) or (Kappuh);
      {$I+}
    end;

{======================================================}
{= ListSupplement2                                    =}
{======================================================}
{= Displays contents of archive.                      =}
{======================================================}

  procedure ListSupplement2;
    begin
      gotoxy(2,wherey);
      write(JH.Name);

      gotoxy(16,wherey);
      if JH.Meth = 0 then
        write('Stored')
      else
        write('Jammed');

      gotoxy(24,wherey);
      TN1 := JH.OSiz;
      TN2 := JH.PSiz;
      TN3 := 100 - ( TN2 / ( TN1 / 100));
      if JH.Meth = 0 then
        TN3 := 0;

      Write(FormStr(CRealStr(TN3,1),4),'%');

      gotoxy(31,wherey);
      Write(formstr(CIntStr(JH.OSiz),10));

      gotoxy(43,wherey);

      TotBytesIn  := TotBytesIn  + JH.OSiz;

      TotBytesOut := TotBytesOut + JH.PSiz +Sizeof(JH);
      Write(formstr(CIntStr(JH.PSiz+Sizeof(JH)),10),'');
      gotoxy(58,wherey);
      write('Ok'#13#10);
    end;


Procedure JAMMED(S:STRING);
var OptionC   : string[1];
    OptSwitch : byte;

begin
  OptSwitch := 1; {extract without subdirs}
  FSplit(s, Dir, Nam, Ext);
  PackNam := Nam;

  if OptSwitch = 1 then
     begin
       Assign(infile,Nam+'.jam');
       {$I-}
       reset(infile,1);
       if IOResult <> 0 then
       begin
         ErrorBox('Error opening file');
         exit;
       end;
       {$I+}

      TotBytesIn  := 0;
      TotBytesOut := 0;
      TotFiles := 0;
      JamInit;
      DoWhat := EX;
      if (paramstr(3) = '') or (paramstr(3) = '*.*') then
        ListJam1(1)
      else
        ListJam1(0);
     end;

end;





0

Featured Post

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Possible fixes for Windows 7 and Windows Server 2008 updating problem. Solutions mentioned are from Microsoft themselves. I started a case with them from our Microsoft Silver Partner option to open a case and get direct support from Microsoft. If s…
Veeam Backup & Replication has added a new integration – Veeam Backup for Microsoft Office 365.  In this blog, we will discuss how you can benefit from Office 365 email backup with the Veeam’s new product and try to shed some light on the needs and …
Internet Business Fax to Email Made Easy - With eFax Corporate (http://www.enterprise.efax.com), you'll receive a dedicated online fax number, which is used the same way as a typical analog fax number. You'll receive secure faxes in your email, fr…
This tutorial demonstrates a quick way of adding group price to multiple Magento products.

771 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now