{ pokus o prepsani, komentovani kodu }

{ cely program vytvari jen binarni mapy rozmisteni znaku v souboru/pozustalych znacich po predchozich kolech }
{ a spousti kompresi (at, uz to dela jakkoliv) jen, kdyz je nejaky pocet znaku vetsi nez 1/8 }
{ cili, tohle nejspis neni ten program, co hledam }

uses crt;
var pz: array [0..255] of word; {longint=2 000 000 000 -- to bude asi pocet-znaku}
    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 tmp1_file_name='lilie.tmp';

{ do pole 'pz' uloz pocet znaku, pridej pz[znak]++ }
{ num written hex $00 = 0, $FF = 255}
{ zvys v poli pocet-znaku[cst]++, jinymi slovy, melo by to byt totez, co pocet-znaku[ord(znak)]++}
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
 out_fp, inp_fp: file;
 out_file_name, inp_file_name:string[12];
 cc:longint; {pomocne cislo}
 NumR: Word;
 buf: array[1..10240] of Char; {10K buf}
 existuje:boolean;

 {sub procedura 'mapuj'}
 procedure mapuj;

 const vys=1280; {kontrola 10240 znaku}
 var
  map: array [1..vys] of byte;
  um, ump: word; {um ukazatel-mapy? ump ukazatel-mapy-p}
  pomm, uz1:byte;
  om: boolean;
  lgc, uz:integer;
  ux, uy:real;
  ifmb: array[1..5] of char; {info/input-file-m-b?}

{CAST A - subsub procedura 'mazznak' - tohle myslim zkopiruje mapu znaku do vystupu}
{pravdepodobne je uvnitr procedury, aby mohla vyuzivat promene z hlavni procedury}
    procedure mazznak;
    var buftmp2:array[1..10240] of char;
        t2a, t2b:word;
    const tmp2_file_name='lilie.tm2';

    begin
     seek(inp_fp, lgc+5);	{ nastav ukazatel na lgc+5, prvnich 5 znaku je jakesi info o mapovani}
     t2b:=0;
     repeat
      BlockRead(out_fp, buf, SizeOf(buf), NumR);	{ nacti buf}
      for t2a:=1 to NumR do if buf[t2a]<>ifmb[1] then	{ porovnej a jestli je znak<>ifmb[1] tak...}
       begin t2b:=t2b+1;buftmp2[t2b]:=buf[t2a];end;	{ ... zapis buf2[count(buf2)] = znak}
      BlockWrite(inp_fp, buftmp2, t2b, NumR);
     until NumR=0;
	{ cili, nejspis to dela jen to, ze vyhodi 'selected' znak, aby bylo mozne delat dalsi mapu}
    end;


{HL.CAST}
 begin
  seek(out_fp, 0);	{ input je v out_fp souboru, takze nastav ukazatel na zacatel souboru}
  ux:=0;

  for um:=1 to vys do map[um]:=0;	{ vyresetuj mapu, kde vys=1280, kde vys<10240 buffer souboru}

  repeat
   BlockRead(out_fp, buf, SizeOf(buf), NumR); { nacti do bufferu }
   lgc:=round(NumR/8);	{  rozdel soubor po 1/8}
   for ump:=1 to lgc do
    begin
     { pro nasledujicich 8 znaku proved...}
     for um:=0 to 7 do
      begin
       { ... a tady to prestava davat smysl, protoze ump+um je treba 50+1+2+3... 51+1+2+3, jestli tam nemelo byt spis ump*8+um}
       if buf[ump+um]=chr(cst) then	{cst je cislo mapy/znaku 1-255, cst prijde jako promena z venku procedury}
        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;	{ case + tohle roluje bity 1xxx.xxxx 01xx.xxxx  001x.xxxx ...;
	{ vytvari to asi mapu vyskytu znaku a zapisuje binarne, po 1 bitu, 8 znaku do 1 byte}
        end;
      end;
    end;
   BlockWrite(inp_fp, map, lgc, NumR);	{ zapis mapu }

   for um:=1 to vys do map[um]:=0;	{ resetuj mapu a nacti dalsi blok a pokracuj }
  until NumR=0;

	{ tohle asi pridava doplnkove udaje, 5 byte, svc=?, svc asi bude save-c, a pujde o nejcetnejsi znak, asi}
  ifmb[1]:=chr(svc);	{ -- takze, uloz vybrany znak, pascal cisluje pole od 1 ne od 0, protoze tak to mam nahore v type nadefinovane}
			{ -- nejspise to zapise posledni znak ze souboru, protoze, z nejakeho duvodu je to nutne ke zpetnemu dekodovani}
  ux:=filesize(inp_fp);	{ file size }
  lgc:=round(ux);	{ ? proc se asi rounduje filesize, kdyz je to integer }
  for pomm:=5 downto 2 do
   { --- nejspis to cele jen prepisuje cisla v ifmb[pomm] na chr a chr pak zapise do souboru ---}
   begin
    uy:=trunc(ux/256);	{ 1) filesize/256 }
    uz:=trunc(ux-uy);   { 1) filesize - filesize/256 }
{ -- a k nemu nejake info, ktere mi neni ted jasne }
    if uz<0 then uz1:=0; {? toto nedava smysl, protoze for-cyklus 'uz1' prepisuje, mozna tam melo byt uz:=0}

    for uz1:=$00 to $FF do if uz=uz1 then begin ifmb[pomm]:=chr(uz1);uz1:=$FF;end; {zapis znak uz do ifmb[pomm] = chr(uz)}

    ux:=uy;
   end;
  seek(inp_fp, 0);	{nastav ukazatel na zacatek souboru}
  BlockWrite(inp_fp, ifmb, 5, NumR);	{ zapise 5 znaku na zacatek input souboru }

  mazznak;	{spusti proceduru map znak}

 end;


