old/PAS/Huffman/unHUff.pas

Uses Buffered;
Type
  PTree = ^TTree;
  TTree = record
    info : byte;
    ti   : longint;
    Left : PTree;
    Right: PTree;
  end;
    ps  = ^el;
    el  = record
        data : PTree;
        prev : ps;
    end;

CONST
  fname  : string[13] = 'input.txt';
  fout   : string[13] = 'input.huf';

VAR
  counts	: array [0..255] of longint;
  INP,OUT	: FILE;
  Nums          : ps;
  THead         : PTree;
{-----}
  GNum       : byte;
  done			: boolean;
  Size,Csize,Go    : longint;
  LastLen		: byte;
{---------------------------------}
Procedure DelBranch(br:PTree);
begin
  if br^.left <> nil then DelBranch(br^.left);
  if br^.right <> nil then DelBranch(br^.right);
  Dispose(br);
end;{DelBranch}
{---------------------------------}
Procedure AddItem(var HEAD:ps; VAL : PTree);
var
 c,NEWs : ps;
Begin
 c := HEAD;
 New(News);
 News^.data := VAL;
 News^.prev := nil;
 if c=nil then
  begin
   HEAD := NEWs;
   exit
  end;
 if val^.ti <= C^.DATA^.ti then
  begin
   News^.prev:=C;
   HEAD:=News;
   exit
  end;
 while (c^.prev <> nil) and
       (not ((val^.ti>C^.data^.ti) and
             (val^.ti<=C^.prev^.data^.ti))) do c:=c^.prev;
 News^.prev := c^.prev;
 C^.prev := News;
end;{AddItem}
{---------------------------------}
Procedure RemoveItem(var HEAD:ps; VAL : PTree);
var
 c,cur : ps;
Begin
 c := HEAD;
 if c=nil then exit;
 if c^.data = val then
  begin
   HEAD:=C^.prev;
   Dispose(C);
   exit
  end;
 while (c^.prev <> nil) and (C^.prev^.data <> val) do c:=c^.prev;
 if c^.prev^.data <> val then exit;
 cur := c^.prev;
 C^.prev := cur^.prev;
 Dispose(cur);
end;{RemoveItem}
{---------------------------------}
Function GetBit(var F:File):boolean;
var Suxx:byte;
begin
  if GNum = 0 then
   begin
     GNum := 8;
     done:=FReadBuf(F,Suxx);
     inc(CSize);
     go:=Suxx;
     if not done then
      begin
       RBLast:=true;
       FReadBuf(F,Suxx);
       WBLast:=true;
       FWriteBuf(OUT,0);
       close(INP);
       Close(OUT);
       Halt(0);
      end;
     if csize=Size-1 then begin done:=FReadBuf(F,Gnum) end;
   end;
  Dec(GNum);
  GetBit := (GO and 128) = 128;
  Go := GO shl 1;
end;{GetBit}
{----------------------------}
Procedure DeleteAll(var HEAD:ps);
var
 c:ps;
begin
  while HEAD <> nil do
   begin
     c:=HEAD^.prev;
     Dispose(HEAD);
     HEAD := C;
   end;
end;{DeleteAll}
{---------------------------------}
Procedure CreateTree;
var
 i : byte;
 News : PTree;
begin
  for i := 0 to 255 do
   if counts[i] <> 0 then
    begin
     New(News);
     News^.info:=i;
     News^.ti:=counts[i];
     News^.Left:=nil;News^.Right:=nil;
     AddItem(Nums,News);
    end;
  while NUMS^.prev <> nil do
   begin
     New(News);
     News^.ti := NUMS^.data^.ti+NUMS^.prev^.data^.ti;
     News^.left := Nums^.data;
     News^.right := Nums^.prev^.data;
     RemoveItem(NUMS,NUMS^.data);
     RemoveItem(NUMS,NUMS^.data);
     AddItem(NUMS,News);
   end;
   THead := News;
   RemoveItem(NUMS,News);
end;{CreateTree}
{---------------------------------}
Procedure GetTimes(var F:file);
begin BlockRead(F,counts,256*4) end;{GetTimes}
{---------------------------------}
VAR
  CURCODE       : longint;
  curlen        : byte;
  CUR           : byte;
  i             : byte;
  Ctr           : Ptree;
BEGIN
  if (ParamCount<1) then
   begin
     WriteLn('Usage: unHUF.exe <FILENAME.EXT> [OUTNAME.ext]');
     Halt(10);
   end;

  Fname := ParamStr(1);
  for size := 1 to Length(Fname) do
   fname[size] := UpCase(fname[size]);

   if Paramcount = 2 then fout := ParamStr(2)
     else fout := Copy(Fname,1,pos('.',Fname)) + 'TXT';

   Assign(INP,Fname);
   Reset(INP,1);
   Assign(OUT,Fout);
   Rewrite(OUT,1);
   Size:=FileSize(INP)-256*4;
   GetTimes(INP);
   CreateTree;
   Ctr := THead;
   RBFirst:=true;
   WBFirst:=true;
   RBLast:=false;
   WBLast:=false;
   while true do
    begin
     while CTR^.left <> nil do
      begin
        if GetBit(INP) then
          CTR:=CTR^.left
        else
          CTR:=CTR^.right;
      end;
     Write(#13'Complete: ',round((csize/size)*100),'%');
     FWriteBuf(OUT,CTR^.INFO);
     CTR:=THead;
    end;
END.