Use gadt for function catalog

author: Sébastien Dailly <sebastien@chimrod.com> 2016-11-21 17:06:19 +0100
committer: Sébastien Dailly <sebastien@chimrod.com> 2017-01-01 13:30:43 +0100
commit: 023c11470e32744a43b7e3c7c248f3c47ebdc687 (patch)
tree: 832e04c2923295d5adf61e58d9a333afb5b26c77
parent: ef312564ca84a2b49fc291434d8fb2f8501bb618 (diff)
23 files changed, 1274 insertions, 256 deletions
diff --git a/.gitignore b/.gitignore
index 31cdc19..884e8f0 100755
--- a/.gitignore
+++ b/.gitignore
@@ -3,3 +3,6 @@ _build/
 *.native
 *.swp
 *.docdir
+*.o
+*.so
+*.a
diff --git a/.merlin b/.merlin
index a3f38e6..3194a14 100755
--- a/.merlin
+++ b/.merlin
@@ -1,4 +1,4 @@
-PKG num curses camlzip ezxmlm uutf text calendar oUnit menhirLib
+PKG num curses camlzip ezxmlm uutf text oUnit menhirLib
 S .
 S odf/*
 S tests/*
diff --git a/Makefile b/Makefile
index a792dd6..f90a98c 100755
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,5 @@
 OCAMLBUILD ?= ocamlbuild
-PACKAGES=num,curses,camlzip,ezxmlm,text,calendar,menhirLib
+PACKAGES=num,curses,camlzip,ezxmlm,text,str,menhirLib
 PATHS=.,odf
 
 MENHIR=-use-menhir
@@ -18,13 +18,14 @@ stub:
 	$(MAKE) -C stub LIB=$(LIB)
 
 deps:
-	opam install ocamlbuild curses camlzip ezxmlm ounit text menhir calendar
+	opam install ocamlbuild curses camlzip ezxmlm ounit text menhir
 
 byte: stub
 	$(OCAMLBUILD) -pkgs $(PACKAGES) $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS) main.byte
 
 native: stub
-	$(OCAMLBUILD) -pkgs $(PACKAGES) $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS) main.native
+	$(OCAMLBUILD) -tags optimize\(3\) -pkgs $(PACKAGES) $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS) main.native
+	#$(OCAMLBUILD) -pkgs $(PACKAGES) $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS) main.native
 
 doc:
 	$(OCAMLBUILD) -pkgs $(PACKAGES) -menhir -Is $(PATHS) licht.docdir/index.html
diff --git a/dataType.ml b/dataType.ml
new file mode 100755
index 0000000..3937465
--- /dev/null
+++ b/dataType.ml
@@ -0,0 +1,133 @@
+module type COMPARABLE = sig
+  type t
+  val eq: t -> t -> bool
+  val neq: t -> t -> bool
+  val lt: t -> t -> bool
+  val le: t -> t -> bool
+  val gt: t -> t -> bool
+  val ge: t -> t -> bool
+end
+
+module Comparable = struct
+
+  let eq = (=)
+  let neq = (<>)
+  let lt = (<)
+  let le = (<=)
+  let gt = (>)
+  let ge = (>=)
+
+end
+
+module Num = struct
+
+  type t =
+    | NAN
+    | N of Num.num
+
+  let nan = NAN
+
+  let of_num n = N n
+
+  let zero = Num.num_of_int 0
+
+  let to_num = function
+    | NAN -> zero
+    | N n -> n
+
+  let eq v1 v2 = match v1, v2 with
+    | N n1, N n2 -> Num.eq_num n1 n2
+    | _, _ -> false
+
+  let neq a b = not (eq a b)
+
+  let lt v1 v2 = match v1, v2 with
+    | N n1, N n2 -> Num.lt_num n1 n2
+    | N x, NAN -> Num.lt_num x (zero)
+    | NAN, N x -> Num.lt_num (zero) x
+    | NAN, NAN -> false
+
+  let le v1 v2 = match v1, v2 with
+    | N n1, N n2 -> Num.le_num n1 n2
+    | N x, NAN -> Num.le_num x (zero)
+    | NAN, N x -> Num.le_num (zero) x
+    | NAN, NAN -> false
+
+  let gt v1 v2 = match v1, v2 with
+    | N n1, N n2 -> Num.gt_num n1 n2
+    | N x, NAN -> Num.gt_num x (zero)
+    | NAN, N x -> Num.gt_num (zero) x
+    | NAN, NAN -> false
+
+  let ge v1 v2 = match v1, v2 with
+    | N n1, N n2 -> Num.ge_num n1 n2
+    | N x, NAN -> Num.ge_num x (zero)
+    | NAN, N x -> Num.ge_num (zero) x
+    | NAN, NAN -> false
+
+  let add v1 v2 = match v1, v2 with
+    | N n1, N n2 -> N (Num.add_num n1 n2)
+    | n1, NAN -> n1
+    | NAN, n1 -> n1
+
+  let mult v1 v2 = match v1, v2 with
+   | N n1, N n2 -> N (Num.mult_num n1 n2)
+   | _, _ -> N zero
+
+  let div v1 v2 = match v1, v2 with
+   | N n1, N n2 -> N (Num.div_num n1 n2)
+   | _, N _ -> N zero
+   | _, _ -> raise Division_by_zero
+
+  let sub v1 v2 = match v1, v2 with
+   | N n1, N n2 -> N (Num.sub_num n1 n2)
+   | v, NAN -> v
+   | NAN, N n -> N (Num.minus_num n)
+
+  let pow v1 v2 = match v1, v2 with
+   | N n1, N n2 -> N (Num.power_num n1 n2)
+   | _, NAN -> N (Num.num_of_int 1)
+   | NAN, _ -> N zero
+
+  let rnd () = N (
+    Num.div_num
+    (Num.num_of_int @@ Int32.to_int @@ Random.int32 Int32.max_int)
+    (Num.num_of_int @@ Int32.to_int @@ Int32.max_int)
+  )
+
+  let min v1 v2 = match v1, v2 with
+   | N n1, N n2 -> N (Num.min_num n1 n2)
+   | NAN, x -> x
+   | x, NAN -> x
+
+  let max v1 v2 = match v1, v2 with
+   | N n1, N n2 -> N (Num.max_num n1 n2)
+   | NAN, x -> x
+   | x, NAN -> x
+
+  let abs = function
+    | NAN -> NAN
+    | N n1 -> N (Num.abs_num n1)
+
+end
+
+module Bool = struct
+
+  type t = bool
+  include Comparable
+
+  let true_ = true
+  let false_ = false
+
+  let or_ = (||)
+  let and_ = (&&)
+  let not = Pervasives.not
+
+end
+
+module String = struct
+
+  type t = UTF8.t
+  include Comparable
+
+end
diff --git a/dataType.mli b/dataType.mli
new file mode 100755
index 0000000..09b0082
--- /dev/null
+++ b/dataType.mli
@@ -0,0 +1,67 @@
+module type COMPARABLE = sig
+  type t
+  val eq: t -> t -> bool
+  val neq: t -> t -> bool
+  val lt: t -> t -> bool
+  val le: t -> t -> bool
+  val gt: t -> t -> bool
+  val ge: t -> t -> bool
+end
+
+module Num: sig
+
+  type t
+
+  val of_num: Num.num -> t
+  val nan: t
+
+  val to_num: t -> Num.num
+
+  val eq: t -> t -> bool
+  val neq: t -> t -> bool
+  val lt: t -> t -> bool
+  val le: t -> t -> bool
+  val gt: t -> t -> bool
+  val ge: t -> t -> bool
+
+  val add: t -> t -> t
+  val sub: t -> t -> t
+  val mult: t -> t -> t
+  val div: t -> t -> t
+  val pow: t -> t -> t
+
+  val rnd: unit -> t
+
+  val max: t -> t -> t
+  val min: t -> t -> t
+
+  val abs: t -> t
+end
+
+module Bool: sig
+  type t = bool
+
+  val true_ : bool
+  val false_: bool 
+
+  val eq: t -> t -> bool
+  val neq: t -> t -> bool
+  val lt: t -> t -> bool
+  val le: t -> t -> bool
+  val gt: t -> t -> bool
+  val ge: t -> t -> bool
+
+  val not: t -> t
+  val and_: t -> t -> t
+  val or_: t -> t -> t
+end
+
+module String: sig
+  type t = UTF8.t
+  val eq: t -> t -> bool
+  val neq: t -> t -> bool
+  val lt: t -> t -> bool
+  val le: t -> t -> bool
+  val gt: t -> t -> bool
+  val ge: t -> t -> bool
+end
diff --git a/errors.ml b/errors.ml
new file mode 100755
index 0000000..8f389ce
--- /dev/null
+++ b/errors.ml
@@ -0,0 +1,12 @@
+
+(** The function is undefined *)
+exception Undefined of UTF8.t * string list
+
+exception TypeError
+
+let printf formatter = function
+  | Undefined (name, args) -> Format.fprintf formatter
+      "There is no function '%s' with signature %a"
+      (UTF8.to_utf8string name)
+      (Format.pp_print_list Format.pp_print_text) args
+  | _ -> Format.fprintf formatter "#Error"
diff --git a/evaluator.ml b/evaluator.ml
new file mode 100755
index 0000000..3adf7fa
--- /dev/null
+++ b/evaluator.ml
@@ -0,0 +1,556 @@
+module D = DataType
+module T = Tools
+
+let u = UTF8.from_utf8string
+
+exception RegisteredFunction
+
+(** Data format *)
+
+type _ dataFormat =
+  | Date: D.Num.t dataFormat    (* Date *)
+  | Number: D.Num.t dataFormat  (* Number *)
+  | String: UTF8.t dataFormat   (* String result, there is only one representation *)
+  | Bool: D.Bool.t dataFormat   (* Boolean result *)
+
+let most_generic_format: type a. a dataFormat -> a dataFormat -> a dataFormat =
+  begin fun a b -> match a, b with
+  | Number, x -> x
+  | x, Number -> x
+  | x, _ -> x
+end
+
+(*** Type definitions *)
+
+type _ typ =
+  | Unit: unit typ
+  | Bool: D.Bool.t typ
+  | Num: D.Num.t typ
+  | String: UTF8.t typ
+  | List: 'a typ -> 'a list typ
+
+let t_bool= Bool
+let t_int = Num
+let t_string = String
+let t_list t = List t
+
+let typ_of_format: type a. a dataFormat -> a typ = function
+  | Date -> Num
+  | Number -> Num
+  | String -> String
+  | Bool -> Bool
+
+let rec compare_typ: type a b. a typ -> b typ -> (a, b) T.cmp = begin fun a b ->
+  match a, b with
+  | Unit, Unit     -> T.Eq
+  | Bool, Bool     -> T.Eq
+  | Num, Num       -> T.Eq
+  | String, String -> T.Eq
+  | List l1, List l2 ->
+      begin match compare_typ l1 l2 with
+      | T.Lt -> T.Lt
+      | T.Eq -> T.Eq
+      | T.Gt -> T.Gt
+      end
+  | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt
+end
+
+let rec print_typ: type a. Format.formatter -> a typ -> unit = fun printer typ -> match typ with
+  | Unit ->   Format.fprintf printer "Unit"
+  | Bool ->   Format.fprintf printer "Bool"
+  | Num  ->   Format.fprintf printer "Num"
+  | String -> Format.fprintf printer "String"
+  | List t -> Format.fprintf printer "List[%a]"
+                print_typ t
+
+let default_format_for_type: type a. a typ -> a dataFormat = function
+  | Num -> Date
+  | String -> String
+  | Bool -> Bool
+  | List _ -> raise Errors.TypeError
+  | Unit -> raise Errors.TypeError
+
+(** Results format.
+    Any value which can be encoded with different representation requires as
+    many format than there are representations for this value.
+*)
+
+type _ result =
+  | Numeric: D.Num.t result (* Any numeric format : the representation depends from the inputs  *)
+  | Date: D.Num.t result    (* Date *)
+  | Number: D.Num.t result  (* Number *)
+  | String: UTF8.t result   (* String result, there is only one representation *)
+  | Bool: D.Bool.t result   (* Boolean result *)
+
+let f_num  = Numeric
+let f_date = Date
+let f_number = Number
+let f_string = String
+let f_bool = Bool
+
+let specialize_result: type a. a result -> a dataFormat -> a result =
+  begin fun a b -> match a, b with
+  | Date, _ -> Date
+  | _, Date -> Date
+  | x, y -> x
+end
+
+let typ_of_result: type a. a result -> a typ = function
+  | Numeric -> Num
+  | Number -> Num
+  | Date -> Num
+  | Bool -> Bool
+  | String -> String
+
+let rec compare_result: type a b. a result -> b result -> (a, b) T.cmp = begin fun a b ->
+  match a, b with
+  | Bool, Bool     -> T.Eq
+  | Numeric, Numeric-> T.Eq
+  | String, String -> T.Eq
+  | Number, Number -> T.Eq
+  | Date, Date -> T.Eq
+  | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt
+
+end
+(*** Values definitions *)
+
+type 'a value =
+  | Bool: D.Bool.t -> D.Bool.t value
+  | Num: D.Num.t dataFormat * D.Num.t -> D.Num.t  value
+  | String: UTF8.t -> UTF8.t   value
+  | List: 'a dataFormat * 'a list -> 'a list value
+  | List2: 'a dataFormat * 'a list list -> 'a list list value
+
+(** Get the value out of the box *)
+let get_value_content: type a. a value -> a = function
+  | Bool b -> b
+  | Num (_, n) -> n
+  | String s -> s
+  | List (t, l) -> l
+  | List2 (t, l) -> l
+
+(** Create a value from a known type and an unboxed value *)
+let build_value: type a. a dataFormat -> a -> a value = begin fun format content ->
+  match (typ_of_format format), content with
+    | Unit, _ -> raise Errors.TypeError
+    | Bool, x -> Bool x
+    | Num, x -> Num (format, x)
+    | String, s -> String s
+    | List t, l -> raise Errors.TypeError
+end
+
+(* Extract the type from a boxed value *)
+let type_of_value: type a. a value -> a typ = function
+  | Bool b -> Bool
+  | Num (n, _) -> Num
+  | String s -> String
+  | List (t, l) -> List (typ_of_format t)
+  | List2 (t, l) -> List (List (typ_of_format t))
+
+let format_of_value: type a. a value -> a dataFormat = function
+  | Bool b -> Bool
+  | Num (f, _) -> f
+  | String s -> String
+  | List (t, l)  -> raise Errors.TypeError
+  | List2 (t, l) -> raise Errors.TypeError
+
+type existencialResult =
+  | Result : 'a value -> existencialResult
+
+(** Catalog for all functions *)
+module C = struct
+
+  (** This is the way the function is store in the map.
+       We just the return type, and the function itself.
+
+       For Fn1 and T1 constructors, we need to add extra information in the
+       GADT signature in order to help the compiler: 'a could be any ('a * 'b),
+       ('a * 'b * 'c) and so on…
+
+       Instead of returning a signature with type 'a t_function, we have to
+       force it as 'a typ t_function.
+    *)
+  type _ t_function =
+    | Fn1: 'b result * ('a -> 'b) -> 'a typ t_function
+    | Fn2: 'c result * ('a -> 'b -> 'c) -> ('a * 'b) t_function
+    | Fn3: 'd result * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function
+
+  (** This is the key for storing functions in the map.
+   *)
+  type _ sig_typ =
+    | T1: 'a typ -> 'a typ t_function sig_typ
+    | T2: 'a typ * 'b typ -> ('a * 'b) t_function sig_typ
+    | T3: 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) t_function sig_typ
+
+  let print_sig_typ: type a. Format.formatter -> a sig_typ -> unit = begin fun printer typ ->
+    match typ with
+    | T1 a -> Format.fprintf printer "(%a)"
+        print_typ a
+    | T2 (a, b) -> Format.fprintf printer "(%a, %a)"
+        print_typ a
+        print_typ b
+    | T3 (a, b, c) -> Format.fprintf printer "(%a, %a, %a)"
+        print_typ a
+        print_typ b
+        print_typ c
+  end
+
+  module ComparableSignature = struct
+
+    type 'a t = 'a sig_typ
+
+    (** Compare two signature *)
+    let eq: type a b. a sig_typ -> b sig_typ -> (a, b) T.cmp = begin fun a b ->
+      match a, b with
+      | T1(a), T1(b) ->
+        begin match compare_typ a b with
+        | T.Lt -> T.Lt
+        | T.Gt -> T.Gt
+        | T.Eq -> T.Eq
+        end
+      | T2(a, b), T2(c, d) ->
+        begin match (compare_typ a c) with
+        | T.Lt -> T.Lt
+        | T.Gt -> T.Gt
+        | T.Eq ->
+          begin match (compare_typ b d) with
+          | T.Lt -> T.Lt
+          | T.Gt -> T.Gt
+          | T.Eq -> T.Eq
+          end
+        end
+      | T3(a, b, c), T3(d, e, f) ->
+        begin match (compare_typ a d) with
+        | T.Lt -> T.Lt
+        | T.Gt -> T.Gt
+        | T.Eq ->
+          begin match (compare_typ b e) with
+          | T.Lt -> T.Lt
+          | T.Gt -> T.Gt
+          | T.Eq ->
+            begin match (compare_typ c f) with
+            | T.Lt -> T.Lt
+            | T.Gt -> T.Gt
+            | T.Eq -> T.Eq
+            end
+          end
+        end
+      | 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)
+
+
+  (* This is the map which contains all the registered functions.
+     Each name is binded with another map with contains the function for each
+     signature.
+   *)
+  let (catalog:Functions.t Catalog.t ref) = ref Catalog.empty
+
+  (**
+     Register a function in the catalog. If the function is already defined,
+     raise an exception.
+   *)
+  let register name signature f = begin
+
+    let name' = String.uppercase_ascii name in
+    let map = begin match Catalog.find name' !catalog 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 := Catalog.add name' map !catalog
+  end
+
+  let inject: type a. a result -> (unit -> a dataFormat) -> a -> existencialResult = fun resultFormat f res ->
+    let (x:a value) = begin match resultFormat, res with
+    | Bool, x -> Bool x
+    | Numeric, x -> Num (f (), x)
+    | Date, x -> Num(Date, x)
+    | Number, x -> Num(Number, x)
+    | String, s -> String s
+    end in
+    Result x
+
+  (** Look in the catalog for a function with the given name and signature *)
+  let find_function: type a. string -> a t_function sig_typ -> a t_function = begin fun name signature ->
+    Catalog.find (String.uppercase_ascii name) !catalog
+    |> Functions.find signature
+  end
+
+end
+
+(** Guess the format to use for the result function from the arguments given.
+    The most specialized format take over the others.
+*)
+let guess_format_result: type a. a result -> existencialResult list -> unit -> a dataFormat =
+  begin fun init_value values () ->
+
+  let init_typ = typ_of_result init_value in
+
+  (* fold over the arguments, and check if they have the same format *)
+  let compare_format (currentResult: a result) (Result value): a result =
+
+    (* If the argument as the same type as the result format, just the most specialized *)
+    match compare_typ init_typ (type_of_value value) with
+      | T.Eq -> begin match value with
+        | Bool b -> Bool
+        | String s -> String
+        | Num (f, v) -> specialize_result currentResult f
+        (* There is no possibility to get init_typ as List typ*)
+        | List (f, v) -> raise Errors.TypeError
+        | List2 (f, v) -> raise Errors.TypeError
+        end
+      (* The types differ, handle the special cases for Lists *)
+      | _ ->
+        begin match value with
+        | List (f, v) ->
+          begin match compare_typ init_typ (typ_of_format f) with
+          | T.Eq -> specialize_result currentResult f
+          | _ -> currentResult
+          end
+        | List2 (f, v) ->
+          begin match compare_typ init_typ (typ_of_format f) with
+          | T.Eq -> specialize_result currentResult f
+          | _ -> currentResult
+          end
+        | _ -> currentResult
+        end in
+
+  begin match List.fold_left compare_format init_value values with
+  | String -> String
+  | Bool -> Bool
+  | Number -> Number
+  | Date -> Date
+  | Numeric -> Number
+  end
+
+end
+
+let register0 name returnType f =
+  C.register name (C.T1(Unit)) (C.Fn1 (returnType, f))
+
+let register1 name typ1 returnType f =
+  C.register name (C.T1(typ1)) (C.Fn1 (returnType, f))
+
+let register2 name (typ1, typ2) result f =
+  C.register name (C.T2(typ1, typ2)) (C.Fn2 (result, f))
+
+let register3 name (typ1, typ2, typ3) result f =
+  C.register name (C.T3(typ1, typ2, typ3)) (C.Fn3 (result, f))
+
+let call name args = begin
+  let name' = UTF8.to_utf8string name in
+  begin try match args with
+
+  | [] ->
+    let C.Fn1(ret, f) = C.find_function name' (C.T1 Unit) in
+    C.inject ret (fun () -> raise Errors.TypeError) (f ())
+
+  | (Result p1)::[] ->
+    let C.Fn1(ret, f) =
+      C.find_function name' (C.T1 (type_of_value p1)) in
+    C.inject ret (guess_format_result ret args) (f (get_value_content p1))
+
+  | (Result p1)::(Result p2)::[] ->
+    let C.Fn2(ret, f) =
+      C.find_function name' (C.T2 (type_of_value p1, type_of_value p2)) in
+    C.inject ret (guess_format_result ret args) (f (get_value_content p1) (get_value_content p2))
+
+  | (Result p1)::(Result p2)::(Result p3)::[] ->
+    let C.Fn3(ret, f) =
+      C.find_function name' (C.T3 (type_of_value p1, type_of_value p2, type_of_value p3)) in
+    C.inject ret (guess_format_result ret args) (f (get_value_content p1) (get_value_content p2) (get_value_content p3))
+
+  | _ -> raise Not_found
+  with Not_found ->
+      let signature = List.map (fun (Result x) ->
+        let formatter = Format.str_formatter in
+        print_typ formatter (type_of_value x);
+        Format.flush_str_formatter ()) args in
+
+      raise (Errors.Undefined (name, signature))
+  end
+end
+
+let repr mapper value = begin
+
+  (** Extract the value from a raw type.
+      If the value is Undefined, raise an exception.
+   *)
+  let extract_value = begin function
+    | ScTypes.Num (n,s) -> Result (Num (Number, (D.Num.of_num n)))
+    | ScTypes.Bool b    -> Result (Bool b)
+    | ScTypes.Date d    -> Result (Num (Date, (D.Num.of_num d)))
+    | ScTypes.Str s     -> Result (String s)
+    | ScTypes.Undefined -> raise Errors.TypeError
+  end in
+
+  (** Extract the value from a raw type.
+      If the value is Undefined, provide a default result.
+   *)
+  let guess_value: type a. a typ -> ScTypes.types -> existencialResult = fun typ value -> begin
+    try extract_value value with Errors.TypeError ->
+      match typ with
+      | Num  ->   Result (Num (Number, (D.Num.nan)))
+      | Bool ->   Result (Bool false)
+      | String -> Result (String (u""))
+      | List x  -> Result (List ((default_format_for_type x), []))
+      | Unit -> raise Errors.TypeError
+  end in
+
+
+  let add_elem: type a. a typ -> a list * a dataFormat -> ScTypes.types -> a list * a dataFormat =
+  begin fun type_of (result, format_of) next ->
+      let Result r = guess_value type_of next in
+      begin match compare_typ type_of (type_of_value r) with
+      | T.Eq ->
+        let l' = (get_value_content r)::result in
+        l' , (most_generic_format (format_of_value r) format_of)
+      | _ -> raise Errors.TypeError
+      end
+  end in
+
+  (* Return the result for any expression as an ScTypes.types result *)
+  let rec get_repr: type a. a value -> ScTypes.types = begin function
+  | Bool b ->  ScTypes.Bool b
+  | Num (format, n)  ->  begin match format with
+    | Number -> ScTypes.Num (D.Num.to_num n, None)
+    | Date -> ScTypes.Date (D.Num.to_num n)
+    | _ -> raise Errors.TypeError (* This pattern could be refuted *)
+    end
+  | String s -> ScTypes.Str s
+  | List (t, l) ->
+         List.hd l      (* Extract the first element *)
+      |> build_value t  (* Convert it in boxed value *)
+      |> get_repr       (* Return it's representation *)
+  | List2 (t, l) ->
+         List.hd l      (* Extract the first element *)
+      |> List.hd
+      |> build_value t  (* Convert it in boxed value *)
+      |> get_repr       (* Return it's representation *)
+  end in
+
+  (** Extract the value from an expression.
+      [extract typ expr] will evaluate the expression and return it. If the
+      result cannot be evaluated (because of references pointing to missing
+      values) a default value of type [typ] will be returned.
+   *)
+  let rec extract = begin function
+    (* For a reference to an external we first extract the value pointed  *)
+    | ScTypes.Ref r ->
+        begin match mapper r with
+        | ScTypes.Refs.Single v -> extract_value v
+        | ScTypes.Refs.Array1 l ->
+
+          (* Guess the list type from it's first defined element *)
+          let Result r = extract_value (List.find ((!=) ScTypes.Undefined) l) in
+          let format_of = format_of_value r in
+          let type_of = type_of_value r in
+          (* Build the list with all the elements *)
+          let elems, format = List.fold_left (add_elem type_of) ([], format_of) l in
+          Result (List (format, elems))
+        | ScTypes.Refs.Array2 l ->
+          (* Guess the list type from it's first defined element *)
+          let Result r = extract_value (Tools.List.find2 ((!=) ScTypes.Undefined) l) in
+          let format_of = format_of_value r in
+          let type_of = type_of_value r in
+          (* Build the list with all the elements *)
+          let elems, format = List.fold_left (fun (result, format_of) elems ->
+            let elems, format = List.fold_left (add_elem type_of) ([], format_of) elems in
+            elems::result, (most_generic_format format_of format)
+            ) ([], format_of) l in
+          Result (List2 (format, elems))
+        end
+
+    (* Evaluate the expression *)
+    | ScTypes.Expression e -> extract e
+    | ScTypes.Value v -> extract_value v
+    | ScTypes.Call (name, args) ->
+        let args' = List.map extract args in
+        call name args'
+    end
+  in
+  let Result r = extract value in
+  get_repr r
+end
+
+let wrap f =
+  let old_catalog = !C.catalog in
+  Tools.try_finally
+    (fun () -> C.catalog := C.Catalog.empty; f ())
+    (fun () -> C.catalog := old_catalog)
+
+(* Register the standard functions *)
+
+module MAKE(C: D.COMPARABLE) = struct
+
+  let register t = begin
+    register2 "="  (t, t) f_bool C.eq;
+    register2 "<>" (t, t) f_bool C.neq;
+    register2 ">"  (t, t) f_bool C.gt;
+    register2 ">=" (t, t) f_bool C.ge;
+    register2 "<"  (t, t) f_bool C.lt;
+    register2 "<=" (t, t) f_bool C.le;
+  end
+
+end
+
+(* Helper for list functions : reduce over a list of elements *)
+let reduce name typ res f = begin
+  register1 name (t_list typ) res (fun x ->
+    List.fold_left f (List.hd x) x);
+  register1 name (t_list (t_list typ)) res (fun x ->
+    List.fold_left (List.fold_left f) (List.hd (List.hd x)) x);
+end
+
+(* Helper for list functions : fold over a list of elements *)
+let fold name t_in t_out f init = begin
+  register1 name (t_list t_in) t_out (fun x ->
+    List.fold_left f init x);
+  register1 name (t_list (t_list t_in)) t_out (fun x ->
+    List.fold_left (List.fold_left f) init x);
+end
+
+
+let () = begin
+
+  let module CompareNum = MAKE(D.Num) in
+  CompareNum.register t_int;
+  register0 "rand"              f_number D.Num.rnd;
+  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;
+
+  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(D.Bool) in
+  CompareBool.register t_bool;
+  register0 "true"                    f_bool (fun () -> D.Bool.true_);
+  register0 "false"                   f_bool (fun () -> D.Bool.false_);
+  register1 "not"   t_bool            f_bool D.Bool.not;
+  register2 "and"   (t_bool, t_bool)  f_bool D.Bool.and_;
+  register2 "or"    (t_bool, t_bool)  f_bool D.Bool.or_;
+  register2 "xor"   (t_bool, t_bool)  f_bool D.Bool.neq;
+
+  let module CompareString = MAKE(D.String) in
+  CompareString.register t_string;
+
+end
diff --git a/evaluator.mli b/evaluator.mli
new file mode 100755
index 0000000..9fa280b
--- /dev/null
+++ b/evaluator.mli
@@ -0,0 +1,65 @@
+val repr: (ScTypes.refs -> ScTypes.types ScTypes.Refs.range) -> ScTypes.expression -> ScTypes.types
+
+(** Type definitions *)
+
+type 'a typ 
+val t_bool: DataType.Bool.t typ
+val t_int:  DataType.Num.t  typ
+val t_string: UTF8.t typ
+val t_list: 'a typ -> 'a list typ
+
+(** Result formats *)
+
+type 'a result
+
+(** Numeric (any format) *)
+val f_num: DataType.Num.t result
+
+(** Date *)
+val f_date: DataType.Num.t result
+
+(** Number *)
+val f_number: DataType.Num.t result
+
+(** Boolean result *)
+val f_bool: DataType.Bool.t result
+
+(** String *)
+val f_string: DataType.String.t result
+
+(** Catalog *)
+
+(** We cannot update an existing function. Any [registerX] function will raise
+ [RegisteredFunction] if a function with the same signature already exists in the catalog. *)
+exception RegisteredFunction
+
+val register0: 
+  string ->           (* The function name *)
+  'a result ->        (* The return type *)
+  (unit -> 'a)        (* The function to call *)
+  -> unit
+
+val register1: 
+  string ->           (* The function name *)
+  'a typ ->           (* The signature *)
+  'b result ->        (* The return type *)
+  ('a -> 'b)          (* The function to call *)
+  -> unit
+
+val register2: 
+  string ->           (* The function name *)
+  ('a typ * 'b typ) ->(* The signature *)
+  'c result ->        (* The return type *)
+  ( 'a -> 'b -> 'c)   (* The function to call*)
+  -> unit
+
+val register3: 
+  string ->           (* The function name *)
+  ('a typ * 'b typ * 'c typ) ->(* The signature *)
+  'd result ->           (* The return type *)
+  ( '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 f516463..1feb62e 100755
--- a/expression.ml
+++ b/expression.ml
@@ -1,6 +1,5 @@
 module C = Catalog
-
-module Calendar = CalendarLib.Calendar.Precise
+module Tuple2 = Tools.Tuple2
 
 let u = UTF8.from_utf8string
 
@@ -35,7 +34,6 @@ let load content = begin
         try String.sub content 0 (String.index content '\000')
         with Not_found -> content in
       Basic (
-        (*try       ScTypes.Num (Tools.Num.of_float_string content')*)
         try       Lexing.from_string content'
                 |> ExpressionParser.content ExpressionLexer.read
         with _ -> ScTypes.Str (UTF8.from_utf8string content')
@@ -47,19 +45,16 @@ let load content = begin
   )
 end
 
+
 let load_expr expr = expr
 
+
 (** Extract the parameters to give to a function.
     return an Error if one of them is an error
  *)
 let eval expr sources = begin
 
-  let rec eval_exp: ScTypes.expression -> ScTypes.types = function
-    | ScTypes.Value v -> v
-    | ScTypes.Call (ident, params) -> C.eval ident (List.map eval_exp params)
-    | ScTypes.Ref r -> sources r
-    | ScTypes.Expression expr -> eval_exp expr
-  in
+  let eval_exp f = Evaluator.repr sources f in
 
   begin try match expr with
     | Basic value -> ScTypes.Result value
@@ -72,7 +67,14 @@ end
 
 let collect_sources expr = begin
   let rec collect refs = function
-    | ScTypes.Ref r -> Cell.Set.union refs (Cell.Set.of_list @@ ScTypes.Refs.collect r)
+    | ScTypes.Ref r ->
+        begin match ScTypes.Refs.collect r with
+        | ScTypes.Refs.Single r -> Cell.Set.add r refs
+        | ScTypes.Refs.Array1 a1 ->
+            List.fold_left (fun set elt -> Cell.Set.add elt set) refs a1
+        | ScTypes.Refs.Array2 a2 ->
+            List.fold_left (List.fold_left (fun set elt -> Cell.Set.add elt set)) refs a2
+        end
     | ScTypes.Call (ident, params) -> List.fold_left collect refs params
     | ScTypes.Expression f -> collect refs f
     | _ -> refs
diff --git a/expression.mli b/expression.mli
index 9888ece..f7f0ece 100755
--- a/expression.mli
+++ b/expression.mli
@@ -15,7 +15,7 @@ val load_expr: t -> t
 val is_defined: t -> bool
 
 (** Evaluate the expression *)
-val eval: t -> (ScTypes.refs -> ScTypes.types) -> ScTypes.result
+val eval: t -> (ScTypes.refs -> ScTypes.types ScTypes.Refs.range) -> ScTypes.result
 
 (** Collect all the cell referenced in the expression *)
 val collect_sources: t -> Cell.Set.t
diff --git a/functions.ml b/functions.ml
index 2014d2e..56d7530 100755
--- a/functions.ml
+++ b/functions.ml
@@ -1,5 +1,3 @@
-open Catalog
-
 let u = UTF8.from_utf8string
 
 let eq = u"="
@@ -14,101 +12,3 @@ let mul = u"*"
 let pow = u"^"
 let div = u"/"
 let sub = u"-"
-
-let sum = u"sum"
-
-let () =
-
-  (** Comparaison *)
-  let compare = function
-    | ScTypes.Num (n1,_)::ScTypes.Num (n2,_)::[] -> Num.compare_num n1 n2
-    | ScTypes.Date n1::ScTypes.Date n2::[] -> Num.compare_num n1 n2
-    | ScTypes.Str s1::ScTypes.Str s2::[] -> UTF8.compare s1 s2
-    | ScTypes.Bool b1::ScTypes.Bool b2::[] -> Pervasives.compare b1 b2
-    | ScTypes.List l1::ScTypes.List l2::[] -> Pervasives.compare l1 l2
-    | t1::t2::[] -> Pervasives.compare t1 t2
-    | _ -> raise ScTypes.Error
-  in
-  register eq  (fun args -> ScTypes.Bool ((compare args) =  0));
-  register neq (fun args -> ScTypes.Bool ((compare args) != 0));
-  register lt  (fun args -> ScTypes.Bool ((compare args) <  0));
-  register le  (fun args -> ScTypes.Bool ((compare args) <= 0));
-  register gt  (fun args -> ScTypes.Bool ((compare args) >  0));
-  register ge  (fun args -> ScTypes.Bool ((compare args) >= 0));
-
-  (** Basic *)
-
-  register sum (fun args ->
-
-    let rec sum value = function
-      | ScTypes.Undefined -> value
-      | ScTypes.Num (n,_) -> Num.add_num value n
-      | ScTypes.Date n -> Num.add_num value n
-      | ScTypes.List l -> List.fold_left sum value l
-      | _ -> raise ScTypes.Error in
-
-    ScTypes.Num (List.fold_left sum (Num.num_of_int 0) args, None)
-  );
-
-  let rec operation f = begin function
-    | ScTypes.Undefined , x -> operation f (ScTypes.Num (Num.num_of_int 0, None), x)
-    | x, ScTypes.Undefined -> operation f (x, ScTypes.Num (Num.num_of_int 0, None))
-    | ScTypes.Num (n1,_), ScTypes.Num (n2,_)    -> ScTypes.Num (f n1 n2, None)
-    | ScTypes.Date n1, ScTypes.Date n2  -> ScTypes.Date (f n1 n2)
-    | ScTypes.Date n1, ScTypes.Num (n2,_)   -> ScTypes.Date (f n1 n2)
-    | ScTypes.Num (n1,_), ScTypes.Date n2   -> ScTypes.Date (f n1 n2)
-    | _ -> raise ScTypes.Error
-  end
-  in
-
-  register add  (function
-    | t1::t2::[] -> (operation Num.add_num) (t1, t2)
-    | _ -> raise ScTypes.Error
-  );
-
-  register mul  (function
-    | t1::t2::[] -> (operation Num.mult_num) (t1, t2)
-    | _ -> raise ScTypes.Error
-  );
-
-  register div  (function
-    | t1::t2::[] -> (operation Num.div_num) (t1, t2)
-    | _ -> raise ScTypes.Error
-  );
-
-  register sub (function
-    | t1::t2::[] -> (operation Num.sub_num) (t1, t2)
-    | _ -> raise ScTypes.Error
-  );
-
-  register pow (function
-    | t1::t2::[] -> (operation Num.power_num) (t1, t2)
-    | _ -> raise ScTypes.Error
-  );
-
-  (** Binary *)
-
-  register (u"true") (function
-    | [] -> ScTypes.Bool true
-    | _ -> raise ScTypes.Error
-  );
-
-  register (u"false") (function
-    | [] -> ScTypes.Bool false
-    | _ -> raise ScTypes.Error
-  );
-
-  register (u"not") (function
-    | (ScTypes.Bool x):: [] -> ScTypes.Bool (not x)
-    | _ -> raise ScTypes.Error
-  );
-
-  register (u"date") (function
-    | (ScTypes.Num (x,_)):: [] -> ScTypes.Date x
-    | _ -> raise ScTypes.Error
-  );
-
-  register (u"num") (function
-    | (ScTypes.Date x):: [] -> ScTypes.Num (x, None)
-    | _ -> raise ScTypes.Error
-  );
diff --git a/main.ml b/main.ml
index 58cbea5..393d4fe 100755
--- a/main.ml
+++ b/main.ml
@@ -97,7 +97,7 @@ let rec normal_mode (t, screen) = begin
     let position = Selection.extract t.Sheet.selected in
     let expr = Sheet.Raw.get_expr position t.Sheet.data
             |> Expression.show in
-    begin match Screen.editor ~position ~init:expr screen with
+    begin match Screen.editor ~position ~prefix:(u"-> ") ~init:expr screen with
     | None ->
       (* Restore the previous value *)
       Screen.status screen expr;
@@ -127,7 +127,7 @@ let rec normal_mode (t, screen) = begin
   | Actions.Search ->
     let expr = Screen.search screen
     |> Expression.load in
-    let pattern = Expression.eval expr (fun _ -> ScTypes.Undefined) in
+    let pattern = Expression.eval expr (fun _ -> ScTypes.Refs.Single ScTypes.Undefined) in
     begin match Sheet.search (`Pattern pattern) t with
     | Some t' -> normal_mode @@ redraw t' screen
     | None -> normal_mode (t, screen)
@@ -155,7 +155,7 @@ let rec normal_mode (t, screen) = begin
     end
 
   | Actions.Command ->
-    begin match Screen.editor ~init:(u":") screen with
+    begin match Screen.editor ~prefix:(u":") screen with
     | None ->
       normal_mode (t, screen)
     | Some content ->
@@ -212,13 +212,13 @@ end
 
 and command (t, screen) action = begin
   match action with
-  | (":w", file) -> (* Save the file *)
+  | ("w", file) -> (* Save the file *)
       Odf.save t.Sheet.data file;
       normal_mode @@ redraw t screen
-  | (":enew", _) -> (* Start a new spreadsheet *)
+  | ("enew", _) -> (* Start a new spreadsheet *)
       let sheet = Sheet.Raw.create in
       normal_mode @@ redraw (Sheet.create sheet) screen
-  | (":q", _) ->  (* Quit *)
+  | ("q", _) ->  (* Quit *)
       t
   | _ -> normal_mode @@ redraw t screen
 end
diff --git a/odf/odf.ml b/odf/odf.ml
index cfbd964..df98adb 100755
--- a/odf/odf.ml
+++ b/odf/odf.ml
@@ -154,7 +154,6 @@ let write_basic attrs output = begin function
       write_num ((NS.value_attr, value)::attrs) output value
   | ScTypes.Str s  -> write_str  attrs output (UTF8.to_utf8string s)
   | ScTypes.Bool b -> write_bool attrs output (string_of_bool b)
-  | ScTypes.List l -> write_error attrs output ""
   | ScTypes.Date d ->
       let value = Tools.Date.to_string d in
       write_date ((NS.date_value_attr, value)::attrs) output value
diff --git a/readme.rst b/readme.rst
index a41c0c0..970817e 100755
--- a/readme.rst
+++ b/readme.rst
@@ -148,14 +148,13 @@ garanted to not loop.)
 Range
 ~~~~~
 
-Yan can reference a range by naming the two bounds (`C6:A1`). The value is
-typed as a List.
+Yan can reference a range by naming the two bounds (`C6:A1`).
 
 Undefined
 ~~~~~~~~~
 
-If a reference point to an an empty cell, the content will be interpreted as Undefined
-
+If a reference point to an an empty cell, the content will be interpreted as
+Undefined. Any formula impliyng Undefined will return Error
 
 Formulas
 ========
@@ -168,12 +167,16 @@ Licht is provided with built-in functions.
 Generic comparaison
 -------------------
 
-Thoses function can be applied to any value, they will never raise error
+Thoses function can be applied to any value.
 
 =============== ===============================
 Function        Value
 =============== ===============================
 *x* `=` *y*     True if *x* equals *y*
+*x* `>` *y*     True if *x* > *y*
+*x* `>=` *y*    True if *x* >= *y*
+*x* `<` *y*     True if *x* < *y*
+*x* `<=` *y*    True if *x* <= *y*
 *x* `<>` *y*    True if *x* does not equals *y*
 =============== ===============================
 
@@ -192,12 +195,11 @@ Function        Value
 Numeric
 -------
 
-In numeric functions, Undefined_ value are considered as `O`
-
 =================== =====================================
 Function            Value
 =================== =====================================
-`sum(Numeric List)` Compute the sum of the list.
 *x* `+` *y*         Add two values
 *x* `**` *y*        Compute *x* ^ *y*
+`sum(Numeric List)` Compute the sum of the list.
+`rnd()`             A random number between 0 and 1
 =================== =====================================
diff --git a/scTypes.ml b/scTypes.ml
index ddbae12..6ea9f35 100755
--- a/scTypes.ml
+++ b/scTypes.ml
@@ -1,7 +1,5 @@
 (** All the types used in the spreadsheet. *)
 
-module Calendar = CalendarLib.Calendar.Precise
-
 let u = UTF8.from_utf8string
 
 exception Error
@@ -11,13 +9,12 @@ type cell = Cell.t
 type ident = UTF8.t
 
 type types =
-  | Num  : Num.num * (UTF8.t option) -> types     (** A number *)
-  | Str  : UTF8.t -> types      (** A string *)
-  | Date : Num.num -> types     (** A date in julian day *)
+  | Num  of Num.num * (UTF8.t option)     (** A number *)
+  | Str  of UTF8.t                        (** A string *)
+  | Date of Num.num                       (** A date in julian day *)
 
-  | Undefined : types           (** The content is not defined *)
-  | Bool : bool -> types        (** A boolean *)
-  | List : types list -> types  (** List with heterogenous datas *)
+  | Undefined                             (** The content is not defined *)
+  | Bool of bool                          (** A boolean *)
 
 type refs =
   | Cell of cell                (** A cell *)
@@ -70,37 +67,55 @@ module Type = struct
       end
     | Str x     -> UTF8.Buffer.add_string buffer x
     | Bool b    -> UTF8.Printf.bprintf buffer "%B" b
-    | List l    ->
-          UTF8.Printf.bprintf buffer "[%a]"
-          (show_list show) l
     | Date n    ->
-           Num.float_of_num n
-        |> Calendar.from_jd
-        |> CalendarLib.Printer.Precise_Calendar.to_string
-        |> u
-        |> UTF8.Buffer.add_string buffer
+        let y, m, d = Tools.Date.date_from_julian_day n in
+        UTF8.Printf.bprintf buffer "%d/%d/%d" y m d
   end
 
 end
 
 module Refs = struct
 
+  type 'a range =
+    | Single of 'a
+    | Array1 of 'a list
+    | Array2 of 'a list list
+
   let collect = function
-    | Cell x -> [Pervasives.fst x]
-    | Range (first, snd) ->
-        let (x1, y1) = Pervasives.fst first
+    | Cell x -> Single (Pervasives.fst x)
+    | Range (fst, snd) ->
+        let (x1, y1) = Pervasives.fst fst
         and (x2, y2) = Pervasives.fst snd in
         let min_x = min x1 x2
         and max_x = max x1 x2
         and min_y = min y1 y2
         and max_y = max y1 y2 in
-        let elms = ref [] in
-        for x = min_x to max_x do
-          for y = min_y to max_y do
-            elms := (x, y)::!elms
-          done
-        done;
-        List.rev (!elms)
+        if (min_x = max_x) || (min_y = max_y) then (
+          (* There is only a one dimension array *)
+          let elms = ref [] in
+          for x = min_x to max_x do
+            for y = min_y to max_y do
+              elms := (x, y)::!elms
+            done
+          done;
+          Array1 (!elms)
+        ) else (
+          (* This a two-dimension array *)
+          let elmx = ref [] in
+          for x = min_x to max_x do
+            let elmy = ref [] in
+            for y = min_y to max_y do
+              elmy := (x, y)::!elmy
+            done;
+            elmx := !elmy::!elmx
+          done;
+          Array2 (!elmx)
+        )
+
+  let map f = function
+    | Single coord ->  Single (f coord)
+    | Array1 values -> Array1 (List.map f values)
+    | Array2 values -> Array2 (List.map (List.map f) values)
 
   let shift (vector_x, vector_y) ref =
     let _shift ((x, y), (fixed_x, fixed_y)) =
@@ -125,9 +140,16 @@ module Result = struct
     | Result v1, Result v2 -> Type.(=) v1 v2
     | _, _ -> t1 = t2
 
-
   let show = begin function
-    | Error _ -> u"#Error"
+    | Error x ->
+        (*
+        let buffer = Buffer.create 16 in
+        let b = Format.formatter_of_buffer buffer in
+        Errors.printf b x;
+        Format.pp_print_flush b ();
+        u(Buffer.contents buffer)
+        *)
+        u"#Error"
     | Result v ->
           let buffer = UTF8.Buffer.create 16 in
           Type.show buffer v;
diff --git a/scTypes.mli b/scTypes.mli
index 642ecd2..deef1a0 100755
--- a/scTypes.mli
+++ b/scTypes.mli
@@ -7,23 +7,22 @@ type cell = (int * int) * (bool * bool)
 type ident = UTF8.t
 
 type types =
-  | Num  : Num.num * (UTF8.t option) -> types     (** A number *)
-  | Str  : UTF8.t -> types      (** A string *)
-  | Date : Num.num -> types     (** A date in julian day *)
+  | Num  of Num.num * (UTF8.t option)     (** A number *)
+  | Str  of UTF8.t                        (** A string *)
+  | Date of Num.num                       (** A date in julian day *)
 
-  | Undefined : types           (** The content is not defined *)
-  | Bool : bool -> types        (** A boolean *)
-  | List : types list -> types  (** List with heterogenous datas *)
+  | Undefined                             (** The content is not defined *)
+  | Bool of bool                          (** A boolean *)
 
 type refs =
-  | Cell of cell                (** A cell *)
-  | Range of cell * cell        (** An area of cells *)
+  | Cell of cell                          (** A cell *)
+  | Range of cell * cell                  (** An area of cells *)
 
 type expression =
-  | Value of types                  (** A direct value *)
-  | Ref of refs                     (** A reference to another cell *)
-  | Call of ident * expression list (** A call to a function *)
-  | Expression of expression        (** An expression *)
+  | Value of types                        (** A direct value *)
+  | Ref of refs                           (** A reference to another cell *)
+  | Call of ident * expression list       (** A call to a function *)
+  | Expression of expression              (** An expression *)
 
 (** Result from a computation *)
 type result =
@@ -40,7 +39,14 @@ end
 
 module Refs : sig
 
-  val collect: refs -> (int * int) list
+  type 'a range =
+    | Single of 'a
+    | Array1 of 'a list
+    | Array2 of 'a list list
+
+  val collect: refs -> (int * int) range
+
+  val map: ('a -> 'b) -> 'a range -> 'b range
   
   val shift: (int * int) -> refs -> refs
 
diff --git a/screen.ml b/screen.ml
index 69290d7..d48381a 100755
--- a/screen.ml
+++ b/screen.ml
@@ -162,9 +162,8 @@ let init () = begin
   && Curses.init_pair 3 Color.black Color.white (* Selected cell *)
   && Curses.init_pair 4 Color.black Color.red   (* referenced cell *)
   && Curses.init_pair 5 Color.black Color.green (* sink cell *)
-  && Curses.curs_set 0
+  && Curses.curs_set 0 in
 
-  in
   if not init then
     raise (Failure "Initialisation")
   else
@@ -186,31 +185,30 @@ end
 
 let draw_input t screen = begin
 
-    let height, width = screen.size in
+  let height, width = screen.size in
 
-    let expr = Sheet.Raw.get_expr (Selection.extract t.Sheet.selected) t.Sheet.data
-            |> Expression.show in
+  let expr = Sheet.Raw.get_expr (Selection.extract t.Sheet.selected) t.Sheet.data
+          |> Expression.show in
 
-    (* Compute the difference between number of bytes in the string, and the
-       number of character printed : Printf.sprintf format use the bytes number
-       in the string, while Curses print the characters in the user encoding *)
-    let result = Sheet.Raw.get_value (Selection.extract t.Sheet.selected) t.Sheet.data
-    |> ScTypes.Result.show in
-    let encoded_result = UTF8.encode result in
-    let result_length_delta = (UTF8.length result) - (String.length encoded_result) in
+  (* Compute the difference between number of bytes in the string, and the
+     number of character printed : Printf.sprintf format use the bytes number
+     in the string, while Curses print the characters in the user encoding *)
+  let result = Sheet.Raw.get_value (Selection.extract t.Sheet.selected) t.Sheet.data
+            |> ScTypes.Result.show in
+  let encoded_result = UTF8.encode result in
+  let result_length_delta = (UTF8.length result) - (String.length encoded_result) in
 
-    ignore (
-       encoded_result
-    |> Printf.sprintf "%-*s" (width - 11 - result_length_delta)
-    |> Curses.mvwaddstr screen.input 0 10
+  ignore (
+     encoded_result
+  |> Printf.sprintf "%-*s" (width - 11 - result_length_delta)
+  |> Curses.mvwaddstr screen.input 0 10
 
-    && Curses.wrefresh screen.input);
-    status screen expr;
-    screen
+  && Curses.wrefresh screen.input);
+  status screen expr;
+  screen
 end
 
 (** Wait for an event and return the key pressed
-    The signal is always followed by NULL character (0x00)
     If the key code contains more than one char, they are both returned
  *)
 let read_key {window} = begin
@@ -227,8 +225,7 @@ let read_key {window} = begin
   | x ->  Buffer.add_char buff @@ char_of_int x;
   end;
   ignore @@ Curses.nodelay window false;
-  let content = Buffer.contents buff in
-  content
+  Buffer.contents buff
 end
 
 let resize data t = begin
@@ -279,10 +276,12 @@ let editor ?position ?(prefix=UTF8.empty) ?(init=UTF8.empty) t = begin
     done;
   end in
 
-  let rec _edit (before:UTF8.t list) after = begin function
-  (* [before] contains all the caracters inserted before the cursor (reverse
-     ordered), while [after] contains all the caracters after the cursor.
+  (* Text edition, handle the keycode.
+
+    [before] contains all the caracters inserted before the cursor (reverse
+     ordered), and [after] contains all the caracters after the cursor.
    *)
+  let rec _edit before after = begin function
   | "\027" -> (* Escape, cancel the modifications *)
     None
   | "\010" -> (* Enter, validate the input *)
@@ -422,15 +421,12 @@ let editor ?position ?(prefix=UTF8.empty) ?(init=UTF8.empty) t = begin
   end
   in
 
-  ignore @@ Curses.curs_set 1;
-  let mode = if with_refs then
-    select_content position (UTF8.empty)
-  else
-    _edit in
-  let res = mode (UTF8.rev_explode init) [] @@ read_key t in
-  ignore @@ Curses.curs_set 0;
-  res
-
+  Tools.try_finally
+    (fun () ->
+      ignore @@ Curses.curs_set 1;
+      try _edit (UTF8.rev_explode init) [] @@ read_key t
+      with _ -> None)
+    (fun () -> ignore @@ Curses.curs_set 0)
 
 end
 
@@ -442,6 +438,7 @@ let search screen = begin
   end
 end
 
+(*
 let read_input position screen = begin
   let result = editor ~position ~init:(u"=") screen in
   begin match result with
@@ -449,4 +446,4 @@ let read_input position screen = begin
   | None -> UTF8.empty
   end
 end
-
+*)
diff --git a/sheet.ml b/sheet.ml
index 773c784..b604c03 100755
--- a/sheet.ml
+++ b/sheet.ml
@@ -21,6 +21,9 @@ module Raw = struct
     sink    : Cell.Set.t;   (** All the cell which references this one *)
   }
 
+  (** The sheet is a map which always contains evaluated values. When a cell is
+      updated, all the cell which references this value are also updated.
+    *)
   and t = content Map.t
 
   (** An empty cell which does contains nothing *)
@@ -30,39 +33,37 @@ module Raw = struct
     sink = Cell.Set.empty;
   }
 
-
   let create = Map.empty
 
-  let get_value (id: cell) t = begin
+  let get_value id t = begin
     try (Map.find id t).value
     with Not_found ->  ScTypes.Result ScTypes.Undefined
   end
 
-  let get_expr (id: cell) t = begin
+  let get_expr id t = begin
     try (Map.find id t).expr
-    with Not_found -> Expression.load @@ UTF8.empty
+    with Not_found -> empty_cell.expr
   end
 
-  (** Extract a value from a reference. *)
-  let get_ref (from:cell) (t:t) : ScTypes.refs -> ScTypes.types = begin
+  (** Extract a value from a reference.
+      This function is given to the evaluator for getting the values from a reference.
+   *)
+  let get_ref from t ref = begin
 
     let extract_values = begin function
       | ScTypes.Result v -> v
       | ScTypes.Error e -> raise e
     end in
 
-    begin function
-    | ScTypes.Cell c ->
-      let coord = Cell.to_pair c in
-      if coord = from then raise Cycle; extract_values (get_value coord t)
-    | ScTypes.Range _ as r ->
-        ScTypes.Refs.collect r
-        |> List.map (fun x -> if x = from then raise Cycle; extract_values (get_value x t))
-        |> (fun x -> ScTypes.List x)
-    end
+    ScTypes.Refs.collect ref
+      |> ScTypes.Refs.map (fun coord -> extract_values (get_value coord t))
+
   end
 
-  (** Update the value for the given cell *)
+  (** Update the value for the given cell.
+      Evaluate the new expression and compare it with the previous value.
+      @return the map updated if the result differ.
+   *)
   let update cell content t = begin
     let new_val = Expression.eval content.expr (get_ref cell t) in
     if not (ScTypes.Result.(=) new_val content.value) then
@@ -73,8 +74,11 @@ module Raw = struct
   end
 
   (** Parse all the successors from [init] and call [f] for each of them.
+
+      As long as [f] return [Some _], the cell successors will also be updated.
+
       [f] is called only once for each successor.
-      @return all the successors collected
+      @return all the successors collected, and the map updated.
    *)
   let successors (f:(cell -> content -> t -> t option)) (init:content) (state:Cell.Set.t * t) = begin
     let rec fold cell (succ, t) = begin
@@ -82,7 +86,8 @@ module Raw = struct
         (* The element has already been parsed, do not cycle *)
         (succ, t)
       else (
-        (* Map.find cannot raise Not_found here *)
+        (* Map.find cannot raise Not_found here : we look for a successor from a registered cell.
+         *)
         let content = Map.find cell t in
         match f cell content t with
         | None -> (succ, t)
@@ -176,7 +181,6 @@ module Raw = struct
       add_element id f t
   end
 
-
   let paste id shift content t = begin
     let expr = Expression.shift shift content.expr in
     let f cell t =
diff --git a/tests/dataType_test.ml b/tests/dataType_test.ml
new file mode 100755
index 0000000..3bf51ad
--- /dev/null
+++ b/tests/dataType_test.ml
@@ -0,0 +1,44 @@
+open OUnit2
+module N = DataType.Num
+
+let test_num_add n1 n2 result ctx = begin
+  assert_equal
+    ~cmp:(Num.(=/))
+    result
+    (N.to_num @@ N.add n1 n2)
+end
+
+let test_num_mult n1 n2 result ctx = begin
+  assert_equal
+    ~cmp:(Num.(=/))
+    result
+    (N.to_num @@ N.mult n1 n2)
+end
+
+let test_num_sub n1 n2 result ctx = begin
+  assert_equal
+    ~cmp:(Num.(=/))
+    result
+    (N.to_num @@ N.sub n1 n2)
+end
+
+let n1 = N.of_num (Num.num_of_int 1)
+let n2 = N.of_num (Num.num_of_int 2)
+
+let num_tests = "num_test">::: [
+
+    "test_add"       >:: test_num_add n1     n1    (Num.num_of_int 2);
+    "test_add_nan1"  >:: test_num_add n1     N.nan (Num.num_of_int 1);
+    "test_add_nan2"  >:: test_num_add N.nan  n1    (Num.num_of_int 1);
+    "test_add_nan3"  >:: test_num_add N.nan  N.nan (Num.num_of_int 0);
+
+    "test_mult"      >:: test_num_mult n2    n1    (Num.num_of_int 2);
+    "test_mult_nan1" >:: test_num_mult n1    N.nan (Num.num_of_int 0);
+    "test_mult_nan2" >:: test_num_mult N.nan n1    (Num.num_of_int 0);
+    "test_mult_nan3" >:: test_num_mult N.nan N.nan (Num.num_of_int 0);
+
+    "test_sub"       >:: test_num_sub n1     n1    (Num.num_of_int 0);
+    "test_sub_nan1"  >:: test_num_sub n1     N.nan (Num.num_of_int 1);
+    "test_sub_nan2"  >:: test_num_sub N.nan  n1    (Num.num_of_int (-1));
+    "test_sub_nan3"  >:: test_num_sub N.nan  N.nan (Num.num_of_int 0);
+ ]
diff --git a/tests/expression_test.ml b/tests/expression_test.ml
index 3674b9a..d1ac2ba 100755
--- a/tests/expression_test.ml
+++ b/tests/expression_test.ml
@@ -11,7 +11,6 @@ let _msg ~expected ~result =
     | Expression.Basic ScTypes.Date _     -> "D"
     | Expression.Basic ScTypes.Undefined  -> "U"
     | Expression.Basic ScTypes.Bool _     -> "B"
-    | Expression.Basic ScTypes.List _     -> "L"
     | Expression.Formula _                -> "F" in
 
     Printf.sprintf "Expected %s:%s but got %s:%s"
diff --git a/tests/sheet_test.ml b/tests/sheet_test.ml
index f63d76f..de42730 100755
--- a/tests/sheet_test.ml
+++ b/tests/sheet_test.ml
@@ -15,7 +15,7 @@ let test_create_ref_1 ctx = begin
        |> snd |> Sheet.Raw.add (0,0) @@ Expression.load @@ u"=C3"
        |> snd in
   let result = (Sheet.Raw.get_value (0, 0) s) in
-  let expected = (ScTypes.Result (ScTypes.Num (Num.num_of_int (-1), Some (u"-1")))) in
+  let expected = (ScTypes.Result (ScTypes.Num (Num.num_of_int (-1), None))) in
 
   assert_equal
     ~msg:(_msg ~expected ~result)
@@ -33,7 +33,7 @@ let test_create_ref_2 ctx = begin
 
 
   let result = (Sheet.Raw.get_value (2, 2) s) in
-  let expected = ScTypes.Result (ScTypes.Num (Num.num_of_int 123, Some (u"123"))) in
+  let expected = ScTypes.Result (ScTypes.Num (Num.num_of_int 123, None)) in
 
   assert_equal
     ~msg:(_msg ~expected ~result)
@@ -47,7 +47,7 @@ let test_create_direct_cycle ctx = begin
        |> Sheet.Raw.add (2,2) @@ Expression.load @@ u"=B2"
        |> snd in
   let result = (Sheet.Raw.get_value (2, 2) s) in
-  let expected = ScTypes.Error Sheet.Raw.Cycle in
+  let expected = ScTypes.Error Errors.TypeError in
 
   assert_equal
     ~msg:(_msg ~expected ~result)
@@ -63,7 +63,7 @@ let test_create_indirect_cycle ctx = begin
        |> snd |> Sheet.Raw.add (0,0) @@ Expression.load @@ u"=A1"
        |> snd in
   let result = (Sheet.Raw.get_value (0, 0) s) in
-  let expected = ScTypes.Result ScTypes.Undefined in
+  let expected = ScTypes.Error Errors.TypeError in
 
   assert_equal
     ~msg:(_msg ~expected ~result)
diff --git a/tests/test.ml b/tests/test.ml
index 1bfd6c1..8a24cd5 100755
--- a/tests/test.ml
+++ b/tests/test.ml
@@ -1,6 +1,7 @@
 let () =
   let tests = OUnit2.test_list [
     Tools_test.tests;
+    DataType_test.num_tests;
     ExpressionParser_test.tests;
     Expression_test.tests;
     Sheet_test.tests;
diff --git a/tools.ml b/tools.ml
index 1e0e1c4..0cf8fe6 100755
--- a/tools.ml
+++ b/tools.ml
@@ -75,6 +75,30 @@ module Num = struct
     with Not_found -> Num.num_of_string a
   end
 
+  let of_float f = begin
+    match classify_float f with
+    | FP_normal
+    | FP_subnormal ->
+      let x,e = frexp f in
+      let n,e =
+        Big_int.big_int_of_int64 (Int64.of_float (ldexp x 52)),
+        (e-52)
+      in
+      if e >= 0 then
+        Big_int (Big_int.shift_left_big_int n e)
+      else
+        Num.div_num
+          (Big_int n)
+          (Big_int Big_int.(shift_left_big_int unit_big_int ~-e))
+    | FP_zero -> Num.num_of_int 0
+    | FP_nan -> Num.div_num (Num.num_of_int 0) (Num.num_of_int 0)
+    | FP_infinite ->
+      if f >= 0. then
+        Num.div_num (Num.num_of_int 1) (Num.num_of_int 0)
+      else
+        Num.div_num (Num.num_of_int (-1)) (Num.num_of_int 0)
+    end
+
 end
 
 module List = struct
@@ -101,6 +125,36 @@ module List = struct
     UTF8.Buffer.add_string buffer last
   end
 
+  let rec findOpt p = begin function
+  | [] -> None
+  | x::l ->
+      if p x then
+        Some(x)
+      else
+        findOpt p l
+  end
+
+  and find2 p = begin function
+  | [] -> raise Not_found
+  | x::l ->
+      begin match findOpt p x with
+      | None -> find2 p l
+      | Some x -> x
+      end
+  end
+
+  (** Convert the list [l] as an array *)
+  let to_array l = begin
+    let elems = ref l in
+    let build = fun _ ->
+      begin match (!elems) with
+      | [] -> assert false
+      | hd::tl ->
+          elems := tl;
+          hd
+      end
+    in Array.init (List.length l) build
+  end
 
 end
 
@@ -152,25 +206,6 @@ module Tuple3 = struct
     let replace3 v (a, b, c) = (a, b, v)
 end
 
-(*
-module Locale = struct
-
-  type locale =
-    | LC_ALL
-    | LC_COLLATE
-    | LC_CTYPE
-    | LC_MONETARY
-    | LC_NUMERIC
-    | LC_TIME
-    | LC_MESSAGES
-
-  external set: locale -> string -> string = "c_set_locale"
-
-  external length: string -> int = "c_length"
-
-end
-*)
-
 module NCurses = struct
 
   type mouse_event =
@@ -215,16 +250,50 @@ module Date = struct
   type t = Num.num
 
   let get_julian_day year month day = begin
-    CalendarLib.Date.make year month day
-    |> CalendarLib.Date.to_jd
+    let y, m =
+      if month > 2 then
+        year, month
+      else
+        year - 1, month + 12
+    in
+    let b =
+      if (year > 1582) || (year = 1582 && month > 10) || (year = 1582 && month = 10 && day >= 15) then
+        let s = y / 100 in
+        2 - s + (s / 4)
+      else
+        0
+      in
+      365 * y + y / 4
+    + (int_of_float (30.6001 *. (float_of_int (m + 1))))
+    + day
+    + b
+    + 1720995
+(*    + 2415019         (* Shift to 30/12/1899 *) *)
     |> Num.num_of_int
+
   end
 
-  let date_from_julian_day j = begin
-    let date = CalendarLib.Date.from_jd (Num.int_of_num @@ Num.floor_num j) in
-    (CalendarLib.Date.year date),
-    (CalendarLib.Date.int_of_month @@ CalendarLib.Date.month date),
-    (CalendarLib.Date.day_of_month date)
+  let date_from_julian_day day = begin
+
+
+    let z = Num.int_of_num (Num.floor_num day) in
+    let f =
+      if z >= 2299161 then
+        (* We use the Num module here to prevent overflow *)
+        let day' = Num.(((num_of_int 4) */ day +/ (num_of_int 274277)) // (num_of_int 146097))
+                |> Num.floor_num
+                |> Num.int_of_num in
+        z + 1401 + ((day' * 3) / 4) - 38
+      else
+        z + 1401
+      in
+    let e = (4 * f) + 3 in
+    let h = 5 * ((e mod 1461) / 4) + 2 in (* 1461 is 365.25 * 4 *)
+    let d = ((h mod 153) / 5) + 1
+    and m = (((h / 153) + 2) mod 12) + 1 in
+    let y = (e / 1461) - 4716 + (14 - m) / 12 in (* 4716 is day 2 *)
+    (y, m, d)
+
   end
 
   let time_from_julian_day j = begin Num.(
@@ -286,3 +355,139 @@ let try_finally f except =
   with e ->
     except ();
     raise e
+
+type (_,_) cmp =
+  | Eq : ('a,'a) cmp
+  | Lt : ('a,'b) cmp
+  | Gt : ('a,'b) cmp
+
+(** Existencial type for comparing two types.
+    This type has no utility, except for structural comparison between two
+    values.
+ *)
+type existencial = Ex: 'a -> existencial
+
+module type COMPARABLE_TYPE = sig
+
+    type 'a t
+
+    val eq: 'a t -> 'b t -> ('a, 'b) cmp
+
+end
+
+module ArrayMap(Ord: COMPARABLE_TYPE) = struct
+
+  type 'a key = 'a Ord.t
+
+  type t = Val : ('a key * 'a) array -> t
+
+  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
+        | Eq -> v
+        | Lt -> find_ ((2 * idx) + 1)
+        | Gt -> find_ ((2 * idx) + 2)
+    end in
+    find_ 0
+  end
+
+  let from_list l = begin
+    let compare (key_x, _) (key_y, _) = match Ord.eq key_x key_y with
+    | Eq -> 0
+    | Lt -> -1
+    | Gt -> 1
+    in
+    let arr = List.to_array l in
+    Array.sort compare arr;
+    Val arr
+  end
+
+end
+
+(** Map for any comparable value.
+    This map can bind 'a key -> 'a value as long as the key are comparable.
+ *)
+module Map(Ord: COMPARABLE_TYPE) = struct
+
+  type 'a key = 'a Ord.t
+
+  type t =
+    | Empty : t
+    | Node : t * 'a key * 'a * t * int -> t
+
+  let singleton x d = Node(Empty, x, d, Empty, 1)
+
+  let empty = Empty
+
+  let is_empty = function
+    | Empty -> true
+    | _ -> false
+
+  let height = function
+    | Empty -> 0
+    | Node(_,_,_,_,h) -> h
+
+  let create l x d r =
+    let hl = height l and hr = height r in
+    Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+  let bal l x d r =
+    let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+    let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+    if hl > hr + 2 then begin
+      match l with
+        Empty -> invalid_arg "Map.bal"
+      | Node(ll, lv, ld, lr, _) ->
+          if height ll >= height lr then
+            create ll lv ld (create lr x d r)
+          else begin
+            match lr with
+              Empty -> invalid_arg "Map.bal"
+            | Node(lrl, lrv, lrd, lrr, _)->
+                create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+          end
+    end else if hr > hl + 2 then begin
+      match r with
+        Empty -> invalid_arg "Map.bal"
+      | Node(rl, rv, rd, rr, _) ->
+          if height rr >= height rl then
+            create (create l x d rl) rv rd rr
+          else begin
+            match rl with
+              Empty -> invalid_arg "Map.bal"
+            | Node(rll, rlv, rld, rlr, _) ->
+                create (create l x d rll) rlv rld (create rlr rv rd rr)
+          end
+    end else
+      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+
+  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
+        | 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)
+  end
+
+  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
+        | Eq -> v
+        | Lt -> find x l
+        | Gt -> find x r
+  end
+
+  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
+        | Eq -> true
+        | Lt -> mem x l
+        | Gt -> mem x r
+  end
+
+end
author	Sébastien Dailly <sebastien@chimrod.com>	2016-11-21 17:06:19 +0100
committer	Sébastien Dailly <sebastien@chimrod.com>	2017-01-01 13:30:43 +0100
commit	023c11470e32744a43b7e3c7c248f3c47ebdc687 (patch)
tree	832e04c2923295d5adf61e58d9a333afb5b26c77
parent	ef312564ca84a2b49fc291434d8fb2f8501bb618 (diff)