# leftist-tree-priority-queue.pkg
# Priority queues implemented as leftist trees
#
# -- Allen Leung
# Compiled by:
# src/lib/std/standard.lib### "Progress is made by lazy men looking
### for easier ways to do things."
###
### -- Robert Heinlein
package leftist_tree_priority_queue
: Priority_Queue # Priority_Queue is from src/lib/src/priority-queue.api{
# A leftist tree is a binary tree with priority ordering
# with the invariant that the left branch is always the taller one
Leftist(X)
= NODE (X, Int, Leftist(X), Leftist(X))
| EMPTY
;
Priority_Queue(X)
=
PRIORITY_QUEUE
{
less: (X, X) -> Bool,
root: Ref( Leftist(X) )
};
exception EMPTY_PRIORITY_QUEUE;
# Assume a is smaller than b:
#
fun merge_trees less (a, b)
=
{ fun dist EMPTY => 0;
dist (NODE(_, d, _, _)) => d;
end;
fun m (EMPTY, a) => a;
m (a, EMPTY) => a;
m (a as NODE (x, d, l, r), b as NODE (y, d', l', r'))
=>
{ my (root, l, r)
=
if (less (x, y) ) (x, l, m (r, b));
else (y, l', m (r', a)); fi;
d_l = dist l;
d_r = dist r;
my (l, r)
=
if (d_l >= d_r ) (l, r);
else (r, l); fi;
NODE (root, 1+int::max (d_l, d_r), l, r);
};
end;
m (a, b);
};
fun make_priority_queue less
=
PRIORITY_QUEUE { less, root => REF EMPTY };
fun make_priority_queue' (less, _, _)
= make_priority_queue less;
fun min (PRIORITY_QUEUE { root => REF (NODE (x, _, _, _)), ... } ) => x;
min _ => raise exception EMPTY_PRIORITY_QUEUE;
end;
fun is_empty (PRIORITY_QUEUE { root => REF EMPTY, ... } ) => TRUE;
is_empty _ => FALSE;
end;
fun clear (PRIORITY_QUEUE { root, ... } )
=
root := EMPTY;
fun delete_min (PRIORITY_QUEUE { root => root as REF (NODE (x, _, l, r)), less } )
=>
{ root := merge_trees less (l, r);
x;
};
delete_min _
=>
raise exception EMPTY_PRIORITY_QUEUE;
end;
fun merge (PRIORITY_QUEUE { root => r1, less }, PRIORITY_QUEUE { root => r2, ... } )
=
PRIORITY_QUEUE
{ root => REF (merge_trees less (*r1,*r2)),
less
};
fun merge_into { src => PRIORITY_QUEUE { root => REF t1, less },
dst => PRIORITY_QUEUE { root => r as REF t2, ... }
}
=
r := merge_trees less (t1, t2);
fun merge_elems (less, q, elements)
=
m (q, elements)
where
fun m (q,[]) => q;
m (q, e ! es) => m (merge_trees less (q, NODE (e, 1, EMPTY, EMPTY)), es);
end;
end;
fun set (PRIORITY_QUEUE { root => r as REF t1, less }) x
=
r := merge_trees less (t1, NODE (x, 1, EMPTY, EMPTY));
fun from_list less list
=
PRIORITY_QUEUE { root => REF (merge_elems (less, EMPTY, list)),
less
};
fun collect (EMPTY, e) => e;
collect (NODE (x, _, l, r), e) => collect (l, collect (r, x ! e));
end;
fun to_list (PRIORITY_QUEUE { root => REF t, ... } )
=
collect (t, []);
};