old/PAS/Huffman/huf2.pas

CONST
  bufSize = 32768;
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;
{---------------------------------}
var
{FReadBuf}
   RBBuf, RBread    : ^BYTE;
   RBcount          : word;
   RBsize           : word;
   RBFirst, RBLast  : boolean;
{FReadBuf}
Function FReadBuf(var F:FILE;var val:byte):boolean;
begin
  if RBFirst then
   begin
    RBfirst:=false;
    GetMem(RBBuf,BUFSize);
    RBcount:=0;
    RBSize:=0;
   end;
  if RBLast then
   begin
    RBLast:=false;
    FreeMem(RBBuf,BufSize);
    RBFirst:=true;
    exit;
   end;
  If RBcount=RBsize then
   begin
     BlockRead(F,RBBuf^,BufSize,RBsize);
    if Rbsize=0 then
      begin
        FReadBuf:=false;
        exit;
      end;
     RBcount:=0;
   end;
  RBread:=PTR(SeG(RBBUF^),Ofs(RBbuf^)+RBcount);
  inc(RBcount);
  val:=RBread^;
  FReadBuf:=true;
end; {FReadBuf}
{-----------------------------------------}
var
{FWriteBuf}
   WBBuf,WBwrt      : ^BYTE;
   WBcount          : word;
   WBFirst, WBLast  : boolean;
{FWritebuf}
Procedure FWriteBuf(var F:FILE;val:byte);
begin
  if WBFirst then
   begin
    WBfirst:=false;
    GetMem(WBBuf,BUFSize);
    WBcount:=0;
   end;
  if WBLast then
   begin
    WBLast:=false;
    BlockWrite(F,WBBuf^,WBcount);
    FreeMem(WBBuf,BufSize);
    WBFirst:=true;
    exit;
   end;
  WBwrt:=PTR(SeG(WBBUF^),Ofs(WBbuf^)+WBcount);
  inc(WBcount);
  WBwrt^:=val;
  If WBcount=BUFsize then
   begin
     BlockWrite(F,WBBuf^,WBcount);
     WBcount:=0;
   end;
end;{FWriteBuf}
{-----------------------------------------}
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 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: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}
{---------------------------------}
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 gg:longint;var F:FILE);
var
  FFF : byte;
begin
   FFF := gg and $0FF;
   FWriteBuf(F,Fff);
end;{IfNeedWrite}
{---------------------------------}
Function GetBit(var F:File):boolean;
begin
  if GNum = 0 then
   begin
     GNum:=8;
     inc(CSize);
     done:=FReadBuf(F,GO);
     if not done then
      begin
       RBLast:=true;
       FReadBuf(F,GO);
       WBLast:=true;
       FWriteBuf(OUT,0);
       close(INP);
       Close(OUT);
       Halt(0);
      end;
     if csize=Size-1 then done:=FReadBuf(F,GNum);
   end;
  Dec(GNum);
  GetBit := (GO and 128) = 128;
  Go := GO shl 1;
end;{GetBit}
{---------------------------------}
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 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:=0;
   curlen:=0;
   csize:=0;
   RBFirst:=true;
   RBLast:=false;
   WBFirst:=true;
   WBLast:=false;
   while FReadBuf(INP,CUR) do
    begin
     inc(csize);
     for i := 0 to tbllens[cur] do
      begin
       if curlen = 8 then
       begin
        IfNeedWrite(curcode,OUT);
        curlen:=0;
        curcode:=0;
       end;
       curcode := (curcode shl 1) + (table[cur] and 1);
       inc(curlen);
      end;
     Write(#13'Complete: ',round((csize/size)*100),'%');
    end;
   if (curlen <> 0) then
    begin
      curcode := curcode shl (7-curlen);
      ifNeedWrite(curcode,OUT);
    end
   else
   curlen:=7;
   FWriteBuf(OUT,curlen);
   RBLast:=true;
   FReadBuf(INP,cur);
   WBLast:=true;
   FWriteBuf(OUT,0);
   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;
   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;
END.