/dev/code

While redoing my fib heap code in OCAML, I figured out a nice tail-recursive way to do part of the heap consolidation function. The pseudo-code of the algorithm, as specified in CLRS is:

CONSOLIDATE(H)
  for i := 0 to d(n[H])
    fo A[i] := NIL

  for each node w in the root list of H
    do x <= w
       d := degree[x]
       while A[d] != NIL
         do y := A[d]
           if key[x] > key[y]
             then exchange x <-> y
           FIB-HEAP-LINK (H,y,x)
           A[d] := nil
           d := d + 1
       A[d] := x
  min[H] := nil
  for i := 0 to D(n[H])
    do if A[i] != NIL
         then add A[i] to the root list of H
              if min[H] = nil or key[A[i]] < key[min[H]]
                then min[H] := A[i]

I tend to split this into two pieces. The first part (the "for each node w ...") creates an array of root-level nodes, each with a different degree (number of children). If two nodes have the same degree, one becomes the child of the other - the one with the lower key being the parent. Once this array has been created, the second part wipes out the old root list and re-inserts the new nodes, adjusting the min pointer to point to the node with the lowest key.

The second part, in OCAML, looks like this:

let fh_consolidate2 heap node =
  match node with
      Empty -> ()
    | Node(n) ->
        if is_empty heap.min then
          heap.min <- node
        else
          (fh_splice_nodes heap.min node;
           if (heap.compare_func n.data (as_fh_node_rec heap.min).data) then
             heap.min <- node);;

I call fh_consolidate2 using an iterator (see my earlier blog on partial functions if you don't understand how I can pass (fh_consolidate2 heap) this way):

Array.iter (fh_consolidate2 heap) a;;

The first part is more interesting because it is a pain to write in OCAML. The LISP version looks like this:

    (do* ((num-roots (fib-heap-node-list-length (fib-heap-min heap)) (decf num-roots))
      (x (fib-heap-min heap) next)
      (d (fib-heap-node-degree x) (fib-heap-node-degree x))
      (next (fib-heap-node-right x) (fib-heap-node-right x)))
     ((<= num-roots 0))
      (do ((y (aref a d) (aref a d)))
      ((null y))
    (when (funcall (fib-heap-compare-func heap)
               (fib-heap-node-data y) (fib-heap-node-data x))
      (let ((temp x))
        (setf x y)
        (setf y temp)))
    (fib-heap-link x y)
    (setf (aref a d) nil)
    (incf d))
      (setf (aref a d) x))

As you can see, this is pretty much an imperitive Lisp version of the pseudo-code.
One observation I made was that since I am clearing out the root level of the heap, I can go ahead and do that as I iterate through the heap. I created a destructive foreach that removes nodes from the heap as it goes through. Since the list is circular, the loop is done when a node's right pointer points to itself (meaning it is the last one):

let destructive_foreach f node =
  match node with
      Empty -> ()
    | Node(n) ->
        let rec foreach_iter curr next =
          fh_remove_from_list curr;
          (f curr);
          if next != curr then
            (foreach_iter next next.right)
        in
          foreach_iter n n.right;;

Now that destructive_foreach handles the "for each node w in the root list of H", I just need a better way to store the nodes in the A array. The "while A[d] != NIL" loop is really just a loop that looks for an empty slot in A. I rewrote the loop as a tail recursive procedure like this:

  let rec put_in_slot x =
    let d = x.degree in
      if is_empty a.(d) then
        a.(d) <- Node(x)
      else
        (let y = (as_fh_node_rec a.(d)) in
           a.(d) <- Empty;
           if heap.compare_func x.data y.data then
             (fh_link x y; put_in_slot x)
           else
             (fh_link y x; put_in_slot y))

Basically, look at the degree of x, if a[d] is empty, put x in there. Otherwise, pull the item out of a[d] and call it y. Link x and y together and then look for a slot to put the new joined-together nodes. Now, the guts of the consolidate routine just look like this:

    destructive_foreach put_in_slot heap.min;
    heap.min <- Empty;
    Array.iter (fh_consolidate2 heap) a;;