home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 1 / 1773 < prev    next >
Encoding:
Internet Message Format  |  1990-12-28  |  9.7 KB

  1. From: gtoal@tharr.UUCP (Graham Toal)
  2. Newsgroups: alt.sources
  3. Subject: dynhuff.p - optimal dynamic huffman
  4. Message-ID: <949@tharr.UUCP>
  5. Date: 3 Sep 90 06:57:01 GMT
  6.  
  7.  
  8. Archive-name: dynhuff.p
  9.  
  10. All this talk of compression prodded me into typing in a program from
  11. an old faded photocopy that's been kicking around my pending file
  12. for several months.  Surprisingly it worked first time, which is just
  13. as well because if there were any bugs in the logic I'd never have
  14. found them ;-)
  15.  
  16. ---- cut here ----
  17. {
  18.   ALGORITHM 673,
  19.  
  20.   ACM Transactions on Mathematical Software, Vol 15, No 2, Pages 158-167. 
  21.  
  22.   Jeffrey Scott Vitter
  23.   Brown University
  24.  
  25.   This file coded up from the paper above by Graham Toal <gtoal@ed.ac.uk>
  26.  
  27.   This is a one-pass dynamic Huffman code generator.  I supply a trivial
  28.   interface for testing.  Real-world use would require that you firstly
  29.   translate this into C (please post here when you do) and secondly
  30.   modify the IO to write binary files. (This writes a text file of
  31.   0's and 1's for demonstration purposes)
  32.  
  33.   Also it needs some logic for what happens on end of file.
  34.  
  35. }
  36.  
  37. program huff(input, output);
  38. const
  39.   n = 256;
  40.   b = n*2 + 1;
  41. var
  42.   alpha: array [1..n] of integer;
  43.   rep: array [1..n] of integer;
  44.   block: array [1..b] of integer;
  45.   weight: array [1..b] of integer;
  46.   parent: array [1..b] of integer;
  47.   parity: array [1..b] of integer;
  48.   rtChild: array [1..b] of integer;
  49.   first: array [1..b] of integer;
  50.   last: array [1..b] of integer;
  51.   prevBlock: array [1..b] of integer;
  52.   nextBlock: array [1..b] of integer;
  53.   availBlock: integer;
  54.   stack: array [1..n] of integer;
  55.   a: integer; c: char;
  56.   M, E, R, Z: integer;
  57.   outpos: integer;
  58.  
  59. procedure Initialize;
  60. var
  61.   i: integer;
  62. begin
  63.   M := 0; E := 0; R := -1; Z := 2*n - 1;
  64.   for i := 1 to n do begin
  65.     M := M+1; R := R+1;
  66.     if R*2 = M then begin E := E+1; R := 0 end;
  67.     alpha[i] := i; rep[i] := i;
  68.   end;
  69.   { Initialize node n as the 0-node }
  70.   block[n] := 1; prevBlock[1] := 1; nextBlock[1] := 1; weight[1] := 0;
  71.   first[1] := n; last[1] := n; parity[1] := 0;
  72.   { Initialize available block list }
  73.   availBlock := 2;
  74.   for i := availBlock to Z-1 do nextBlock[i] := i+1;
  75.   nextBlock[Z] := 0;
  76. end;
  77.  
  78. procedure Transmit(i: integer);
  79. begin
  80.   outpos := outpos + 1;
  81.   write(i:1);
  82.   if outpos = 64 then begin outpos := 0; writeln end;
  83. end;
  84.  
  85. procedure Receive: integer;
  86. var
  87.   a: char;
  88. begin
  89.   if eoln then readln;
  90.   if eof then begin
  91.     {writeln('Unexpected end of file');} halt;
  92.   end;
  93.   read(a);
  94.   Receive := ORD(a)-ORD('0');
  95. end;
  96.  
  97. procedure EncodeAndTransmit(j: integer);
  98. var
  99.   i, ii, q, t, root: integer;
  100. begin
  101.   q := rep[j]; i := 0;
  102.   if q <= M then begin { Encode letter of zero weight }
  103.     q := q - 1;
  104.     if q < R*2 then t := E+1 else begin q := q - R; t := E end;
  105.     for ii := 1 to t do begin
  106.       i := i + 1; stack[i] := q mod 2;
  107.       q := q div 2
  108.     end;
  109.     q := M;
  110.   end;
  111.   if M = n then root := n else root := Z;
  112.   while q <> root do begin { Traverse up the tree }
  113.     i := i + 1; stack[i] := (first[block[q]] - q + parity[block[q]]) mod 2;
  114.     q := parent[block[q]] - (first[block[q]] - q + 1 - parity[block[q]]) div 2
  115.   end;
  116.   for ii := i downto 1 do Transmit(stack[ii])
  117. end;
  118.  
  119. function FindChild(j, parity: integer): integer;
  120. var
  121.   delta, right, gap: integer;
  122. begin
  123.   delta := 2*(first[block[j]]-j) + 1 - parity;
  124.   right := rtChild[block[j]]; gap := right - last[block[right]];
  125.   if delta <= gap then FindChild := right-delta
  126.   else begin
  127.     delta := delta - gap - 1;
  128.     right := first[prevBlock[block[right]]]; gap := right - last[block[right]];
  129.     if delta <= gap then FindChild := right-delta
  130.     else FindChild := first[prevBlock[block[right]]] - delta + gap + 1
  131.   end;
  132. end;
  133.  
  134. procedure ReceiveAndDecode: integer;
  135. var
  136.   i, q: integer;
  137. begin
  138.   if M = n then q := n else q := Z; { Set q to the root node }
  139.   while q > n do { Traverse down the tree }
  140.     q := FindChild(q, Receive);
  141.   if q = M then begin { Decode 0-node }
  142.     q := 0;
  143.     for i := 1 to E do q := q*2 + Receive;
  144.     if q < R then q := q*2 + Receive else q := q + R;
  145.     q := q + 1;
  146.   end;
  147.   ReceiveAndDecode := alpha[q];
  148. end;
  149.  
  150. procedure InterchangeLeaves(e1, e2: integer);
  151. var
  152.   temp: integer;
  153. begin
  154.   rep[alpha[e1]] := e2; rep[alpha[e2]] := e1;
  155.   temp := alpha[e1]; alpha[e1] := alpha[e2]; alpha[e2] := temp;
  156. end;
  157.  
  158. procedure Update(k: integer);
  159. var
  160.   q, leafToIncrement, bq, b, oldParent, oldParity, nbq, par, bpar: integer;
  161.   slide: boolean;
  162.  
  163. procedure FindNode;
  164. begin
  165.   q := rep[k]; leafToIncrement := 0;
  166.   if q <= M then begin { A zero weight becomes positive }
  167.     InterchangeLeaves(q, M);
  168.     if R = 0 then begin R := M div 2; if R > 0 then E := E-1 end;
  169.     M := M-1; R := R-1; q := M+1; bq := block[q];
  170.     if M > 0 then begin
  171.       { Split the 0-node into an internal node with two children.  The new
  172.         0-node is node M; the old 0-node is node M+1; the new parent of
  173.         nodes M and M+1 is node M+n }
  174.       block[M] := bq; last[bq] := M; oldParent := parent[bq];
  175.       parent[bq] := M+n; parity[bq] := 1;
  176.       { Create a new internal block of zero weight for node M+n }
  177.       b := availBlock; availBlock := nextBlock[availBlock];
  178.       prevBlock[b] := bq; nextBlock[b] := nextBlock[bq];
  179.       prevBlock[nextBlock[bq]] := b; nextBlock[bq] := b;
  180.       parent[b] := oldParent; parity[b] := 0; rtChild[b] := q;
  181.       block[M+n] := b; weight[b] := 0;
  182.       first[b] := M+n; last[b] := M+n;
  183.       leafToIncrement := q; q := M+n;
  184.     end;
  185.   end else begin { Interchange q with the first node in q's block }
  186.     InterchangeLeaves(q, first[block[q]]);
  187.     q := first[block[q]];
  188.     if (q = M+1) and (M > 0) then begin
  189.       leafToIncrement := q; q := parent[block[q]]
  190.     end;
  191.   end
  192. end;
  193.  
  194. procedure SlideAndIncrement;
  195. begin { q is currently the first node in its block }
  196.   bq := block[q]; nbq := nextBlock[bq];
  197.   par := parent[bq]; oldParent := par; oldParity := parity[bq];
  198.   if (
  199.        (q <= n) and (first[nbq] > n) and (weight[nbq] = weight[bq]))
  200.      or
  201.        ((q > n) and (first[nbq] <= n) and (weight[nbq] = weight[bq]+1)
  202.      ) then begin     { Slide q over the next block }
  203.     slide := true;
  204.     oldParent := parent[nbq]; oldParity := parity[nbq];
  205.     { Adjust child pointers for next higher level in tree }
  206.     if par > 0 then begin
  207.       bpar := block[par];
  208.       if rtChild[bpar] = q then rtChild[bpar] := last[nbq]
  209.       else if rtChild[bpar] = first[nbq] then rtChild[bpar] := q
  210.       else rtChild[bpar] := rtChild[bpar]+1;
  211.       if par <> Z then
  212.         if block[par+1] <> bpar then
  213.           if rtChild[block[par+1]] = first[nbq] then
  214.             rtChild[block[par+1]] := q
  215.           else if block[rtChild[block[par+1]]] = nbq then
  216.             rtChild[block[par+1]] := rtChild[block[par+1]]+1
  217.     end;
  218.     { Adjust parent pointers for block nbq }
  219.     parent[nbq] := parent[nbq] - 1 + parity[nbq]; parity[nbq] := 1-parity[nbq];
  220.     nbq := nextBlock[nbq];
  221.   end else slide := false;
  222.   if (
  223.       ((q <= n) and (first[nbq] <= n))
  224.       or
  225.       ((q > n) and (first[nbq] > n))
  226.      )
  227.      and (weight[nbq] = weight[bq]+1) then begin
  228.     { Merge q into the block of weight one higher }
  229.     block[q] := nbq; last[nbq] := q;
  230.     if last[bq] = q then begin { q's old block disappears }
  231.       nextblock[prevBlock[bq]] := nextBlock[bq];
  232.       prevBlock[nextBlock[bq]] := prevBlock[bq];
  233.       nextBlock[bq] := availBlock; availBlock := bq;
  234.     end else begin
  235.       if q > n then rtChild[bq] := FindChild(q-1, 1);
  236.       if parity[bq] = 0 then parent[bq] := parent[bq] - 1;
  237.       parity[bq] := 1-parity[bq];
  238.       first[bq] := q-1;
  239.     end
  240.   end else if last[bq] = q then begin
  241.     if slide then begin { q's block is slid forward in the block list }
  242.       prevBlock[nextBlock[bq]] := prevBlock[bq];
  243.       nextBlock[prevBlock[bq]] := nextBlock[bq];
  244.       prevBlock[bq] := prevBlock[nbq]; nextBlock[bq] := nbq;
  245.       prevBlock[nbq] := bq; nextBlock[prevBlock[bq]] := bq;
  246.       parent[bq] := oldParent; parity[bq] := oldParity;
  247.     end;
  248.     weight[bq] := weight[bq]+1;
  249.   end else begin
  250.     { A new block is created for q }
  251.     b := availBlock; availBlock := nextBlock[availBlock];
  252.     block[q] := b; first[b] := q; last[b] := q;
  253.     if q > n then begin
  254.       rtChild[b] := rtChild[bq];
  255.       rtChild[bq] := FindChild(q-1, 1);
  256.       if rtChild[b] = q-1 then parent[bq] := q
  257.       else if parity[bq] = 0 then parent[bq] := parent[bq]-1
  258.     end else if parity[bq] = 0 then parent[bq] := parent[bq]-1;
  259.     first[bq] := q-1; parity[bq] := 1-parity[bq];
  260.     { Insert q's in block in its proper place in the block list }
  261.     prevBlock[b] := prevBlock[nbq]; nextBlock[b] := nbq;
  262.     prevBlock[nbq] := b; nextBlock[prevBlock[b]] := b;
  263.     weight[b] := weight[bq]+1;
  264.     parent[b] := oldParent; parity[b] := oldParity
  265.   end;
  266.   { Move q one level higher in the tree }
  267.   if q <= n then q := oldParent else q := par
  268. end;
  269.  
  270. begin
  271.   { Set q to the node whose weight should increase }
  272.   FindNode;
  273.   while q > 0 do
  274.     { At this point, q is the first node in its block.  Increment q's weight
  275.       by 1 and slide q if necessary over the next block to maintain the
  276.       invariant.  Then set q to the node one level higher that needs
  277.       incrementing next }
  278.     SlideAndIncrement;
  279.   { Finish up some special cases involving the 0-node }
  280.   if LeafToIncrement <> 0 then begin
  281.     q := leafToIncrement;
  282.     SlideAndIncrement
  283.   end
  284. end;
  285.  
  286. begin
  287.   outpos := 0;
  288.   Initialize;
  289.   { Decide to encode or decode depending on data in file! }
  290.   { This is only for pedagogical purposes of course.      }
  291.   if (input^ <> '0') and (input^ <> '1') then begin
  292.     while (not eof) do begin
  293.       while (not eoln) do begin
  294.         read(c);
  295.         EncodeAndTransmit(ORD(c));
  296.         Update(ORD(c));
  297.       end;
  298.       readln;
  299.       EncodeAndTransmit(10);
  300.       Update(10);
  301.     end;
  302.   end else begin
  303.     while (not eof) do begin
  304.       a := ReceiveAndDecode;
  305.       if a = 10 then writeln else write(CHR(a));
  306.       Update(a);
  307.     end;
  308.     writeln;
  309.   end
  310. end.
  311.