Add a representation for the splay tree

8 files changed, 185 insertions, 116 deletions

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