{----------------------------------------------------------------------------}
{----------------------------------------------------------------------------}
{----------------------------------------------------------------------------}
function crunch(infile,outfile:String):integer;
label L1,Ende;
var
tab1    :array[1..10000]of Byte;  {EingabeDateiBlock}
tab2    :array[1..20000]of Byte;  {AusgabeDateiBlock}
inF,outF:FILE;                    {Die Files}
lesen   :integer;                 {Anzahl der gelesenen Bytes}
schreib :integer;                 {Anzahl der zu schreibenden Bytes}
F       :integer;                 {Nummer des Fehlers}
procedure crunch_block;
label L1,COD,UNC;
var lv1,lv2,lv3:word;        {Pointer im LeseFeld}
    merk:Byte;      {merker für das letzte Byte}
    anzC:byte;      {Anzahl für Codierte   Bytes}
    anzU:byte;      {Anzahl für UnCodierte Bytes}
begin
 lv1:=1;lv2:=1;schreib:=0;
 repeat
  anzC:=0;anzU:=0;
  lv3:=lv2;inc(lv2);                     {Position des CountBytes}
  merk:=tab1[lv1];inc(lv1);              {Wie lautet das erste Byte}
  tab2[lv2]:=merk;                       {das 1.Byte wird eingetragen}
  if(lv1>lesen) then begin tab2[lv3]:=anzU;inc(lv2);goto L1;end;
  if(merk<>tab1[lv1]) then goto UNC;     {Vergleiche mit 2.Byte}
{*************** Codieren der mehr als 1 gleichen Bytes *********************}
COD:inc(AnzC);                        {es sind mindestens 2Bytes}
    inc(lv1);                         {Anpassen des Nächsten LeseBytes}
    if(merk=tab1[lv1])and             {Wenns noch gleich dem ersten Byte ist}
      (lv1<=lesen    )and             {und der Bloch nicht überschritten}
      (AnzC<127      ) then goto COD; {und die max Anzahl nicht überschritten}
    tab2[lv3]:=AnzC;inc(lv2);     {Eintrag Anzahl der gleichen Bytes}
    goto L1;
{************************** Uncodierte Folge ********************************}
UNC:inc(lv2);tab2[lv2]:=tab1[lv1];    {Eintrag des Bytes in die Ausgabe}
    inc(lv1);inc(AnzU);               {Anpassen der Pointer}
    if(tab1[lv1]=tab1[lv1-1]) then begin
      dec(lv1);dec(AnzU);tab2[lv3]:=AnzU+128;goto L1;end;
    if(AnzU=127)or(lv1>lesen)then begin
      tab2[lv3]:=AnzU+128;inc(lv2);goto L1;end;
    goto UNC;
L1:until lv1>lesen;
 schreib:=lv2-1;
 Blockwrite(OutF,schreib,2,lesen);
end;

begin
f:=0;
{$I-}FileMode:=0;assign(inF,infile);     reset(InF,1);{$I+}
if (IOResult <> 0) then begin f:=1;Goto Ende;end; {Konnte Datei nicht öffnen}
{$I-}FileMode:=2;assign(OutF,outfile);rewrite(OutF,1);{$I+}
if (IOResult <> 0) then begin f:=2;Goto Ende;end; {Konnte Datei nicht öffnen}
 repeat
   Blockread(InF,tab1,8192,lesen);        {lesen des zu packenden Blocks}
   if(lesen=0) then goto L1;              {falls nichts mehr da ist zum Lesen}
   crunch_block;                          {Packe den Block}
   Blockwrite(OutF,tab2,schreib,lesen);   {Schreiben der gepackten Daten}
   if(lesen<>schreib) then f:=3;          {Es wurde nicht alles geschrieben}
L1:until (lesen=0)or(f<>0);          {Schleife bis ein Fehler oder nichts mehr zu Lesen}
close(OutF);close(InF);                   {Schließen der Files}
ENDE: crunch:=F; end;                     {Feierabend und FehlerR³ckgabe}
{*********************************************************************************************}
label ende;
var f:integer;
begin
clrscr;
if ParamCount<>3 then begin
 writeln('                            LängenCodierer');
 writeln('                           ----------------');
 writeln('');
 writeln(' Mit diesem Programm können Dateien komprimiert und wieder dekomprimiert');
 writeln(' werden, was sich hier nur für Dateien mit längeren gleichen Zeichenfol-');
 writeln(' gen lohnt.');
 writeln('(C) 1995 by Dave Sun');
 writeln('                              Bedienung');
 writeln('                             -----------');
 writeln('');
 writeln('              Packer.exe [Option] [QuellName] [ZielName]');
 writeln(' Im Namen kann das Verzeichnis und das Laufwerk angegeben werden');
 writeln(' Option a  : archivieren');
 writeln(' Option x  : auspacken');
 goto Ende;end;
 if (paramStr(1)='a') or (paramStr(1)='A') then
     f:=crunch(paramStr(2),paramStr(3));
 if (paramStr(1)='x') or (paramStr(1)='X') then
     f:=Decrunch(paramStr(2),paramStr(3));
{----------------------------------------------------------------------------}
 writeln;writeln;
 if(f=1)or(f=2) then writeln(paramStr(f+1),' nicht vorhanden oder konnte nicht geöffnet werden');
 if(f=3) then writeln('LeseFehler von Datenträger');
 if(f=4) then writeln('SchreibFehler von Datenträger');
 if(f=5) then writeln('EntpackFehler keine Crunch-Gepackte Datei');
{*********************************************************************************************}
Ende:end.