{ Initialize all nodes to single element
  binary trees with zero weight and depth. }
Procedure ZeroTree;
  var i: integer;
  begin
    For i := 0 to NumNodes do with Node[i] do
      begin
        Weight:=0.0; TDepth:=0; LChild:=NoChild; RChild:=NoChild;
      end;
  end; { Procedure ZeroTree }

Procedure PutWe(w: integer);
  var b1, b2: char;
  begin
    b1 := chr(w and $FF);      b2 := chr(w shr 8);
    WriteOutFile(b1);              WriteOutFile(b2);
  end; { Procedure PutWe }

Function GetCNr: char;
  Var return: char;

    Function Alike: boolean;
      begin
        If EOFile then EOFlag:=true else NewChar:=GetC;
        If EOFile then Alike:=false
        else           Alike:=( (NewChar=LastChar) and (LikeCt<255) );
      end; { Function Alike }

    Procedure NoHistory; {set up the state machine}
      begin
        State:=SentChar;
        If not EOFile then LastChar:=GetC;
        EoFlag:=EoFile; If EOFlag then State:=EndFile;
        Return:=LastChar;
      end; { Procedure NoHistory }

    Procedure SentAChar;   {LastChar is sent, need lookahead}

        Procedure SentDLE;
          begin
            State:=NoHist; Return:=chr(0);
          end; { Procedure SentDLE }

        Procedure CheckAlike;
          begin
            LikeCt:=1;   While alike do LikeCt:=succ(LikeCt);
            Case LikeCt of
                1: begin
                     LastChar:=NewChar; Return:=LastChar;
                     EoFlag:=EoFile;
                   end;
                2: begin { just pass through }
                     State:=SendNewC; Return:=LastChar;
                   end;
              else begin
                     State:=SendCnt; Return:=DLE;
                   end;
            end;
          end; { Procedure CheckAlike }

      begin
        If EOFlag then State := EndFile
                             {no return value, set to SPEOF in calling routine}
        else
          If LastChar=DLE then SentDLE
          else CheckAlike;
      end; { Procedure SentAChar }

    Procedure SendNewChar;   {Previous sequence complete, newchar set}
      begin
        EOFlag:=EOFile;
        State:=SentChar; LastChar:=NewChar; Return:=LastChar;
      end; { Procedure SendNewChar }

    Procedure SendCount;  {Sent DLE for repeat sequence, send count}
      begin
        State:=SendNewC; Return:=chr(LikeCt);
      end; { Procedure SendCount }

  begin
    Case State of
        NoHist: NoHistory;
      SentChar: SentAChar;
      SendNewC: SendNewChar;
       SendCnt: SendCount;
           else WriteLn('Program Bug - Bad State!');
    end;
    GetCnr:=Return;
  end; { Function GetCNr }

Procedure WriteHeader;
  Var i, k, l, r, NumNodes: integer;       { NumNodes: nbr of nodes in
                                                         simplified tree }
  begin
    PutWe(Recognize);                      { identifies as compressed }
    PutWe(Crc);                            { unsigned sum of original data }

                                  { Record the original file name w/o drive }
    If (InFileName[2]=':') then
      InFileName:=copy(InFileName,3,length(InFileName)-2);
    InFileName:=InFileName+chr(0);                    {mark end of file name}
    For i:=1 to Length(InFileName) do WriteOutFile(InFileName[i]);

    { Write out a simplified decoding tree. Only the interior nodes are
      written. When a child is a leaf index (representing a data value)
      it is recoded as -(index + 1) to distinguish it from interior
      indexes which are recoded as positive indexes in the new tree.
      Note that this tree will be empty for an empty file. }

    If DcTreeHd<NumVals then NumNodes:=0
    else                     NumNodes:=DcTreeHd-(pred(NumVals));
    PutWe(NumNodes);

    i:=DcTreeHd;
    For k:=0 to pred(NumNodes) do
      begin
        l:=Node[i].LChild;           r:=Node[i].RChild;
        if l<NumVals then l:=-(succ(l)) else l:=DcTreeHd-l;
        if r<NumVals then r:=-(succ(r)) else r:=DcTreeHd-r;
        PutWe(l); { left child }     PutWe(r); { right child }
        i:=pred(i);
      end;
  end; { Procedure WriteHeader }

{$A-}

