ack/lang/occam/test/Huffman.ocm

def
  bits.in.character	= 8,
  number.of.characters= 1 << bits.in.character,
  number.of.codes	= number.of.characters + 1,
  character.mask	= not ((not 0) << bits.in.character):

def
  root = 0, size.of.tree = (2* number.of.codes)-1, not.a.node = size.of.tree:

var
  escape, weight[size.of.tree],
  children[size.of.tree], parent[size.of.tree],
  character[size.of.tree], representative[number.of.characters] :

proc construct.tree =
  -- Create a tree for the encoding in which every character is escaped
  seq
    escape := root
    weight[escape] := 1
    children[escape] := root		-- it is a leaf
    seq ch= [0 for number.of.characters]
      representative[ch] := not.a.node					:

proc create.leaf(var new.leaf, value ch) =
  -- Extend the tree by fision of the escape leaf into two new leaves
  var new.escape:
  seq
    new.leaf		:= escape + 1
    new.escape		:= escape + 2

    children[escape]	:= new.leaf	-- escape is the new parent

    weight[new.leaf]	:= 0
    children[new.leaf]	:= root
    parent[new.leaf]	:= escape
    character[new.leaf]	:= ch
    representative[ch /\ character.mask] := new.leaf

    weight[new.escape]	:= 1
    children[new.escape]:= root
    parent[new.escape]	:= escape

    escape		:= new.escape					:

proc swap.trees(value i, j) =
  -- Exchange disjoint sub-trees routed at i and j
  proc swap.words(var p,q) =
    -- Exchange values stored in p and q
    var t:
    seq
      t := p
      p := q
      q := t								:

  proc adjust.offspring(value i) =
    -- Restore downstream pointers to node i
    if
      children[i] = root
	representative[character[i] /\ character.mask] := i
      children[i] <> root
	seq child=[children[i] for 2]
	  parent[child] := i						:
  
  seq
    swap.words(children[i], children[j])
    swap.words(character[i], character[j])
    adjust.offspring(i)
    adjust.offspring(j)							:

proc increment.frequency(value ch) =
  -- Adjust the weights of all relevant nodes to account for one more occurence
  -- of the character ch, and adjust the shape of the tree if necessary
  var node:
  seq
    if
      representative[ch /\ character.mask] <> not.a.node
	node := representative[ch /\ character.mask]
      representative[ch /\ character.mask] = not.a.node
        create.leaf(node, ch)
    while node <> root
      if
	weight[node-1] > weight[node]
	  seq
	    weight[node] := weight[node] + 1
	    node := parent[node]
	weight[node-1] = weight[node]
	  if i= [1 for (node-root)-1]
	    weight[(node-i)-1] > weight[node]
	      seq
		swap.trees(node, node-i)
		node := node-i
    weight[root] := weight[root] + 1					:

proc encode.character(chan output, value ch) =
  -- Transmit the encoding of ch along output
  def size.of.encoding = bits.in.character + (number.of.codes - 1) :
  var encoding[size.of.encoding], length, node:
  seq
    if
      representative[ch /\ character.mask] <> not.a.node
	seq
	  length := 0
	  node := representative[ch /\ character.mask]
      representative[ch /\ character.mask] = not.a.node
	seq
	  seq i=[0 for bits.in.character]
	    encoding[i] := (ch >> i) /\ 1	-- i'th bit of unencoded ch
	  length := bits.in.character
	  node := escape
    while node <> root
      seq
	encoding[length] := node - children[parent[node]]
	length := length + 1
	node := parent[node]
    seq i= [1 for length]
      output ! encoding[length-i]					:

proc decode.character(chan input, var ch) =
  -- Receive an encoding along input and store the corresponding character in ch
  var node:
  seq
    node := root
    while children[node] <> root
      var bit:
      seq
	input ? bit
	node := children[node] + bit
    if
      node < escape
	ch := character[node]
      node = escape
	var bit:
	seq
	  input ? bit
	  ch := -bit
	  seq i= [2 for bits.in.character - 1]
	    seq
	      input ? bit
	      ch := (ch << 1) \/ bit					:

def end.of.message = -1:

proc copy.encoding(chan source, sink) =
  -- Read a stream of characters from source, until signalled on end.of.source,
  -- and transmit their encodings in sequence along sink, followed by that of
  -- end.of.message, maintaining throughout the encoding tree for the encoding
  -- determined by the cumulative frequencies of the characters transmitted
  var more.characters.expected:
  seq
    construct.tree
    more.characters.expected := true
    while more.characters.expected
      var ch:
      seq
	source ? ch
	if
	  ch <> end.of.message
	    seq
	      encode.character(sink, ch)
	      increment.frequency(ch)
	  ch = end.of.message
	    more.characters.expected := false
    encode.character(sink, end.of.message)				:

proc copy.decoding(chan source, sink) =
  -- Read the encodings of a stream of characters, up to and including the
  -- encoding of end.of.message, from source and transmit the corresponding
  -- characters along sink, maintaining the encoding tree for encoding
  -- determined by the cumulative frequencies of the characters received
  var more.characters.expected:
  seq
    construct.tree
    more.characters.expected := true
    while more.characters.expected
      var ch:
      seq
	decode.character(source, ch)
	if
	  ch <> end.of.message
	    seq
	      sink ! ch
	      increment.frequency(ch)
	  ch = end.of.message
	    more.characters.expected:=false				:

var choose:
seq
  input ? choose
  if
    choose='e'
      copy.encoding(input, output)
    choose='d'
      copy.decoding(input, output)