Написать программу для кодирования методом Шеннона - Фано

program code;
type
  mas=array[0..100]of integer;
  mass=array[0..100,0..100]of char;
var start,stop,l,g_level,i,j:integer;
    a:mas; b:mass;
 
procedure shannon(var start_pos,end_pos:integer; aa:mas; bb:mass; level:integer);
var i,j,k:integer; isum,jsum:array[0..10000]of integer;
begin
  if level > g_level then g_level:=level;
  while i<(j-1) do begin
    while((isum[i]>jsum[j]) and (i<(j-1))) do begin
      j:=j-1;
      jsum[j]:=jsum[j]+aa[j];
    end;
    while ((isum[i]<jsum[j]) and (i<(j-1))) do begin
      inc(i);
      isum[i]:=isum[i]+aa[i];
    end;
   end;
   if i=start then bb[start,level]:=('0')
              else if ((i-start)>=1) then begin
                                          for k:=start to i do
                                                              bb[k,level]:=('0');
                                          shannon(start,i,a,bb,level+1);  
                                          end;
end;
 
 
 
 
 
 
 
 
 
 
 
begin
start:=0;
stop:=8;
l:=1;
a[1]:=4; a[2]:=6; a[3]:=6; a[4]:=3; a[5]:=1; a[6]:=2; a[7]:=2; a[8]:=1;
for i:=0 to 7 do
  for j:=0 to 7 do b[i,j]:=('x');
 
shannon(start,stop,a,b,l);
 
for i:=0 to 7 do begin
 for j:=0 to 7 do write(b[i,j],' ');
 writeln;
 end;
 
end.

program Shennon;
type
  mas=array[1..100]of real;
  var tex:text;
      s,qq:array[1..10000]of char;
      sum,tmp,p1:real;
      i,j,jj,k,n:byte;
      a,l:array[1..100]of integer;
      p,q:array[1..100]of real;
      c:array[1..100] of string;
      kol,d,h:integer;
      bol,t:boolean;
      tmp1:char;
begin
   jj:=1;
   k:=1;
   n:=0;
   kol:=0;
   assign(tex,'d:\2.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]:2); //Вывод символов в файле
  writeln;
  for k:=1 to kol do begin
                      write(a[k]:2); //Вывод колличества каждого символа в файле
                      if a[k]>0 then begin
                                      qq[jj]:=s[k];
                                      inc(jj);
                                     end;
                     end;
  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;
  writeln;
 
  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];
                         tmp1:=qq[i];
                         p[i]:=p[i+1];
                         qq[i]:=qq[i+1];
                         p[i+1]:=tmp;
                         qq[i+1]:=tmp1;
                         end;
until bol=false;
   writeln;
//вычисления
 for i:=2 to n do
  begin
   q[i] := q[i-1]+p[i-1]; //Подсчёт вероятности обратного события
  end;
 for i:=1 to n do
  begin //Подсчёт длины кодового слова
   repeat
    if exp(ln(2)*d)>p[i]
     then d := d-1;
   until (exp(ln(2)*d)<=p[i]);
   l[i] := abs(d);
   d := 0;
  end;
 for i:=1 to n do
  begin //Составление кодового слова
   for j:=1 to l[i] do
    begin
     if j=1
      then p1 := q[i]*2
      else p1 := p1*2;
     if (trunc(p1) > 1)
      then p1 := p1 - 2;
     if (trunc(p1) = 1)
      then c[i] := c[i] + '1'
      else c[i] := c[i] + '0';
    end;
  end;
for i:=1 to n do
q[i]:=1-p[i];  
for i:=1 to n do writeln('p[',qq[i]:2,']=',p[i]:4:3,'  q[',qq[i]:2,']=',q[i]:1:3,'  l[',qq[i]:2,']=',l[i],'  c[',qq[i]:2,']=',c[i]:5);
end.