Написать программу, осуществляющую шифровку текста по алгоритму Фано

Type
  tM = Record
         Ch  : Char;
         Ss  : Longint;
         Cod : Byte;
       end;
Var
  i,j,N,k : Byte;
  m       : array [0..255] of tM;
  mm      : tM;
  St,Sb   : String;
  f       : Text;
  fb      : File of Byte;
 
Function IntToBin(A : Longint) : String;
Var
  S : String;
  n : Longint;
Begin
  S:=''; n:=A;
  While n>0 do
  Begin
    S:=Chr(Ord('0')+(n mod 2))+S;
    n:=n div 2;
  end;
  IntToBin:=S;
end;
 
Function k2(k : Byte) : Longint; { 2 в сетепени k }
Begin
  If k>0 then k2:=2*k2(k-1)
  else k2:=1;
end;
 
Function BinToInt(S : String) : Byte{Longint};
Begin
  If Length(S)>1 then
    BinToInt:=(Ord(S[1])-Ord('0'))*k2(Length(S)-1)+BinToInt(Copy(S,2,Length(S)-1))
  else
    BinToInt:=Ord(S[1])-Ord('0');
end;
 
Function BitExpand(bi : String; kk : Byte) : String;
Var bitS : String;
Begin
  bitS:=bi;
  While Length(bitS)<kk do bitS:='0'+bitS;
  BitExpand:=bitS;
End;
 
Function SearchCh(SChar : Char) : Byte;
Var nm : Byte;
Begin
  For nm:=0 to 255 do
    If m[nm].Ch=SChar then
    Begin
      SearchCh:=nm;
      Break;
    end;
end;
 
Begin
  { Readln(St);      }
  { или              }
  { St:=ParamStr(1); }
  { или              }
  {}St:='c:\RHDSetup.log';{}
  
  Assign(f,St);
  Assign(fb,'c:\RHDSetup.cod');
  
  For i:=0 to 255 do
  Begin
    m[i].Ch:=Chr(i);
    m[i].Ss:=0;
  End;
  
  Reset(f);
  While Not EOF(f) do
  Begin
    Readln(f,St);
    For i:=1 to Length(st) do Inc(m[Ord(St[i])].Ss);
  End;
  Close(f);
  
  For i:=0 to 254 do
   For j:=i+1 to 255 do
     If m[j].Ss>m[i].Ss then
     Begin
       mm:=m[j];
       m[j]:=m[i];
       m[i]:=mm;
     End;
  For N:=255 downto 0 do If m[n].Ss<>0 then Break;
  
{-temp- Writeln(ln(N)/ln(2)); -}
  k:=Trunc(ln(N)/ln(2));
  If (ln(N)/ln(2))-k>0.000001 then Inc(k);
{-temp- Writeln(k);           -}
  
  For i:=0 to N do m[i].Cod:=i;
  
  Reset(f);
  ReWrite(fb);
  sb:='';
  While not EOF(f) do
  Begin
    Readln(f,St);
    For i:=1 to Length(St) do
    Begin
      sb:=sb+BitExpand(IntToBin(m[SearchCh(St[i])].Cod),k);
      While Length(sb)>=8 do
      Begin
        Write(fb,BinToInt(Copy(sb,1,8)));
        Delete(sb,1,8);
      End;
    end;
  end;
  If Length(sb)>0 then Write(fb,BinToInt(sb));
  Close(fb);
  Close(f);
  
//  Writeln('Chastiy symbol: ',m[0].Ch,' - ',m[0].Ss);
//  For i:=0 to 255 do
//    If m[i].Ss>0 then Writeln(m[i].Ch,' - ',m[i].Ss)
End.

Type
  tM = Record
         Ch  : Char;
         Ss  : Longint;
         Cod : Byte;
       end;
Var
  i,j,N,k : Byte;
  m       : array [0..255] of tM;
  mm      : tM;
  St,Sb   : String;
  f       : File of Char;
  fb      : File of Byte;
  CCh     : Char;
 
Function IntToBin(A : Longint) : String;
Var
  S : String;
  n : Longint;
