{pakovac ... mapovani+huffman}
const JmenoProgramu='ce~s';
type poradityp=record pocet1:word;por1:byte;end;
var
    FromF,ToF: file;
    jmeno1,jmeno2:string;
    Nacteno, Zapsano, NactenoX, ZapsanoX: Word;
    vstbuf: array[1..5000] of char;
    vystbuf: array[1..5001] of char;
    outbuf1: array[1..5001] of byte;
    mapa: array[1..10000] of byte;
    Konec:boolean;
    pocet:array[0..3] of word;
    pocet_poradi:array[0..3] of poradityp;
    komprimovat:boolean;
    a,b,c,d:word;
    e,f:byte;
    ovl_byte:word;ovl_bit:byte;
    tabulka:array[0..3] of record t_data:string;t_pocet:byte;end;
const tabmax=3;

procedure chyba;
begin
  writeln('pr.: ',jmenoprogramu,' "vstsoubor.pripona" "vystsoubor.prip" "funkce"');
  writeln('pozn.: soubor+pripona = max. 12 znaku');
  writeln('fce: k = koduj                     d = dekoduj');
  halt;
end;

procedure otevri;
var soub:file;
begin
  write('Otevri');
  {$I-} Assign(soub, jmeno1);Reset(soub);Close(soub); {$I+}
  if IOResult<>0 then begin writeln('> Vstupni soubor nenalezen.');chyba;end;

  Assign(FromF,jmeno1);Reset(FromF,1);
  Assign(  ToF,jmeno2);Rewrite(ToF,1);
end;

procedure zavri;
begin
  write('Zavri');
  Close(FromF);
  Close(ToF);
end;

procedure nacti_blok;
begin
  write('Nacti blok');
  BlockRead(FromF,VstBuf,SizeOf(VstBuf),Nacteno);
  if Nacteno=0 then Konec:=false;
end;

procedure zapis_blok;
begin
  write('Zapis blok');
    BlockWrite(ToF,VystBuf,ZapsanoX,Zapsano);
    if Zapsano<>ZapsanoX then
      begin
        writeln('>Chyba pri zapisu (mozny nedostatek mista na disku).');
        chyba;
      end;
end;

procedure spocitej;
var s_a:word;s_b:byte;s_c:byte;
begin
  pocet[0]:=0;
  pocet[1]:=0;
  pocet[2]:=0;
  pocet[3]:=0;
  for s_a:=1 to nacteno do
    begin
      s_b:=ord(vstbuf[s_a]);
      s_c:=s_b shr 6;
      inc(pocet[s_c]);

      s_c:=s_b shr 4;
      asm
         and       s_c,00000011b
      end;
      inc(pocet[s_c]);

      s_c:=s_b shr 2;
      asm
         and       s_c,00000011b
      end;
      inc(pocet[s_c]);

      s_c:=s_b;
      asm
         and       s_c,00000011b
      end;
      inc(pocet[s_c]);
    end;
end;

procedure poradi;
var p_b:poradityp;
begin
  for e:=0 to 3 do begin pocet_poradi[e].pocet1:=pocet[e];pocet_poradi[e].por1:=e;end;
  if pocet_poradi[0].pocet1<pocet_poradi[1].pocet1 then
    begin p_b:=pocet_poradi[1];pocet_poradi[1]:=pocet_poradi[0];pocet_poradi[0]:=p_b;end;
  if pocet_poradi[2].pocet1<pocet_poradi[3].pocet1 then
    begin p_b:=pocet_poradi[3];pocet_poradi[3]:=pocet_poradi[2];pocet_poradi[2]:=p_b;end;
  if pocet_poradi[1].pocet1<pocet_poradi[2].pocet1 then
    begin p_b:=pocet_poradi[2];pocet_poradi[2]:=pocet_poradi[1];pocet_poradi[1]:=p_b;end;
  if pocet_poradi[0].pocet1<pocet_poradi[1].pocet1 then
    begin p_b:=pocet_poradi[1];pocet_poradi[1]:=pocet_poradi[0];pocet_poradi[0]:=p_b;end;
  if pocet_poradi[2].pocet1<pocet_poradi[3].pocet1 then
    begin p_b:=pocet_poradi[3];pocet_poradi[3]:=pocet_poradi[2];pocet_poradi[2]:=p_b;end;
end;

procedure textiky(pro_a:word);
begin
writeln;
writeln(pocet[0],' ',pocet_poradi[0].por1);
writeln(pocet[1],' ',pocet_poradi[1].por1);
writeln(pocet[2],' ',pocet_poradi[2].por1);
writeln(pocet[3],' ',pocet_poradi[3].por1);
writeln('kontrolni soucet: ',pocet[0]+pocet[1]+pocet[2]+pocet[3],'/',nacteno shl 2,'(dvojic*2=Bite)');

