program haffman;
USES CRT;
Label link1;
Var S, R:array[1..7] of integer; {начальный массив и упорядоченный}
    wordshifr:array[1..10] of string;
{шифрованное двоичным кодом слово}
    stroka, st, word:string; 
{stroka - то что вводим, st - путь, word - слово для шифрования}
    f:file;
    z, x, c, v, b, n, m, def:Char; 
{символы алфавита, def - символ, который читается из заданной строки. для сравнения с символами данного алфавита}
    n1, n2, n3, n4, n5, n6, n7, symbol: integer; 
{количество символов, symbol - меняется в цикле для записи количества символов }
    shag, min:integer; 
{счетчик шагов цикла, min - минимальное число в начальном массиве}
    z1, x1, c1, v1, b1 ,n1 ,m1:string;
{двоичные коды символов}

begin
ClrScr;
{объявляем переменные}
z:=z;
x:=x;
c:=c;
v:=v;
b:=b;
n:=n;
m:=m;
n1:=0;
n2:=0;
n3:=0;
n4:=0;
n5:=0;
n6:=0;
n7:=0;

{считаем строку для составления алгоритма Хаффмана}
write('vvedite stroku iz bukv z,x,c,v,b,n,m');
readln(stroka);
{укажем файл}
write('ukajite put k failu i ego imya -');
readln(st);
Assign(f, st);
rewrite(f);
write(f, stroka);
{посчитаем количество каждого из 7 символов}
while not eof(f) do
                 begin
                 read(f,def);
                 if def=z then n1:=n1 + 1;
                 if def=x then n1:=n2 + 1;
                 if def=c then n1:=n3 + 1;
                 if def=v then n1:=n4 + 1;
                 if def=b then n1:=n5 + 1;
                 if def=n then n1:=n6 + 1;
                 if def=m then n1:=n7 + 1;
                 end;

close(f);

{запишем в первый массив все полученные количества символов}
symbol:=n1;
{объявим symbol = n1 , чтобы записать количество символов Z в первую ячейку}
link1:
for shag:=1 to 7 do
                 begin
                 S[shag]:=symbol;
                 if symbol=n1 then symbol:=n2;
                 GOTO link1;
                 if symbol=n2 then symbol:=n3;
                 GOTO link1;
                 if symbol=n3 then symbol:=n4;
                 GOTO link1;
                 if symbol=n4 then symbol:=n5;
                 GOTO link1;
                 if symbol=n5 then symbol:=n6;
                 GOTO link1;
                 if symbol=n6 then symbol:=n7;
                 GOTO link1;
                 if symbol=n7 then symbol:=n7;
                 end;
{получили массив, заполненный целыми числами = количеству каждого символа в строке}
{перенесем элементы массива в порядке убывания}
for shag:=1 to 7 do begin                 
                 while (shag+1)<=7 do
                        begin
                        If S[shag]<S[shag+1] then min:=S[shag];
                        end;
                        R[8-shag]:=min;
                    end;
z1:="0";
x1:="10";
c1:="110";
v1:="1110";
b1:="11110";
n1:="111110";
m1:="1111111";
{получили коды символов}
write('napishite slovo, sostoyachee iz bukv alfavita, chtobi zashifrovat ego - ');
Readln(word);

Assign(f, 'C:\811\recent.txt');
rewrite(f);
write(f, word);

{шифруем слово}
shag:=1;
while not eof(f) do
                 begin
                 read(f,def);
                 if def=z then wordshifr[shag]:=z1;
                 if def=x then wordshifr[shag]:=x1;
                 if def=c then wordshifr[shag]:=c1;
                 if def=v then wordshifr[shag]:=v1;
                 if def=b then wordshifr[shag]:=b1;
                 if def=n then wordshifr[shag]:=n1;
                 if def=m then wordshifr[shag]:=m1;
                 shag:=shag+1;
                 end;
close(f);
write('slovo ',word,'zashifrovano! rezultat - ');
writeln(wordshifr);
end.

program huffman;

const sb=256;

type obr=record
      vl:longint;
      len:byte
     end;
     
var a:array[0..511]of longint;
    b:array[byte]of word;
    c:array[0..1,byte]of word;
    st:array[byte]of byte;
    j,obc:byte;
    f,g:file;
    obb,size:longint;
    brp,brm,bwp:word;
    bufr,bufw:array[0..sb-1]of byte;
    reof:boolean;
    o:array[byte]of obr;
    
    
procedure opget(var f:file;s:string);
begin
 assign(f,s);
 reset(f,1);
 blockread(f,bufr,sb,brm)
end;


procedure init;
begin
 brp:=0;
 brm:=0;
 bwp:=0;
 obb:=0;
 obc:=0;
 reof:=false
end;


procedure putc(var f:file;b:byte);
begin
 if bwp=sb then begin blockwrite(f,bufw,sb); bwp:=0 end;
 bufw[bwp]:=b;
 inc(bwp)
end;


procedure clput(var f:file);
begin
 putc(f,obb shr 24);
 blockwrite(f,bufw,bwp);
 close(f)
end;


procedure out(var out:file;ch:byte);
var glk:byte;
begin
 obb:=obb or o[ch].vl shl (32-o[ch].len-obc);
 inc(obc,o[ch].len);
 while obc>=8 do begin
  glk:=obb shr 24;
  putc(out,glk);
  obb:=obb shl 8;
  dec(obc,8)
 end
end;


procedure sift(l,r:word);
var i,j,x:word;
begin
 i:=l; j:=l+l+1; x:=b[l];
 if (j<r)and(a[b[j]]>a[b[j+1]])then inc(j);
 while (j<=r)and(a[x]>=a[b[j]])do begin
  b[i]:=b[j]; i:=j; j:=j+j+1;
  if (j<r)and(a[b[j]]>a[b[j+1]])then inc(j)
 end;
 b[i]:=x
end;


procedure obh(i:word;p:byte);
begin
 if i<256 then begin
  o[i].len:=p;
  o[i].vl:=0;
  for j:=0 to p-1 do o[i].vl:=o[i].vl shl 1+st[j]
 end
 else begin
  st[p]:=0;
  obh(c[0,i-256],p+1);
  st[p]:=1;
  obh(c[1,i-256],p+1)
 end
end;
procedure build;
var i,p:word;
begin
 for i:=0 to 255 do b[i]:=i;
 for i:=127 downto 0 do sift(i,255);
 p:=0;
 for i:=255 downto 1 do begin
  c[0,p]:=b[0];
  b[0]:=b[i];
  sift(0,i-1);
  c[1,p]:=b[0];
  b[0]:=p+256;
  a[p+256]:=a[c[0,p]]+a[c[1,p]];
  sift(0,i-1);
  inc(p)
 end;
 obh(p+255,0)
end;


procedure getc(var f:file);
var ch:byte;
begin
 ch:=bufr[brp];
 out(g,ch);
 inc(a[ch]);
 inc(brp);
 if brp=brm then begin
  if eof(f) then reof:=true else build;
  blockread(f,bufr,sb,brm); brp:=0
 end
end;



begin
 init;
 opget(f,paramstr(1));
 size:=filesize(f);
 assign(g,'test.glk');
 rewrite(g,1);
 blockwrite(g,size,4);
 for j:=0 to 255 do a[j]:=1;
 build;
 while not reof do getc(f);
 clput(g)
end.