Procedure Adjust(Top, Bottom: integer; Var List: ValType);
  Var k, Temp: integer;

    { Compare two trees, if a > b return true, else return false. }
    Function CmpTrees(a, b: integer): boolean;    {entry with root nodes}
      begin
        CmpTrees:=false;
        If Node[a].Weight>Node[b].Weight then CmpTrees:=true
        else
          If Node[a].Weight=Node[b].Weight then
            If Node[a].TDepth>Node[b].TDepth then CmpTrees:=true;
      end; { Function CmpTrees }

  begin
    k:=succ(2*Top);                                       { left child of top }
    Temp:=List[Top];                         { remember root node of top tree }
    If (k<=Bottom) then
      begin
        If ( k<Bottom) and (CmpTrees(List[k],List[succ(k)]) ) then k:=succ(k);
      { k indexes "smaller" child (in heap of trees) of top
        now make top index "smaller" of old top and smallest child }
        If CmpTrees(Temp,List[k]) then
          begin
            List[Top]:=List[k]; List[k]:=Temp; Adjust(k,Bottom,List);
          end;
      end;
  end; { Procedure Adjust }

{$A+}

{ The count of number of occurrances of each input value have already been
  prevented from exceeding MAXCOUNT. Now we must scale them so that their
  sum doesn't exceed ceiling and yet no non-zero count can become zero.
  This scaling prevents errors in the weights of the interior nodes of the
  Huffman tree and also ensures that the codes will fit in an unsigned integer.
  Rescaling is used if necessary to limit the code length. }
Procedure Scale(Ceil: integer);                 { upper limit on total weight }
  var i, c, ovflw, divisor: integer;
      w, sum:               real;
      Increased:            boolean;
  begin
    Repeat { Until not Increased }
      Sum:=0; OvFlw:=0;
      For i:=0 to pred(NumVals) do
        begin
          If Node[i].Weight>(Ceil-Sum) then OvFlw:=succ(OvFlw);
          Sum:=Sum+Node[i].Weight;
        end;
      Divisor:=succ(Ovflw);
    { Ensure no non-zero values are lost }
      Increased:=false;
      For i:=0 to pred(NumVals) do
        begin
          w:=Node[i].Weight;
          If (w<Divisor) and (w<>0) then
            begin          { Don't fail to provide a code if it's used at all }
              Node[i].Weight:=Divisor; Increased:=true;
            end;
        end;
    Until not Increased;
  { Scaling factor choosen, now scale }
    If Divisor>1 then
      For i:=0 to pred(NumVals) do with Node[i] do
        Weight:=int((Weight/Divisor)+0.5);
  end; { Procedure Scale }

{$A-}
  { Recursive routine to walk the indicated subtree and level
    and maintain the current path code in bstree. When a leaf
    is found the entire code string and length are put into
    the encoding table entry for the leaf's data value.
    Returns ERROR if codes are too long. }

Function BuildEnc(Level, Root: integer): integer;       {returns error or null}
  Var l, r, Return: integer;
  begin
    Return:=Null;
    l:=Node[Root].LChild; r:=Node[Root].RChild;
    If (l=NoChild) and (r=NoChild) then
      begin                                                {have a leaf}
        CodeLen[Root]:=Level;
        Code[Root]:=TCode and ($FFFF shr (16-Level));
        If Level>16 then Return:=Error else Return:=Null;
      end
    else
      begin
        If l<>NoChild then
          begin                                  {Clear path bit and go deeper}
            TCode:=TCode and not(1 shl Level);
            If BuildEnc(succ(Level),l)=Error then Return:=Error;
          end;
        If r<>NoChild then
          begin                                    {Set path bit and go deeper}
            TCode:=TCode or (1 shl Level);
            If BuildEnc(succ(Level),r)=Error then Return:=Error;
          end;
      end;
    BuildEnc:=Return;
  end; { Function BuildEnc }

{$A+}

Procedure BuildTree(Var List: ValType; Len: integer);       {Huffman algorithm}
  Var FreeNode:    integer;                            {next free node in tree}
      LCh, RCh:    integer;              {temporaries for left, right children}
      i:           integer;

    Function Maximum(a, b: integer): integer;
      begin
        If a>b then Maximum:=a else Maximum:=b;
      end; { Function Maximum }

  begin
                   { Initialize index to next available (non-leaf) node.
                     Lower numbered nodes correspond to leaves (data values). }
    FreeNode:=NumVals;
                    { Take from list two btrees with least weight and build an
                      interior node pointing to them.  This forms a new tree. }
    While (Len>1) do
      begin
        LCh:=List[0];                           { This one will be left child }
                             { delete top (least) tree from the list of trees }
        Len:=pred(Len);
        List[0]:=List[Len];
        Adjust(0,pred(Len),List);
                           { Take new top (least) tree. Reuse list slot later }
        RCh:=List[0];                          { This one will be right child }
            { Form new tree from the two least trees using a free node as root.
              Put the new tree in the list. }
        With Node[FreeNode] do
          begin
            LChild:=LCh; RChild:=RCh;
            Weight:=Node[LCh].Weight+Node[RCh].Weight;
            TDepth:=succ(Maximum(Node[LCh].TDepth,Node[RCh].TDepth));
          end;
        List[0]:=FreeNode;                                 {put at top for now}
        FreeNode:=succ(FreeNode);                              {next free node}
                                       { reheap list to get least tree at top }
        Adjust(0,pred(Len),List);
      end;
    DcTreeHd:=List[0];                                   { head of final tree }
  end; { Procedure BuildTree }

