1(* ========================================================================= *)
2(* A HEAP DATATYPE FOR ML                                                    *)
3(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License            *)
4(* ========================================================================= *)
5
6structure Heap :> Heap =
7struct
8
9(* Leftist heaps as in Purely Functional Data Structures, by Chris Okasaki *)
10
11datatype 'a node = E | T of int * 'a * 'a node * 'a node;
12
13datatype 'a heap = Heap of ('a * 'a -> order) * int * 'a node;
14
15fun rank E = 0
16  | rank (T (r,_,_,_)) = r;
17
18fun makeT (x,a,b) =
19  if rank a >= rank b then T (rank b + 1, x, a, b) else T (rank a + 1, x, b, a);
20
21fun merge cmp =
22    let
23      fun mrg (h,E) = h
24        | mrg (E,h) = h
25        | mrg (h1 as T (_,x,a1,b1), h2 as T (_,y,a2,b2)) =
26          case cmp (x,y) of
27            GREATER => makeT (y, a2, mrg (h1,b2))
28          | _ => makeT (x, a1, mrg (b1,h2))
29    in
30      mrg
31    end;
32
33fun new cmp = Heap (cmp,0,E);
34
35fun add (Heap (f,n,a)) x = Heap (f, n + 1, merge f (T (1,x,E,E), a));
36
37fun size (Heap (_, n, _)) = n;
38
39fun null h = size h = 0;
40
41fun top (Heap (_,_,E)) = raise Empty
42  | top (Heap (_, _, T (_,x,_,_))) = x;
43
44fun remove (Heap (_,_,E)) = raise Empty
45  | remove (Heap (f, n, T (_,x,a,b))) = (x, Heap (f, n - 1, merge f (a,b)));
46
47fun app f =
48    let
49      fun ap [] = ()
50        | ap (E :: rest) = ap rest
51        | ap (T (_,d,a,b) :: rest) = (f d; ap (a :: b :: rest))
52    in
53      fn Heap (_,_,a) => ap [a]
54    end;
55
56fun toList h =
57    if null h then []
58    else
59      let
60        val (x,h) = remove h
61      in
62        x :: toList h
63      end;
64
65fun toStream h =
66    if null h then Stream.Nil
67    else
68      let
69        val (x,h) = remove h
70      in
71        Stream.Cons (x, fn () => toStream h)
72      end;
73
74fun toString h =
75    "Heap[" ^ (if null h then "" else Int.toString (size h)) ^ "]";
76
77end
78