From 397f2878434d1a1a3ea2091f309ae03c58c6c4db Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Wed, 1 Nov 2017 10:40:44 +0100 Subject: Added splaytree --- Makefile | 5 ++- catalog.ml | 40 +++++++++---------- splay.ml | 127 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ tools.ml | 14 ++++--- 4 files changed, 158 insertions(+), 28 deletions(-) create mode 100644 splay.ml diff --git a/Makefile b/Makefile index ec420a0..5dbb9a0 100755 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ OCAMLBUILD ?= ocamlbuild -PACKAGES=num,curses,camlzip,ezxmlm,text,str,menhirLib +PACKAGES=dynlink,num,curses,camlzip,ezxmlm,text,str,menhirLib PATHS=.,odf MENHIR=-use-menhir @@ -33,6 +33,9 @@ doc: test.byte: stub $(OCAMLBUILD) -pkgs $(PACKAGES),oUnit -cflag -g -lflag -g $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS),tests,tests/odf $@ +%.cmxs: stub + $(OCAMLBUILD) -use-ocamlfind -tags optimize\(3\) -pkgs $(PACKAGES) $(MENHIR) -Is $(PATHS) $@ + test: test.byte ./test.byte diff --git a/catalog.ml b/catalog.ml index bd17a18..67ec69d 100755 --- a/catalog.ml +++ b/catalog.ml @@ -32,13 +32,13 @@ module Make(Data:DATA_SIG) = struct module ComparableSignature = struct - type 'a t = 'a sig_typ + type 'a t = string * 'a sig_typ (* Type for pure equality *) type (_, _) eq = Eq : ('a, 'a) eq (** Compare two signature *) - let eq: type a b. a sig_typ -> b sig_typ -> (a, b) T.cmp = begin fun a b -> + let comp: type a b. string * a sig_typ -> string * b sig_typ -> (a, b) T.cmp = begin fun (namea, a) (nameb, b) -> let cmp: type c d. c Data.typ -> d Data.typ -> ((c, d) eq -> (a, b) T.cmp) -> (a, b) T.cmp = begin fun a b f -> match Data.compare_typ a b with @@ -47,14 +47,22 @@ module Make(Data:DATA_SIG) = struct | T.Gt -> T.Gt end in - match a, b with + if namea < nameb then + T.Lt + else if namea > nameb then + T.Gt + else match a, b with | T1(a), T1(b) -> cmp a b (fun Eq -> T.Eq) + | T1(_), _ -> T.Lt + | _, T1(_) -> T.Gt | T2(a, b), T2(c, d) -> cmp a c (fun Eq -> cmp b d (fun Eq -> T.Eq) ) + | T2(_), _ -> T.Lt + | _, T2(_) -> T.Gt | T3(a, b, c), T3(d, e, f) -> cmp a d (fun Eq -> @@ -63,22 +71,21 @@ module Make(Data:DATA_SIG) = struct ) ) - | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt end end module Catalog = Map.Make(String) - module Functions = Tools.Map(ComparableSignature) + module Functions = Splay.Make(ComparableSignature) (* This is the map which contains all the registered functions. Each name is binded with another map with contains the function for each signature. *) - type t = Functions.t Catalog.t + type t = Functions.tree - let empty = Catalog.empty + let empty = Functions.empty (** Register a function in the catalog. If the function is already defined, @@ -87,26 +94,17 @@ module Make(Data:DATA_SIG) = struct let register t name signature f = begin let name' = String.uppercase_ascii name in - let map = begin match Catalog.find name' t with - | exception Not_found -> - Functions.singleton signature f - | x -> - (* We prevent any update to already registered function *) - if (Functions.mem signature x) then - raise RegisteredFunction - else - Functions.add signature f x - end in - - Catalog.add name' map t + if Functions.member (name', signature) t then + raise RegisteredFunction + else + Functions.add (name', signature) f t end (** Look in the catalog for a function with the given name and signature *) let find_function: type a. t -> string -> a t_function sig_typ -> a t_function = begin fun t name signature -> - Catalog.find (String.uppercase_ascii name) t - |> Functions.find signature + Functions.find ((String.uppercase_ascii name), signature) t end end diff --git a/splay.ml b/splay.ml new file mode 100644 index 0000000..6f740eb --- /dev/null +++ b/splay.ml @@ -0,0 +1,127 @@ +module Make (El : Tools.COMPARABLE_TYPE) = struct + + type 'a elem = 'a El.t + + type treeVal = + | Leaf : treeVal + | Node : treeVal * ('a elem * 'a) * treeVal -> treeVal + + type tree = treeVal ref + + type splay = S : treeVal * ('a elem * 'a) * treeVal -> splay + + let empty = ref Leaf;; + + let isEmpty tree = !tree = Leaf + + let rec splay : type a. a elem -> splay -> splay = fun x t -> begin + let S (l, y, r) = t in + begin match El.comp x (fst y) with + | Tools.Eq -> t + | Tools.Lt -> + begin match l with + | Leaf -> t + | Node (ll, z, rr) -> + begin match El.comp x (fst z) with + | Tools.Eq -> S (ll, z, Node (rr, y, r)) + | Tools.Lt -> + begin match ll with + | Leaf -> S (ll, z, Node (rr, y, r)) + | Node (t1, k, t2 ) -> + let ll = S (t1, k, t2) in + let S (newL, newV, newR) = splay x ll + in S (newL, newV, Node (newR, z, Node (rr, y, r))) + end + | Tools.Gt -> + begin match rr with + | Leaf -> S (ll, z, Node (rr, y, r)) + | Node (t1, k, t2 ) -> + let rr = S (t1, k, t2) in + let S (newL, newV, newR) = splay x rr + in S (Node (ll, z, newL), newV, Node (newR, y, r)) + end + end + end + | Tools.Gt -> + begin match r with + | Leaf -> t + | Node (ll, z, rr) -> + begin match El.comp x (fst z) with + | Tools.Eq -> S (Node (l, y, ll), z, rr) + | Tools.Lt -> + begin match ll with + | Leaf -> S (Node (l, y, ll), z, rr) + | Node (t1, k, t2 ) -> + let ll = S (t1, k, t2) in + let S (newL, newV, newR) = splay x ll + in S (Node (l, y, newL), newV, Node (newR, z, rr)) + end + | Tools.Gt -> + begin match rr with + | Leaf -> S (Node (l, y, ll), z, rr) + | Node (t1, k, t2 ) -> + let rr = S (t1, k, t2) in + let S (newL, newV, newR) = splay x rr + in S (Node (Node(l, y, ll), z, newL), newV, newR) + end + end + end + end + end + + let member: type a. a elem -> treeVal ref -> bool = fun x t -> + + match !t with + | Leaf -> false + | Node (l, c, r) -> + let S (l', c', r') = splay x (S (l, c, r)) in + t := Node (l', c', r'); + begin match El.comp (fst c') x with + | Tools.Eq -> true + | _ -> false + end + + let find: type a. a elem -> treeVal ref -> a = fun x t -> + + match !t with + | Leaf -> raise Not_found + | Node (l, c, r) -> + let S (l', c', r') = splay x (S (l, c, r)) in + t := Node (l', c', r'); + begin match El.comp (fst c') x with + | Tools.Eq -> snd c' + | _ -> raise Not_found + end + + let add: type a. a elem -> a -> treeVal ref -> treeVal ref = fun key value t -> + begin match !t with + | Leaf -> ref (Node (Leaf, (key, value), Leaf)) + | Node (l, c, r) -> + let S (l, y, r) = splay key (S (l, c, r)) in + begin match El.comp key (fst y) with + | Tools.Eq -> ref (Node (l, y, r)) + | Tools.Lt -> ref (Node (l, (key, value), Node (Leaf, y, r))) + | Tools.Gt -> ref (Node (Node (l, y, Leaf), (key, value), r)) + end + end + + let delete: type a. a elem -> treeVal ref -> treeVal ref = fun x t -> + begin match !t with + | Leaf -> ref Leaf + | Node (l, c, r) -> + let S (l, y, r) = splay x (S (l, c, r)) in + begin match El.comp x (fst y) with + Tools.Eq -> + begin match (l,r) with + | (Leaf, _) -> ref r + | (_, Leaf) -> ref l + | (Node (t1, c, t2), _) -> + let S (newL, newV, newR) = splay x (S (t1, c, t2)) + in ref (Node (newL, newV, r)) end + | _ -> ref (Node (l, y, r)) end + end + + let rec depth tree = match tree with + | Node (l, _, r) -> max (depth l) (depth r) + 1 + | Leaf -> 0 +end diff --git a/tools.ml b/tools.ml index 53b1c15..f8f03cb 100755 --- a/tools.ml +++ b/tools.ml @@ -304,7 +304,7 @@ module type COMPARABLE_TYPE = sig type 'a t - val eq: 'a t -> 'b t -> ('a, 'b) cmp + val comp: 'a t -> 'b t -> ('a, 'b) cmp end @@ -317,7 +317,7 @@ module ArrayMap(Ord: COMPARABLE_TYPE) = struct let find: type a. a key -> t -> a = begin fun k (Val map) -> let rec find_ idx : a = begin let x, v = Array.get map idx in - match Ord.eq x k with + match Ord.comp x k with | Eq -> v | Lt -> find_ ((2 * idx) + 1) | Gt -> find_ ((2 * idx) + 2) @@ -326,7 +326,7 @@ module ArrayMap(Ord: COMPARABLE_TYPE) = struct end let from_list l = begin - let compare (key_x, _) (key_y, _) = match Ord.eq key_x key_y with + let compare (key_x, _) (key_y, _) = match Ord.comp key_x key_y with | Eq -> 0 | Lt -> -1 | Gt -> 1 @@ -401,7 +401,7 @@ module Map(Ord: COMPARABLE_TYPE) = struct let rec add: type a. a key -> a -> t -> t = begin fun x data t -> match t with | Empty -> Node(Empty, x, data, Empty, 1) | Node(l, v, d, r, h) -> - match Ord.eq x v with + match Ord.comp x v with | Eq -> Node(l, x, data, r, h) | Lt -> bal (add x data l) v d r | Gt -> bal l v d (add x data r) @@ -410,7 +410,7 @@ module Map(Ord: COMPARABLE_TYPE) = struct let rec find: type a. a key -> t -> a = begin fun x t -> match t with | Empty -> raise Not_found | Node(l, k, v, r, _) -> - match Ord.eq x k with + match Ord.comp x k with | Eq -> v | Lt -> find x l | Gt -> find x r @@ -419,12 +419,13 @@ module Map(Ord: COMPARABLE_TYPE) = struct let rec mem: type a. a key -> t -> bool = begin fun x t -> match t with | Empty -> false | Node(l, k, v, r, _) -> - match Ord.eq x k with + match Ord.comp x k with | Eq -> true | Lt -> mem x l | Gt -> mem x r end + (* let rec fold: ('a -> wrapper -> 'a) -> 'a -> t -> 'a = begin fun f init t -> match t with | Empty -> init @@ -433,4 +434,5 @@ module Map(Ord: COMPARABLE_TYPE) = struct let result = f res_left @@ Ex (k, v) in fold f result r end + *) end -- cgit v1.2.3