{ Initialize the Huffman translation. This requires reading the input file
  through any preceding translation functions to get the frequency
  distribution of the various values. }

Procedure InitializeHuffman;
  var c, i:     integer;
      BtList:   ValType;                  { list of intermediate binary trees }
      ListLen:  integer;                  { length of btlist }
      Ceiling:  integer;                  { limit for scaling }

  { Heap and Adjust maintain a list of binary trees as a heap with the top
    indexing the binary tree on the list which has the least weight or,
    in case of equal weights, least depth in its longest path. The depth part
    is not strictly necessary, but tends to avoid long codes which might
    provoke rescaling. }

    Procedure Heap(Var List: ValType; l: integer);
      Var i, len: integer;
      begin
        Len:=(l-2) div 2;
        For i:=Len DownTo 0 do Adjust(i,pred(l),List);
      end; { Procedure Heap }

  begin
    Write('Pass 1: Analysis,');
    Crc:=0; ZeroTree; State:=NoHist; EOFile:=false; EOFlag:=false;
    Repeat { Until EOFlag }                    { Build frequency info in tree }
      C:=ord(GetCnr);
      If EOFlag then C:=SpEOF;
      With Node[C] do
        If Weight<MaxCount then Weight:=Weight+1.0;
      If EOFlag then Write(' End of file found,');
    until (EOFlag);
  { PrintFrequency; }
    Ceiling:=MaxCount;
           { Try to build encoding table. Fail if any code is > 16 bits long. }
    Repeat { Until BuildEnc(0,DcTreeHd) <> Error }
      If (Ceiling<>MaxCount) then Write(' *** rescaling ***,');
      Scale(Ceiling);
      Ceiling:=Ceiling div 2;                        {in case we rescale again}
      ListLen:=0;                  {find length of list and build single nodes}
        For i:=0 to pred(NumVals) do
          If Node[i].Weight>0.0 then
            begin
              Node[i].TDepth:=0; BtList[listlen]:=i; ListLen:=succ(ListLen);
            end;
      Heap(BtList,pred(ListLen));
      Write(' Building tree');
      BuildTree(BtList,ListLen);
      For i:=0 to pred(NumVals) do CodeLen[i]:=0;
    until (BuildEnc(0,DcTreeHd)<>Error);
  { PrintList;}
                                              { Initialize encoding variables }
    CBitsRem:=0; CurIn:=0;
  end; { Procedure InitializeHuffman }

  { Get an encoded byte or EOF. Reads from specified stream AS NEEDED.
    There are two unsynchronized bit-byte relationships here:
      The input stream bytes are converted to bit strings of various lengths
      via the static variables named Cxxxxx.  These bit strings are
      concatenated without padding to become the stream of encoded result
      bytes, which this function returns one at a time. The EOF (end of file)
      is converted to SPEOF for convenience and encoded like any other input
      value. True EOF is returned after that. }

Function GetHuff: char;                    {returns byte values except for EOF}
  Var RByte:      integer;                                  {Result byte value}
      Need, Take: integer;                                    {numbers of bits}
      Return:     integer;
  begin
    RByte:=0;
    Need:=8;                                          {build one byte per call}
    Return:=Error;                                    {start off with an error}
                                   { Loop to build a byte of encoded data.
                                     Initialization forces read the first time}
    While Return=Error do
      begin
        If CBitsRem>=Need then
          begin                              {Current code fullfills our needs}
            If need = 0 then Return:=RByte and $00FF
            else
              begin
                RByte:=RByte or (CCode shl (8-Need));
                                                           {take what we need}
                CCode:=CCode shr Need;
                                                           {and leave the rest}
                CBitsRem:=CBitsRem-Need;
                Return:=RByte and $00FF;
              end;
          end
        else
          begin
            If CBitsRem>0 then
              begin                            {We need more than current code}
                RByte:=RByte or (CCode shl (8-Need));
                                                           {take what there is}
                Need:=Need-CBitsRem;
              end;
            If curin=SpEOF then
              begin
                CBitsRem:=0;
                If Need=8 then
                  begin                                           {end of file}
                    Done:=true;
                    Return:=0;                           {any valid char value}
                  end
                else Return:=RByte and $00FF;                      {data first}
              end
            else
              begin
                CurIn:=ord(GetCnr);
                If EOFlag then CurIn:=SpEOF;
                CCode:=Code[CurIn];
                CBitsRem:=CodeLen[CurIn];
              end;
          end;
      end;
    GetHuff:=chr(Return);
  end; { Function GetHuff }