(* This is the second part of Turbo squeeze program.  This split was
     required because the entire file would not fit on a VT180. Jeff Duncan
  *)

  PROCEDURE putc( VAR filename : tfile; character : char);

    (* This procedure writes a character to a file.  All characters are
       stored in a temporary buffer until the buffer is full, then written
       to the file.  It is the responsibility of the closing procedure to
       insure that the last block is written correctly.
    *)

    BEGIN (* putc *)
      outfilebuffer[outfilepointer] := ord(character);
      outfilepointer := outfilepointer + 1;
      IF outfilepointer > buffersize
        THEN
          BEGIN (* we have a full buffer, let's write it out *)
            blockwrite(filename, outfilebuffer, 1);
            outfilepointer := 1;
            outbuffer_num := outbuffer_num + 1;
          END;
    END; (* putc *)

  PROCEDURE zero_tree;
    { Initialize all nodes to single element binary trees with
      zero weight and depth. }

    VAR i: integer;
    BEGIN
      FOR i := 0 TO NUMNODES DO
        BEGIN
          node[i].weight := 0;
          node[i].tdepth := 0;
          node[i].lchild := NoChild;
          node[i].rchild := NoChild;
        END;
    END;

  PROCEDURE putwe(w: integer);
    { write out low order byte of word to file, then high order byte
      regardless of host CPU. }

    VAR b1, b2: char;

    BEGIN
      b1 := chr(w AND $FF);
      b2 := chr(w shr 8);
      putc(out_file,b1);
      putc(out_file,b2);
    END;

  FUNCTION GetC_CRC: char;
    { Get next byte from file and update checksum }

    VAR 
      c: char;
    BEGIN
      IF (infilepointer > inbuffersize) AND (NOT eof(in_file))
        THEN
          BEGIN (* is input buffer empty and more data to follow *)
            IF infilesize < 16
              THEN (* less than 2048 bytes left? *)
                BEGIN
                  blockread(in_file, infilebuffer, infilesize); (* no get rest *)
                  infilepointer := 1;
                  inbuffersize := infilesize * 128;
                END
              ELSE
                BEGIN (* full 2048 left so get maximum *)
                  blockread(in_file, infilebuffer, 16);
                  inbuffersize := 2048;
                  infilepointer := 1;
                  infilesize := infilesize - 16;
                END
          END;
      IF NOT ((infilepointer > inbuffersize) AND eof(in_file))
        THEN
          BEGIN (* another character is available to read *)
            getc_crc := chr(infilebuffer[infilepointer]);
            c := chr(infilebuffer[infilepointer]);
            crc := crc + infilebuffer[infilepointer]; { update checksum }
            infilepointer := infilepointer + 1;
          END
        ELSE EOFlag := true;
    END;


  PROCEDURE PrintBits(len, number: integer);

    VAR i, j: integer;

    BEGIN
      write('  code ');
      FOR i:=len-1 DOWNTO 0 DO
        BEGIN
          j := (number shr i) AND $0001;
          write(j:1);
        END;
      writeln;
    END;


  FUNCTION getcnr: char;

    VAR return: char;

    FUNCTION alike: boolean;

      BEGIN
        newchar := getc_crc;
        IF EOFlag
          THEN
            alike := false
          ELSE
            BEGIN
              IF (newchar = lastchar) AND (likect < 255)
                THEN alike := true
                ELSE alike := false;
            END;
      END;

    PROCEDURE NoHistory; {set up the state machine}
      BEGIN
        state := SentChar;
        lastchar := GetC_CRC;
        IF EOFlag
          THEN
            state := EndFile;
        return := lastchar;
      END;

    PROCEDURE SentAChar;   {Lastchar is set, need lookahead}

      PROCEDURE SentDLE;
        BEGIN
          state := NoHist;
          return := chr(0);
        END;

      PROCEDURE CheckAlike;
        BEGIN
          likect := 1;
          WHILE alike DO
            likect := likect + 1;
          CASE likect OF
            1: BEGIN
                 lastchar := newchar;
                 return := lastchar;
               END;
            2: BEGIN { just pass through }
                 state := SendNewC;
                 return := lastchar;
               END;
          ELSE
            state := SendCnt;
            return := DLE;
          END;
        END;

      BEGIN
        IF EOFlag
          THEN
            state := EndFile {no return value, set to SPEOF in calling
                            routine}
          ELSE
            BEGIN
              IF lastchar = DLE
                THEN SentDLE
                ELSE CheckAlike;
            END;
      END;

    PROCEDURE SendNewChar;   {Previous sequence complete, newchar set}

      BEGIN
        state := SentChar;
        lastchar := newchar;
        return := lastchar;
      END;

    PROCEDURE SendCount;  {Sent DLE for repeat sequence, send count}

      BEGIN
        state := SendNewC;
        return := chr(likect);
      END;

    BEGIN
      CASE state OF
        NoHist:   NoHistory;
        SentChar: SentAChar;
        SendNewC: SendNewChar;
        SendCnt:  SendCount;
      ELSE writeln('program bug - bad state');
      END;
      getcnr := return;
    END;

  PROCEDURE Write_Header;
    { Write out the header of the compressed file }

    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
        putc(out_file,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 - (NUMVALS - 1);
      putwe(numnodes);
      i := dctreehd;
      FOR k:=0 TO numnodes-1 DO
        BEGIN
          l := node[i].lchild;
          r := node[i].rchild;
          IF l < NUMVALS
            THEN
              l := -(l + 1)
            ELSE l := dctreehd - l;
          IF r < NUMVALS
            THEN r := -(r + 1)
            ELSE r := dctreehd - r;
          putwe(l);  { left child }
          putwe(r);  { right child }
          i := i - 1;
        END;
    END;

  PROCEDURE Adjust(top, bottom: integer; VAR list: ValType);

  { Make a heap from a heap with a new top }

    VAR k, temp: integer;

    FUNCTION cmptrees(a, b: integer): boolean; {entry with root nodes}
    { Compare two trees, if a > b return true, else return false. }
      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;

    BEGIN
      k := 2 * top + 1;    { 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[k + 1]))
              THEN
                k := k + 1;
               { 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;


{  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
          sum := 0;
        ovflw := 0;
          FOR i:=0 TO numvals-1 DO
            BEGIN
              IF node[i].weight > (ceil - sum)
                THEN
                  ovflw := ovflw + 1;
              sum := sum + node[i].weight;
            END;
          divisor := ovflw + 1;

          { Ensure no non-zero values are lost }
          increased := FALSE;
          FOR i:=0 TO numvals-1 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 numvals-1 DO
            WITH node[i] DO
              weight := int((weight / divisor) + 0.5);
    END;

  FUNCTION buildenc(level, root: integer): integer; {returns error or null}

  {  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. }

    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(level+1,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(level+1,r)=ERROR
                          THEN return := ERROR;
                      END;
             END;
      buildenc := return;
    END;
{.pa}

  PROCEDURE Build_Tree(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;

    BEGIN
      write('Building tree');
      { 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 := len - 1;
             list[0] := list[len];
             adjust(0, len - 1, 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 := 1 + Maximum(node[lch].tdepth, node[rch].tdepth);
                 END;
             list[0] := freenode;       {put at top for now}
             freenode := freenode + 1;  {next free node}
             { reheap list to get least tree at top }
             adjust(0, len - 1, list);
           END;
      dctreehd := list[0];   { head of final tree }
    END;