ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MAGAZINE/MISC/PCTV2N3.ZIP/HUFFMAN.PAS

Pascal/Delphi Source File | 1990-09-14 | 9.2 KB | 291 lines

 {$M 32767,0,655360}
 Program Huffman; {$R-}

{  Huffman compression routine.
   Uses up to 15 bits for compression.

   For Turbo Pascal 5.5
   Copyright (c) 1989, Rick Gessner.  }

 Uses Crt;

 Const
   VideoMem  = $B800;     {set=$B000 if your screen is mono }
 Type
   TableType = Array[0..255] of Word;{one for each valid byte value }
   BuffType  = Array[1..1] of Byte;  {used to pass conformant arrays}

 {-----------------------------------------------------------------}

 FUNCTION Bit_Count(Val: Word): Word;
 Var I : Integer;
 Begin
   I:=0;             { The purpose of this routine is to determine }
   While Val>0 do    { the significant number of bits required to  }
   Begin             { represent the given value.                  }
     Inc(I);         { It will be used by Compress and Decompress  }
     Val:=Val Shr 1; { to determine how many bits to write to the  }
   end;              { output buffer for each huffman code.        }
   Bit_Count:=I;
 end; {Bit count}

 {-----------------------------------------------------------------}

 FUNCTION Create_Huffman_Code_Table(Var CodeTable,Index: TableType;
          TheSize,Count: Word): Boolean;
                {Returns false if it overruns the 15 Bit limitation}
 Type
   NodeRec = Record
               Value: Real;
               Next : Integer;
             end;
 Var  TempVal  : Real;
      Start    : Integer;
      IncrVal,
      WorkVal,
      BitNum,
      NodeCount,
      I,Item   : Word;
      NodeList : Array[0..1000] of NodeRec;

PROCEDURE Combine(Node1,Node2: Integer);
Begin
  Inc(NodeCount);
  { Add the node values: }
  NodeList[NodeCount].Value := NodeList[Node1].Value +
                               NodeList[Node2].Value;
  { Point node up: }
  Nodelist[Node1].Next := NodeCount*(Ord(Node1>1)*-1);
  { Set this node to top of list: }
  NodeList[Node2].Next := NodeCount;
end; {Combine}

PROCEDURE Build_SubTree(NodePos: Integer; Max: Real);
Begin
  Repeat
    Combine(Start,Start-1);       {Combine 2 successive nodes}
    Dec(Start,2);
    If (NodePos<>NodeCount) then
      Begin
        If (NodeList[NodePos].Value>NodeList[NodeCount].Value)
            and (Start>=1) then
              Build_SubTree(NodeCount,NodeList[NodePos].Value);
        Combine(NodePos,Nodecount);
        NodePos := NodeCount;
      end
    else
      If (NodeList[NodePos].Value<=NodeList[Start].Value)
        then
          Begin
            { Combine current node with 1st node: }
            Combine(NodePos,Start);
            Dec(Start);
            NodePos := NodeCount;
          end;
  Until (NodeList[NodeCount].Value>=Max) or (Start<1);
end; {Build substree}

Begin
  FillChar(NodeList,Sizeof(NodeList),0);
  Create_Huffman_Code_Table := False;
  { Here, put probability of each code in table in its }
  {  correspondiong node: }
  For Item:=1 to Count do
    NodeList[Item].Value:=CodeTable[Index[Item]]/TheSize;
  NodeCount := Count;
  Start     := Count;
  Build_SubTree(Succ(NodeCount),1);  {Make the huffman codes }
  For Item:=1 to Count do
    Begin
      I:=Item; BitNum:=0;
      TempVal := 0; WorkVal:=0; IncrVal:=1;
      Repeat
        If (NodeList[i].Value<>TempVal) and
           (NodeList[i].value<>0)
        then
          Begin
            If NodeList[i].Next<0 then Inc(WorkVal,IncrVal);
            TempVal := NodeList[i].Value;
            IncrVal := IncrVal shl 1; { Travel down the nodes, }
            Inc(BitNum);              {  tracking the current bit }
          end;                        {  pattern until you hit a }
        I:=Abs(NodeLIst[i].Next);     {  terminal node.}
      Until NodeList[I].Next=0;
      If BitNum > 15 then exit;       { Jump out, were outta space }
      Inc(WorkVal,IncrVal);
      { Assign this code to the current entry: }
      CodeTable[Index[Item]]:=WorkVal;
    end;
      Create_Huffman_Code_Table := True;
 end; {Create Huffman code Table}

 {-----------------------------------------------------------------}

 FUNCTION Create_Freq_Index(Var CodeTable,
                                FreqIndex: TableType) : Word;

 Var
   I,J,K,CodeTableCount : Integer;

 Begin
   FillChar(FreqIndex,SizeOf(FreqIndex),0);   {Init freq. index}
   CodeTableCount := 0;
   { This is really just a routine that creates an index }
   {  into CodeTable: }
   For I:=0 to 255 do If CodeTable[i]<>0 then
     Begin
       J:=1;
       While (J<=CodeTableCount) and
             (CodeTable[FreqIndex[j]]>CodeTable[i]) do Inc(J);
       If FreqIndex[j]<>0 then
       Move(FreqIndex[j],FreqIndex[j+1],
            Succ(CodeTableCount-J)*SizeOf(Freqindex[1]));
       FreqIndex[j]:=i;
       Inc(CodeTableCount);
     end;
   Create_Freq_Index := CodeTableCount;
 end; {Create freq index}

 {-----------------------------------------------------------------}

