old/PAS/Huffman/huf.pas

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 string[200];
  INP,OUT	:  FILE;
  Nums          :  ps;
  THead         :  PTree;
  Code          :  string;
  GO,GNum       :  byte;
  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);
  while not eof(F) do
   begin
    BlockRead(F,ch,1,rsize);
    inc(counts[ch])
   end;
  Seek(F,CurPos);
end;{SetTimes}
{---------------------------------}
Procedure GetTimes(var F:file);
begin BlockRead(F,counts,256*4) end;{GetTimes}
{---------------------------------}
Procedure PutTimes(var F:file);
begin BlockWrite(F,counts,256*4) end;{GetTimes}
{---------------------------------}
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:string);
begin
  if (Bra^.left=nil) and (Bra^.right=nil) and (BRA^.info = VAL) then
      Code := cur;
  if (Bra^.left<>nil) then begin
   GetCode(val,Bra^.left,cur+'1');
   GetCode(val,Bra^.right,cur+'0')
  end;
end;{GetCode}
{---------------------------------}
Procedure SetTable;
var i : byte;
begin
  for i := 1 to 255 do
    if counts[i] <> 0 then
     begin
       GetCode(i,THead,'');
       table[i] := Code;
     end;
end;{SetTable}
{---------------------------------}
Function GetByte(cur:string):byte;
var ret:byte;
begin
  ret:=0;
  while length(cur)>0 do
   begin
    ret:=ret shl 1 + ord(cur[1])-ord('0');
    delete(cur,1,1);
   end;
   GetByte:=ret;
end;{GetByte}
{---------------------------------}
Procedure IfNeedWrite(var GGG:string;var F:FILE);
var
  LLL : string;
  FFF : byte;
begin
  while length(GGG)>7 do
   begin
     LLL := Copy(GGG,1,8);
     Delete(GGG,1,8);
     fff := GetByte(LLL);
     BlockWrite(F,Fff,1);
   end;
end;{IfNeedWrite}
{---------------------------------}
Function GetBit(var F:File):boolean;
begin
  if GNum = 0 then
   begin
     GNum:=8;
     inc(CSize);
     if (not eof(F)) and (csize<>Size-1) then BlockRead(F,GO,1)
     else
      begin
        BlockRead(F,GO,1);
        BlockRead(F,GNum,1)
      end;
   end;
  Dec(GNum);
  GetBit := (GO and 128) = 128;
  Go := GO shl 1;
end;{GetBit}
{---------------------------------}
VAR
  CURCODE       : string;
  CUR           : 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 pos('.HUF',fname) = 0 then
  begin
   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;
   Assign(OUT,Fout);
   Rewrite(OUT,1);
   BlockWrite(OUT,Fname,14);
   PutTimes(OUT);
   curcode:='';
   csize:=0;
   while not eof(INP) do
    begin
     inc(csize);
     BlockRead(INP,CUR,1);
     curcode := curcode + table[cur];
     IfNeedWrite(curcode,OUT);
     Write(#13'Complete: ',round((csize/size)*100),'%');
    end;
   cur := length(curcode);
   if (cur <> 0) then
    begin
     for size := 0 to 8-cur do curcode := curcode+'0';
     IfNeedWrite(curcode,OUT);
    end
   else
    cur:=8;
   BlockWrite(OUT,cur,1);
   Close(OUT);
   Close(INP);
  end
 else
  begin
   Assign(INP,Fname);
   Reset(INP,1);
   if ParamCount = 2 then FOut := ParamStr(2)
   else BlockRead(INP,Fout,14);
   Assign(OUT,Fout);
   Rewrite(OUT,1);
   Size:=FileSize(INP)-256*4-14;
   GetTimes(INP);
   CreateTree;
   Ctr := THead;
   while not eof(INP) 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),'%');
     BlockWrite(OUT,CTR^.INFO,1);
     CTR:=THead;
    end;
   close(INP);
   Close(OUT);
  end;
END.