|
| 1 | +(* This file is part of DBL, released under MIT license. |
| 2 | + * See LICENSE for details. |
| 3 | +*) |
| 4 | + |
| 5 | +import open RedBlackTree |
| 6 | +import open OrderedSetSignature |
| 7 | + |
| 8 | +data rec Q Val = Nil | E of Val , Q Val | T of Tree Val , Q Val |
| 9 | + |
| 10 | +let rec eqMain eq qs1 qs2 = |
| 11 | + match (qs1,qs2) with |
| 12 | + | (Nil,Nil) => True |
| 13 | + | (Nil, E _ _) => False |
| 14 | + | (E _ _, Nil) => False |
| 15 | + | (T Leaf rest, _) => eqMain eq rest qs2 |
| 16 | + | (_, T Leaf rest) => eqMain eq qs1 rest |
| 17 | + | (T (Node _ _ left elem right) rest, _) => |
| 18 | + eqMain eq (T left (E elem (T right rest))) qs2 |
| 19 | + | (_, T (Node _ _ left elem right) rest) => |
| 20 | + eqMain eq qs1 (T left (E elem (T right rest))) |
| 21 | + | (E elem1 rest1, E elem2 rest2) => |
| 22 | + match eq elem1 elem2 with |
| 23 | + | Noteq => False |
| 24 | + | Eq => eqMain eq rest1 rest2 |
| 25 | + end |
| 26 | + end |
| 27 | + |
| 28 | +let rec subsetMain comp qs1 qs2 = |
| 29 | + match (qs1,qs2) with |
| 30 | + | (Nil,_) => True |
| 31 | + | (E _ _ , Nil) => False |
| 32 | + | (T Leaf rest, _) => subsetMain comp rest qs2 |
| 33 | + | (_ , T Leaf rest) => subsetMain comp qs1 rest |
| 34 | + | (T (Node _ _ left elem right) rest, _) => |
| 35 | + subsetMain comp (T left (E elem (T right rest))) qs2 |
| 36 | + | (_, T (Node _ _ left elem right) rest) => |
| 37 | + subsetMain comp qs1 (T left (E elem (T right rest))) |
| 38 | + | (E elem1 rest1, E elem2 rest2) => |
| 39 | + match comp elem1 elem2 with |
| 40 | + | Less => False |
| 41 | + | Equal => subsetMain comp rest1 rest2 |
| 42 | + | Greater => subsetMain comp qs1 rest2 |
| 43 | + end |
| 44 | + end |
| 45 | + |
| 46 | +let partionLt compare = fn tree key1 => let (_,left,right) = |
| 47 | + split (fn key2 => match compare key1 key2 with |
| 48 | + | Greater => Greater | _ => Less end) tree in (left,right) |
| 49 | + |
| 50 | +let partionGt compare = fn tree key1 => let (_, left,right) = |
| 51 | + split (fn key2 => match compare key1 key2 with |
| 52 | + | Less => Less | _ => Greater end) tree in (left,right) |
| 53 | + |
| 54 | +let rec least tree = |
| 55 | + match tree with |
| 56 | + | Leaf => None |
| 57 | + | Node _ _ Leaf x _ => Some x |
| 58 | + | Node _ _ left _ _ => least left |
| 59 | + end |
| 60 | + |
| 61 | +let rec greatest tree = |
| 62 | + match tree with |
| 63 | + | Leaf => None |
| 64 | + | Node _ _ _ x Leaf => Some x |
| 65 | + | Node _ _ _ _ right => greatest right |
| 66 | + end |
| 67 | + |
| 68 | +pub let makeOrderedSet {Val} (compare : Val -> Val -> [] Ordered) = Set { |
| 69 | + T = Tree Val |
| 70 | + , empty = Leaf |
| 71 | + , method isEmpty = |
| 72 | + (fn tree => match tree with |
| 73 | + | Leaf => True |
| 74 | + | _ => False |
| 75 | + end) |
| 76 | + , method singletonSet = fn elem => Node Black 1 Leaf elem Leaf |
| 77 | + , singleton = fn elem => Node Black 1 Leaf elem Leaf |
| 78 | + , method insert = fn tree elem => |
| 79 | + match search (fn val => compare elem val) tree [] with |
| 80 | + | (Leaf,zipper) => zipRed elem Leaf Leaf zipper |
| 81 | + | (Node _ _ _ _ _,_) => tree |
| 82 | + end |
| 83 | + , method remove = fn tree elem => |
| 84 | + match search (fn val => compare elem val) tree [] with |
| 85 | + | (Leaf,_) => tree |
| 86 | + | (Node color _ left _ right,zipper) => delete color left right zipper |
| 87 | + end |
| 88 | + , method member = fn tree elem => let rec search tree elem = |
| 89 | + match tree with |
| 90 | + | Leaf => False |
| 91 | + | Node _ _ left val right => |
| 92 | + match compare elem val with |
| 93 | + | Less => search left elem |
| 94 | + | Greater => search right elem |
| 95 | + | Equal => True |
| 96 | + end |
| 97 | + end in search tree elem |
| 98 | + , method foldl = fn tree func acc => let rec foldl tree func acc = |
| 99 | + match tree with |
| 100 | + | Leaf => acc |
| 101 | + | Node _ _ left val right => |
| 102 | + foldl right func (func val (foldl left func acc)) |
| 103 | + end in foldl tree func acc |
| 104 | + , method foldr = fn tree func acc => let rec foldr tree func acc = |
| 105 | + match tree with |
| 106 | + | Leaf => acc |
| 107 | + | Node _ _ left val right => |
| 108 | + foldr left func (func val (foldr right func acc)) |
| 109 | + end in foldr tree func acc |
| 110 | + , method toList = fn tree => let rec toList tree acc = |
| 111 | + match tree with |
| 112 | + | Leaf => acc |
| 113 | + | Node _ _ left val right => |
| 114 | + toList left (val :: toList right acc) |
| 115 | + end in toList tree [] |
| 116 | + , method union = fn tree1 tree2 => let rec union tree1 tree2 = |
| 117 | + match tree1 with |
| 118 | + | Leaf => tree2 |
| 119 | + | Node _ _ left1 key1 right1 => |
| 120 | + match tree2 with |
| 121 | + | Leaf => tree1 |
| 122 | + | Node _ _ _ _ _ => |
| 123 | + let (_,left2,right2) = split (fn key2 => compare key1 key2) tree2 |
| 124 | + in join_val key1 (union left1 left2) (union right1 right2) |
| 125 | + end |
| 126 | + end in union tree1 tree2 |
| 127 | + , method intersection = fn tree1 tree2 => let rec intersection tree1 tree2 = |
| 128 | + match tree1 with |
| 129 | + | Leaf => Leaf |
| 130 | + | Node _ _ left1 key1 right1 => |
| 131 | + match tree2 with |
| 132 | + | Leaf => Leaf |
| 133 | + | _ => let (value_out, left2, right2) = |
| 134 | + split (fn key2 => compare key1 key2) tree2 |
| 135 | + in let left = intersection left1 left2 |
| 136 | + in let right = intersection right1 right2 |
| 137 | + in match value_out with |
| 138 | + | Some _ => join_val key1 left right |
| 139 | + | None => join left right |
| 140 | + end |
| 141 | + end |
| 142 | + end in intersection tree1 tree2 |
| 143 | + , method diffrence = fn tree1 tree2 => let rec diffrence tree1 tree2 = |
| 144 | + match tree1 with |
| 145 | + | Leaf => Leaf |
| 146 | + | Node _ _ left1 key1 right1 => |
| 147 | + match tree2 with |
| 148 | + | Leaf => tree1 |
| 149 | + | _ => let (value_out, left2, right2) = |
| 150 | + split (fn key2 => compare key1 key2) tree2 |
| 151 | + in let left = diffrence left1 left2 |
| 152 | + in let right = diffrence right1 right2 |
| 153 | + in match value_out with |
| 154 | + | Some _ => join left right |
| 155 | + | None => join_val key1 left right |
| 156 | + end |
| 157 | + end |
| 158 | + end in diffrence tree1 tree2 |
| 159 | + , method eq = fn set1 set2 => |
| 160 | + eqMain (fn e1 e2 => (compare e1 e2).toComparable) (T set1 Nil) (T set2 Nil) |
| 161 | + , method subset = fn set1 set2 => subsetMain compare (T set1 Nil) (T set2 Nil) |
| 162 | + , method partionLt = partionLt compare |
| 163 | + , method partionGt = partionGt compare |
| 164 | + , method rangeii = fn tree left right => |
| 165 | + let (_, tree') = partionLt compare tree left in |
| 166 | + let (tree'',_) = partionGt compare tree' right in tree'' |
| 167 | + , method rangeei = fn tree left right => |
| 168 | + let (_, tree') = partionGt compare tree left in |
| 169 | + let (tree'',_) = partionGt compare tree' right in tree'' |
| 170 | + , method rangeie = fn tree left right => |
| 171 | + let (_, tree') = partionLt compare tree left in |
| 172 | + let (tree'',_) = partionLt compare tree' right in tree'' |
| 173 | + , method rangeee = fn tree left right => |
| 174 | + let (_, tree') = partionGt compare tree left in |
| 175 | + let (tree'',_) = partionLt compare tree' right in tree'' |
| 176 | + , method least = fn tree => least tree |
| 177 | + , method greatest = fn tree => greatest tree |
| 178 | + , method leastGt = fn tree val => let rec leastGt tree val = |
| 179 | + match tree with |
| 180 | + | Leaf => None |
| 181 | + | Node _ _ left key right => |
| 182 | + match compare val key with |
| 183 | + | Less => let x = leastGt left val in |
| 184 | + match x with |
| 185 | + | None => Some key |
| 186 | + | _ => x |
| 187 | + end |
| 188 | + | Equal => least right |
| 189 | + | Greater => leastGt right val |
| 190 | + end |
| 191 | + end in leastGt tree val |
| 192 | + , method leastGeq = fn tree val => let rec leastGeq tree val = |
| 193 | + match tree with |
| 194 | + | Leaf => None |
| 195 | + | Node _ _ left key right => |
| 196 | + match compare val key with |
| 197 | + | Less => match leastGeq left val with |
| 198 | + | None => Some key |
| 199 | + | x => x |
| 200 | + end |
| 201 | + | Equal => Some val |
| 202 | + | Greater => leastGeq right val |
| 203 | + end |
| 204 | + end in leastGeq tree val |
| 205 | + , method greatestLt = fn tree val => let rec greatestLt tree val = |
| 206 | + match tree with |
| 207 | + | Leaf => None |
| 208 | + | Node _ _ left key right => |
| 209 | + match compare val key with |
| 210 | + | Less => greatestLt left val |
| 211 | + | Equal => greatest left |
| 212 | + | Greater => match greatestLt right val with |
| 213 | + | None => Some key |
| 214 | + | x => x |
| 215 | + end |
| 216 | + end |
| 217 | + end in greatestLt tree val |
| 218 | + , method greatestLeq = fn tree val => |
| 219 | + let rec greatestLeq tree val = |
| 220 | + match tree with |
| 221 | + | Leaf => None |
| 222 | + | Node _ _ left key right => |
| 223 | + match compare val key with |
| 224 | + | Less => greatestLeq left val |
| 225 | + | Equal => Some val |
| 226 | + | Greater => match greatestLeq right val with |
| 227 | + | None => Some key |
| 228 | + | x => x |
| 229 | + end |
| 230 | + end |
| 231 | + end in greatestLeq tree val |
| 232 | +} |
0 commit comments