From 3bdff980eaf72ea8be3886e8b4463a45cf4e7dc9 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Thu, 2 Nov 2017 13:34:37 +0100 Subject: Add a representation for the splay tree --- catalog.ml | 21 ++++++-- catalog.mli | 4 ++ evaluator.ml | 76 ++++++++++++++--------------- evaluator.mli | 9 +++- expression.ml | 2 +- main.ml | 6 +++ splay.ml | 153 ++++++++++++++++++++++++++++++++-------------------------- splay.mli | 30 ++++++++++++ 8 files changed, 185 insertions(+), 116 deletions(-) create mode 100755 splay.mli diff --git a/catalog.ml b/catalog.ml index 67ec69d..e4cd34b 100755 --- a/catalog.ml +++ b/catalog.ml @@ -7,6 +7,8 @@ module type DATA_SIG = sig val compare_typ: 'a typ -> 'b typ -> ('a, 'b) T.cmp + val repr: Format.formatter -> 'a typ -> unit + end (** We cannot update an existing function. Any [registerX] function will raise @@ -30,6 +32,12 @@ module Make(Data:DATA_SIG) = struct | T2: 'a Data.typ * 'b Data.typ -> ('a * 'b) t_function sig_typ | T3: 'a Data.typ * 'b Data.typ * 'c Data.typ -> ('a * 'b * 'c) t_function sig_typ + + let repr: type a. Format.formatter -> a sig_typ -> unit = fun formatter -> function + | T1 t -> Format.fprintf formatter "(%a)" Data.repr t + | T2 (t1, t2) -> Format.fprintf formatter "(%a,%a)" Data.repr t1 Data.repr t2 + | T3 (t1, t2, t3) -> Format.fprintf formatter "(%a,%a,%a)" Data.repr t1 Data.repr t2 Data.repr t3 + module ComparableSignature = struct type 'a t = string * 'a sig_typ @@ -73,17 +81,22 @@ module Make(Data:DATA_SIG) = struct end + + let repr : type a. Format.formatter -> a t -> unit = begin fun formatter (str, typ) -> + Format.fprintf formatter "%s:%a" + str + repr typ + end + end - module Catalog = Map.Make(String) 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.tree + type t = Functions.t let empty = Functions.empty @@ -107,4 +120,6 @@ module Make(Data:DATA_SIG) = struct Functions.find ((String.uppercase_ascii name), signature) t end + let repr = Functions.repr + end diff --git a/catalog.mli b/catalog.mli index d5e5cfd..e871378 100644 --- a/catalog.mli +++ b/catalog.mli @@ -5,6 +5,8 @@ module type DATA_SIG = sig type 'a returnType val compare_typ: 'a typ -> 'b typ -> ('a, 'b) Tools.cmp + + val repr: Format.formatter -> 'a typ -> unit end @@ -31,4 +33,6 @@ module Make(D:DATA_SIG): sig (** Find a function with the given name and signature *) val find_function: t -> string -> 'a t_function sig_typ -> 'a t_function + val repr: Format.formatter -> t -> unit + end diff --git a/evaluator.ml b/evaluator.ml index 46bbab7..8862b3a 100755 --- a/evaluator.ml +++ b/evaluator.ml @@ -7,13 +7,6 @@ module Data = struct type 'a dataFormat = 'a ScTypes.dataFormat -let most_generic_format: type a. a dataFormat -> a dataFormat -> a dataFormat = - begin fun a b -> match a, b with - | ScTypes.Number, x -> x - | x, ScTypes.Number -> x - | x, _ -> x -end - (*** Type definitions *) type _ typ = @@ -45,7 +38,7 @@ begin fun a b -> | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt end -let rec print_typ: +let rec repr: type a. Format.formatter -> a typ -> unit = fun printer typ -> match typ with | Unit -> Format.fprintf printer "Unit" @@ -53,7 +46,7 @@ fun printer typ -> match typ with | Num -> Format.fprintf printer "Num" | String -> Format.fprintf printer "String" | List t -> Format.fprintf printer "List[%a]" - print_typ t + repr t type 'a returnType = 'a ScTypes.returnType @@ -94,13 +87,6 @@ let type_of_value: type a. a value -> a typ = function | List (t, l) -> List (typ_of_format t) | Matrix (t, l) -> List (List (typ_of_format t)) -let format_of_value: type a. a value -> a ScTypes.dataFormat = function - | Bool b -> ScTypes.Bool - | Num (f, _) -> f - | String s -> ScTypes.String - | List (t, l) -> raise Errors.TypeError - | Matrix (t, l) -> raise Errors.TypeError - let inject': type a. a ScTypes.returnType -> (unit -> a ScTypes.dataFormat) -> a -> a value = fun resultFormat f res -> begin match resultFormat, res with @@ -144,8 +130,14 @@ end module C = Catalog.Make(Data) + +type t = C.t + let (catalog:C.t ref) = ref C.empty +let get_catalog () = !catalog + +let repr = C.repr type existencialResult = | Result : 'a Data.value -> existencialResult [@@unboxed] @@ -217,14 +209,14 @@ let call name args = begin with Not_found -> let signature = List.map (fun (Result x) -> let formatter = Format.str_formatter in - Data.print_typ formatter (Data.type_of_value x); + Data.repr formatter (Data.type_of_value x); Format.flush_str_formatter ()) args in raise (Errors.Undefined (name, signature)) end end -let repr mapper value = begin +let eval mapper value = begin (** Extract the value from a raw type. If the value is Undefined, raise an exception. @@ -331,31 +323,27 @@ let if_: type a. bool -> a -> a -> a = fun a b c -> if a then b else c let () = begin + (* Build a date *) + register3 "date" (t_int, t_int, t_int) f_date ( + fun year month day -> + Date.get_julian_day + (Num.int_of_num @@ Num.floor_num @@ D.Num.to_num year) + (Num.int_of_num @@ Num.floor_num @@ D.Num.to_num month) + (Num.int_of_num @@ Num.floor_num @@ D.Num.to_num day) + |> D.Num.of_num + ); + let module CompareNum = Make_Compare(D.Num) in Data.( CompareNum.register t_int; register0 "rand" f_number D.Num.rnd; - register1 "+" t_int f_num (fun x -> x); - register1 "-" t_int f_num D.Num.neg; (* Unary negation *) - register2 "+" (t_int, t_int) f_num D.Num.add; - register2 "-" (t_int, t_int) f_num D.Num.sub; - register2 "*" (t_int, t_int) f_number D.Num.mult; - register2 "/" (t_int, t_int) f_number D.Num.div; - register2 "^" (t_int, t_int) f_number D.Num.pow; - register3 "if" (t_bool, t_int, t_int) f_number if_; register3 "if" (t_bool, t_bool, t_bool) f_bool if_; register3 "if" (t_bool, t_string, t_string) f_string if_; register1 "abs" t_int f_number D.Num.abs; - fold "sum" t_int f_number D.Num.add (D.Num.of_num (Num.num_of_int 0)); - fold "product" t_int f_number D.Num.mult (D.Num.of_num (Num.num_of_int 1)); - - reduce "min" t_int f_num D.Num.min; (* Minimum value from a list *) - reduce "max" t_int f_num D.Num.max; (* Maximum value from a list *) - let module CompareBool = Make_Compare(D.Bool) in CompareBool.register t_bool; register0 "true" f_bool (fun () -> D.Bool.true_); @@ -368,15 +356,21 @@ let () = begin let module CompareString = Make_Compare(D.String) in CompareString.register t_string; - (* Build a date *) - register3 "date" (t_int, t_int, t_int) f_date ( - fun year month day -> - Date.get_julian_day - (Num.int_of_num @@ Num.floor_num @@ D.Num.to_num year) - (Num.int_of_num @@ Num.floor_num @@ D.Num.to_num month) - (Num.int_of_num @@ Num.floor_num @@ D.Num.to_num day) - |> D.Num.of_num - ) + reduce "min" t_int f_num D.Num.min; (* Minimum value from a list *) + reduce "max" t_int f_num D.Num.max; (* Maximum value from a list *) + + fold "sum" t_int f_number D.Num.add (D.Num.of_num (Num.num_of_int 0)); + fold "product" t_int f_number D.Num.mult (D.Num.of_num (Num.num_of_int 1)); + + register1 "+" t_int f_num (fun x -> x); + register1 "-" t_int f_num D.Num.neg; (* Unary negation *) + register2 "^" (t_int, t_int) f_number D.Num.pow; + register2 "+" (t_int, t_int) f_num D.Num.add; + register2 "-" (t_int, t_int) f_num D.Num.sub; + register2 "*" (t_int, t_int) f_number D.Num.mult; + register2 "/" (t_int, t_int) f_number D.Num.div; + ) end + diff --git a/evaluator.mli b/evaluator.mli index de03ffc..b296b90 100755 --- a/evaluator.mli +++ b/evaluator.mli @@ -1,4 +1,10 @@ -val repr: (ScTypes.refs -> ScTypes.result option ScTypes.Refs.range) -> ScTypes.expression -> ScTypes.result +type t + +val eval: (ScTypes.refs -> ScTypes.result option ScTypes.Refs.range) -> ScTypes.expression -> ScTypes.result + +val repr: Format.formatter -> t -> unit + +val get_catalog: unit -> t (** Type definitions *) @@ -56,6 +62,5 @@ val register3: ( 'a -> 'b -> 'c -> 'd) (* The function to call*) -> unit - (** [wrap f] run [f] inside a context where there is no functions *) val wrap: (unit -> 'a) -> 'a diff --git a/expression.ml b/expression.ml index d42b90e..fd697a9 100755 --- a/expression.ml +++ b/expression.ml @@ -55,7 +55,7 @@ let load_expr expr = expr *) let eval expr sources = begin - let eval_exp f = Evaluator.repr sources f in + let eval_exp f = Evaluator.eval sources f in begin try match expr with | Basic value -> ScTypes.Result value diff --git a/main.ml b/main.ml index 9ecdf84..3b83e85 100755 --- a/main.ml +++ b/main.ml @@ -215,6 +215,12 @@ and command (t, screen) action = begin | ("w", file) -> (* Save the file *) Odf.save t.Sheet.data file; normal_mode @@ redraw t screen + | ("repr", file) -> (* Save the file *) + let out_gv = open_out_bin file in + let form = Format.formatter_of_out_channel out_gv in + Evaluator.repr form (Evaluator.get_catalog ()); + close_out out_gv; + normal_mode @@ redraw t screen | ("enew", _) -> (* Start a new spreadsheet *) normal_mode @@ redraw (Sheet.create Sheet.Raw.empty) screen | ("q", _) -> (* Quit *) diff --git a/splay.ml b/splay.ml index 6f740eb..ec5750c 100644 --- a/splay.ml +++ b/splay.ml @@ -1,21 +1,34 @@ -module Make (El : Tools.COMPARABLE_TYPE) = struct +module type KEY = sig + + type 'a t + + val comp: 'a t -> 'b t -> ('a, 'b) Tools.cmp + + val repr: Format.formatter -> 'a t -> unit + +end + +module Make (El : KEY) = struct type 'a elem = 'a El.t - type treeVal = - | Leaf : treeVal - | Node : treeVal * ('a elem * 'a) * treeVal -> treeVal + type leaf (** Fantom type for typing the tree *) + type node (** Fantom type for typing the tree *) - type tree = treeVal ref + type 'a treeVal = + | Leaf : leaf treeVal + | Node : _ treeVal * ('a elem * 'a) * _ treeVal -> node treeVal - type splay = S : treeVal * ('a elem * 'a) * treeVal -> splay + type t = T : 'a treeVal ref -> t [@@unboxed] - let empty = ref Leaf;; + let empty = T (ref Leaf) - let isEmpty tree = !tree = Leaf + let isEmpty (T tree) = match !tree with + | Leaf -> true + | _ -> false - let rec splay : type a. a elem -> splay -> splay = fun x t -> begin - let S (l, y, r) = t in + let rec splay : type a. a elem -> node treeVal -> node treeVal = fun x t -> begin + let Node (l, y, r) = t in begin match El.comp x (fst y) with | Tools.Eq -> t | Tools.Lt -> @@ -23,22 +36,20 @@ module Make (El : Tools.COMPARABLE_TYPE) = struct | Leaf -> t | Node (ll, z, rr) -> begin match El.comp x (fst z) with - | Tools.Eq -> S (ll, z, Node (rr, y, r)) + | Tools.Eq -> Node (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))) + | Leaf -> Node (ll, z, Node (rr, y, r)) + | Node _ as ll -> + let Node (newL, newV, newR) = splay x ll + in Node (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)) + | Leaf -> Node (ll, z, Node (rr, y, r)) + | Node _ as rr -> + let Node (newL, newV, newR) = splay x rr + in Node (Node (ll, z, newL), newV, Node (newR, y, r)) end end end @@ -47,81 +58,85 @@ module Make (El : Tools.COMPARABLE_TYPE) = struct | Leaf -> t | Node (ll, z, rr) -> begin match El.comp x (fst z) with - | Tools.Eq -> S (Node (l, y, ll), z, rr) + | Tools.Eq -> Node (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)) + | Leaf -> Node (Node (l, y, ll), z, rr) + | Node _ as ll -> + let Node (newL, newV, newR) = splay x ll + in Node (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) + | Leaf -> Node (Node (l, y, ll), z, rr) + | Node _ as rr -> + let Node (newL, newV, newR) = splay x rr + in Node (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 + let member: type a. a elem -> t -> bool = fun x (T 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'); + | Node _ as root -> + let root' = splay x root in + t := root'; + let Node (_, c', _) = root' in 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 + let find: type a. a elem -> t -> a = fun x (T 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'); + | Node _ as root -> + let root' = splay x root in + t := root'; + let Node (_, c', _) = root' in 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 + let add: type a. a elem -> a -> t -> t = fun key value (T t) -> match !t with + | Leaf -> T (ref (Node (Leaf, (key, value), Leaf))) + | Node _ as root -> + let root' = splay key root in + let Node (l, y, r) = root' 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)) + | Tools.Eq -> T (ref root') + | Tools.Lt -> T (ref (Node (l, (key, value), Node (Leaf, y, r)))) + | Tools.Gt -> T (ref (Node (Node (l, y, Leaf), (key, value), r))) end - end - let delete: type a. a elem -> treeVal ref -> treeVal ref = fun x t -> + let repr formatter (T t) = begin + + let repr_edge from formatter dest = begin + Format.fprintf formatter "\"%a\" -> \"%a\"\n" + El.repr from + El.repr dest + end in + + let rec repr': type a b. a El.t -> Format.formatter -> b treeVal -> unit = fun parent formatter -> function + | Leaf -> () + | Node (l, c, r) -> + let key = fst c in + Format.fprintf formatter "%a%a%a" + (repr_edge parent) key + (repr' key) l + (repr' key) r in + begin match !t with - | Leaf -> ref Leaf + | Leaf -> Format.fprintf formatter "digraph G {}" | 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 key = fst c in + Format.fprintf formatter "digraph G {\n%a%a}" + (repr' key) l + (repr' key) 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/splay.mli b/splay.mli new file mode 100755 index 0000000..41c1a5a --- /dev/null +++ b/splay.mli @@ -0,0 +1,30 @@ +module type KEY = sig + + type 'a t + + val comp: 'a t -> 'b t -> ('a, 'b) Tools.cmp + + val repr: Format.formatter -> 'a t -> unit + +end + +module Make (El : KEY) : sig + + type t + + (** Create an empty tree *) + val empty: t + + (** Return the element in the tree with the given key *) + val find: 'a El.t -> t -> 'a + + (** Add one element in the tree *) + val add: 'a El.t -> 'a -> t -> t + + (** Check if the key exists *) + val member: 'a El.t -> t -> bool + + (** Represent the content in dot syntax *) + val repr: Format.formatter -> t -> unit + +end -- cgit v1.2.3