huffmann.~pas

Hoffman编码

unit Huffmann;

interface


uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

const n=6;m=2*n-1;
      s=100;


type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Memo1: TMemo;
    Button1: TButton;
    Memo2: TMemo;
    Memo3: TMemo;
    Button2: TButton;
    Edit2: TEdit;
    Memo4: TMemo;
    Label1: TLabel;
    procedure Edit1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Edit2KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Button2Click(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }
  end;

  nodetype=record
           weight:integer;
           parent,lch,rch:0..m;
           end;

  codetype=array[0..n]of integer;
  hfmt=array[1..m]of nodetype;
  hfmcd=array[1..n]of codetype;
  doubleinteger=record
               S1,S2:integer;
               end;
var
  Form1: TForm1;
  w:array[1..n]of integer;
  ht:hfmt;
  hcd:hfmcd;
  P,Q:integer;
  cd:codetype;
  code:array[1..s]of integer;
implementation

{$R *.dfm}
function select(x:integer):doubleinteger;
var i,a,b:integer;
begin
   i:=1;
   while ht[i].parent<>0 do i:=i+1;
   a:=i;
   while i<=x do begin
      if (ht[i].parent=0) and (ht[i].weight<ht[a].weight)then a:=i;
      i:=i+1;
      end;
   i:=1;
   while (ht[i].parent<>0)or(a=i) do i:=i+1;
   b:=i;
   while i<=x do
   begin
     if (i<>a) and (ht[i].parent=0) and (ht[i].weight<ht[b].weight)then b:=i;
      i:=i+1;
      end;
   select.S1:=a;
   select.S2:=b;
end;


procedure Initialize(w:array of integer);
var i:integer;
begin
   for i:=n+1 to m do
   begin
      ht[i].weight:=0;
      ht[i].parent:=0;
      ht[i].lch:=0;
      ht[i].rch:=0;
   end;
   for i:=1 to s do code[i]:=9;
end;



procedure huffmanncode;
var a,b,i,j,c,q,f:integer;
begin
   for i:=n+1 to m do
   begin
      a:=select(i-1).S1;
      b:=select(i-1).S2;

      ht[a].parent:=i;ht[b].parent:=i;
      ht[i].lch:=a;ht[i].rch:=b;
      ht[i].weight:=ht[a].weight+ht[b].weight;
      ht[i].parent:=0;
   end;

   for i:=1 to n do
   begin
      c:=i;f:=ht[c].parent;j:=n;
      for q:=0 to n do
      cd[q]:=9;
      while f<>0 do
          begin
             if ht[f].lch=c then cd[j]:=0 else cd[j]:=1;
             j:=j-1; c:=f; f:=ht[c].parent;
          end;
      cd[0]:=n-j;
      hcd[i]:=cd;
    end;
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
P:=1;
Q:=1;
end;

procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
if (Key=VK_RETURN) then
  begin
    if Edit1.Text <>'' then
      w[P]:=strtoint(Edit1.Text);
      Edit1.Text := '';
    Memo1.Text:=Memo1.Text+inttostr(w[P])+'  ';
      ht[P].weight:=w[P];
      ht[P].parent:=0;
      ht[P].lch:=0;
      ht[P].rch:=0;
          P:=P+1;
   end;
end;


procedure TForm1.Button1Click(Sender: TObject);
var i,j:integer;
    S:string;
begin
 S:='';
 Initialize(w);
 huffmanncode;
 for i:=1 to n do
 begin
 S:='';
 for j:=1 to n do if hcd[i][j]<>9 then
 S:=S+inttostr(hcd[i][j]);
 memo2.Text:=memo2.Text+inttostr(i)+':'+S+';   ';
 end;
end;






procedure TForm1.Edit2KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
if (Key=VK_RETURN) then
  begin
      code[Q]:=strtoint(Edit2.Text);
      Edit2.Text := '';
    Memo4.Text:=Memo4.Text+inttostr(code[Q]);
      Q:=Q+1;
   end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var i,x,y:integer;
begin
   i:=1;
   y:=m;
   while code[i]<>9 do
   begin
   repeat
      if code[i]=0 then x:=ht[y].lch else x:=ht[y].rch;
      y:=x;
      i:=i+1;
   until (y>=1)and(y<=n);
   form1.Memo3.Text:=form1.Memo3.Text+inttostr(y)+' ';
   y:=m;
   end;

end;

end.