old/PAS/Huffman/easyhuff.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;
  table         : array [0..255] of longint;
  tbllens       : array [0..255] of byte;
  INP,OUT	: FILE;
  Nums          : ps;
  THead         : PTree;
{-----}
  Code          : longint;
  CodeLen       : byte;
{-----}
  GO,GNum       : byte;
  done			: boolean;
  Size,Csize    : longint;
{---------------------------------}
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 SetTimes(var F:File);
var
  curpos,rsize	: word;
  ch		: byte;
begin
  FillChar(counts,256,0);
  CurPos := FilePos(F);
  Seek(F,0);
  RBFirst:=true;
  RBLast:=false;
  while FreadBuf(F,ch) do inc(counts[ch]);
  RBLast:=true;
  FReadBuf(F,ch);
  Seek(F,CurPos);
end;{SetTimes}
{---------------------------------}
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}
{---------------------------------}
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 GetCode(VAL:Byte;BRA:PTree;cur:longint;len:byte);
begin
  if (Bra^.left=nil) and (Bra^.right=nil) and (BRA^.info = VAL) then
   begin
      Code := cur;
      CodeLen:=len;
   end;
  if (Bra^.left<>nil) then begin
   GetCode(val,Bra^.left,(cur shl 1) + 1,len+1);
   GetCode(val,Bra^.right,(cur shl 1),len+1)
  end;
end;{GetCode}
{---------------------------------}
Procedure SetTable;
var i : byte;
begin
  for i := 0 to 255 do
    if counts[i] <> 0 then
     begin
       GetCode(i,THead,0,0);
       table[i] := Code;
       tbllens[i] := codelen;
     end;
end;{SetTable}
{---------------------------------}
Procedure PutTimes(var F:file);
begin BlockWrite(F,counts,256*4) end;{GetTimes}
{---------------------------------}
Procedure IfNeedWrite(var gg:longint;var num:byte;var F:FILE);
var
  FFF : byte;
begin
  while num >= 8 do
   begin
    FWriteBuf(F,((gg shl (32-num)) and $FF000000) shr 24);
    dec(num,8);
   end;
end;{IfNeedWrite}
{---------------------------------}
VAR
  CURCODE       : longint;
  curlen        : byte;
  CUR           : byte;
  i             : byte;
  Ctr           : Ptree;
BEGIN
  if (ParamCount<1) then
   begin
     WriteLn('Usage: HUF.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)) + 'HUF';

   Assign(INP,Fname);
   Reset(INP,1);
{   Size:=FileSize(INP);}
   SetTimes(INP);
   CreateTree;
   SetTable;
   DelBranch(THead);
   Assign(OUT,Fout);
   Rewrite(OUT,1);
   PutTimes(OUT);
   curcode:=0;
   curlen:=0;
   RBFirst:=true;
   RBLast:=false;
   WBFirst:=true;
   WBLast:=false;
  while FreadBuf(inp,cur) do
   begin
     if ((curlen mod 8) + tbllens[cur])< 32 then
      begin
        if (curlen+tbllens[cur]) > 32 then ifNeedWrite(curcode,curlen,OUT);
        curcode := (curcode shl tbllens[cur]) + table[cur];
        inc(curlen,tbllens[cur]);
      end
     else
      begin
       for i := 1 to tbllens[cur] do
        begin
         if curlen >= 8 then IfNeedWrite(curcode,curlen,OUT);
         curcode := (curcode shl 1) +
                    ((table[cur] shr (tbllens[cur]-i)) and 1);
         inc(curlen);
        end;
      end;
   end;

   if (curlen mod 8) <> 0 then
    begin
     cur := 8-(curlen mod 8);
     curcode := curcode shl (cur);
     inc(curlen,cur);
    end;

   ifNeedWrite(curcode,curlen,OUT);
   FWriteBuf(OUT,cur);

   RBLast:=true;
   FReadBuf(INP,cur);

   WBLast:=true;
   FWriteBuf(OUT,0);

   Close(OUT);
   Close(INP);
END.