Кодирование методом Хаффмана и Фано

uses crt;
type
  mas=array[1..100]of real;
  var tex:text;
      s:array[1..10000]of char;
      sum,tmp:real;
      i,j,n:byte;
      a,kl:array[1..100]of integer;
      p:array[1..100]of real;
      c:array[1..50,1..50] of 0..1;
      kol:integer;
      bol:boolean;
  function delen(b,e:byte):byte;
  var i,m:byte;
      sb,se,d:real;
  begin
   sb:=0;
         for i:=b to e-1 do
             sb:=sb+p[i];
    se:=p[e];
    m:=e;
    repeat
         d:=sb-se;
         m:=m-1;
         sb:=sb-p[m];
         se:=se+p[m];
    until abs(sb-se)>=d;
    delen:=m;
  end;
  procedure fano(b,e,k:byte);
  var m,i:byte;
  begin
     if e>b then
      begin
           inc(k);
           m:=delen(b,e);
           for i:=b to e do
               if i>m then begin c[i,k]:=1; inc(kl[i]); end
               else begin c[i,k]:=0; inc(kl[i]); end;
           fano(b,m,k);
           fano(m+1,e,k);
      end;
  end;
  procedure cena_kod;
  var kod:real;i:integer;
  begin
   kod:=0;
   for i:=1 to n do kod:=kod+kl[i]*p[i] ;
   writeln;
   write('cena koda: ',kod:4:3);
  end;
  procedure fail;
  var t,l:boolean;
      d:integer;
      i,j,h,k:integer;
  begin
   k:=1;
   n:=0;
   kol:=0;
   assign(tex,'222.txt');
   reset(tex);
   while not Eoln(tex)do
     begin
      inc(kol);
      read(tex,s[kol]);
     end;
  writeln('Кол-во символов:',kol);
   while not Eoln(tex) do
     for i:=1 to kol do read(tex,s[i]);
   for i:=1 to kol do
   begin
     for j:=i to kol do
       begin
        t:=true;
        for h:=1 to i-1 do
          if (s[i]=s[i-h]) then
                                begin
                                 t:=false;
                                 break;
                                end
                             else t:=true;
    if (s[i]=s[j])and(t=true) then  a[k]:=a[k]+1;
   end;
   inc(k);
  end;
  close(tex);
  for i:=1 to kol do  write(s[i],' ');
  writeln;
  for k:=1 to kol do   write(a[k],' ');
  for k:=1 to kol do
     if a[k]<>0 then n:=n+1;
  i:=1;
  for k:=1 to kol do
    if a[k]<>0 then
     begin
      a[i]:=a[k];
      inc(i);
     end;
  while  l do
   begin
    l:=false;
    for i:=1 to n-1 do
     if a[i]<a[i+1] then
      begin
       d:=a[i+1];
       a[i+1]:=a[i] ;
       a[i]:=d;
       l:=true;
      end;
   end;
  writeln;
  end;
  begin
  clrscr;
  fail;
  sum:=0;
  for i:=1 to n do
    begin
     p[i]:=a[i]/kol;
     sum:=sum+p[i];
    end; 
  repeat
     bol:=false;
     for i:=1 to n-1 do
          if p[i]<p[i+1] then
                         begin
                         bol:=true;
                         tmp:=p[i];
                         p[i]:=p[i+1];
                         p[i+1]:=tmp;    
                         end;
until bol=false;
  for i:=1 to n do writeln('p[',i:2,']=  ',p[i]:4:3);
   writeln;
      fano(1,n,0);
      for i:=1 to n do
       begin
          for j:=1 to kl[i] do write(c[i,j]);
          writeln;
       end;
  cena_kod;
  readkey;
  end.