home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / CRUNCH10.ZIP / CRUNCH.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-12-15  |  46.6 KB  |  1,001 lines
  1. Program Cruncher;
  2.  
  3. {$M 10240, 0, 0}
  4. {$F+}
  5.  
  6. { Crunch.Pas version 1.0                                                      }
  7. {                                                                             }
  8. { Written by Richard P. Byrne - November 1988                                 }
  9. {                                                                             }
  10. { Compress a set of input files into an archive using Lempel-Ziv-Welch (LZW)  }
  11. { compression techniques.                                                     }
  12.  
  13. Uses  Dos,
  14.       Crt,
  15.       MemAlloc,
  16.       StrProcs;
  17.  
  18. Const
  19.  
  20.    BufSize     =  10240;   { Use 10K file buffers                             }
  21.    CrunchBits  =  12;      { Maximum code size of 12 bits                     }
  22.    TableSize   =  4095;    { We'll need 4K entries in table                   }
  23.    ClearCode   =  256;     { Code indicating code table has been cleared      }
  24.    FirstEntry  =  257;     { First free table entry                           }
  25.    UnUsed      =  -1;      { Prefix indicating an unused code table entry     }
  26.  
  27.    StdAttr     =  $23;     { Standard file attribute for DOS Find First/Next  }
  28.  
  29.    CrcTab : array [0..255] of Word =            { Table for CRC calculation   }
  30.             ( $0000, $C0C1, $C181, $0140, $C301, $03C0, $0280, $C241,
  31.               $C601, $06C0, $0780, $C741, $0500, $C5C1, $C481, $0440,
  32.               $CC01, $0CC0, $0D80, $CD41, $0F00, $CFC1, $CE81, $0E40,
  33.               $0A00, $CAC1, $CB81, $0B40, $C901, $09C0, $0880, $C841,
  34.               $D801, $18C0, $1980, $D941, $1B00, $DBC1, $DA81, $1A40,
  35.               $1E00, $DEC1, $DF81, $1F40, $DD01, $1DC0, $1C80, $DC41,
  36.               $1400, $D4C1, $D581, $1540, $D701, $17C0, $1680, $D641,
  37.               $D201, $12C0, $1380, $D341, $1100, $D1C1, $D081, $1040,
  38.               $F001, $30C0, $3180, $F141, $3300, $F3C1, $F281, $3240,
  39.               $3600, $F6C1, $F781, $3740, $F501, $35C0, $3480, $F441,
  40.               $3C00, $FCC1, $FD81, $3D40, $FF01, $3FC0, $3E80, $FE41,
  41.               $FA01, $3AC0, $3B80, $FB41, $3900, $F9C1, $F881, $3840,
  42.               $2800, $E8C1, $E981, $2940, $EB01, $2BC0, $2A80, $EA41,
  43.               $EE01, $2EC0, $2F80, $EF41, $2D00, $EDC1, $EC81, $2C40,
  44.               $E401, $24C0, $2580, $E541, $2700, $E7C1, $E681, $2640,
  45.               $2200, $E2C1, $E381, $2340, $E101, $21C0, $2080, $E041,
  46.               $A001, $60C0, $6180, $A141, $6300, $A3C1, $A281, $6240,
  47.               $6600, $A6C1, $A781, $6740, $A501, $65C0, $6480, $A441,
  48.               $6C00, $ACC1, $AD81, $6D40, $AF01, $6FC0, $6E80, $AE41,
  49.               $AA01, $6AC0, $6B80, $AB41, $6900, $A9C1, $A881, $6840,
  50.               $7800, $B8C1, $B981, $7940, $BB01, $7BC0, $7A80, $BA41,
  51.               $BE01, $7EC0, $7F80, $BF41, $7D00, $BDC1, $BC81, $7C40,
  52.               $B401, $74C0, $7580, $B541, $7700, $B7C1, $B681, $7640,
  53.               $7200, $B2C1, $B381, $7340, $B101, $71C0, $7080, $B041,
  54.               $5000, $90C1, $9181, $5140, $9301, $53C0, $5280, $9241,
  55.               $9601, $56C0, $5780, $9741, $5500, $95C1, $9481, $5440,
  56.               $9C01, $5CC0, $5D80, $9D41, $5F00, $9FC1, $9E81, $5E40,
  57.               $5A00, $9AC1, $9B81, $5B40, $9901, $59C0, $5880, $9841,
  58.               $8801, $48C0, $4980, $8941, $4B00, $8BC1, $8A81, $4A40,
  59.               $4E00, $8EC1, $8F81, $4F40, $8D01, $4DC0, $4C80, $8C41,
  60.               $4400, $84C1, $8581, $4540, $8701, $47C0, $4680, $8641,
  61.               $8201, $42C0, $4380, $8341, $4100, $81C1, $8081, $4040 );
  62.  
  63. Type
  64.  
  65.    { Define data types needed to implement a code table for LZW compression   }
  66.    HashRec     =  Record               { Code Table record format...          }
  67.                      First  : Integer; { Addr of 1st suffix for this prefix   }
  68.                      Next   : Integer; { Addr of next suffix in chain         }
  69.                      Suffix : Char;    { Suffix character                     }
  70.                   end {HashRec};
  71.    HashArray   =  Array[0..TableSize] of HashRec; { Define the code table     }
  72.    TablePtr    =  ^HashArray;                     { Allocate dynamically      }
  73.  
  74.    { Define data types needed to implement input and output file buffers      }
  75.    BufArray    =  Array[1..BufSize] of byte;
  76.    BufPtr      =  ^BufArray;
  77.  
  78.    { Define the structure of an archive file header                           }
  79.    HdrRec      =  Record         
  80.                      ArcMark  :  Byte;
  81.                      ComprType:  Byte;
  82.                      Name     :  Array[1..13] of Byte;
  83.                      Size     :  LongInt;
  84.                      Date     :  Word;
  85.                      Time     :  Word;
  86.                      CRC      :  Word;
  87.                      Len      :  LongInt;
  88.                      MaxBits  :  Byte;
  89.                   end {HdrRec};
  90.  
  91.    { Define the structure of a DOS Disk Transfer Area (DTA)                   }
  92.    DTARec      =  Record         
  93.                      Filler   :  Array[1..21] of Byte;
  94.                      Attr     :  Byte;
  95.                      Time     :  Word;
  96.                      Date     :  Word;
  97.                      Size     :  LongInt;
  98.                      Name     :  String[12];
  99.                   end {DtaRec};
  100.  
  101.    { Define data types needed to implement a sorted singly linked list to     }
  102.    { hold the names of all files to be compressed                             }
  103.    NameStr      = String[12];
  104.    PathStr      = String[64];
  105.    NodePtr      = ^NameList;
  106.    NameList     = Record                  { Linked list node structure...     }
  107.                      Path : PathStr;      { Path of input file                }
  108.                      Name : NameStr;      { Name of input file                }
  109.                      Size : LongInt;      { Size in bytes of input file       }
  110.                      Date : Word;         { Date stamp of input file          }
  111.                      Time : Word;         { Time stamp of input file          }
  112.                      Next : NodePtr;      { Next node in linked list          }
  113.                   end {NameList};
  114.  
  115. Var
  116.    CrcVal      :  Word;          { CRC calculation variable                   }
  117.    InFileSpecs :  Array[1..20] of String;    { Input file specifications      }
  118.    MaxSpecs    :  Word;          { Total number of filespecs to be archived   }
  119.    OutFileName :  String;        { Name of resulting archive file             }
  120.    InFile,                       { I/O file variables                         }
  121.    OutFile     :  File;
  122.    InBuf,                        { I/O buffers                                }
  123.    OutBuf      :  BufPtr;
  124.    InBufIdx,                     { Points to next char in buffer to be read   }
  125.    OutBufIdx   :  Word;          { Points to next free space in output buffer }
  126.    MaxInBufIdx :  Word;          { Count of valid chars in input buffer       }
  127.    InputEof    :  Boolean;       { End of file indicator                      }
  128.    HashTable   :  TablePtr;      { Points to code table for LZW compression   }
  129.    FreeEntry   :  Integer;       { Index of 1st free entry in code table      }
  130.    CodeSize    :  Byte;     { Size of codes (in bits) currently being written }
  131.    MaxCode     :  Word;   { Largest code that can be written in CodeSize bits }
  132.    ArcHdr      :  HdrRec;   { Header for an archived file                     }
  133.    HdrOffset   :  LongInt;  { Offset within output file of the ARChive header }
  134.    FirstCh     :  Boolean;  { Flag indicating the START of a crunch operation }
  135.    TableFull   :  Boolean;  { Flag indicating a full symbol table             }
  136.    Ok_to_Clear :  Boolean;  { Flag indicating when it's "safe" to clear table }
  137.    BytesIn     :  LongInt;  { Count of input file bytes processed             }
  138.    BytesOut    :  LongInt;  { Count of crunched bytes output                  }
  139.  
  140.    SaveByte    :  Byte;     { Output code buffer                              }
  141.    BitsUsed    :  Byte;     { Index into output code buffer                   }
  142.    CodeBytes   :  Byte;   { Used for determining when to clear the code table }
  143.  
  144.    ListHead    :  NodePtr;  { Pointer to head of linked list                  }
  145.  
  146. { --------------------------------------------------------------------------- }
  147. { Houskeeping stuff (error routines and initialization of program variables)  }
  148. { --------------------------------------------------------------------------- }
  149.  
  150. Procedure Syntax;
  151. Begin
  152.    Writeln;
  153.    Writeln;
  154.    Writeln('Crunch.Exe');
  155.    Writeln('   Usage:   Crunch arcfilename [filespec [...]]');
  156.    Writeln;
  157.    Writeln('   A filespec is defined as [d:][\path\]name');
  158.    Writeln('   where ''name'' may contain DOS wildcard characters.');
  159.    Writeln;
  160.    Writeln('   Multiple filespecs may be entered up to a maximum of 20.');
  161.    Writeln;
  162.    Writeln('   If no filespecs are entered, *.* is assumed.');
  163.    Writeln;
  164.    Halt(255);
  165. end {Syntax};
  166.  
  167. { --------------------------------------------------------------------------- }
  168.  
  169. Procedure Fatal(Msg : String);
  170. Begin
  171.    Writeln;
  172.    Writeln;
  173.    Writeln('Crunch.Exe');
  174.    Writeln('   Error: ', Msg);
  175.    Writeln('   Program halted');
  176.    Writeln;
  177.    Writeln;
  178.    Halt(128);
  179. end {Fatal};
  180.  
  181. { --------------------------------------------------------------------------- }
  182.  
  183. Procedure AddToList(PathSpec : PathStr; DTA : DTARec);
  184. { Add an entry to a linked list of filenames to be crunched.  Maintain        }
  185. { sorted order (standard ASCII collating sequence) by filename                }
  186. Var
  187.    MemError : Word;
  188.    NewNode  : NodePtr;
  189.    Done     : Boolean;
  190.    ListNode : NodePtr;
  191. Begin
  192.    { Allocate a new node                                                      }
  193.    MemError := Malloc(NewNode, SizeOf(NewNode^));
  194.    If MemError <> 0 then
  195.       Fatal('Not enough memory to process all filenames!');
  196.  
  197.    { Populate the fields of the new node                                      }
  198.    NewNode^.Path := PathSpec;
  199.    NewNode^.Name := DTA.Name;
  200.    NewNode^.Size := DTA.Size;
  201.    NewNode^.Date := DTA.Date;
  202.    NewNode^.Time := DTA.Time;
  203.    NewNode^.Next := NIL;
  204.  
  205.    { Find the proper location in the list at which to insert the new node     }
  206.    If ListHead = NIL then
  207.       ListHead := NewNode
  208.    else
  209.       If DTA.Name < ListHead^.Name then begin
  210.          NewNode^.Next := ListHead;
  211.          ListHead      := NewNode;
  212.       end {then}
  213.       else begin
  214.          Done     := FALSE;
  215.          ListNode := ListHead;
  216.          While NOT Done do begin
  217.             If ListNode^.Name = DTA.Name then begin
  218.                ListNode^.Path := PathSpec;
  219.                MemError := Dalloc(NewNode);
  220.                Done := TRUE;
  221.             end {then}
  222.             else
  223.                If ListNode^.Next = NIL then begin
  224.                   ListNode^.Next := NewNode;
  225.                   Done := TRUE;
  226.                end {then}
  227.                else
  228.                   If ListNode^.Next^.Name > DTA.Name then begin
  229.                      NewNode^.Next  := ListNode^.Next;
  230.                      ListNode^.Next := NewNode;
  231.                      Done := TRUE;
  232.                   end {then}
  233.                   else
  234.                      ListNode := ListNode^.Next;
  235.          end {while};
  236.       end {if};
  237. end {AddToList};
  238.  
  239. { --------------------------------------------------------------------------- }
  240.  
  241. Procedure GetNames;
  242. { Expand input file specifications.  Store the name of each file to be        }
  243. { compressed in a sorted, singly linked list                                  }
  244. Var
  245.    DosDTA   : DTARec;
  246.    I        : Word;
  247.    InPath   : String;
  248. Begin
  249.    ListHead := NIL;
  250.    For I := 1 to MaxSpecs do begin   { Loop through all input file specs      }
  251.       InPath := Upper(PathOnly(InFileSpecs[I]));
  252.       FindFirst(InFileSpecs[I], StdAttr, SearchRec(DosDTA));
  253.       While DosError = 0 do begin    { Loop through all matching files        }
  254.          If (NOT SameFile(InPath + DosDTA.Name, OutFileName)) then
  255.             AddToList(InPath, DosDTA);
  256.          FindNext(SearchRec(DosDTA));
  257.       end {while};
  258.    end {for};
  259. end {GetNames};
  260.  
  261. { --------------------------------------------------------------------------- }
  262.  
  263. Function ParamCheck : Boolean;
  264. { Verify all command line parameters                                          }
  265. Var
  266.    SearchBuf : SearchRec;
  267.    OutPath   : String;
  268.    Ch        : Char;
  269.    I         : Word;
  270. Begin
  271.  
  272.    If ParamCount < 1 then Syntax;
  273.    If ParamCount > 21 then begin
  274.       Writeln('Too many command line parameters entered!');
  275.       Syntax;
  276.    end {if};
  277.  
  278.    OutFileName := Upper(ParamStr(1));
  279.    If Pos('.', OutFileName) = 0 then
  280.       OutFileName := Concat(OutFileName, '.ARC');
  281.  
  282.    FindFirst(OutFileName, StdAttr, SearchBuf);
  283.    If DosError = 0 then begin
  284.       Writeln;
  285.       Write(OutFileName, ' already exists!  Overwrite it (Y/N, Enter=N)? ');
  286.       Ch := ReadKey;
  287.       Writeln(Ch);
  288.       Writeln;
  289.       If UpCase(Ch) <> 'Y' then begin
  290.          Writeln;
  291.          Writeln('Program aborted!');
  292.          Halt;
  293.       end {if};
  294.    end {if};
  295.  
  296.    If ParamCount = 1 then begin
  297.       InFileSpecs[1] := '*.*';
  298.       MaxSpecs := 1;
  299.    end {then}
  300.    else
  301.       For I := 2 to ParamCount do begin
  302.          InFilespecs[Pred(I)] := ParamStr(I);
  303.          MaxSpecs := Pred(I);
  304.       end {for};
  305.  
  306.    GetNames;
  307.  
  308. End {ParamCheck};
  309.  
  310. { --------------------------------------------------------------------------- }
  311.  
  312. Procedure Initialize;
  313. Begin
  314.  
  315.    { Boolean flags ... all initialized to false                               }
  316.    InputEof    := FALSE;   { Input end of file flag                           }
  317.    TableFull   := FALSE;   { Code Table Full flag                             }
  318.    Ok_to_Clear := FALSE;   { "Safe" to clear code table flag                  }
  319.  
  320.    { The next two counters are initialized to 1 to prevent division by zero   }
  321.    BytesIn     := 1;       { Input byte counter                               }
  322.    BytesOut    := 1;       { Output byte counter                              }
  323.  
  324.    OutBufIdx   := 1;       { Output buffer index                              }
  325.  
  326.    SaveByte    := 0;       { These 3 variables are used to construct output   }
  327.    BitsUsed    := 0;       { bytes from variable sized bit codes              }
  328.    CodeBytes   := 0;
  329.  
  330. end {Initialize};
  331.  
  332. { --------------------------------------------------------------------------- }
  333. { I/O Support routines                                                        }
  334. { --------------------------------------------------------------------------- }
  335.  
  336. Procedure GetBuffers;
  337. { Allocate Input and Output buffers                                           }
  338. Var
  339.    MemError : Word;
  340. Begin
  341.    MemError := Malloc(InBuf, Sizeof(InBuf^));
  342.    If MemError <> 0 then
  343.       Fatal(Concat('Cannot allocate Input buffer',
  344.                    #13#10,
  345.                    '           DOS Return Code on allocation request was ',
  346.                    IntStr(MemError, 0)));
  347.  
  348.    MemError := Malloc(OutBuf, Sizeof(OutBuf^));
  349.    If MemError <> 0 then
  350.       Fatal(Concat('Cannot allocate Output buffer',
  351.                    #13#10,
  352.                    '           DOS Return Code on allocation request was ',
  353.                    IntStr(MemError, 0)));
  354. End {GetBuffers};
  355.  
  356. { --------------------------------------------------------------------------- }
  357.  
  358. Procedure DropBuffers;
  359. { Deallocate input and output buffers                                         }
  360. Var
  361.    MemError : Word;
  362. Begin
  363.    MemError := Dalloc(InBuf);
  364.    MemError := Dalloc(OutBuf);
  365. end {DropBuffers};
  366.  
  367. { --------------------------------------------------------------------------- }
  368.  
  369. Procedure OpenOutput;
  370. Var
  371.    RC : Integer;
  372. Begin
  373.    Assign(OutFile, OutFileName);
  374.    FileMode := 66;
  375.    {$I-} ReWrite(OutFile, 1); {$I+}
  376.    RC := IOResult;
  377.    If RC <> 0 then
  378.       Fatal(Concat('Cannot open output file',
  379.                    #13#10,
  380.                    '           Return Code was ',
  381.                    IntStr(RC, 0)));
  382. End {OpenOutput};
  383.  
  384. { --------------------------------------------------------------------------- }
  385.  
  386. Function OpenInput(InFileName : String) : Boolean;
  387. Var
  388.    RC : Integer;
  389. Begin
  390.    Assign(InFile, InFileName);
  391.    FileMode := 64;
  392.    {$I-} Reset(InFile, 1); {$I+}
  393.    OpenInput := (IOResult = 0);
  394. End {OpenInput};
  395.  
  396. { --------------------------------------------------------------------------- }
  397.  
  398. Procedure CloseOutput;
  399. Var
  400.    RC : Integer;
  401. Begin
  402.    {$I-} Close(OutFile) {$I+};
  403.    RC := IOResult;
  404. end {CloseOutput};
  405.  
  406. { --------------------------------------------------------------------------- }
  407.  
  408. Procedure CloseInput;
  409. Var
  410.    RC : Integer;
  411. Begin
  412.    {$I-} Close(InFile)  {$I+};
  413.    RC := IOResult;
  414. end {CloseInput};
  415.  
  416. { --------------------------------------------------------------------------- }
  417.  
  418. Procedure Read_Block;
  419. { Read a "block" of data into our our input buffer                            }
  420. Begin
  421.    BlockRead(InFile, InBuf^[1], SizeOf(InBuf^), MaxInBufIdx);
  422.    If MaxInBufIdx = 0 then
  423.       InputEof := TRUE;
  424.    InBufIdx := 1;
  425. end {Read_Block};
  426.  
  427. { --------------------------------------------------------------------------- }
  428.  
  429. Procedure Write_Block;
  430. { Write a block of data from the output buffer to our output file             }
  431. Begin
  432.    BlockWrite(OutFile, OutBuf^[1], Pred(OutBufIdx));
  433.    OutBufIdx := 1;
  434. end {Write_Block};
  435.  
  436. { --------------------------------------------------------------------------- }
  437.  
  438. Procedure PutChar(B : Byte);
  439. { Put one character into our output buffer                                    }
  440. Begin
  441.    OutBuf^[OutBufIdx] := B;
  442.    Inc(OutBufIdx);
  443.    If OutBufIdx > SizeOf(OutBuf^) then
  444.       Write_Block;
  445.    Inc(BytesOut);
  446. end {PutChar};
  447.  
  448. { --------------------------------------------------------------------------- }
  449.  
  450. Procedure FlushOutput;
  451. { Write any data sitting in our output buffer to the output file              }
  452. Begin
  453.    If OutBufIdx > 1 then
  454.       Write_Block;
  455. End {FlushOutput};
  456.  
  457. { --------------------------------------------------------------------------- }
  458.  
  459. Procedure PutCode(Code : Integer);
  460. { Assemble coded bytes for output                                             }
  461. Var
  462.    PutCharAddr : Pointer;
  463. Begin
  464.    PutCharAddr := @PutChar;
  465.  
  466.    Inline(
  467.                                {;  Register useage:}
  468.                                {;}
  469.                                {;  AX - holds Code}
  470.                                {;  BX - BH is a work register, BL holds SaveByte}
  471.                                {;  CX - holds our loop counter CodeSize}
  472.                                {;  DX - holds BitsUsed}
  473.                                {;}
  474.      $8B/$46/<CODE/            {                mov         ax,[bp+<Code]}
  475.      $31/$DB/                  {                xor         bx,bx}
  476.      $89/$D9/                  {                mov         cx,bx}
  477.      $89/$DA/                  {                mov         dx,bx}
  478.      $8A/$1E/>SAVEBYTE/        {                mov         bl,[>SaveByte]}
  479.      $8A/$0E/>CODESIZE/        {                mov         cl,[>CodeSize]}
  480.      $8A/$16/>BITSUSED/        {                mov         dl,[>BitsUsed]}
  481.      $3D/$FF/$FF/              {                cmp         ax,-1               ;Any work to do?}
  482.      $75/$0D/                  {                jnz         Repeat              ;Yup, go do it}
  483.      $80/$FA/$00/              {                cmp         dl,0                ;Any leftovers?}
  484.      $74/$65/                  {                jz          AllDone             ;Nope, we're done}
  485.      $53/                      {                push        bx                  ;Yup...push leftovers}
  486.      $0E/                      {                push        cs}
  487.      $FF/$96/>PUTCHARADDR/     {                call        [bp+>PutCharAddr]   ;   and send to output}
  488.      $EB/$5D/                  {                jmp short   AllDone}
  489.                                {;}
  490.      $30/$FF/                  {Repeat:         xor         bh,bh               ;Zero out BH}
  491.      $D1/$D8/                  {                rcr         ax,1                ;Get low order bit into CY flag}
  492.      $73/$02/                  {                jnc         SkipBit             ;Was the bit set?}
  493.      $FE/$C7/                  {                inc         bh                  ;Yes, xfer to BH}
  494.      $87/$D1/                  {SkipBit:        xchg        cx,dx               ;Swap CX & DX}
  495.      $D2/$E7/                  {                shl         bh,cl               ;Shift bit over}
  496.      $87/$D1/                  {                xchg        cx,dx               ;Put CX & DX back where they were}
  497.      $42/                      {                inc         dx                  ;Bump count of bit positions used}
  498.      $08/$FB/                  {                or          bl,bh               ;Transfer bit to output byte (SaveByte)}
  499.      $83/$FA/$08/              {                cmp         dx,8                ;Full byte yet?}
  500.      $72/$26/                  {                jb          GetNext             ;Nope, go get more code bits}
  501.      $50/                      {                push        ax                  ;Yup, save regs in preparation}
  502.      $53/                      {                push        bx                  ;    for call to output routine}
  503.      $51/                      {                push        cx}
  504.      $52/                      {                push        dx}
  505.      $53/                      {                push        bx                  ;Push byte to output onto stack}
  506.      $0E/                      {                push        cs}
  507.      $FF/$96/>PUTCHARADDR/     {                call        [bp+>PutCharAddr]   ;   and call the output routine}
  508.      $31/$C0/                  {                xor         ax,ax}
  509.      $A0/>CODEBYTES/           {                mov         al,[>CodeBytes]     ;Recalculate position in un-arc}
  510.      $FE/$C0/                  {                inc         al                  ;  program's input code buffer}
  511.      $31/$C9/                  {                xor         cx,cx               ;  CodeBytes :=}
  512.      $8A/$0E/>CODESIZE/        {                mov         cl,[>CodeSize]      ;  Succ(CodeBytes) MOD CodeSize}
  513.      $F6/$F1/                  {                div         cl                  }
  514.      $88/$E0/                  {                mov         al,ah}
  515.      $A2/>CODEBYTES/           {                mov         [>CodeBytes],al}
  516.      $5A/                      {                pop         dx}
  517.      $59/                      {                pop         cx}
  518.      $5B/                      {                pop         bx}
  519.      $58/                      {                pop         ax}
  520.      $31/$DB/                  {                xor         bx,bx               ;Prepare SaveByte for next byte}
  521.      $89/$DA/                  {                mov         dx,bx               ;Set BitsUsed to zero}
  522.      $E2/$C2/                  {GetNext:        loop        Repeat              ;Repeat for all code bits}
  523.                                {;}
  524.      $88/$1E/>SAVEBYTE/        {                mov         [>SaveByte],bl      ;Put SaveByte and BitsUsed}
  525.      $88/$16/>BITSUSED/        {                mov         [>BitsUsed],dl      ;   back in memory}
  526.                                {;}
  527.      $C6/$06/>OK_TO_CLEAR/$00/ {                mov byte    [>Ok_to_Clear],0    ;Test if it's ok to clear the}
  528.      $31/$C0/                  {                xor         ax,ax               ;   Code table at this time}
  529.      $A0/>CODEBYTES/           {                mov         al,[>CodeBytes]}
  530.      $04/$02/                  {                add         al,2}
  531.      $3A/$06/>CODESIZE/        {                cmp         al,[>CodeSize]      ;Ok to clear table?}
  532.      $75/$05/                  {                jnz         AllDone             ;Nope, don't set flag TRUE}
  533.      $C6/$06/>OK_TO_CLEAR/$01);{                mov byte    [>Ok_to_Clear],1    ;Ok, set flag}
  534.                                {AllDone:}
  535.    
  536. end {Putcode};
  537.  
  538. { --------------------------------------------------------------------------- }
  539. { ARChive file support routines                                               }
  540. { --------------------------------------------------------------------------- }
  541.  
  542. Procedure Begin_ARC(ListPtr : NodePtr);
  543. { Write a dummy header to the archive.  Include as much info as is currently  }
  544. { known (we'll come back and fill in the rest later...)                       }
  545. Begin
  546.    HdrOffset := FilePos(OutFile);         { Save file position for later use  }
  547.    With ArcHdr do begin
  548.       ArcMark   := $1A;                   { Special archive ID byte           }
  549.       ComprType := 8;                     { Type of compression used          }
  550.       FillChar(Name, 13, #0);             { Name of file to be compressed     }
  551.       Move(ListPtr^.Name[1], Name, Ord(ListPtr^.Name[0]));
  552.       Size      := 0;                     { Don't know crunched size yet...   }
  553.       Date      := ListPtr^.Date;         { Date of input file                }
  554.       Time      := ListPtr^.Time;         { Time of input file                }
  555.       CRC       := 0;                     { Don't know CRC value yet...       }
  556.       Len       := ListPtr^.Size;         { Original size of input file       }
  557.       MaxBits   := 12;                    { Largest code size used            }
  558.    end {with};
  559.    Move(ArcHdr, OutBuf^, SizeOf(HdrRec)); { Put header into output buffer     }
  560.    Inc(OutBufIdx, SizeOf(HdrRec));        {...adjust buffer index accordingly }
  561.    FlushOutput;                           { Write it now                      }
  562. End {Begin_ARC};
  563.  
  564. { --------------------------------------------------------------------------- }
  565.  
  566. Procedure Update_ARC_Header;
  567. { Update the archive's header with information that we now possess.  Check to }
  568. { make sure that our cruncher actually produced a smaller file.  If not,      }
  569. { scrap the crunched data, modify the archive header accordingly, and just    }
  570. { copy the input file to the output file (stowage method 2 - Storing).        }
  571. Var
  572.    EndPos : LongInt;
  573.    Redo   : Boolean;
  574. Begin
  575.    Redo := FALSE;                            { Set REDO flag to false         }
  576.  
  577.    EndPos := FilePos(OutFile);               { Save current file position     }
  578.    Seek(OutFile, HdrOffset);                 { Rewind back to file header     }
  579.  
  580.                                              { Update compressed size field   }
  581.    ArcHdr.Size := Succ(EndPos - HdrOffset - SizeOf(ArcHdr));
  582.    ArcHdr.CRC  := CrcVal;                    { Update CRC value               }
  583.  
  584.    Redo := (ArcHdr.Size >= ArcHdr.Len);      { Have we compressed the file?   }
  585.    If Redo then begin                        { No...                          }
  586.       ArcHdr.ComprType := 2;                 { ...change stowage type         }
  587.       ArcHdr.Size      := ArcHdr.Len;        { ...update compressed size      }
  588.    end {if};
  589.  
  590.    Move(ArcHdr, OutBuf^, SizeOf(HdrRec));    { Move updated header to out buf }
  591.    Inc(OutBufIdx, SizeOf(HdrRec));           { Adjust output buffer index     }
  592.    FlushOutput;                              { Write updated header to file   }
  593.  
  594.    If Redo then begin
  595.       { If compression didn't make a smaller file, then ...                   }
  596.       Seek(OutFile, Pred(FilePos(OutFile))); { Rewind output file by 1 byte   }
  597.       Seek(InFile, 0);                       { Rewind the input file          }
  598.       InputEof := FALSE;                     { Reset EOF indicator            }
  599.       Read_Block;                            { Prime the input buffer         }
  600.       While NOT InputEof do begin            { Copy input to output           }
  601.          BlockWrite(OutFile, InBuf^, MaxInBufIdx);
  602.          Read_Block;
  603.       end {while};
  604.       Truncate(Outfile);                     { Truncate output file           }
  605.    end {then}
  606.    else begin
  607.       { Compression DID make a smaller file ...                               }
  608.       Seek(OutFile, FileSize(OutFile));   { Move output file pos back to eof  }
  609.    end {if};
  610. End {Update_ARC_Header};
  611.  
  612. { --------------------------------------------------------------------------- }
  613.  
  614. Procedure End_ARC;
  615. { Write the special archive end of file marker bytes to the output file       }
  616. Const
  617.    ArcEofStr : Array[1..2] of Byte = ($1A, $00);
  618. Begin
  619.    Move(ArcEofStr, OutBuf^, SizeOf(ArcEofStr));
  620.    Inc(OutBufIdx, SizeOf(ArcEofStr));
  621.    FlushOutput;
  622. end {End_ARC};
  623.  
  624. { --------------------------------------------------------------------------- }
  625. { code Table support routines                                                 }
  626. { --------------------------------------------------------------------------- }
  627.  
  628. Procedure GetTable;
  629. { Dynamically allocate space for our code table                               }
  630. Var
  631.    MemError : Word;
  632. Begin
  633.    MemError := Malloc(HashTable, Sizeof(HashTable^));
  634.    If MemError <> 0 then
  635.       Fatal(Concat('Cannot allocate workspace memory',
  636.                    #13#10,
  637.                    '           DOS Return Code on allocation request was ',
  638.                    IntStr(MemError, 0)));
  639. end {GetTable};
  640.  
  641. { --------------------------------------------------------------------------- }
  642.  
  643. Procedure DropTable;
  644. { Give ram used by code table back to DOS                                     }
  645. Var
  646.    MemError : Word;
  647. Begin
  648.    MemError := Dalloc(HashTable);
  649. end {DropTable};
  650.  
  651. { --------------------------------------------------------------------------- }
  652.  
  653. Procedure ClearTable;
  654. { Clear the LZW Code Table                                                    }
  655. Begin
  656.     Inline(
  657.                             {;}
  658.                             {;  This routine may be called to clear the code table}
  659.                             {;}
  660.      $B9/$00/$01/           {            mov     cx,256          ;clear the 1st 256 entries}
  661.      $C4/$3E/>HASHTABLE/    {            les     di,[>HashTable] ;ES:DI points to first table entry}
  662.      $89/$FE/               {            mov     si,di           ;save offset in SI for later}
  663.      $89/$C8/               {Looper:     mov     ax,cx}
  664.      $48/                   {            dec     ax              ;get index of entry to clear}
  665.      $BA/$05/$00/           {            mov     dx,5            ;entries are 5 bytes long}
  666.      $F7/$E2/               {            mul     dx              ;convert ax to an offset}
  667.      $89/$F7/               {            mov     di,si           ;get starting offset of table}
  668.      $01/$C7/               {            add     di,ax           ;es:di points to entry to be cleared}
  669.      $B8/$FF/$FF/           {            mov     ax,-1           ;clear pointers to -1}
  670.      $FC/                   {            cld}
  671.      $AB/                   {            stosw}
  672.      $AB/                   {            stosw}
  673.      $AA/                   {            stosb}
  674.      $E2/$EB);              {            loop    Looper}
  675.                             {Done:}
  676.    
  677. FreeEntry := FirstEntry;               { Set first free entry                 }
  678.    CodeSize  :=   9;                   { Reset codesize to minimum            }
  679.    MaxCode   := 512;                   { Reset max code for codesize bits     }
  680.    TableFull := FALSE;                 { Reset flag indicating a full table   }
  681. End {ClearTable};
  682.  
  683. { --------------------------------------------------------------------------- }
  684.  
  685. Function Table_Lookup(    TargetPrefix : Integer;
  686.                           TargetSuffix : Char;
  687.                       Var FoundAt      : Integer   ) : Boolean;
  688. { --------------------------------------------------------------------------- }
  689. { Search for a Prefix:Suffix pair in our Symbol table.  If found, return the  }
  690. { index value where found.  If not found, attempt to add the entry to the end }
  691. { of the table.  If the table is already full, don't add the entry, just set  }
  692. { the boolean variable TableFull to TRUE.                                     }
  693. { --------------------------------------------------------------------------- }
  694. Begin
  695.    Inline(
  696.                              {;}
  697.                              {; Lookup an entry in the code Table.  If found, return TRUE and set the VAR}
  698.                              {; parameter FoundAt with the index of the entry at which the match was found.}
  699.                              {; If not found, return FALSE, and add unmatched prefix/suffix to end of table.}
  700.                              {;}
  701.                              {;}
  702.                              {; Register usage:}
  703.                              {;   AX - varies                     BL - holds target suffix character}
  704.                              {;                                   BH - If search fails, determines how to}
  705.                              {;                                        add the new entry}
  706.                              {;   CX - not used                   DX - holds size of 1 table entry (5)}
  707.                              {;   DI - varies                     SI - holds offset of 1st table entry}
  708.                              {;   ES - seg addr of code table     DS - program's data segment}
  709.                              {;}
  710.                              {;}
  711.      $8A/$5E/<TARGETSUFFIX/  {            mov byte    bl,[bp+<TargetSuffix]   ;Target Suffix character}
  712.      $8B/$46/<TARGETPREFIX/  {            mov word    ax,[bp+<TargetPrefix]   ;Index into table}
  713.      $BA/$05/$00/            {            mov         dx,5                    ;5 byte table entries}
  714.      $F7/$E2/                {            mul         dx                      ;AX now an offset into table}
  715.      $C4/$3E/>HASHTABLE/     {            les         di,[>HashTable]         ;code table address}
  716.      $89/$FE/                {            mov         si,di                   ;save offset in SI}
  717.      $01/$C7/                {            add         di,ax                   ;es:di points to table entry}
  718.                              {;}
  719.      $B7/$00/                {            mov         bh,0                    ;Chain empty flag (0=empty)}
  720.      $26/$83/$3D/$FF/        {        es: cmp word    [di],-1                 ;Anything on the chain?}
  721.      $74/$33/                {            jz          NotFound                ;Nope, search fails}
  722.      $B7/$01/                {            mov         bh,1                    ;Chain empty flag (1=not empty)}
  723.                              {;}
  724.      $26/$8B/$05/            {        es: mov word    ax,[di]                 ;Get index of 1st entry in chain}
  725.      $89/$46/<TARGETPREFIX/  {Loop:       mov word    [bp+<TargetPrefix],ax   ;Save index for later}
  726.      $BA/$05/$00/            {            mov         dx,5}
  727.      $F7/$E2/                {            mul         dx                      ;convert index to offset}
  728.      $89/$F7/                {            mov         di,si                   ;es:di points to start of table}
  729.      $01/$C7/                {            add         di,ax                   ;es:di points to table entry}
  730.                              {;}
  731.      $26/$3A/$5D/$04/        {        es: cmp byte    bl,[di+4]               ;match on suffix?}
  732.      $74/$0D/                {            jz          Found                   ;Yup, search succeeds}
  733.                              {;}
  734.      $26/$83/$7D/$02/$FF/    {        es: cmp word    [di+2],-1               ;any more entries in chain?}
  735.      $74/$15/                {            jz          NotFound                ;nope, search fails}
  736.                              {;}
  737.      $26/$8B/$45/$02/        {        es: mov word    ax,[di+2]               ;get index of next chain entry}
  738.      $EB/$E1/                {            jmp short   Loop                    ;   and keep searching}
  739.                              {;}
  740.      $C6/$46/$FF/$01/        {Found:      mov byte    [bp-1],1                ;return TRUE}
  741.      $C4/$7E/<FOUNDAT/       {            les         di,[bp+<FoundAt]        ;get address of Var parameter}
  742.      $8B/$46/<TARGETPREFIX/  {            mov word    ax,[bp+<TargetPrefix]   ;get index of entry where found}
  743.      $26/$89/$05/            {        es: mov         [di],ax                 ;and store it}
  744.      $EB/$3F/                {            jmp short   Done}
  745.                              {;}
  746.      $A1/>FREEENTRY/         {NotFound:   mov word    ax,[>FreeEntry]         ;Index of next free table entry}
  747.      $3D/>TABLESIZE/         {            cmp word    ax,>Tablesize           ;Any room in table}
  748.      $72/$07/                {            jb          NotFull                 ;Yes}
  749.      $C6/$06/>TABLEFULL/$01/ {            mov byte    [>TableFull],1          ;Set flag}
  750.      $EB/$24/                {            jmp short   SkipAdd                 ;Exit without adding entry}
  751.      $80/$FF/$00/            {NotFull:    cmp         bh,0                    ;Adding new entry}
  752.      $74/$06/                {            jz          First                   ;New entry is 1st one in the chain}
  753.      $26/$89/$45/$02/        {        es: mov         [di+2],ax               ;Append new entry to chain}
  754.      $EB/$03/                {            jmp short   InitNew}
  755.      $26/$89/$05/            {First:  es: mov         [di],ax                 ;New entry is 1st one in chain}
  756.      $BA/$05/$00/            {InitNew:    mov         dx,5}
  757.      $F7/$E2/                {            mul         dx                      ;ax = offset of new entry in table}
  758.      $89/$F7/                {            mov         di,si}
  759.      $01/$C7/                {            add         di,ax                   ;es:di points at new entry}
  760.      $B8/$FF/$FF/            {            mov         ax,-1}
  761.      $FC/                    {            cld}
  762.      $AB/                    {            stosw                               ;Init FIRST ptr to -1}
  763.      $AB/                    {            stosw                               ;Init NEXT ptr to -1}
  764.      $88/$D8/                {            mov         al,bl                   ;al=suffix for this new entry}
  765.      $AA/                    {            stosb                               ;Init SUFFIX field}
  766.      $FF/$06/>FREEENTRY/     {            inc word    [>FreeEntry]            ;point FreeEntry to next empty slot}
  767.      $C6/$46/$FF/$00/        {SkipAdd:    mov byte    [bp-1],0                ;return FALSE}
  768.      $C4/$7E/<FOUNDAT/       {            les         di,[bp+<FoundAt]        ;get address of Var parameter}
  769.      $26/$C7/$05/$FF/$FF);   {        es: mov word    [di],-1                 ;and store a -1 in it}
  770.                              {;}
  771.                              {Done:}
  772.                              {;}
  773.    
  774.    
  775. end {Table_Lookup};
  776.  
  777. { --------------------------------------------------------------------------- }
  778. { The actual Crunching algorithm                                              }
  779. { --------------------------------------------------------------------------- }
  780.  
  781. Procedure Crunch(Suffix : Integer);
  782. Const
  783.    LastCode    : Integer = 0;   { Typed constant, so value retained across calls }
  784. Var
  785.    WhereFound  : Integer;
  786.    CrunchRatio : LongInt;
  787. Begin
  788.    If FirstCh then begin         { If just getting started ...             }
  789.       ClearTable;                { ... clear the code table,               }
  790.       LastCode := Suffix;        {     get first character from input,     }
  791.       FirstCh  := FALSE;         {     and reset the first char flag.      }
  792.    end {then}
  793.    else begin
  794.       If Suffix <> -1 then begin { If there's work to do ...               }
  795.          If Table_Lookup(LastCode, Chr(Suffix), WhereFound) then begin
  796.             { LastCode:Suffix pair is found in the code table, then ...       }
  797.             { ... set LastCode to the entry where the pair is located         }
  798.             LastCode  := WhereFound;
  799.          end {then}
  800.          else begin
  801.             { Not in table.  If table not full, then was added as new entry.  }
  802.             PutCode(LastCode);            { Write current LastCode code       }
  803.             LastCode := Suffix;           { Reset LastCode code for new char  }
  804.  
  805.             If (FreeEntry > MaxCode) and (CodeSize < CrunchBits) then begin
  806.                { Time to increase the code size and change the max. code      }
  807.                Inc(CodeSize);
  808.                MaxCode := MaxCode shl 1;
  809.             end {if};
  810.  
  811.             If TableFull and Ok_to_Clear then begin
  812.                { Decide if code table should be cleared                       }
  813.                CrunchRatio := (100 * (BytesIn - BytesOut)) DIV BytesIn;
  814.                If CrunchRatio < 40 then begin
  815.                   { Ok, lets clear the code table (adaptive reset)            }
  816.                   PutCode(ClearCode);
  817.                   ClearTable;
  818.                end {if};
  819.             end {if};
  820.  
  821.          end {if};
  822.       end {then}
  823.       else begin                    { Nothing to crunch...must be EOF on input   }
  824.          PutCode(LastCode);         { Write last prefix code                     }
  825.          PutCode(-1);               { Tell putcode to flush remaining bits       }
  826.          FlushOutput;               { Flush our output buffer                    }
  827.       end {if};
  828.    end {if};
  829. end {Crunch};
  830.  
  831. { --------------------------------------------------------------------------- }
  832. { This routine packs the input before passing it to the Crunch routine        }
  833. { --------------------------------------------------------------------------- }
  834.  
  835. Procedure Pack_and_Crunch(Source : String);
  836. Type
  837.    StateType = (NOHIST, INREP);
  838. Const
  839.    DLE                  = #144;                { Hex 90 }
  840.    State    : Statetype = NOHIST;
  841.    LastChar : Char      = #0;
  842.    DupCount : Byte      =  0;
  843. Var
  844.    I, J     : Word;
  845. Begin
  846.    If FirstCh then begin
  847.       State  := NOHIST;
  848.       CrcVal := 0;
  849.    end {if};
  850.    If Source = '' then begin                 { No work to do }
  851.       If State = INREP then                  { but still have some left-overs }
  852.          If DupCount >= 3 then begin         { Only pack if it's worth doing  }
  853.             Crunch(Ord(DLE));
  854.             Crunch(DupCount);
  855.          end {then}
  856.          else
  857.             For J := 1 to Pred(DupCount) do
  858.                Crunch(Ord(LastChar));
  859.    end {then}
  860.    else begin                                { We have work to do }
  861.       I := 1;
  862.       While I <= Length(Source) do begin
  863.          Inc(BytesIn);
  864.          CRCVal := ((CRCVal shr 8) and $00FF) xor CRCTab[(CRCVal xor Ord(Source[I])) and $00FF];
  865.          Case State of
  866.             NOHIST : begin
  867.                         If Source[I] = DLE then begin
  868.                            Crunch(Ord(DLE));
  869.                            Crunch(0);
  870.                         end {then}
  871.                         else begin
  872.                            If (Source[I] = LastChar) and (NOT FirstCh) then begin
  873.                               State    := INREP;
  874.                               DupCount := 2;
  875.                            end {then}
  876.                            else
  877.                               Crunch(Ord(Source[I]));
  878.                         end {if};
  879.                         LastChar := Source[I];
  880.                      end {NOHIST};
  881.             INREP  : begin
  882.                         If (LastChar = Source[I]) and (DupCount < 255) then
  883.                            Inc(DupCount)
  884.                         else begin
  885.                            If DupCount >= 3 then begin { Only pack if worth it }
  886.                               Crunch(Ord(DLE));
  887.                               Crunch(DupCount);
  888.                            end {then}
  889.                            else
  890.                               For J := 1 to Pred(Dupcount) do
  891.                                  Crunch(Ord(LastChar));
  892.                            If Source[I] = DLE then begin
  893.                               Crunch(Ord(DLE));
  894.                               Crunch(0);
  895.                            end {then}
  896.                            else
  897.                               Crunch(Ord(Source[I]));
  898.                            State := NOHIST;
  899.                            LastChar := Source[I];
  900.                         end {if};
  901.                      end {INREP};
  902.          end {case};
  903.          Inc(I);
  904.       end {while};   
  905.    end {if};
  906.  
  907.    If Source = '' then           { If input was null (ie. EOF on input) ...   }
  908.       Crunch(-1);                { then tell the Crunch proc to do EOF stuff  }
  909.  
  910. end {Pack_and_Crunch};
  911.  
  912. { --------------------------------------------------------------------------- }
  913. { This routine handles processing for one input file                          }
  914. { --------------------------------------------------------------------------- }
  915.  
  916. Procedure Process_One_File;
  917. Var
  918.    OneString : String;
  919.    Remaining : Word;
  920. Begin
  921.    Read_Block;                { Prime the input buffer                        }
  922.    FirstCh   := TRUE;         { 1st character flag for Crunch procedure       }
  923.  
  924.    While NOT InputEof do begin
  925.       Remaining := Succ(MaxInBufIdx - InBufIdx);
  926.  
  927.       If Remaining > 255 then
  928.          Remaining := 255;
  929.  
  930.       If Remaining = 0 then
  931.          Read_Block
  932.       else begin
  933.          Move(InBuf^[InBufIdx], OneString[1], Remaining);
  934.          OneString[0] := Chr(Remaining);
  935.          Inc(InBufIdx, Remaining);
  936.          Pack_and_Crunch(OneString);
  937.       end {if};
  938.  
  939.    end {while};
  940.  
  941.    Pack_and_Crunch('');     { This forces EOF processing }
  942.  
  943. end {Process_One_File};
  944.  
  945. { --------------------------------------------------------------------------- }
  946.  
  947. Procedure Process_All_Files;
  948. Var
  949.    InPath   : String;
  950.    ComprPct : Word;
  951.    ListNode : NodePtr;
  952. Begin
  953.    If ListHead = NIL then begin
  954.       Writeln;
  955.       Writeln('There are no files to crunch!');
  956.       Writeln;
  957.       Halt;
  958.    end {if};
  959.  
  960.    OpenOutput;
  961.  
  962.    ListNode := ListHead;
  963.    While ListNode <> NIL do begin
  964.       If OpenInput(Concat(ListNode^.Path, ListNode^.Name)) then begin
  965.          Write('Processing ', ListNode^.Name, '...');
  966.          Initialize;
  967.          Begin_ARC(ListNode);
  968.          Process_One_File;
  969.          Update_ARC_Header;
  970.          CloseInput;
  971.          If ArcHdr.Len > 0 then
  972.             ComprPct := Round((100.0 * (ArcHdr.Len - ArcHdr.Size)) / ArcHdr.Len)
  973.          else
  974.             ComprPct := 0;
  975.          Writeln('Done (', ComprPct, '%)');
  976.       end {then}
  977.       else
  978.          Writeln('Could not open ', ListNode^.Name, '.  Skipping this file ...');
  979.       ListNode := ListNode^.Next;
  980.    end {while};
  981.    End_ARC;
  982.    CloseOutput;
  983. End {Process_All_Files};
  984.  
  985. { --------------------------------------------------------------------------- }
  986. { Main Program (driver)                                                       }
  987. { --------------------------------------------------------------------------- }
  988.  
  989. Begin
  990.    Assign(Output, '');        { Reset output to DOS stdout device             }
  991.    Rewrite(Output);
  992.    If ParamCheck then begin
  993.       Initialize;             { Initialize some variables                     }
  994.       GetBuffers;             { Allocate input and output buffers             }
  995.       GetTable;               { Initialize the code table                     }
  996.       Process_All_Files;      { Crunch the file                               }
  997.       DropBuffers;            { Be polite and de-allocate Buffer memory and   }
  998.       DropTable;              {    code table memory                          }
  999.    end {if};
  1000. End.
  1001.