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.