Begin
  S:=''; n:=A;
  While n>0 do
  Begin
    S:=Chr(Ord('0')+(n mod 2))+S;
    n:=n div 2;
  end;
  IntToBin:=S;
end;
 
Function k2(k : Byte) : Longint; { 2 в сетепени k }
Begin
  If k>0 then k2:=2*k2(k-1)
  else k2:=1;
end;
 
Function BinToInt(S : String) : Byte{Longint};
Begin
  If Length(S)>1 then
    BinToInt:=(Ord(S[1])-Ord('0'))*k2(Length(S)-1)+BinToInt(Copy(S,2,Length(S)-1))
  else
    BinToInt:=Ord(S[1])-Ord('0');
end;
 
Function BitExpand(bi : String; kk : Byte) : String;
Var bitS : String;
Begin
  bitS:=bi;
  While Length(bitS)<kk do bitS:='0'+bitS;
  BitExpand:=bitS;
End;
 
Function SearchCh(SChar : Char) : Byte;
Var nm : Byte;
Begin
  For nm:=0 to 255 do
    If m[nm].Ch=SChar then
    Begin
      SearchCh:=nm;
      Break;
    end;
end;
 
Function SearchCod(SCod : Byte) : Byte;
Var nm : Byte;
Begin
  For nm:=0 to 255 do
    If m[nm].Cod=SCod then
    Begin
      SearchCod:=nm;
      Break;
    end;
end;
 
 
Begin
  { Readln(St);      }
  { или              }
  { St:=ParamStr(1); }
  { или              }
  {}St:='c:\RHDSetup.log';{}
  
  Assign(f,St);
  Assign(fb,'c:\RHDSetup.cod');
  
  For i:=0 to 255 do
  Begin
    m[i].Ch:=Chr(i);
    m[i].Ss:=0;
  End;
  
  Reset(f);
  While Not EOF(f) do
  Begin
    Read(f,CCh);
    Inc(m[Ord(CCh)].Ss);
  End;
  Close(f);
  
  For i:=0 to 254 do
   For j:=i+1 to 255 do
     If m[j].Ss>m[i].Ss then
     Begin
       mm:=m[j];
       m[j]:=m[i];
       m[i]:=mm;
     End;
  For N:=255 downto 0 do If m[n].Ss<>0 then Break;
  
{-temp- Writeln(ln(N)/ln(2)); -}
  k:=Trunc(ln(N)/ln(2));
  If (ln(N)/ln(2))-k>0.000001 then Inc(k);
{-temp- Writeln(k);           -}
  
  For i:=0 to N do m[i].Cod:=i;
  
  Reset(f);
  ReWrite(fb);
  sb:='';
  While not EOF(f) do
  Begin
    Read(f,CCh);
 
      sb:=sb+BitExpand(IntToBin(m[SearchCh(CCh)].Cod),k);
      While Length(sb)>=8 do
      Begin
        Write(fb,BinToInt(Copy(sb,1,8)));
        Delete(sb,1,8);
      end;
 
  end;
  If Length(sb)>0 then Write(fb,BinToInt(sb));
  Close(fb);
  Close(f);
  
  {--== DECODE ==--}
  Assign(f,'c:\RHDSetup.txt');
  ReWrite(f);
  Reset(fb);
  sb:='';
  While not EOF(fb) do
  Begin
    Read(fb,j);
    sb:=sb+BitExpand(IntToBin(j),8);
    While Length(sb)>=k do
      Begin
        Write(f,m[SearchCod(BinToInt(Copy(sb,1,k)))].Ch);
        Delete(sb,1,k);
      End;
      
  end;
  If Length(sb)>0 then Write(f,m[SearchCod(BinToInt(Copy(sb,1,k)))].Ch);
  Close(fb);
  Close(f);
  
  
//  Writeln('Chastiy symbol: ',m[0].Ch,' - ',m[0].Ss);
//  For i:=0 to 255 do
//    If m[i].Ss>0 then Writeln(m[i].Ch,' - ',m[i].Ss)
End.