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/comp-lib/binary-dict.sml
ViewVC logotype

Annotation of /sml/trunk/src/comp-lib/binary-dict.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 89 - (view) (download)

1 : monnier 89 (* binary-dict.sml
2 :     *
3 :     * COPYRIGHT (c) 1993 by AT&T Bell Laboratories.
4 :     *
5 :     * This code was adapted from Stephen Adams' binary tree implementation
6 :     * of applicative integer sets.
7 :     *
8 :     * Copyright 1992 Stephen Adams.
9 :     *
10 :     * This software may be used freely provided that:
11 :     * 1. This copyright notice is attached to any copy, derived work,
12 :     * or work including all or part of this software.
13 :     * 2. Any derived work must contain a prominent notice stating that
14 :     * it has been altered from the original.
15 :     *
16 :     *
17 :     * Name(s): Stephen Adams.
18 :     * Department, Institution: Electronics & Computer Science,
19 :     * University of Southampton
20 :     * Address: Electronics & Computer Science
21 :     * University of Southampton
22 :     * Southampton SO9 5NH
23 :     * Great Britian
24 :     * E-mail: sra@ecs.soton.ac.uk
25 :     *
26 :     * Comments:
27 :     *
28 :     * 1. The implementation is based on Binary search trees of Bounded
29 :     * Balance, similar to Nievergelt & Reingold, SIAM J. Computing
30 :     * 2(1), March 1973. The main advantage of these trees is that
31 :     * they keep the size of the tree in the node, giving a constant
32 :     * time size operation.
33 :     *
34 :     * 2. The bounded balance criterion is simpler than N&R's alpha.
35 :     * Simply, one subtree must not have more than `weight' times as
36 :     * many elements as the opposite subtree. Rebalancing is
37 :     * guaranteed to reinstate the criterion for weight>2.23, but
38 :     * the occasional incorrect behaviour for weight=2 is not
39 :     * detrimental to performance.
40 :     *
41 :     *)
42 :    
43 :     signature BINARY_DICT =
44 :     sig
45 :     type ord_key
46 :     type 'a dict
47 :     val mkDict : unit -> 'a dict
48 :     val insert : 'a dict * ord_key * 'a -> 'a dict
49 :     val peek : 'a dict * ord_key -> 'a option
50 :     val overlay : 'a dict * 'a dict -> 'a dict
51 :     val size : 'a dict -> int
52 :     val fold : (((ord_key * 'a) * 'b -> 'b) * 'b * 'a dict) -> 'b
53 :     val members : 'a dict -> (ord_key * 'a) list
54 :     end (* signature BINARY_DICT *)
55 :    
56 :     functor BinaryDict (K : ORD_KEY) : BINARY_DICT =
57 :     struct
58 :    
59 :     type ord_key = K.ord_key
60 :    
61 :     (*
62 :     ** val weight = 3
63 :     ** fun wt i = weight * i
64 :     *)
65 :     fun wt (i : int) = i + i + i
66 :    
67 :     datatype 'a dict =
68 :     E
69 :     | T of {
70 :     key : K.ord_key,
71 :     value : 'a,
72 :     cnt : int,
73 :     left : 'a dict,
74 :     right : 'a dict
75 :     }
76 :    
77 :     fun numItems E = 0
78 :     | numItems (T{cnt,...}) = cnt
79 :    
80 :     fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E}
81 :     | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r}
82 :     | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E}
83 :     | N(k,v,l as T n,r as T n') =
84 :     T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r}
85 :    
86 :     fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) =
87 :     N(b,bv,N(a,av,x,y),z)
88 :     | single_L _ = raise Match
89 :     fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) =
90 :     N(a,av,x,N(b,bv,y,z))
91 :     | single_R _ = raise Match
92 :     fun double_L (a,av,w,T{key=c,value=cv,left=T{key=b,value=bv,left=x,right=y,...},right=z,...}) =
93 :     N(b,bv,N(a,av,w,x),N(c,cv,y,z))
94 :     | double_L _ = raise Match
95 :     fun double_R (c,cv,T{key=a,value=av,left=w,right=T{key=b,value=bv,left=x,right=y,...},...},z) =
96 :     N(b,bv,N(a,av,w,x),N(c,cv,y,z))
97 :     | double_R _ = raise Match
98 :    
99 :     fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E}
100 :     | T' (k,v,E,r as T{right=E,left=E,...}) =
101 :     T{key=k,value=v,cnt=2,left=E,right=r}
102 :     | T' (k,v,l as T{right=E,left=E,...},E) =
103 :     T{key=k,value=v,cnt=2,left=l,right=E}
104 :    
105 :     | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p
106 :     | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p
107 :    
108 :     (* these cases almost never happen with small weight*)
109 :     | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) =
110 :     if ln < rn then single_L p else double_L p
111 :     | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) =
112 :     if ln > rn then single_R p else double_R p
113 :    
114 :     | T' (p as (_,_,E,T{left=E,...})) = single_L p
115 :     | T' (p as (_,_,T{right=E,...},E)) = single_R p
116 :    
117 :     | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...},
118 :     r as T{cnt=rn,left=rl,right=rr,...})) =
119 :     if rn >= wt ln then (*right is too big*)
120 :     let val rln = numItems rl
121 :     val rrn = numItems rr
122 :     in
123 :     if rln < rrn then single_L p else double_L p
124 :     end
125 :    
126 :     else if ln >= wt rn then (*left is too big*)
127 :     let val lln = numItems ll
128 :     val lrn = numItems lr
129 :     in
130 :     if lrn < lln then single_R p else double_R p
131 :     end
132 :    
133 :     else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r}
134 :    
135 :     fun mkDict () = E
136 :    
137 :     fun insert (E,x,v) = T{key=x,value=v,cnt=1,left=E,right=E}
138 :     | insert (T(set as {key,left,right,value,...}),x,v) =
139 :     case K.cmpKey (key,x) of
140 :     GREATER => T'(key,value,insert(left,x,v),right)
141 :     | LESS => T'(key,value,left,insert(right,x,v))
142 :     | _ => T{key=x,value=v,left=left,right=right,cnt= #cnt set}
143 :    
144 :     fun concat3 (E,x,v,r) = insert(r,x,v)
145 :     | concat3 (l,x,v,E) = insert(l,x,v)
146 :     | concat3 (l as (T{key=k1,left=l1,right=r1,value=v1,cnt=c1}),
147 :     x, v, r as (T{key=k2,left=l2,right=r2,value=v2,cnt=c2})) =
148 :     if wt c1 < c2 then T'(k2,v2,concat3(l,x,v,l2),r2)
149 :     else if wt c2 < c1 then T'(k1,v1,l1,concat3(r1,x,v,r))
150 :     else N(x,v,l,r)
151 :    
152 :     fun split_lt (E,x) = E
153 :     | split_lt (t as (T {key,value,left=l,right=r,...}),x) =
154 :     (case K.cmpKey(key,x)
155 :     of GREATER => split_lt(l, x)
156 :     | LESS => concat3(l,key,value,split_lt(r,x))
157 :     | _ => l)
158 :    
159 :     fun split_gt (E,x) = E
160 :     | split_gt (t as (T {key,value,left=l,right=r,...}),x) =
161 :     (case K.cmpKey(key,x)
162 :     of LESS => split_gt(r, x)
163 :     | GREATER => concat3(split_gt(l,x),key,value,r)
164 :     | _ => r)
165 :    
166 :     fun overlay (E,s2) = s2
167 :     | overlay (s1,E) = s1
168 :     | overlay (s1 as T{key,value,left=l,right=r, ...}, s2) =
169 :     let val l2 = split_lt(s2, key)
170 :     val r2 = split_gt(s2, key)
171 :     in concat3(overlay(l,l2),key,value,overlay(r,r2))
172 :     end
173 :    
174 :     fun peek(set, x) = let
175 :     fun mem E = NONE
176 :     | mem (T(n as {key,left,right,...})) =
177 :     case K.cmpKey (x,key) of
178 :     GREATER => mem right
179 :     | LESS => mem left
180 :     | _ => SOME(#value n)
181 :     in mem set end
182 :    
183 :     fun size E = 0
184 :     | size (T{cnt,...}) = cnt
185 :    
186 :     fun fold(f,base,set) =
187 :     let fun fold'(base, E) = base
188 :     | fold'(base, T(n as {key, value, left, right, ...})) =
189 :     fold'(f((key,value),fold'(base,right)),left)
190 :     in fold'(base,set)
191 :     end
192 :    
193 :     fun members set = fold(op ::, [], set)
194 :    
195 :     end (* functor BinaryDict *)
196 :    
197 :     (*
198 :     * $Log: binary-dict.sml,v $
199 :     * Revision 1.1.1.1 1998/04/08 18:39:14 george
200 :     * Version 110.5
201 :     *
202 :     *)

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