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