{-------------------类型定义---------------------------------}
   type
       aset=set of char;
       chrecord=record
               data:integer;
                 ch:char;
               end;
  intar=array[0..51]of chrecord;{英文字母有26个}
  charar=array ['a'..'z']of integer;
  nodetype=record
           weight:integer;
           parent,lch,rch:0..51;{说需的节点最多为51个}
           ch:char;
           flag:0..1;
           end;
  bit=0..1;
  codetype=record
           bits:array[1..26]of bit;
           start:1..26;
           ch:char;
           end;
  hufftree=array[1..51]of nodetype;
  huffcode=array[1..26]of codetype;
   var i,j,m,n:integer;
       ar:intar;
       ht:hufftree; hcd:huffcode;
       hnode:nodetype;
{---------------------------过程定义-------------------------}   procedure createweight(var ar:intar;var n,m:integer);
      var ch:char;
          cch:charar;
          a:aset;
      begin
         i:=1;   n:=0;
         a:=[];
         for ch:='a' to 'z' do
         cch[ch]:=0;
       while not eof do
             begin
             read(ch);
             cch[ch]:=cch[ch]+1;
             a:=a+[ch];
             end;        for ch:='a' to 'z' do
              begin
              if ch in a then
                  begin
                  ar[i].data:=cch[ch];
                  ar[i].ch:=ch;
                 i:=i+1;
                  end;
                  n:=i-1;    m:=2*n - 1;
              end;
        end;     procedure huffmantree(var ht:hufftree);{初始化huffman树}
            var i:integer;
            begin
            for i:=1 to m do
               begin
               ht[i].parent:=0;
               ht[i].lch:=0;
               ht[i].rch:=0;
               end;
            for i:=1 to n do
                begin
                  ht[i].weight:=ar[i].data;
                  ht[i].ch:=ar[i].ch;
                end;
           end;{结束初始化}
     procedure  select(g:integer; var s1,s2:integer);
       var j,k:integer;{从数组[1。。g]中选取两个权值小的分别赋给s1,s2}
       begin
      j:=1;
       while ht[j].flag <> 0 do
           j:=j+1;    {flag = 0 表示未被访问过,如果第一个数在以前曾被访问过
                   那么这个数肯定不是所需的,所以j后移}
        s1:=j;     s2:=j;
        for k:=j+1 to g do
           if ( ht[k].flag = 0 )and (ht[k].weight < ht[s1].weight ) then
            s1:=k; {最后的到的s1为以前没访问过的最小值}
          ht[s1].flag:= 1;  {标记数组中第s1个元素已访问过}
          for k:= j+1 to g do
           if ( ht[k].flag = 0 )and (ht[k].weight < ht[s2].weight ) then
           s2:=k;
       ht[s2].flag:=1;   end;
    procedure joinweight;{ht为哈夫曼树}
          var i,s1,s2:integer;
         begin
          for i:=n+1 to m+1 do begin
             select(i-1,s1,s2);
             ht[s1].parent:=i;
             ht[s2].parent:=i;
             ht[i].lch:=s1;
             ht[i].rch:=s2;
             ht[i].weight:=ht[s1].weight + ht[s2].weight;                             end;        end;
        procedure huffmancode(var hcd:huffcode) ;
          var cd:codetype;i,j,c,f:integer;
          begin
            for i:=1 to n do  begin
                cd.start:=n;
             c:=i; f:=ht[c].parent; cd.ch:=ht[c].ch;
             while f<>0 do                                begin
               if ht[f].lch=0 then cd.bits[cd.start]:=0
                  else cd.bits[cd.start]:=1;
               cd.start:=cd.start - 1;
               c:=f;
               f:=ht[f].parent;                           end;
               hcd[i]:=cd;          end ;for i:= 1 to n do begin
                 write(hcd[i].ch);
                for j:= n-hcd[i].start to n do
                write(' ',hcd[i].bits[j]);writeln;
                                  end;
        end;
     {---------------------------下面是主程序---------------------------------}        begin
    writeln('*****************************************************************************');
        writeln(strin);
        writeln('*****************************************************************************');
        writeln('WARNING!');
        writeln('place input your telegram characters and with ctrl+z to stop');{以ctrl+z结束输入}
        createweight(ar,n,m);
        for i:= 1 to m do
         ht[i].flag:=0;
     huffmantree(ht);
      joinweight;
     for i:= 1 to m do
       writeln(ht[i].ch,'  weight  ',ht[i].weight,' parent ',ht[i].parent,' lch  ',ht[i].lch,'  rch  ',ht[i].rch);
{       huffmancode(hcd);}
         writeln('-------this is the end-----');
        end.好象是山农大的一人写的偶不知道该怎么在DELPHI里运行。。
最近想在DELPHI里学算法。。无从下手的感觉。
谢谢