summaryrefslogtreecommitdiffstats
path: root/map.sml
diff options
context:
space:
mode:
authorRose Hogenson <rosehogenson@posteo.net>2025-05-16 16:54:17 -0700
committerRose Hogenson <rosehogenson@posteo.net>2025-05-16 16:54:17 -0700
commit5582235bd300f8de997192f9109d596d12df4bbe (patch)
treed219a6c0a3d96052eec422527cd05775354abf76 /map.sml
parentff12ef4eea67453c1a6c1fa4614b74adf7c3caca (diff)
downloadsml-5582235bd300f8de997192f9109d596d12df4bbe.tar.zst
Fix spelling of file names
Diffstat (limited to 'map.sml')
-rw-r--r--map.sml186
1 files changed, 0 insertions, 186 deletions
diff --git a/map.sml b/map.sml
deleted file mode 100644
index d8b3a37..0000000
--- a/map.sml
+++ /dev/null
@@ -1,186 +0,0 @@
-(* 🅱️-tree *)
-signature MAP =
-sig
- type key
- type 'a map
-
- val empty : 'a map
- val null : 'a map -> bool
- val insert : key -> 'a -> 'a map -> 'a map
- val lookup : key -> 'a map -> 'a option
- val delete : key -> 'a map -> 'a map
- val union : 'a map -> 'a map -> 'a map
- val intersect : 'a map -> 'a map -> 'a map
- val difference : 'a map -> 'b map -> 'a map
- val fromList : (key * 'a) list -> 'a map
- val toList : 'a map -> (key * 'a) list
- val lookupMin : 'a map -> (key * 'a) option
-end
-
-functor Map (type k
- val cmp : k * k -> order) :> MAP where type key = k =
-struct
- type key = k
-
- datatype 'a map =
- Tip
- | Two of int * 'a map * key * 'a * 'a map
- | Three of int * 'a map * key * 'a * 'a map * key * 'a * 'a map
-
- val empty : 'a map = Tip
-
- fun null Tip = true
- | null _ = false
-
- fun height (Tip : 'a map) : int = 0
- | height (Two (h, _, _, _, _)) = h
- | height (Three (h, _, _, _, _, _, _, _)) = h
-
- fun two (l : 'a map) (k : key) (v : 'a) (r : 'a map) : 'a map =
- if height l <> height r then raise Fail "two: height mismatch" else
- Two (height l + 1, l, k, v, r)
-
- fun three (a : 'a map) (k1 : key) (v1 : 'a) (b : 'a map) (k2 : key) (v2 : 'a) (c : 'a map) : 'a map =
- if not (height a = height b andalso height b = height c) then raise Fail "three: height mismatch" else
- Three (height a + 1, a, k1, v1, b, k2, v2, c)
-
- fun view (Tip : 'a map) : ('a map * key * 'a * 'a map) option = NONE
- | view (Two (_, l, k, v, r)) = SOME (l, k, v, r)
- | view (Three (h, a, k1, v1, b, k2, v2, c)) = SOME (a, k1, v1, two b k2 v2 c)
-
- fun lookup (k : key) (m : 'a map) : 'a option =
- case view m of
- NONE => NONE
- | SOME (l, k', v, r) =>
- case cmp (k, k') of
- EQUAL => SOME v
- | LESS => lookup k l
- | GREATER => lookup k r
-
- datatype 'a insertResult =
- One of 'a map
- | Split of 'a map * key * 'a * 'a map
-
- fun join' (left : 'a map) (k : key) (v : 'a) (right : 'a map) : 'a insertResult =
- if height left = height right then
- Split (left, k, v, right)
- else if height left < height right then
- case right of
- Tip => raise Fail "unreachable"
- | Two (_, rl, rk, rv, rr) =>
- (case join' left k v rl of
- One newNode => One (two newNode rk rv rr)
- | Split (left, k, v, right) => One (three left k v right rk rv rr))
- | Three (_, ra, rk1, rv1, rb, rk2, rv2, rc) =>
- case join' left k v ra of
- One newNode => One (three newNode rk1 rv1 rb rk2 rv2 rc)
- | Split (left, k, v, right) => Split (two left k v right, rk1, rv1, two rb rk2 rv2 rc)
- else
- case left of
- Tip => raise Fail "unreachable"
- | Two (_, ll, lk, lv, lr) =>
- (case join' lr k v right of
- One newNode => One (two ll lk lv newNode)
- | Split (left, k, v, right) => One (three ll lk lv left k v right))
- | Three (_, la, lk1, lv1, lb, lk2, lv2, lc) =>
- case join' lc k v right of
- One newNode => One (three la lk1 lv1 lb lk2 lv2 newNode)
- | Split (left, k, v, right) => Split (two la lk1 lv1 lb, lk2, lv2, two left k v right)
-
- fun join (left : 'a map) (k : key) (v : 'a) (right : 'a map) : 'a map =
- case join' left k v right of
- One node => node
- | Split (left, k, v, right) => two left k v right
-
- fun split (m : 'a map) (k : key) : 'a map * bool * 'a map =
- case view m of
- NONE => (Tip, false, Tip)
- | SOME (l, k', v, r) =>
- case cmp (k, k') of
- EQUAL => (l, true, r)
- | LESS =>
- let val (ll, found, lr) = split l k
- in (ll, found, join lr k' v r)
- end
- | GREATER =>
- let val (rl, found, rr) = split r k
- in (join l k' v rl, found, rr)
- end
-
- fun splitLast (m : 'a map) : 'a map * (key * 'a) =
- case view m of
- SOME (l, k, v, Tip) => (l, (k, v))
- | SOME (l, k, v, r) =>
- let val (t', k') = splitLast r
- in (join l k v t', k')
- end
- | NONE => raise Fail "splitLast Tip"
-
- fun join2 (Tip : 'a map) (tr : 'a map) : 'a map = tr
- | join2 tl tr =
- let val (tl', (kx, x)) = splitLast tl
- in join tl' kx x tr
- end
-
- fun delete (k : key) (m : 'a map) : 'a map =
- let val (tl, _, tr) = split m k
- in join2 tl tr
- end
-
- fun union (Tip : 'a map) (t2 : 'a map) : 'a map = t2
- | union t1 t2 =
- case view t2 of
- NONE => t1
- | SOME (l2, k2, v2, r2) =>
- let
- val (l1, _, r1) = split t1 k2
- val tl = union l1 l2
- val tr = union r1 r2
- in join tl k2 v2 tr
- end
-
- fun intersect (Tip : 'a map) (_ : 'a map) : 'a map = Tip
- | intersect t1 t2 =
- case view t2 of
- NONE => Tip
- | SOME (l2, k2, v2, r2) =>
- let
- val (l1, b, r1) = split t1 k2
- val tl = intersect l1 l2
- val tr = intersect r1 r2
- in
- if b then join tl k2 v2 tr
- else join2 tl tr
- end
-
- fun difference (Tip : 'a map) (_ : 'b map) : 'a map = Tip
- | difference t1 t2 =
- case view t2 of
- NONE => t1
- | SOME (l2, k2, _, r2) =>
- let
- val (l1, _, r1) = split t1 k2
- val tl = difference l1 l2
- val tr = difference r1 r2
- in join2 tl tr
- end
-
- fun singleton (k : key) (v : 'a) : 'a map = two Tip k v Tip
-
- fun insert (k : key) (v : 'a) (m : 'a map) : 'a map = union m (singleton k v)
-
- fun fromList (l : (key * 'a) list) : 'a map = foldl (fn ((kx, x), acc) => insert kx x acc) empty l
-
- fun toList' (m : 'a map) (acc : (key * 'a) list) : (key * 'a) list =
- case view m of
- NONE => acc
- | SOME (l, k, v, r) => toList' l ((k, v) :: toList' r acc)
-
- fun toList (m : 'a map) : (key * 'a) list = toList' m []
-
- fun lookupMin (m : 'a map) : (key * 'a) option =
- case view m of
- NONE => NONE
- | SOME (Tip, k, v, _) => SOME (k, v)
- | SOME (l, _, _, _) => lookupMin l
-end