FUNCTION Compress(Var Buffer1,Buffer2; Var CodeTable : TableType;
                   Var TheSize: Word): Boolean;

Var OrigBuffer      : BuffType Absolute Buffer1;
    NewBuff         : BuffType Absolute Buffer2;
    CodeTableIndex  : TableType;
    NewBuffBitNum,
    BitNum,
    OrigBuffPos,
    NewBuffPos,
    CodeCount,I     : Word;

Begin
  FillChar(CodeTable,SizeOf(CodeTable),0);   {Init freq. table}
  { Build frequency table: }
  For I:=1 to TheSize do Inc(CodeTable[OrigBuffer[i]]);
  { Create table index: }
  CodeCount := Create_Freq_Index(CodeTable,CodeTableIndex);
  If Create_Huffman_Code_Table(CodeTable,CodeTableIndex,
                               TheSize,CodeCount)
  then  {The index is no longer needed}
    Begin
      NewBuffPos    := 1;        { Notice that the code images are }
      NewBuffBitNum := 0;        {  being written backwards.       }
      NewBuff[NewBuffPos]:=0;
      For OrigBuffPos:=1 to TheSize do
        Begin
          For BitNum:=Bit_Count(CodeTable[OrigBuffer[OrigBuffPos]])
            downto 1 do
              Begin
                NewBuff[NewBuffPos] := NewBuff[NewBuffPos] +
                        (((CodeTable[OrigBuffer[OrigBuffPos]]
                Shr Pred(BitNum)) and 1) Shl NewBuffBitNum);
                If NewBuffBitNum<7 then Inc(NewBuffBitNum) else
                  Begin
                    NewBuffBitNum:=0; Inc(NewBuffPos);
                    NewBuff[NewBuffPos]:=0;
                  end;
              end;
           end;
          TheSize := NewBuffPos;
      end else Compress:=False;
 end; {Compress}

 {------------------------------------------------------------------}

PROCEDURE Decompress(Var Buffer1,Buffer2; Var CodeTable: TableType;
                      Var Size: Word);

Var  OrigBuff        : BuffType absolute Buffer1;
     NewBuff         : BuffType absolute Buffer2;
     CodeIndex       : TableType;
     BitNum,
     BuffPos,
     NextCode,
     CodeCount       : Word;


{ Compare Value to Huffman code}
{ table using a binary search. }
{ If no match, return 0, else  }
{ return proper byte value.     }

FUNCTION Find_Encoded_Val(Var Value: Word): Byte;

Var I : Integer;

Begin
  Find_Encoded_Val:=0;
  If Value>=CodeTable[CodeIndex[CodeCount]] then
    For I:=1 to CodeCount do
      If CodeTable[CodeIndex[i]]=Value then
        Begin
          Find_Encoded_Val:=CodeIndex[i]; exit;
        end;
end; {Find_Encoded_Val}

Begin
  { Make code table index: }
  CodeCount := Create_Freq_Index(CodeTable,CodeIndex);
  BuffPos := 1; {Position in input buffer}
  BitNum  := 1; {Current bit number of current byte in input buffer}
  Size    := 0; {Init reported size of return buffer}
  Repeat
    NextCode:=0;
    Inc(Size);
    Repeat
      NextCode:= (NextCode shl 1) + (OrigBuff[BuffPos] and 1);
      OrigBuff[BuffPos]:=OrigBuff[BuffPos] shr 1;
      If BitNum<8 then Inc(BitNum) else
        Begin
          BitNum:=1; Inc(BuffPos);
        end;
      NewBuff[Size]:=Find_Encoded_Val(NextCode);
    Until (NewBuff[Size]<>0) or (NextCode=0);
  Until NextCode=0;
end; {Decompress}

{-----------------------------------------------------------------}

PROCEDURE Test_It_Out;

Const ScreenSize = 160*20;  {20 lines of the screen: char+Attr}

Var   OldBuffer,
       NewBuffer        : Array[1..4000] of byte;
       CompressionTable : TableType;
       TheSize          : Word;

Begin
  { Write 20 strings to screen: }
  For TheSize:=1 to 20 do Writeln('Hello there: ',TheSize);
  { Grab the screen image: }
  Move(Mem[VideoMem:0],OldBuffer,ScreenSize);
  Writeln('This is the original image, press a key to test...');
  If Readkey<>Chr(0) then ClrScr;
  TheSize := ScreenSize;
  { Compress the buffer: }
  Writeln('Compressing...');
  If Compress(OldBuffer,NewBuffer,CompressionTable,TheSize) then
    Begin
      FillChar(OldBuffer,SizeOf(OldBuffer),0);
      Writeln('Decompressing...');
      { Decompress buffer: }
      Decompress(NewBuffer,OldBuffer,CompressionTable,TheSize);
      Writeln('Done, press a key...');
      If Readkey=' ' then;
      ClrScr;
      { Redisplay buffer on screen: }
      Move(OldBuffer,Mem[VideoMem:0],3200);
      Readln
    end;
end; {Test it out}

{------------------------------------------------------------------}

Begin
  ClrScr;
  Test_It_Out;
end. {Huffman program}