|
p align="left">Draw(P,w div 2,30,1,w div 2); end; procedure MakeDeCodeTable(Top: PTree); procedure CT(P: PTree; code: string); begin if P<>nil then begin if (P. Wiegth>=0) and (P. IsLeaf) then begin decodetable [P. Symbol] : =code; end; if not P. IsLeaf then begin CT(P. Left,code+'0'); CT(P. Right,code+'1'); end; end; end; begin CT(Top,''); end; var DCounter: integer; DString: String; DByte: byte; DB: Boolean; procedure AddCharToDMess(C: Char); var S: String; begin With Form1. DecodedMsg do begin S: =Text; Clear; Text: =S+C; end; end; procedure Decode(BIT: Char); var i,j: integer; c: char; begin if DB then begin if DCounter=0 then DCounter: =7 else dec(DCounter); DByte: =((DByte shl 1) or (byte(bit) and 1)); if DCounter=0 then begin AddSymbol(DecodeTree,chr(DByte)); CheckWiegth(DecodeTree); Enumerate(DecodeTree); Huffman(DecodeTree); Vitter(DecodeTree); DrawTree(Form1. Panel2,DecodeTree,Form1. Panel2. ClientWidth,500); MakeDeCodeTable(DecodeTree); AddCharToDMess(chr(DByte)); DString: =''; DB: =false; end; end else if DecodeTree=nil then begin DB: =true; Decode(BIT); end else begin DString: =DString + Bit; for c: =#0 to #255 do begin if DecodeTable [c] =DString then begin if c=#0 then begin DB: =true; DCounter: =0; end else begin AddSymbol(DecodeTree,c); CheckWiegth(DecodeTree); Enumerate(DecodeTree); Huffman(DecodeTree); Vitter(DecodeTree); DrawTree(Form1. Panel2,DecodeTree,Form1. Panel2. ClientWidth,500); MakeDeCodeTable(DecodeTree); DString: =''; AddCharToDMess(c); DB: =false; break; end; end; end; end; end; procedure MakeCodeTable(Top: PTree); procedure CT(P: PTree; code: string); begin if P<>nil then begin if (P. Wiegth>=0) and (P. IsLeaf) then begin codetable [P. Symbol] : =code; end; if not P. IsLeaf then begin CT(P. Left,code+'0'); CT(P. Right,code+'1'); end; end; end; begin CT(Top,''); end; procedure ShowCT; var C: Char; begin Form1. CodeTableMemo. Clear; For c: =#0 to #255 do begin if CodeTable [c] <>'' then begin Form1. CodeTableMemo. Lines. Append(c+' - '+CodeTable [c]); end; end; end; procedure AddCharToMess(C: Char); var S: String; begin With Form1. MessageMemo do begin S: =Text; Clear; Text: =S+C; end; end; procedure AddCoded(c: char); var s: string; begin S: =Form1. CodedMsg. Lines. Text; Form1. CodedMsg. Clear; Form1. CodedMsg. Lines. Text: =S+' '+CodeTable [c]; end; procedure AddASC(c: char); var i: integer; s: string; b: byte; begin s: =''; b: =byte(c); for i: =1 to 8 do begin s: =chr((b and 1) +$30) +s; b: =(b shr 1); end; S: =Form1. CodedMsg. Lines. Text+' '+s; Form1. CodedMsg. Clear; Form1. CodedMsg. Lines. Text: =S; end; procedure TForm1. InCharKeyPress(Sender: TObject; var Key: Char); var B: Boolean; begin B: =AddSymbol(Tree,Key); CheckWiegth(Tree); Enumerate(Tree); Huffman(Tree); DrawTree(Panel1,Tree,Panel1. ClientWidth,500); Application. MessageBox('stop','stop',MB_OK); Vitter(Tree); DrawTree(Panel1,Tree,Panel1. ClientWidth,500); if B then begin AddCoded(#0); AddASC(key); end else begin AddCoded(key); end; MakeCodeTable(Tree); AddCharToMess(Key); ShowCT; InChar. Clear; end; procedure TForm1. Button1Click(Sender: TObject); var s: string; c: char; begin s: =CodedMsg. Text; if(s<>'') then begin while s [1] =' ' do Delete(s,1,1); while ((s<>'') and (s [1] <>' ')) do begin Decode(s [1]); Delete(s,1,1); end; CodedMsg. Clear; CodedMsg. Text: =s; end; end; procedure TForm1. FormResize(Sender: TObject); begin Panel1. Top: =20; Panel1. Height: =(ClientHeight div 2) - 20; Label2. Top: =(ClientHeight div 2); Panel2. top: =(ClientHeight div 2) +20; Panel2. Height: =(ClientHeight div 2) - 20; end; procedure TForm1. FormPaint(Sender: TObject); begin DrawTree(Panel1,Tree,Panel1. ClientWidth,500); DrawTree(Panel2,DecodeTree,Panel2. ClientWidth,500); end; procedure TForm1. Button2Click(Sender: TObject); var s: string; c: char; begin s: =CodedMsg. Text; if(s<>'') then begin while s [1] =' ' do Delete(s,1,1); if ((s<>'') and (s [1] <>' ')) then begin Decode(s [1]); Delete(s,1,1); end; CodedMsg. Clear; CodedMsg. Text: =s; end; end; end. unit Core; {$B-} interface uses Graphics; type PTree = ^TTree; TTree = record Left,Right,Up: PTree; Symbol: char; Wiegth: integer; Number: integer; IsLeaf: boolean; end; function NewNode(l,r,u: PTree; s: char; c,n: integer; i: boolean): PTree; procedure DeleteTree(var P: PTree); function AddNewSymbolToTree(var Top: PTree; c: char): boolean; function AddSymbolToTree(var Top: PTree; c: char): boolean; function AddSymbol(var Top: PTree; c: char): boolean; function MaxLevel(Top: PTree): integer; procedure NodesOnLevel(Top: PTree; var qol: integer; l,level: integer); function GetNodeFromLevel(P: Ptree; level,number: integer; var l,n: integer): PTree; procedure Enumerate(P: PTree); function CheckWiegth(P: PTree): integer; function GetNodeByNumber(P: PTree; number: integer): PTree; function GetLeafByWiegthMax(P: PTree; wiegth: integer): PTree; procedure Vitter(P: PTree); procedure Huffman(P: PTree); implementation Uses Math,SysUtils; {$B-} function CheckWiegth(P: PTree): integer; begin Result: =0; if P<>nil then begin if not P. Isleaf then begin Result: =CheckWiegth(P. left) +CheckWiegth(P. right); P. Wiegth: =Result; end else Result: =P. Wiegth; end else Result: =0; end; procedure Huffman(P: PTree); var i,j,k: integer; t,tt: PTree; tmp: TTree; begin k: =1; t: =GetNodeByNumber(P,k); while t<>nil do begin tt: =GetNodeByNumber(P,k+1); if tt<>nil then begin if tt. Wiegth<t. Wiegth then begin move(tt^,tmp,sizeof(tmp)); move(t^,tt^,sizeof(tmp)); move(tmp,t^,sizeof(tmp)); CheckWiegth(P); Enumerate(P); k: =1; end; end; inc(k); T: =GetNodeByNumber(P,k); end; end; procedure Vitter(P: PTree); var i,j,k,l: integer; t,tt,ttt: PTree; tmp: TTree; begin k: =1; t: =GetNodeByNumber(P,1); while t<>nil do begin if not T. IsLeaf then begin tt: =GetLeafByWiegthMax(P,t. wiegth); if(tt<>nil) then begin if(tt. Number>T. Number) then begin move(tt^,tmp,sizeof(tmp)); move(t^,tt^,sizeof(tmp)); move(tmp,t^,sizeof(tmp)); CheckWiegth(P); Enumerate(P); k: =1; end; end; end; inc(k); T: =GetNodeByNumber(P,k); end; end; function GetLeafByWiegthMax(P: PTree; wiegth: integer): PTree; var i: integer; Node: PTree; begin Result: =nil; i: =1; Node: =GetNodeByNumber(P, i); while Node<>nil do begin if Node. Wiegth > wiegth then exit; // ??????? if Node. IsLeaf and (Node. Wiegth=wiegth) then begin Result: =Node; end; inc(i); Node: =GetNodeByNumber(P, i); end; end; function GetNodeByNumber(P: PTree; number: integer): PTree; begin if(P<>nil) then begin if P. Number=number then result: =P else begin Result: =GetNodeByNumber(P. Left,number); if Result=nil then Result: =GetNodeByNumber(P. Right,number); end; end else Result: =nil; end; procedure Enumerate(P: PTree); var i,j,k,l,n,o,s: integer; T: PTree; begin n: =0; k: =MaxLevel(P); for i: =k downto 1 do begin o: =1; s: =1; l: =1; T: =GetNodeFromLevel(P, i,l,o,s); while T<>nil do begin inc(n); T. Number: =n; inc(l); o: =1; s: =1; T: =GetNodeFromLevel(P, i,l,o,s); end; end; end; function GetNodeFromLevel(P: PTREE; level,number: integer; var l,n: integer): PTree; var T: PTRee; begin result: =nil; if(P<>nil) then begin if(l<level) then begin inc(l); T: =GetNodeFromLevel(P. Left,level,number,l,n); dec(l); if(T=nil) then begin inc(l); Result: =GetNodeFromLevel(P. Right,level,number,l,n); dec(l); end else Result: =T; end else begin if(l=level) then begin if(n=number) then result: =P else begin result: =nil; end; inc(n); end else result: =nil; end; end else result: =nil; end; procedure NodesOnLevel(Top: PTree; var qol: integer; l,level: integer); begin if Top<>nil then begin if level=l then begin inc(qol); end else begin NodesOnLevel(top. Left,qol,l+1,Level); NodesOnLevel(top. Right,qol,l+1,Level); end; end; end; function MaxLevel(Top: PTree): integer; begin if(Top=nil) then begin Result: =0; end else begin Result: =Max(MaxLevel(Top. Left),MaxLevel(Top. Right)) +1; end; end; function AddSymbol(var Top: PTree; c: char): boolean; begin if(not AddSymbolToTree(Top,c)) then if(not AddNewSymbolToTree(Top,c)) then result: =false // Error else result: =true // Added else result: =false; // Updated end; function AddSymbolToTree(var Top: PTree; c: char): boolean; begin if Top=nil then Result: =False else begin if Top. IsLeaf then begin if Top. Symbol=c then begin inc(Top. Wiegth); result: =true; end else begin result: =false; end; end else begin if AddSymbolToTree(Top. left,c) or AddSymbolToTree(Top. right,c) then begin inc(Top. Wiegth); result: =true; end else result: =false; end; end; end; function AddNewSymbolToTree(var Top: PTree; c: char): boolean; begin if Top=nil then begin Top: =NewNode(nil,nil,nil,#0,1,0,false); Top. left: =NewNode(nil,nil,Top,#0,0,0,true); Top. Right: =NewNode(nil,nil,Top,c,1,0,true); result: =true; end else begin if (Top. Wiegth=0) and (top. Symbol=#0) then begin Top. Left: =NewNode(nil,nil,Top,#0,0,0,true); Top. Right: =NewNode(nil,nil,Top,c,1,0,true); Top. IsLeaf: =false; Top. Wiegth: =1; Result: =true; end else begin if (Top. Left<>nil) and AddNewSymbolToTree(Top. Left,c) then begin result: =true; exit; end; if (Top. Right<>nil) and AddNewSymbolToTree(Top. Right,c) then begin result: =true; exit; end; result: =false; end; end; end; procedure DeleteTree(var P: PTree); begin if P=nil then exit; DeleteTree(P. Left); DeleteTree(P. Right); Dispose(P); P: =nil; end; function NewNode(l,r,u: ptree; s: char; c,n: integer; i: boolean): PTree; var P: PTree; begin new(P); P. Left: =l; P. Right: =r; P. Up: =u; P. Symbol: =s; P. Wiegth: =c; P. Number: =n; P. IsLeaf: =i; result: =P; end; end.
Страницы: 1, 2, 3
| 
