home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 10 / praxis / lzhuf.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-07-10  |  20.0 KB  |  660 lines
  1. (* ------------------------------------------------------ *)
  2. (*                    LZHUF.PAS                           *)
  3. (*       Verschlüsseln und Packen von Daten mit dem       *)
  4. (*                 Huffman-Algorithmus                    *)
  5. (*            (c) 1990 Ralf Hensmann & TOOLBOX            *)
  6. (* ------------------------------------------------------ *)
  7. PROGRAM LZHuf;
  8.  
  9. TYPE
  10.   CARDINAL = WORD;
  11.  
  12. VAR
  13.   InBuffer, OutBuffer : ARRAY [0..2051] OF BYTE;
  14.   InBufP,   OutBufP   : 0..2050;
  15.   InBitP,   OutBitP   : 0..8;
  16.   InFile,   OutFile   : FILE;
  17.   MaxIn               : INTEGER;
  18.   test                : TEXT;
  19.   ReadBuf, WriteBuf   : ARRAY [0..2048] OF BYTE;
  20.   ReadPtr, WritePtr,
  21.   ReadMax             : INTEGER;
  22.  
  23.   (* ----- Hilfsfunktionen zum Lesen von Bits ----------- *)
  24.  
  25.   FUNCTION BufRead : BYTE;
  26.   BEGIN
  27.     IF ReadPtr = ReadMax THEN BEGIN
  28.       BlockRead(InFile, ReadBuf, 2048, ReadMax);
  29.       ReadPtr := 0;
  30.     END;
  31.     BufRead := ReadBuf[ReadPtr];
  32.     Inc(ReadPtr);
  33.   END;
  34.  
  35.   PROCEDURE BufWrite(B : BYTE);
  36.   VAR
  37.    written : CARDINAL;
  38.   BEGIN
  39.     IF WritePtr = 2048 THEN BEGIN
  40.       Blockwrite(OutFile, WriteBuf, 2048, written);
  41.       IF written <> 2048 THEN BEGIN
  42.         WriteLn('Kein Platz');
  43.         Halt;
  44.       END;
  45.       WritePtr := 0;
  46.     END;
  47.     WriteBuf[WritePtr] := B;
  48.     Inc(WritePtr);
  49.   END;
  50.  
  51.   PROCEDURE BufFlush;
  52.   VAR
  53.     written : CARDINAL;
  54.   BEGIN
  55.     Blockwrite(OutFile, WriteBuf, WritePtr, written);
  56.     IF written <> WritePtr THEN BEGIN
  57.       WriteLn('Kein Platz');
  58.       Halt;
  59.     END;
  60.     WritePtr := 0;
  61.   END;
  62.  
  63.   PROCEDURE PutCode(Bits : CARDINAL; Len : CARDINAL);
  64.   VAR
  65.     hilf : CARDINAL;
  66.   BEGIN
  67.       (* unbenutzte Bits löschen *)
  68.     Bits := Bits AND ($FFFF SHL(16 - Len));
  69.       (* wenn notwendig, Flush *)
  70.     IF OutBufP >= 2048 THEN BEGIN
  71.       BlockWrite(OutFile, OutBuffer, 2048, hilf);
  72.       IF hilf <> 2048 THEN BEGIN
  73.         WriteLn('Schreibfehler: Platte ist voll');
  74.         Halt;
  75.       END;
  76.       FOR hilf := 2048 TO OutBufP DO
  77.         OutBuffer[hilf-2048] := OutBuffer[hilf];
  78.       Dec(OutBufP, 2048);
  79.     END;
  80.     IF OutBitP + Len > 16 THEN
  81.       OutBuffer[OutBufP + 2] := Hi(Bits SHL(16 - OutBitP));
  82.     IF OutBitP > 0 THEN
  83.       Bits := (Bits SHR OutBitP) OR
  84.               (OutBuffer[OutBufP] SHL 8);
  85.     OutBuffer[OutBufP]   := Hi(Bits);
  86.     OutBuffer[OutBufP+1] := Lo(Bits);
  87.     Inc(OutBufP, (OutBitP + Len) SHR 3);
  88.     OutBitP := (OutBitP + Len) AND 7;
  89.   END;
  90.  
  91.   PROCEDURE FlushCode;
  92.   VAR
  93.     written : CARDINAL;
  94.   BEGIN
  95.     IF OutBitP > 0 THEN Inc(OutBufP);
  96.     BlockWrite(OutFile, OutBuffer, OutBufP, written);
  97.     IF written <> OutBufP THEN BEGIN
  98.       WriteLn('Platte ist voll');
  99.       Halt;
  100.     END;
  101.   END;
  102.  
  103.   FUNCTION GetBit : BYTE;
  104.   BEGIN
  105.     IF InBitP = 8 THEN BEGIN
  106.       InBitP := 0;
  107.       Inc(InBufP);
  108.     END;
  109.     IF (InBufP > MaxIn) THEN BEGIN
  110.       BlockRead(InFile, InBuffer, 2048, MaxIn);
  111.       Dec(MaxIn);
  112.       InBufP := 0;
  113.     END;
  114.     Inc(InBitP);
  115.     GetBit := InBuffer[InBufP] SHR (8 - InBitP) AND 1;
  116.   END;
  117.  
  118.   FUNCTION GetByte : BYTE;
  119.   VAR
  120.     HilfB : BYTE;
  121.   BEGIN
  122.     HilfB := InBuffer[InBufP] SHL InBitP;
  123.     Inc(InBufP);
  124.     IF InBufP > MaxIn THEN BEGIN
  125.       BlockRead(InFile, InBuffer, 2048, MaxIn);
  126.       Dec(MaxIn);
  127.       InBufP := 0;
  128.     END;
  129.     GetByte := HilfB OR InBuffer[InBufP] SHR (8 - InBitP);
  130.   END;
  131.  
  132.   (* ----- Multiple Binary Trees ------------------------ *)
  133.  
  134. CONST
  135.   BufMax    = 4096;            (* Puffergröße             *)
  136.   LookAhead = 60;              (* vorausschauender Puffer *)
  137.   ThresHold = 2;               (* Minimaler Wert für LZSS *)
  138.   NUL       = BufMax;          (* Null-Zeiger             *)
  139.   TextMax   = BufMax + LookAhead - 1;
  140.  
  141. VAR
  142.   TextBuf   : ARRAY [0..TextMax] OF BYTE;   (* Textpuffer *)
  143.   LSon, Dad : ARRAY [0..BufMax] OF CARDINAL;  (* "Zeiger" *)
  144.   RSon      : ARRAY [0..BufMax+256] OF CARDINAL;
  145.          (* "Zeiger" - die oberen Elemente sind die Root- *)
  146.          (* Zeiger der einzelnen Zeichen                  *)
  147.   MatchPos,
  148.   MatchLen  : CARDINAL;
  149.                     (* Pos. und Länge des besten Matching *)
  150.  
  151.   PROCEDURE InitTree;      (* Initialisiert den Binärbaum *)
  152.   VAR
  153.     i : CARDINAL;
  154.   BEGIN
  155.                             (* Root-Zeiger auf NUL setzen *)
  156.     FOR i := BufMax + 1 TO BufMax + 256 DO
  157.       RSon[i] := NUL;
  158.                             (* Zeiger der Tabelle löschen *)
  159.     FOR i := 0 TO BufMax - 1 DO
  160.       Dad[i] := NUL;
  161.   END;
  162.  
  163.   PROCEDURE InsertNode(pos : CARDINAL);
  164.                  (* Fügt String an Stelle pos in Baum ein *)
  165.   VAR
  166.     cmp     : INTEGER;     (* Vergleich der Zeichenketten *)
  167.     i, hilf : CARDINAL;
  168.     node    : CARDINAL;    (* gerade untersuchter Knoten  *)
  169.   BEGIN
  170.     node := TextBuf[pos] + BufMax+1;  (* Wurzel des Baums *)
  171.     RSon[pos] := NUL;                 (* Zeiger "erden"   *)
  172.     LSon[pos] := NUL;
  173.     MatchLen  := 0;
  174.     cmp       := 1;              (* Root steht in RSon... *)
  175.     REPEAT
  176.                                  (* Knoten weiterbewegen  *)
  177.       IF cmp >= 0 THEN
  178.         IF RSon[node] <> NUL THEN
  179.           node := RSon[node]       (* Wurzel weitersetzen *)
  180.         ELSE BEGIN
  181.            (* Baumende ist erreicht, Element hier anfügen *)
  182.           RSon[node] := pos;
  183.           Dad[pos]   := node;
  184.           Exit;
  185.         END
  186.       ELSE IF LSon[node] <> NUL THEN
  187.         node := LSon[node]         (* Wurzel weitersetzen *)
  188.       ELSE BEGIN
  189.            (* Baumende ist erreicht, Element hier anfügen *)
  190.         LSon[node] := pos;
  191.         Dad[pos]   := node;
  192.         Exit;
  193.       END;
  194.         (* Knoten mit Element vergleichen *)
  195.       i := 1;
  196.       REPEAT
  197.         cmp := INTEGER(TextBuf[pos + i]) - TextBuf[node +i];
  198.         IF cmp = 0 THEN Inc(i);
  199.       UNTIL (i >= LookAhead) OR (cmp <> 0);
  200.  
  201.         (* i enthält die Anzahl der gleichen Zeichen ... *)
  202.       IF i > ThresHold THEN BEGIN
  203.         IF (i > MatchLen) THEN BEGIN
  204.             (* neue Position *)
  205.           MatchPos := (pos - node) AND (BufMax - 1) - 1;
  206.           MatchLen := i;
  207.         END;
  208.         IF (i = MatchLen) AND (i < LookAhead) THEN BEGIN
  209.           hilf := (pos - node) AND (BufMax - 1) - 1;
  210.           IF hilf < MatchPos THEN
  211.             MatchPos := hilf;
  212.         END;
  213.       END;
  214.     UNTIL (MatchLen >= LookAhead);
  215.               (* Sonderfall: node wird durch pos ersetzt, *)
  216.               (*             da beide gleich sind.        *)
  217.     Dad[pos]  := Dad[node];
  218.     LSon[pos] := LSon[node];
  219.     RSon[pos] := RSon[node];
  220.     Dad[LSon[node]] := pos;
  221.     Dad[RSon[node]] := pos;
  222.     IF RSon[Dad[node]] = node THEN
  223.       RSon[Dad[node]] := pos
  224.     ELSE
  225.       LSon[Dad[node]] := pos;
  226.     Dad[node] := NUL;      (* node als gelöscht eintragen *)
  227.   END;
  228.  
  229.   PROCEDURE DeleteNode(pos : CARDINAL);
  230.   VAR
  231.     node : CARDINAL;
  232.   BEGIN
  233.     IF Dad[pos]  = NUL THEN Exit;     (* bereits gelöscht *)
  234.     IF RSon[pos] = NUL THEN
  235.       node := LSon[pos]
  236.     ELSE IF LSon[pos] = NUL THEN
  237.       node := RSon[pos]
  238.     ELSE BEGIN
  239.       node := LSon[pos];
  240.       IF RSon[node] <> NUL THEN BEGIN
  241.         (* Unterstes rechtes Element suchen und vor den   *)
  242.         (* linken Ast hängen                              *)
  243.         REPEAT
  244.           node := RSon[node];
  245.         UNTIL RSon[node] = NUL;
  246.         RSon[Dad[node]] := LSon[node];
  247.         Dad[LSon[node]] := Dad[node];
  248.         LSon[node]      := LSon[pos];
  249.         Dad[LSon[pos]]  := node;
  250.       END;
  251.       RSon[node]     := RSon[pos];
  252.       Dad[RSon[pos]] := node;
  253.     END;
  254.       (* node enthält nun das Element, um pos zu ersetzen *)
  255.     Dad[node] := Dad[pos];
  256.     IF RSon[Dad[pos]] = pos THEN
  257.       RSon[Dad[pos]] := node
  258.     ELSE
  259.       LSon[Dad[pos]] := node;
  260.     Dad[pos] := NUL;
  261.   END;
  262.  
  263.   (* ----- Positionstabellen für LZSS ------------------- *)
  264.   (* Tabellen zur Ver- und Entschlüsselung der ersten     *)
  265.   (* 6 Bit in ein Alphabet mit variablen Längen, da       *)
  266.   (* kleinere 6-Bit-Werte sehr viel häufiger auftauchen   *)
  267.   (* als längere.                                         *)
  268.  
  269.   (* Kompression: *)
  270.  
  271. CONST
  272.   c_len  : ARRAY [0..63] OF BYTE =
  273.             ($03, $04, $04, $04, $05, $05, $05, $05,
  274.              $05, $05, $05, $05, $06, $06, $06, $06,
  275.              $06, $06, $06, $06, $06, $06, $06, $06,
  276.              $07, $07, $07, $07, $07, $07, $07, $07,
  277.              $07, $07, $07, $07, $07, $07, $07, $07,
  278.              $07, $07, $07, $07, $07, $07, $07, $07,
  279.              $08, $08, $08, $08, $08, $08, $08, $08,
  280.              $08, $08, $08, $08, $08, $08, $08, $08);
  281.  
  282.   c_code : ARRAY [0..63] OF CARDINAL =
  283.             ($00, $20, $30, $40, $50, $58, $60, $68,
  284.              $70, $78, $80, $88, $90, $94, $98, $9C,
  285.              $A0, $A4, $A8, $AC, $B0, $B4, $B8, $BC,
  286.              $C0, $C2, $C4, $C6, $C8, $CA, $CC, $CE,
  287.              $D0, $D2, $D4, $D6, $D8, $DA, $DC, $DE,
  288.              $E0, $E2, $E4, $E6, $E8, $EA, $EC, $EE,
  289.              $F0, $F1, $F2, $F3, $F4, $F5, $F6, $F7,
  290.              $F8, $F9, $FA, $FB, $FC, $FD, $FE, $FF);
  291.  
  292.   (* Dekompression: *)
  293.  
  294. VAR
  295.   d_len  : ARRAY [0..255] OF BYTE;
  296.   d_code : ARRAY [0..255] OF CARDINAL;
  297.  
  298.   PROCEDURE MakeTable;
  299.   VAR
  300.     i, entry : CARDINAL;
  301.   BEGIN
  302.     FOR entry := 0 TO 62 DO BEGIN
  303.       i := c_code[entry];
  304.       WHILE (i < c_code[entry+1]) DO BEGIN
  305.         d_len[i]  := c_len[entry];
  306.         d_code[i] := entry SHL 6;
  307.         Inc(i);
  308.       END;
  309.     END;
  310.     i := c_code[63];
  311.     WHILE (i <= 255) DO BEGIN
  312.       d_len[i]  := c_len[entry];
  313.       d_code[i] := 63 SHL 6;
  314.       Inc(i);
  315.     END;
  316.     FOR i := 0 TO 63 DO
  317.       c_code[i] := c_code[i] SHL 8;
  318.   END;
  319.  
  320.   (* ----- Adaptive Huffman Coding ---------------------- *)
  321.  
  322. CONST
  323.   NChar   = 256 + (LookAhead-ThresHold);
  324.               (* ASCII-Char + Längen der LZSS-Codierungen *)
  325.   NTable  = 2*NChar - 1;
  326.               (* Anzahl der N-1 Knoten + N Blätter        *)
  327.   Root    = NTable - 1;    (* Position der Wurzel         *)
  328.   MaxFreq = $100;          (* Neuaufbau des Huffman-Trees *)
  329.  
  330. VAR
  331.   Freq    : ARRAY [0..NTable] OF CARDINAL;
  332.               (* Häufigkeiten                             *)
  333.   Prnt    : ARRAY [0..NTable+NChar-1] OF CARDINAL;
  334.               (* Zeiger auf den "oberen" Knoten.          *)
  335.               (* Die Elemente NTable..NTable+NChar-1      *)
  336.               (* zeigen auf die Grundknoten des Baums     *)
  337.   Son     : ARRAY [0..NTable-1] OF CARDINAL;
  338.               (* Zeiger auf die Zweig-Elemente Son[] und  *)
  339.               (* Son[+1]                                  *)
  340.  
  341.   PROCEDURE InitHuff;           (* Initialisiert den Baum *)
  342.   VAR
  343.    i, j : CARDINAL;
  344.   BEGIN
  345.                                 (* Blätter initialisieren *)
  346.     FOR i := 0 TO NChar-1 DO BEGIN
  347.       Freq[i] := 1;  Son[i]  := i + NTable;
  348.       Prnt[i + NTable] := i;
  349.     END;
  350.                                 (* Knoten initialisieren  *)
  351.     i := 0;
  352.     FOR j := NChar TO Root DO BEGIN
  353.       Freq[j]  := Freq[i] + Freq[i+1];
  354.       Son[j]   := i;  Prnt[i] := j;  Prnt[i+1]:= j;
  355.       i := i + 2;
  356.     END;
  357.     Freq[NTable] := $FFFF;              (* Frequenzzähler *)
  358.     Prnt[Root]   := 0;                  (* Wurzel         *)
  359.   END;
  360.  
  361.   PROCEDURE Reconstruct;
  362.   VAR
  363.     i, j : CARDINAL;
  364.     f, k : CARDINAL;
  365.     l    : CARDINAL;
  366.   BEGIN
  367.       (* Teil 1: Blätter suchen und Frequenzen halbieren  *)
  368.     j := 0;
  369.     FOR i := 0 TO Root DO BEGIN
  370.       IF Son[i] >= NTable THEN BEGIN
  371.          (* Blatt gefunden und wieder an Anfang der Liste *)
  372.          (* schreiben                                     *)
  373.         Freq[j] := (Freq[i] + 1) DIV 2;
  374.         Son[j]  := Son[i];
  375.         Inc(j);
  376.       END;
  377.     END;
  378.       (* Teil 2: Knoten aus den Blättern bilden           *)
  379.     i := 0;                          (* "jüngerer" Knoten *)
  380.     FOR j := NChar TO Root DO BEGIN  (* j : freier Knoten *)
  381.       f := Freq[i] + Freq[i+1];      (* Neue Frequenz     *)
  382.                             (* Platz zum Einsetzen suchen *)
  383.       k := j - 1;
  384.       Freq[j] := f;
  385.       WHILE f < Freq[k] DO Dec(k);
  386.       Inc(k);
  387.       l := (j-k) * 2;
  388.       Move(Freq[k], Freq[k+1], l);
  389.       Freq[k] := f;
  390.       Move(Son[k], Freq[k+1], l);
  391.       Son[k] := i;
  392.     END;
  393.       (* Parent-Zweige verbinden *)
  394.     FOR i := 0 TO Root DO BEGIN
  395.       k       := Son[i];
  396.       Prnt[k] := i;
  397.       IF k < NTable THEN
  398.         Prnt[k+1] := i;       (* älterer Bruder, wenn Son *)
  399.                               (* nicht auf Verweis zeigt  *)
  400.     END;
  401.   END;
  402.  
  403.   PROCEDURE Update( c : CARDINAL);
  404.     (* korrigiert Huffman-Tree *)
  405.   VAR
  406.     x, f, y : CARDINAL;
  407.   BEGIN
  408.     IF Freq[Root] = MaxFreq THEN
  409.       Reconstruct;
  410.     c := Prnt[c + NTable];(* c: Zeiger auf unteren Knoten *)
  411.     REPEAT
  412.       Inc(Freq[c]);  f := Freq[c];  x := c + 1;
  413.       IF f > Freq[x] THEN BEGIN     (* Knoten austauschen *)
  414.         REPEAT
  415.          Inc(x);
  416.         UNTIL f <= Freq[x];
  417.         Dec( x);
  418.           (* x zeigt auf das Element, gegen das es        *)
  419.           (* ausgetauscht werden soll                     *)
  420.         Freq[c] := Freq[x];
  421.         Freq[x] := f;
  422.         f       := Son[c];
  423.         y       := Son[x];
  424.         Prnt[f] := x;
  425.         IF (f < NTable) THEN Prnt[f+1] := x;
  426.         Prnt[y] := c;
  427.         IF (y < NTable) THEN Prnt[y+1] := c;
  428.         Son[c] := y;  Son[x] := f;  c := x;
  429.       END;
  430.       c := Prnt[c];
  431.     UNTIL (c = 0);       (* Wurzel erreicht *)
  432.   END;
  433.  
  434.   PROCEDURE EncodeChar( c : CARDINAL);
  435.                  (* Verschlüsselt Buchstaben nach Huffman *)
  436.   VAR
  437.     bits, len, node : CARDINAL;
  438.   BEGIN
  439.     bits := 0;  len := 0;
  440.     node := Prnt[c+NTable];
  441.                      (* Der Code wird rückwärts aufgebaut *)
  442.     REPEAT
  443.       IF len = 16 THEN BEGIN               (* Puffer voll *)
  444.         PutCode(bits, 16);
  445.         bits := 0;  len := 0;
  446.       END;
  447.       bits := bits SHR 1;
  448.       IF ODD(node) THEN
  449.                      (* älterer Sohn - dann 1 abspeichern *)
  450.         bits := bits + $8000;
  451.       Inc(len);
  452.       node := Prnt[node];
  453.     UNTIL node = Root;
  454.     PutCode(bits, len);  Update(c);
  455.   END;
  456.  
  457.   PROCEDURE EncodePosition(c : CARDINAL);
  458.   VAR
  459.     i : CARDINAL;
  460.   BEGIN
  461.                     (* Obere 6 Bit durch Tabelle codieren *)
  462.     i := c SHR 6;
  463.     PutCode(c_code[i], c_len[i]);
  464.       (* untere 6 Bit normal ... *)
  465.     PutCode(c SHL 10, 6);
  466.   END;
  467.  
  468.   PROCEDURE EncodeEnd;
  469.   BEGIN
  470.     FlushCode;
  471.   END;
  472.  
  473.   FUNCTION DecodeChar : CARDINAL;
  474.   VAR
  475.     c : CARDINAL;
  476.   BEGIN
  477.        (* Suche des Zeichens im Baum von der Wurzel aus.  *)
  478.        (* Wird 0 gelesen, ist der "jüngere" Sohn gemeint. *)
  479.     c := Son[Root];
  480.     WHILE c < NTable DO c := Son[c+GetBit];
  481.       (* c steht auf dem gemeinten Zeichen *)
  482.     Dec(c, NTable);
  483.     Update(c);
  484.     DecodeChar := c;
  485.   END;
  486.  
  487.   FUNCTION DecodePosition : CARDINAL;
  488.   VAR
  489.     c, i, len : CARDINAL;
  490.   BEGIN
  491.       (* Bits aus Tabelle suchen *)
  492.     i := GetByte;  c := d_code[i];  len := d_len[i];
  493.       (* restliche untere Bits holen *)
  494.     Dec(len, 2);
  495.     WHILE len > 0 DO BEGIN
  496.       i := i SHL 1 + GetBit;
  497.       Dec(len);
  498.     END;
  499.     DecodePosition := c OR (i AND $3F);
  500.   END;
  501.  
  502.   PROCEDURE Encode;
  503.   VAR
  504.     i            : CARDINAL; (* Laufvariable              *)
  505.     c            : BYTE;     (* Zeichen, das gelesen wird *)
  506.     TextSize     : LONGINT;
  507.           (* Anzahl der Zeichen, die verarbeitet wurden   *)
  508.     Len          : CARDINAL;
  509.           (* Anzahl der unverarbeiteten Zeichen im Puffer *)
  510.     R            : CARDINAL;
  511.           (* Position, von der geschrieben wird           *)
  512.     S            : CARDINAL;
  513.           (* Position, in die Zeichen gelesen werden      *)
  514.     LastMatchLen : CARDINAL;
  515.           (* Anzahl der Zeichen bei Schreiben von LZSS    *)
  516.     PrintCount   : LONGINT;  (* Zähler für Hilfsausgabe   *)
  517.     OldSize      : LONGINT;
  518.   BEGIN
  519.     PrintCount := 0;
  520.     TextSize   := FileSize(InFile);
  521.     OldSize    := TextSize;
  522.     BlockWrite(OutFile, TextSize, SizeOf(TextSize));
  523.     InitHuff;  InitTree;
  524.     R := BufMax - LookAhead;  S := 0;
  525.                    (* Puffer mit Leerzeichen füllen       *)
  526.     FillChar(TextBuf, R, ' ');
  527.                    (* erste Zeichen einlesen              *)
  528.     BlockRead(InFile, TextBuf[R], LookAhead, Len);
  529.     TextSize := Len;
  530.     FOR i := R - 1 DOWNTO R - LookAhead DO
  531.       InsertNode(i);
  532.                    (* Zeiger im Leerzeichenbereich setzen *)
  533.     InsertNode(R);             (* ersten Zeiger setzen... *)
  534.     REPEAT
  535.       IF MatchLen > Len THEN MatchLen := Len;
  536.       IF MatchLen <= ThresHold THEN BEGIN
  537.           (* Zeichen verschlüsseln *)
  538.         MatchLen := 1;
  539.         EncodeChar(TextBuf[R]);
  540.       END ELSE BEGIN
  541.           (* LZSS verschlüsseln *)
  542.         EncodeChar(255 + MatchLen - ThresHold);
  543.         EncodePosition(MatchPos);
  544.       END;
  545.       LastMatchLen := MatchLen;
  546.                       (* Anzahl der geschriebenen Zeichen *)
  547.       i := 0;
  548.       WHILE (i < LastMatchLen) AND
  549.             (TextSize < OldSize) DO BEGIN
  550.                                  (* Neue Zeichen einlesen *)
  551.         BlockRead(InFile, c, 1);
  552.         (* c := BufRead; *)
  553.         DeleteNode(S);
  554.         TextBuf[S] := c;
  555.         IF (S < LookAhead - 1) THEN
  556.           TextBuf[BufMax+S] := c;  (* Zum Stringvergleich *)
  557.         S := (S + 1) AND (BufMax - 1);
  558.         R := (R + 1) AND (BufMax - 1);
  559.         InsertNode(R);
  560.                (* Zeichen wird in Zeigerliste aufgenommen *)
  561.         Inc(i);
  562.         Inc(TextSize);
  563.       END;
  564.       IF TextSize >= PrintCount THEN BEGIN
  565.         Write('.');
  566.         Inc(PrintCount, 1024);
  567.       END;
  568.        (* Diese Schleife wird aufgerufen, wenn nicht alle *)
  569.        (* Zeichen gelesen werden konnten (Ende der Datei) *)
  570.       WHILE i < LastMatchLen DO BEGIN
  571.         DeleteNode( S);
  572.         S := (S + 1) AND (BufMax - 1);
  573.         R := (R + 1) AND (BufMax - 1);
  574.         IF Len > 0 THEN BEGIN
  575.           InsertNode(R);
  576.                (* Wenn noch Zeichen im Puffer stehen, die *)
  577.           Dec(Len);             (* nicht verarbeitet sind *)
  578.         END;
  579.         Inc(i);
  580.       END;
  581.     UNTIL (Len = 0);
  582.     EncodeEnd;
  583.   END;
  584.  
  585.   PROCEDURE Decode;
  586.   VAR
  587.     S, R, c           : CARDINAL;
  588.     TextSize, count,
  589.     PrintCount        : LONGINT;
  590.     newpos, newlen, k : CARDINAL;
  591.   BEGIN
  592.       (* Filelänge lesen *)
  593.     BlockRead(InFile, TextSize, SizeOf(TextSize), S);
  594.     IF S <> SizeOf(TextSize) THEN Exit;
  595.     R := BufMax - LookAhead;
  596.     S := 0;
  597.     PrintCount := 0;
  598.     InitHuff;
  599.     FillChar(TextBuf, R, ' ');
  600.     Count := 0;
  601.     WHILE Count < TextSize DO BEGIN
  602.       c := DecodeChar;
  603.       IF c < 256 THEN BEGIN
  604.         BufWrite(c);
  605.         TextBuf[R] := c;
  606.         R := (R + 1) AND (BufMax - 1);
  607.         Inc(Count);
  608.       END ELSE BEGIN
  609.         newpos := (R - DecodePosition - 1) AND (BufMax - 1);
  610.         newlen := c + ThresHold - 255;
  611.         FOR k := 0 TO newlen - 1 DO BEGIN
  612.           c := TextBuf[(newpos + k) AND (BufMax - 1)];
  613.           BufWrite(c);
  614.           TextBuf[R] := c;
  615.           R := (R + 1) AND (BufMax - 1);
  616.           Inc(Count);
  617.         END;
  618.       END;
  619.       IF Count > PrintCount THEN BEGIN
  620.         Write('.');
  621.         Inc(PrintCount, 1024);
  622.       END;
  623.     END;
  624.     BufFlush;
  625.   END;
  626.  
  627. VAR
  628.   p : STRING;
  629.  
  630. BEGIN
  631.   WritePtr := 0;  ReadPtr := 0;  ReadMax := 0;
  632.   MakeTable;
  633.   FillChar(OutBuffer, SizeOf(OutBuffer), #0);
  634.   OutBufP := 0;  InBufP := 0;
  635.   OutBitP := 0;  InBitP := 0;
  636.   MaxIn   := -1;
  637.   p       := ParamStr(1);  p[1] := UpCase(p[1]);
  638.   IF (ParamCount <> 3) OR (Length(p) <> 1) OR
  639.      (p[1] < 'D') OR (p[1] > 'E') THEN BEGIN
  640.     WriteLn('"LZHUF e file1 file2"',
  641.             '   komprimiert file1 in file2');
  642.     WriteLn('"LZHUF d file1 file2"',
  643.             ' dekomprimiert file1 in file2');
  644.     Halt;
  645.   END;
  646.   Assign(InFile,  ParamStr(2));
  647.   Assign(OutFile, ParamStr(3));
  648.   (*$I-*)
  649.   Rewrite(OutFile, 1);  Reset(InFile, 1);
  650.   (*$I+*)
  651.   IF IOResult <> 0 THEN BEGIN
  652.     WriteLn(' Files konnten nicht geöffnet werden...');
  653.     Halt;
  654.   END;
  655.   IF p[1] = 'E' THEN Encode ELSE Decode;
  656.   Close(InFile);  Close(OutFile);
  657. END.
  658. (* ------------------------------------------------------ *)
  659. (*                 Ende von LZHUF.PAS                     *)
  660.