// Code adapted from Lec5.ml with minimal changes. // This is *not* idiomatic F# code. type 'a my_list = Empty | Cons of 'a * 'a my_list let tail l = match l with | Empty -> failwith "tail" | Cons (_, tl) -> tl (* # let tail l = match l with | Empty -> invalid_arg "tail" | Cons (_, tl) -> tl;; val tail : 'a my_list -> 'a my_list *) type ('a, 'b) choice = Left of 'a | Right of 'b (* let l = Left 7 let r = Right "a" ;; [l; r];; [Left "b"; l; r];; *) let get_int c = match c with | Left i -> i | Right b -> if b then 1 else 0 (* # let get_int c = match c with | Left i -> i | Right b -> if b then 1 else 0;; val get_int : (int, bool) choice -> int *) (* module ListMap = type t<'a, 'b> = ('a * 'b) list let empty = [] let member = List.mem_assoc let add k v m = (k, v)::m let remove = List.remove_assoc let find = List.assoc *) exception Not_found module TrivialMap = type t<'a, 'b> = | Empty | Add of 'a * 'b * t<'a, 'b> | Remove of 'a * t<'a, 'b> let empty = Empty let rec hasKey k m = match m with | Empty -> false | Add (k2, _, _) when k = k2 -> true | Remove (k2, _) when k = k2 -> false | Add (_, _, m2) -> hasKey k m2 | Remove (_, m2) -> hasKey k m2 let add k v m = Add (k, v, m) let remove k m = Remove (k, m) let rec find k m = match m with | Empty -> raise Not_found | Add (k2, v, _) when k = k2 -> v | Remove (k2, _) when k = k2 -> raise Not_found | Add (_, _, m2) -> find k m2 | Remove (_, m2) -> find k m2 module MyListMap = type t<'a, 'b> = Empty | Add of 'a * 'b * t<'a, 'b> let empty = Empty let rec hasKey k m = match m with | Empty -> false | Add (k2, _, _) when k = k2 -> true | Add (_, _, m2) -> hasKey k m2 let rec add k v m = match m with | Empty -> Add (k, v, Empty) | Add (k2, _, m) when k = k2 -> Add (k, v, m) | Add (k2, v2, m) -> Add (k2, v2, add k v m) let rec remove k m = match m with | Empty -> Empty | Add (k2, _, m) when k = k2 -> m | Add (k2, v, m) -> Add (k2, v, remove k m) let rec find k m = match m with | Empty -> raise Not_found | Add (k2, v, _) when k = k2 -> v | Add (_, _, m2) -> find k m2 module BTreeMap = type t<'a, 'b> = Empty | T of t<'a, 'b> * 'a * 'b * t<'a, 'b> let empty = Empty let rec hasKey k m = match m with | Empty -> false | T (_, k2, _, _) when k = k2 -> true | T (m1, k2, _, _) when k < k2 -> hasKey k m1 | T (_, _, _, m2) -> hasKey k m2 let rec add k v m = match m with | Empty -> T (Empty, k, v, Empty) | T (m1, k2, _, m2) when k = k2 -> T (m1, k, v, m2) | T (m1, k2, v2, m2) when k < k2 -> T (add k v m1, k2, v2, m2) | T (m1, k2, v2, m2) -> T (m1, k2, v2, add k v m2) let rec split_rightmost m = match m with | Empty -> raise Not_found | T (Empty, k, v, Empty) -> k, v, Empty | T (m1, k, v, m2) -> let rk, rv, rm = split_rightmost m2 in rk, rv, T (m1, k, v, rm) let rec remove k m = match m with | Empty -> Empty | T (m1, k2, _, Empty) when k = k2 -> m1 | T (Empty, k2, _, m2) when k = k2 -> m2 | T (m1, k2, _, m2) when k = k2 -> let rk, rv, rm = split_rightmost m2 in T (rm, rk, rv, m2) | T (m1, k2, v, m2) when k < k2 -> T (remove k m1, k2, v, m2) | T (m1, k2, v, m2) -> T (m1, k2, v, remove k m2) let rec find k m = match m with | Empty -> raise Not_found | T (_, k2, v, _) when k = k2 -> v | T (m1, k2, _, _) when k < k2 -> find k m1 | T (_, _, _, m2) -> find k m2 module RBTreeMap = type color = R | B | BB | NB type t<'a, 'b> = | L | BBL | T of color * t<'a, 'b> * ('a * 'b) * t<'a, 'b> let empty = L let blacken = function | R -> B | B -> BB | BB -> failwith "blacken: impossible" | NB -> R let whiten = function | R -> NB | B -> R | BB -> B | NB -> failwith "whiten: impossible" let rec hasKey k m = match m with | BBL -> failwith "hasKey: impossible" | L -> false | T (_, _, (k2, _), _) when k = k2 -> true | T (_, m1, (k2, _), _) when k < k2 -> hasKey k m1 | T (_, _, _, m2) -> hasKey k m2 let rec balance = function | ((B | BB) as col,T (R,T (R,a,x,b), y, c),z,d) | ((B | BB) as col,T (R,a,x,T (R,b,y,c)),z,d) | ((B | BB) as col,a,x,T (R,T (R,b,y,c),z,d)) | ((B | BB) as col,a,x,T (R,b,y,T (R,c,z,d))) -> T (whiten col,T (B,a,x,b),y,T (B,c,z,d)) | (BB,T (NB,T (B,a,w,b),x,T (B,c,y,d)),z,e) -> T (B,balance (B,T (R,a,w,b),x,c),y,T (B,d,z,e)) | (BB,a,x,T (NB,T (B,b,y,c),z,T (B,d,w,e))) -> T (B,T (B,a,x,b),y,balance (B,c,z,T (R,d,w,e))) | (color,a,x,b) -> T (color,a,x,b) let add k v m = let rec ins = function | BBL -> failwith "add: impossible" | L -> T (R,L,(k,v),L) | T (c,a,(k2,_),b) when k = k2 -> balance (c,a,(k,v),b) | T (c,a,(k2,v2),b) when k < k2 -> balance (c,ins a,(k2,v2),b) | T (c,a,(k2,v2),b) -> balance (c,a,(k2,v2),ins b) in match ins m with | L | BBL -> failwith "add: impossible" | T (_,a,(k,v),b) -> T (B,a,(k,v),b) let bubble = function | (c1,T (c2,a,x,b),y,T (c3,c,z,d)) when c1=BB || c2=BB -> balance (blacken c1,T (whiten c2,a,x,b),y,T (whiten c3,c,z,d)) | (c,a,x,b) -> T (c,a,x,b) let rec find_max = function | BBL -> failwith "find_max: impossible" | L -> raise Not_found | T (_,_,x,L) -> x | T (_,_,_,m) -> find_max m let rec delete = function | T (R,L,_,L) -> L | T (B,L,_,L) -> BBL | T (B,T (R,a,p,b),_,L) | T (B,L,_,T (R,a,p,b)) -> T (B,a,p,b) | T (c,(T _ as a),x,(T _ as b)) -> bubble (c,remove_max a,find_max a,b) | _ -> failwith "delete: impossible" and remove k = function | BBL -> failwith "remove: impossible" | L -> L | T (_,_,(k2,_),_) as m when k = k2 -> delete m | T (c,a,(k2,_ as x),b) when k < k2 -> bubble (c,remove k a,x,b) | T (c,a,x,b) -> bubble (c,a,x,remove k b) and remove_max = function | T (_,_,_,L) as m -> delete m | T (c,a,x,b) -> balance (c,a,x,remove_max b) | _ -> failwith "remove_max: impossible" let rec find k = function | BBL -> failwith "find: impossible" | L -> raise Not_found | T (_,_,(k2,v),_) when k = k2 -> v | T (_,m,(k2,_),_) when k < k2 -> find k m | T (_,_,_,m) -> find k m module M = RBTreeMap let m = M.empty |> M.add 3 "3" |> M.add 6 "6" |> M.add 7 "7" let test i = printfn "%d -> %s" i (M.find i m) test 3 test 7 test 13