a:=(pro_a shr 1);
b:=a-pocet[pocet_poradi[0].por1];
c:=b-pocet[pocet_poradi[1].por1];
a:=1*a+2*b+3*c + 4*8+1;          {bitu}
writeln('celkem: ',a,'/',a shr 3,' ...priblizna komprimace');
end;

procedure do_vystupu(co_dat:byte); {podle tabulky pro kombinaci}
var d_a,d_b,d_c:byte;d_d:word;d_str:string[1];
begin
  for d_a:=0 to tabulka[co_dat].t_pocet do
    begin
      if ovl_bit=0 then outbuf1[ovl_byte]:=0;
      d_str:=copy(tabulka[co_dat].t_data,d_a,1);
      if d_str='1' then
        begin
          d_b:=1;
          d_b:=d_b shl ovl_bit;
          outbuf1[ovl_byte]:=outbuf1[ovl_byte]+d_b;
        end;
      inc(ovl_bit);
      if ovl_bit=8 then begin ovl_bit:=0;inc(ovl_byte);end;
    end;
end;
procedure do_mapy(co_dat:boolean); {0/1}
var m_b:byte;
begin
  if ovl_bit=0 then mapa[ovl_byte]:=0;
  if co_dat=true then
    begin
      m_b:=1;
      m_b:=m_b shl ovl_bit;
      mapa[ovl_byte]:=mapa[ovl_byte]+m_b;
    end;
  inc(ovl_bit);
  if ovl_bit=8 then begin ovl_bit:=0;inc(ovl_byte);end;
end;

procedure podminka_mapy(podm:word;pm_co:byte);
begin
  case podm of
    1: if pm_co=pocet_poradi[0].por1 then do_mapy(true) else do_mapy(false);
    2: begin
         if pm_co=pocet_poradi[1].por1 then do_mapy(true);
         if (pm_co=pocet_poradi[2].por1) or (pm_co=pocet_poradi[3].por1) then do_mapy(false);
       end;
    2: begin
         if pm_co=pocet_poradi[2].por1 then do_mapy(true);
         if pm_co=pocet_poradi[3].por1 then do_mapy(false);
       end;
   end;
end;

procedure m_spocitej;
var s_a:word;s_b:byte;s_c:byte;
begin
  pocet[0]:=0;
  pocet[1]:=0;
  pocet[2]:=0;
  pocet[3]:=0;
  for s_a:=1 to OVL_BYTE do
    begin
      s_b:=mapa[s_a];
      s_c:=s_b shr 6;
      inc(pocet[s_c]);

      s_c:=s_b shr 4;
      asm
         and       s_c,00000011b
      end;
      inc(pocet[s_c]);

      s_c:=s_b shr 2;
      asm
         and       s_c,00000011b
      end;
      inc(pocet[s_c]);

      s_c:=s_b;
      asm
         and       s_c,00000011b
      end;
      inc(pocet[s_c]);
    end;
end;

Procedure CompK;
begin
    zapsanox:=0;
    spocitej;
     poradi;
textiky(nacteno);

  {mapovani}
  ovl_byte:=1;
  ovl_bit:=0;
  for b:=1 to 3 do
  for a:=1 to nacteno do
    begin
      e:=ord(vstbuf[a]);
      f:=e shr 6;
        podminka_mapy(b,f);
      f:=e shr 4;
      asm
         and       f,00000011b
      end;
        podminka_mapy(b,f);
      f:=e shr 2;
      asm
         and       f,00000011b
      end;
        podminka_mapy(b,f);
      f:=e;
      asm
         and       f,00000011b
      end;
        podminka_mapy(b,f);
    end;

    {pozn. Zapamatovat pocty+ (ovl_byte pro m_spocitej}
    m_spocitej;
     poradi;
textiky(ovl_byte);
  ovl_byte:=1;
  ovl_bit:=1;   {... if komprim.. ovl_bit:=0 ovl_byte:=1 !!! SET to 0/1}
    {u nekomprim bude asi rychlejsi zapsat cely BYTE}


{    begin vystbuf[c]:=chr(ord(vstbuf[(a-1)*3+d]));inc(c);end;}
     komprimovat:=false;
     for a:=1 to 40 do vystbuf[a]:=chr(outbuf1[a]);
end;



procedure koduj_vse;
begin
  Konec:=True;
  repeat
    Nacti_Blok;
    if Konec<>False then
      begin CompK;if zapsanoX<>0 then Zapis_Blok;ZapsanoX:=0;end;
  until Konec=False;
end;


begin
  jmeno1:=ParamStr(1);
  jmeno2:=ParamStr(2);
  if (jmeno1=jmeno2) or (jmeno1='') or (jmeno2='') then
   begin writeln('> Chyba v zadavani jmen souboru.');chyba;end;

  Otevri;
  Koduj_Vse;
  Zavri;
end.

