diff options
| -rwxr-xr-x | Makefile | 5 | ||||
| -rwxr-xr-x | catalog.ml | 40 | ||||
| -rw-r--r-- | splay.ml | 127 | ||||
| -rwxr-xr-x | tools.ml | 14 |
4 files changed, 158 insertions, 28 deletions
@@ -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
@@ -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 @@ -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 |