Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/smlnj-lib/Util/left-priorityq-fn.sml
ViewVC logotype

Annotation of /sml/trunk/src/smlnj-lib/Util/left-priorityq-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1061 - (view) (download)

1 : jhr 1061 (* left-priorityq-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies
4 :     *
5 :     * An implementation of priority queues based on leaftist heaps (see
6 :     * Purely Functional Data Structures by Chris Okasaki).
7 :     *)
8 :    
9 :     functor LeftPriorityQFn (P : PRIORITY) : MONO_PRIORITYQ =
10 :     struct
11 :    
12 :     type item = P.item
13 :    
14 :     datatype queue = Q of (int * heap)
15 :     and heap = EMPTY | ND of (int * item * heap * heap)
16 :    
17 :     val empty = Q(0, EMPTY)
18 :    
19 :     fun singleton x = ND(1, x, EMPTY, EMPTY)
20 :    
21 :     fun rank EMPTY = 0
22 :     | rank (ND(r, _, _, _)) = r
23 :    
24 :     fun mkNode (x, a, b) = if (rank a >= rank b)
25 :     then ND(rank b + 1, x, a, b)
26 :     else ND(rank a + 1, x, b, a)
27 :    
28 :     fun mergeHeap (h, EMPTY) = h
29 :     | mergeHeap (EMPTY, h) = h
30 :     | mergeHeap (h1 as ND(_, x, h11, h12), h2 as ND(_, y, h21, h22)) = (
31 :     case P.compare(P.priority x, P.priority y)
32 :     of GREATER => mkNode(x, h11, mergeHeap(h12, h2))
33 :     | _ => mkNode(y, h21, mergeHeap(h1, h22))
34 :     (* end case *))
35 :    
36 :     fun insert (x, Q(n, h)) = Q(n+1, mergeHeap(singleton x, h))
37 :    
38 :     fun next (Q(_, EMPTY)) = NONE
39 :     | next (Q(n, ND(_, x, h1, h2))) = SOME(x, Q(n-1, mergeHeap(h1, h2)))
40 :    
41 :     fun remove (Q(_, EMPTY)) = raise List.Empty
42 :     | remove (Q(n, ND(_, x, h1, h2))) = (x, Q(n-1, mergeHeap(h1, h2)))
43 :    
44 :     fun merge (Q(n1, h1), Q(n2, h2)) = Q(n1+n2, mergeHeap(h1, h2))
45 :    
46 :     fun numItems (Q(n, _)) = n
47 :    
48 :     fun isEmpty (Q(_, EMPTY)) = true
49 :     | isEmpty _ = false
50 :    
51 :     fun fromList [] = empty
52 :     | fromList l = let
53 :     fun merge ([], [h]) = h
54 :     | merge ([], hl) = merge (hl, [])
55 :     | merge ([h], hl) = merge (h::hl, [])
56 :     | merge (h1::h2::r, l) = merge (r, mergeHeap(h1, h2) :: l)
57 :     in
58 :     Q(List.length l, merge (List.map singleton l, []))
59 :     end
60 :    
61 :     end;

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0