aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xMakefile5
-rwxr-xr-xcatalog.ml40
-rw-r--r--splay.ml127
-rwxr-xr-xtools.ml14
4 files changed, 158 insertions, 28 deletions
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