不是自己写的,你看得懂就好,再问我没有用的!呵
注：其中Progress是TfrmMain上的一个ProgressBar，Status是一个StatusBar
const
FileHead: string[8]='Huffman'#0;
HeadSize=8;
BufCount=$FFFF;
type
TCode=array[0..255]of Byte;
TNodeCode=record
Ascii: Byte;
Code: TCode;
end;
procedure TfrmMain.Compress (SName, TName: string);
type
PNode=^TNode;
TNode=record
Ascii, Code: Byte;
Num: Integer;
Left, Right, Father: PNode;
CodeStr: TCode;
end;
var
SFile, TFile: file;
Buf: array[1..BufCount]of Byte;
Size, Wrote: Integer;
Appears: array[0..255]of Integer;
NodeNum: SmallInt;
Nodes: array[1..256]of PNode;
CodeNum: SmallInt;
Codes: array[1..256]of TNodeCode;
AscCodes: array[0..255]of TCode;
I, J, ReadByte: Integer;
P: PNode;
{Varibles below are used for WriteBit}
Bits, CurByte: Byte;
OutBuf: array[1..BufCount]of Byte;
BitsSize: Word;
procedure BuildCode (P: PNode);
begin
if P=nil then Exit;
with P^ do
begin
CodeStr:= Father^.CodeStr;
Inc (CodeStr[0]);
CodeStr[CodeStr[0]]:= Code;
end;
if P^.Left=nil then
begin
Inc (CodeNum);
Codes[CodeNum].Code:= P^.CodeStr;
Codes[CodeNum].Ascii:= P^.Ascii;
Exit;
end;
BuildCode (P^.Left);
BuildCode (P^.Right);
end;
procedure FreeTree (P: PNode);
var
R: PNode;
begin
if P=nil then Exit;
R:= P^.Left;
FreeTree (R);
R:= P^.Right;
FreeTree (R);
Dispose (P);
end;
procedure WriteBit (Bit: Byte);
var
Temp: Byte;
begin
Dec (Bits);
Temp:= Bit shl Bits;
CurByte:= CurByte or Temp;
if Bits=0 then
begin
Bits:= 8;
Inc (BitsSize);
OutBuf[BitsSize]:= CurByte;
CurByte:= 0;
if BitsSize=BufCount then
begin
BlockWrite (TFile, OutBuf, BitsSize);
BitsSize:= 0;
FillChar (OutBuf, SizeOf(OutBuf), 0);
end;
end;
end;
procedure FlushBit;
begin
if (Bits=8) and (BitsSize=0) then Exit;
if Bits<>8 then
begin
Inc (BitsSize);
OutBuf[BitsSize]:= CurByte;
end;
BlockWrite (TFile, OutBuf, BitsSize);
Bits:= 8;
CurByte:= 0;
BitsSize:= 0;
FillChar (OutBuf, SizeOf(OutBuf), 0);
end;
begin
Canceled:= False;
Bits:= 8;
CurByte:= 0;
BitsSize:= 0;
FillChar (OutBuf, SizeOf(OutBuf), 0);
btnCancel.Enabled:= True;
AssignFile (SFile, SName);
AssignFile (TFile, TName);
Status.SimpleText:= '正在扫描输入文件...';
Reset (SFile, 1);
FillChar (Appears, SizeOf(Appears), 0);
while not Eof(SFile) do
begin
BlockRead (SFile, Buf, BufCount, ReadByte);
for I:= 1 to ReadByte do Inc (Appears[Buf]);
end;
CloseFile (SFile);
Status.SimpleText:= '正在生成哈夫曼树...';
NodeNum:= 0;
FillChar (Nodes, SizeOf(Nodes), 0);
for I:=0 to 255 do
if Appears>0 then
begin
New (P);
with P^ do
begin
Ascii:= I;
Code:= 2;
Num:= Appears;
Left:= nil;
Right:= nil;
Father:= nil;
FillChar (CodeStr, SizeOf(CodeStr), 0);
end;
J:= 1;
while (J<=NodeNum) and (Nodes[J]^.Num>=P^.Num) do Inc (J);
Inc (NodeNum);
Move (Nodes[J], Nodes[J+1], (NodeNum-J)*SizeOf(Nodes[J]));
Nodes[J]:= P;
end;
if NodeNum=1 then Nodes[1]^.Code:=0;
while NodeNum>1 do
begin
New (P);
with P^ do
begin
Num:= 0;
Ascii:= 0;
Code:= 2;
Left:= nil;
Right:= nil;
Father:= nil;
FillChar (CodeStr, SizeOf(CodeStr), 0);
end;
P^.Right:=Nodes[NodeNum];
Nodes[NodeNum]^.Father:= P;
Nodes[NodeNum]^.Code:= 1;
Inc (P^.Num, Nodes[NodeNum]^.Num);
Dec (NodeNum);
P^.Left:=Nodes[NodeNum];
Nodes[NodeNum]^.Father:= P;
Nodes[NodeNum]^.Code:= 0;
Inc (P^.Num, Nodes[NodeNum]^.Num);
J:= NodeNum;
while (J>=2) and (Nodes[J-1]^.Num<=P^.Num) do Dec (J);
Move (Nodes[J], Nodes[J+1], (NodeNum-J)*SizeOf(Nodes[J]));
Nodes[J]:= P;
end;
CodeNum:= 0;
if Nodes[1]<>nil then
if Nodes[1]^.Left=nil
then
begin
CodeNum:= 1;
with Codes[1] do
begin
Ascii:= Nodes[1]^.Ascii;
FillChar (Code, SizeOf(Code), 0);
Code[0]:=1;
end;
end
else
begin
BuildCode (Nodes[1]^.Left);
BuildCode (Nodes[1]^.Right);
end;
FreeTree (Nodes[1]);
FillChar (AscCodes, SizeOf(AscCodes), 0);
for I:= 1 to CodeNum do
with Codes do
AscCodes[Ascii]:= Code;
Status.SimpleText:= '正在写输出文件...';
Reset (SFile, 1);
Rewrite (TFile, 1);
BlockWrite (TFile, FileHead[1], HeadSize);
BlockWrite (TFile, CodeNum, SizeOf(CodeNum));
for I:= 1 to CodeNum do
with Codes do
begin
BlockWrite (TFile, Ascii, SizeOf(Ascii));
BlockWrite (TFile, Code[0], SizeOf(Code[0]));
for J:= 1 to Code[0] do WriteBit (Code[J]);
FlushBit;
end;
Size:= FileSize(SFile);
BlockWrite (TFile, Size, SizeOf(Size));
Wrote:= 0;
Progress.Min:= 0;
Progress.Max:= Size;
while not Eof(SFile) do
begin
BlockRead (SFile, Buf, BufCount, ReadByte);
for I:= 1 to ReadByte do
for J:= 1 to AscCodes[Buf, 0] do
WriteBit (AscCodes[Buf, J]);
Inc (Wrote, ReadByte);
Progress.Position:= Wrote;
end;
FlushBit;
CloseFile (TFile);
CloseFile (SFile);
Status.SimpleText:= '完成';
btnCancel.Enabled:= False;
end;
