uses crt;
var pz: array [0..255] of word; {longint=2 000 000 000}
    nej: array [0..255] of boolean;
    defmap: array [0..255] of byte;   {min delka mapy je 2(=0), tj. (2-257)}
    cst,svc,pmap:byte;   {=pocet map} {znak mapy je cislo mapy 1-255}
const tm='lilie.tmp';

procedure pocetzn(zn:char);begin for cst:=$00 to $FF do if chr(cst)=zn then pz[cst]:=pz[cst]+1 end;
procedure cti_pocit;
var
 Fl1,Fl2: file;
 Sf1,Sf2:string[12];
 cc:longint; {pomocne cislo}
 NumR: Word;
 buf: array[1..10240] of Char; {10K buf}
 existuje:boolean;

 procedure mapuj;
 const vys=1280; {kontrola 10240 znaku}
 var
  map: array [1..vys] of byte;
  um,ump: word;
  pomm,uz1:byte;
  om: boolean;
  lgc,uz:integer;
  ux,uy:real;
  ifmb: array[1..5] of char;
{CAST A} procedure mazznak;
    var buftmp2:array[1..10240] of char;
        t2a,t2b:word;
    const tmp2='lilie.tm2';
    begin
     seek(fl2,lgc+5);
     t2b:=0;
     repeat
      BlockRead(Fl1,buf,SizeOf(buf),NumR);
      for t2a:=1 to NumR do if buf[t2a]<>ifmb[1] then
       begin t2b:=t2b+1;buftmp2[t2b]:=buf[t2a];end;
      BlockWrite(Fl2,buftmp2,t2b,NumR);
     until NumR=0;
    end;
{HL.CAST} begin
  seek(fl1,0);
  ux:=0;
  for um:=1 to vys do map[um]:=0;
  repeat
   BlockRead(Fl1,buf,SizeOf(buf),NumR);
   lgc:=round(NumR/8);
   for ump:=1 to lgc do
    begin
     for um:=0 to 7 do
      begin
       if buf[ump+um]=chr(cst) then
        begin
         case um of 0:pomm:=0;1:pomm:=1;2:pomm:=3;3:pomm:=7;
         4:pomm:=15;5:pomm:=31;6:pomm:=63;7:pomm:=127;end;
         map[ump]:=map[ump]+pomm;
        end;
      end;
    end;
   BlockWrite(Fl2,map,lgc,NumR);
   for um:=1 to vys do map[um]:=0;
  until NumR=0;
  ifmb[1]:=chr(svc);
  ux:=filesize(fl2);
  lgc:=round(ux);
  for pomm:=5 downto 2 do
   begin
    uy:=trunc(ux/256);
    uz:=trunc(ux-uy);
    if uz<0 then uz1:=0;
    for uz1:=$00 to $FF do if uz=uz1 then begin ifmb[pomm]:=chr(uz1);uz1:=$FF;end;
    ux:=uy;
   end;
  seek(fl2,0);
  BlockWrite(Fl2,ifmb,5,NumR);
  mazznak;
 end;
begin
  Sf2:=ParamStr(2);
  {$I-} Assign(fl2,sf2);Reset(fl2);Close(fl2); {$I+}
  Existuje:=(IOResult=0) and (sf2<>'');
  if Existuje=true
   then
    begin
     Assign(Fl2,sf2);Reset(Fl2,1);
     repeat
      BlockRead(Fl2,buf,SizeOf(buf),NumR);
      for cc:=0 to NumR do pocetzn(buf[cc]);
     until NumR=0;

     cc:=filesize(fl2)+1;cc:=round(cc/8);
     existuje:=false; {=otazka zda komprimovat}
     for cst:=0 to 255 do
      begin
       nej[cst]:=false;
       if cc<pz[cst] then begin nej[cst]:=true;svc:=cst;if existuje=false then existuje:=true end
      end;
     if existuje=true
      then
       begin
{}
        Sf1:=tm;
        seek(fl2,0);
        Assign(Fl1,sf1);Rewrite(Fl1,1);
        repeat
         BlockRead(Fl2,buf,SizeOf(buf),NumR);
         BlockWrite(Fl1,buf,NumR,Numr);
        until NumR=0;
        Close(Fl2);        {POZOR !!! ted Fl1=lil.tmp(soubor.pri)}
        Sf2:=ParamStr(1);Assign(Fl2,sf2);Rewrite(Fl2,1);
        for cst:=$00 to $FF do if nej[cst]=true then mapuj;
        Close(Fl1);Close(Fl2);
{}
       end
      else writeln('Soubor neni vhodny pro komprimaci timto programem.');
    end
   else WriteLn('Vstupni soubor nenalezen');
end;



begin
Writeln('Program LILIE, verze 1.0, FREEWARE              autor: Peter Mlich');
for cst:=0 to 255 do pz[cst]:=0;
cti_pocit;
end.