begin {kod procedury 'cti_pocit'}

{--- kontrola souboru, zda je mozne zapisovat ---}
  inp_file_name:=ParamStr(2);
  {$I-} Assign(inp_fp,  inp_file_name);Reset(inp_fp);Close(inp_fp); {$I+}	{zjisti zda lze prepsat soubor, directiva I/O checking code}
  Existuje:=(IOResult=0) and (inp_file_name<>'');
  if Existuje=<>true
	 begin
	 WriteLn('Vstupni soubor nenalezen');
	exit
	end;
  {if Existuje=true}
   {then}
    begin

{--- spocitej pocet znaku ---}
     Assign(inp_fp,  inp_file_name);Reset(inp_fp, 1);	{ otevri soubor input }
     repeat
      BlockRead(inp_fp, buf, SizeOf(buf), NumR);	{ nacti buffer }
      for cc:=0 to NumR do pocetzn(buf[cc]);		{ do 'pz' uloz pocty znaku v buferu}
     until NumR=0;


{--- pokud aspon 1 znak se opakuje vicekrat nez size/8, tak je mozne soubor komprimovat ---}
	{ zjisti, zda je mozne soubor komprimovat }
	{ pokud pocet znaku pz[char] < 1/8 filesize; proc zrovna 1/8 zatim jeste nevim }
     cc:=filesize(inp_fp)+1;cc:=round(cc/8);		{ cc = round ((delkaSouboru(input)+1)/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
{ --- zkopiruje soubor1 do soubor 2 a smaze obsah soubor1 ---}
{nevim proc, nejspis to ma neco vyresit}
        out_file_name:=tmp1_file_name;
        seek(inp_fp, 0);		{ukazatel na zacatek souboru}
        Assign(out_fp, out_file_name);
	Rewrite(out_fp, 1);	{vytvor 'out soubor', delka 1 znak}
        repeat
         BlockRead(inp_fp, buf, SizeOf(buf), NumR);	{precti data ze 'souboru inp' do 'buf'}
         BlockWrite(out_fp, buf, NumR, Numr);		{zapis data z 'buf' do 'souboru out'}
        until NumR=0;
        Close(inp_fp);        {POZOR !!! ted out_fp=lil.tmp(soubor.pri)}

	{ smaze obsah input souboru }
        inp_file_name:=ParamStr(1); Assign(inp_fp,  inp_file_name); Rewrite(inp_fp, 1);




	{ spusti mapovani, at uz to je cokoliv :) }
	{ mapovani si precte z outputu data do buf a neco s tim provede }
	{ tipuji, ze premapuji data podle poctu znaku a priradim jim cisla 0, 1, 2;}
        {  tim ziskam pro nekolik buferu spoustu dat, ktera jsou 0, 1, 2}
        for cst:=$00 to $FF do if nej[cst]=true then mapuj;
	
        Close(out_fp);
	Close(inp_fp);
{}
       end
      else writeln('Soubor neni vhodny pro komprimaci timto programem.');
    {end}
end;



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