Add functions for date and condition booleans

8 files changed, 256 insertions, 136 deletions

diff --git a/catalog.ml b/catalog.ml
index 450966f..19fb3f4 100755
--- a/catalog.ml
+++ b/catalog.ml
@@ -41,11 +41,11 @@ module Make(Data:DATA_SIG) = struct
     let eq: type a b. a sig_typ -> b sig_typ -> (a, b) T.cmp = begin fun a b ->

 

       let cmp: type c d. c Data.typ -> d Data.typ -> ((c, d) eq -> (a, b) T.cmp) -> (a, b) T.cmp =

-        begin fun a b f -> match Data.compare_typ a b with

+      begin fun a b f -> match Data.compare_typ a b with

         | T.Eq -> f Eq

         | T.Lt -> T.Lt

         | T.Gt -> T.Gt

-        end in

+      end in

 

       match a, b with

 

diff --git a/date.ml b/date.ml
new file mode 100644
index 0000000..9b24afe
--- /dev/null
+++ b/date.ml
@@ -0,0 +1,101 @@
+type t = Num.num
+
+let get_julian_day year month day = begin
+  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 day = begin
+
+  let shift_day = Num.floor_num day
+    |> Num.add_num (Num.num_of_int 2415019) in
+
+  let z = Num.int_of_num shift_day in
+  let f =
+    if z >= 2299161 then
+      (* We use the Num module here to prevent overflow *)
+      let day' = Num.(((num_of_int 4) */ shift_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.(
+  let day = floor_num j in
+  let time = j -/ day in
+
+  let h = floor_num @@ time */ (num_of_int 24) in
+  let h_24 = (h // (num_of_int 24)) in
+  let m = floor_num @@ (num_of_int 1440) */ (time -/ h_24 ) in
+  let s = (num_of_int 86400) */ (time -/ h_24 -/ (m // (num_of_int 1440))) in
+  (h, m, s)
+) end
+
+(** Compute the julian for a given date.
+
+    Integer return number of days since November 24, 4714 BC.
+    Fractionnal part return the time since midnight.
+*)
+let from_string str = begin
+  let n = Num.num_of_int in
+  let date_regex = Str.regexp "[0-9]+-[0-9]+-[0-9]+"
+  and time_regex = Str.regexp "[0-9]+-[0-9]+-[0-9]+T[0-9]+:[0-9]+:[0-9]" in
+  if Str.string_match time_regex str 0 then
+    Scanf.sscanf str "%d-%d-%dT%d:%d:%d" (fun year month day hour min sec ->
+    Num.(
+      let nhour = n hour // (n 24)
+      and nmin  = n min // (n 1440)
+      and nsec  = n sec // (n 86400) in
+      (get_julian_day year month day) +/ nhour +/ nmin +/ nsec
+    )
+  ) else if Str.string_match date_regex str 0 then
+    Scanf.sscanf str "%d-%d-%d" get_julian_day
+  else (
+    Num.num_of_int 0
+  )
+end
+
+let to_string date = begin
+  let y, m, d = date_from_julian_day date
+  and h, n, s = time_from_julian_day date in
+
+  Printf.sprintf "%d-%02d-%02dT%02d:%02d:%02g"
+    y
+    m
+    d
+    (Num.int_of_num h)
+    (Num.int_of_num n)
+    (Num.float_of_num s)
+
+end
+
+
diff --git a/evaluator.ml b/evaluator.ml
index 4bbf780..b390771 100755
--- a/evaluator.ml
+++ b/evaluator.ml
@@ -388,7 +388,7 @@ let f_number: DataType.Num.t Data.result = Data.Number
 let f_string: DataType.String.t Data.result = Data.String

 let f_bool: DataType.Bool.t Data.result = Data.Bool

 

-module MAKE(C: D.COMPARABLE) = struct

+module Make_Compare(C: D.COMPARABLE) = struct

 

   let register t = begin

     register2 "="  (t, t) f_bool C.eq;

@@ -423,10 +423,12 @@ let fold name t_in t_out f init = begin
     List.fold_left (List.fold_left f) init x);

 end

 

+let if_: type a. bool -> a -> a -> a = fun a b c -> if a then b else c

+

 

 let () = begin

 

-  let module CompareNum = MAKE(D.Num) in

+  let module CompareNum = Make_Compare(D.Num) in

   Data.(

   CompareNum.register t_int;

   register0 "rand"              f_number  D.Num.rnd;

@@ -439,6 +441,10 @@ let () = begin
   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));

@@ -447,7 +453,7 @@ let () = begin
   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

+  let module CompareBool = Make_Compare(D.Bool) in

   CompareBool.register t_bool;

   register0 "true"                    f_bool (fun () -> D.Bool.true_);

   register0 "false"                   f_bool (fun () -> D.Bool.false_);

@@ -456,7 +462,7 @@ let () = begin
   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

+  let module CompareString = Make_Compare(D.String) in

   CompareString.register t_string;

 

   (* Build a date *)

diff --git a/expressionParser.mly b/expressionParser.mly
index ac3f71d..f85f44f 100755
--- a/expressionParser.mly
+++ b/expressionParser.mly
@@ -55,6 +55,14 @@ basic:
                                 (Num.int_of_num @@ snd $3)
                                 (Num.int_of_num @@ snd $5)
                               )}
+  | NUM COLON NUM COLON NUM {
+      Date (Num.(
+      let nhour = (snd $1) // (num_of_int 24)
+      and nmin  = (snd $3) // (num_of_int 1440)
+      and nsec  = (snd $5) // (num_of_int 86400) 
+      in nhour +/ nmin +/ nsec
+      ))
+    }
 
 expr:
   | num                     {Value (Num ((snd $1), Some (u(fst $1))))}
diff --git a/sheet.ml b/sheet.ml
index 38a45d7..256a5a1 100755
--- a/sheet.ml
+++ b/sheet.ml
@@ -81,28 +81,44 @@ module Raw = struct
         None

   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, 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

-      if (Cell.Set.mem cell succ) then

-        (* The element has already been parsed, do not cycle *)

-        (succ, t)

-      else (

-        (* 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)

-        | Some x -> Cell.Set.fold fold content.sink (Cell.Set.add cell succ, x)

+  (** Parse all the successors from an element, apply a function to each of

+      them, and return them *)

+  let rec traverse (f:(cell -> content -> t -> t option)) source (init, t) = begin

+

+    let rec successors element (parents, succ, t) = begin

+

+      let content = Map.find element t in

+      if Cell.Set.mem element parents then (

+        (* if the cell has already been visited, mark it in error, and all the

+           descendant *)

+        let cycle_error = Some (ScTypes.Error Cycle) in

+        let t = Map.add element { content with value = cycle_error} t

+        and set_error cell content t =

+          if content.value = cycle_error then

+            None

+          else

+            Some (Map.add cell { content with value = cycle_error} t) in

+        let succ = Cell.Set.add element succ in

+        let succ, t = traverse set_error content (succ, t) in

+        (Cell.Set.empty, succ, t)

+      ) else (

+        begin match f element content t with

+        | None ->

+          (* The content does not change, we do not update the successors *)

+          (Cell.Set.empty, succ, t)

+        | Some t' ->

+          let parents' = Cell.Set.add element parents in

+          let succ' = Cell.Set.add element succ in

+          if (Cell.Set.is_empty content.sink) then

+            (Cell.Set.empty, succ', t')

+          else

+            Cell.Set.fold successors content.sink (parents', succ', t')

+        end

       )

     end in

-    Cell.Set.fold fold init.sink state

+    let _, succ, t = Cell.Set.fold successors source.sink (Cell.Set.empty, init, t) in

+    succ, t

   end

 

   (** Remove the cell from the sheet *)

@@ -146,7 +162,7 @@ module Raw = struct
     | t, None -> Cell.Set.empty, t

     | t, Some content ->

         (** Update all the successors *)

-        successors update content (Cell.Set.singleton id, t)

+        traverse update content (Cell.Set.singleton id, t)

   end

 

   let add_element id f t = begin

@@ -175,7 +191,7 @@ module Raw = struct
     in

 

     (** Update the value for each sink already evaluated *)

-    successors update content (Cell.Set.singleton id, updated)

+    traverse update content (Cell.Set.singleton id, updated)

   end

 

   let add id expression t = begin

diff --git a/tests/sheet_test.ml b/tests/sheet_test.ml
index 1a1bef3..b289b14 100755
--- a/tests/sheet_test.ml
+++ b/tests/sheet_test.ml
@@ -80,6 +80,29 @@ let test_create_indirect_cycle ctx = begin
     result
 end
 
+let test_check_BFS ctx = begin
+
+  let s = Sheet.Raw.create
+      (* First set A1 to 3 *)
+      |> Sheet.Raw.add (1,1) @@ Expression.load @@ u"=3"
+      |> snd |> Sheet.Raw.add (1,2) @@ Expression.load @@ u"=A1"
+      |> snd |> Sheet.Raw.add (2,2) @@ Expression.load @@ u"=A1"
+      |> snd |> Sheet.Raw.add (5,5) @@ Expression.load @@ u"=B2"
+      (* A3 = A1 + A1 = 6 *)
+      |> snd |> Sheet.Raw.add (1,3) @@ Expression.load @@ u"=A2 + E5"
+      (* Then set A1 to 2 *)
+      |> snd |> Sheet.Raw.add (1,1) @@ Expression.load @@ u"=2"
+      |> snd in
+  let result = (Sheet.Raw.get_value (1, 3) s) in
+  (* A3 = A1 + A1 = 4 *)
+  let expected = Some (ScTypes.Result (ScTypes.Num (Num.num_of_int 4, None))) in
+
+  assert_equal
+    ~msg:(_msg ~expected ~result)
+    expected
+    result
+end
+
 let test_delete ctx = begin
 
   let s = Sheet.Raw.create
@@ -126,7 +149,7 @@ let test_update_succs2 ctx = begin
        |> snd |> Sheet.Raw.add (1,2) @@ Expression.load @@ u"=A1/0"
        |> snd |> Sheet.Raw.add (1,1) @@ Expression.load @@ u"=2"
        |> fst in
-  (* Only (1, 1) is updated ; (1, 2) does not change, neither (2, 2) *)
+  (* Only (1, 1) is updated ; (2, 2) does not change, neither (2, 2) *)
   let expected = Cell.Set.of_list [(1,1)] in
 
   assert_equal
@@ -139,6 +162,7 @@ let tests = "sheet_test">::: [
     "test_ref1"     >:: test_create_ref_1;
     "test_cycle1"   >:: test_create_direct_cycle;
     "test_cycle2"   >:: test_create_indirect_cycle;
+    "test_BFS"      >:: test_check_BFS;
     "test_delete"   >:: test_delete;
     "test_update_succs1"   >:: test_update_succs1;
     "test_update_succs2"   >:: test_update_succs2;
diff --git a/tests/tools_test.ml b/tests/tools_test.ml
index b64afbc..5514404 100755
--- a/tests/tools_test.ml
+++ b/tests/tools_test.ml
@@ -1,5 +1,43 @@
 open OUnit2
 
+module TestList = struct
+
+  let test_linearize ctx = begin
+    let input = [
+      ['1'; '2'; '3'];
+      ['A'; 'B'];
+      ['W'; 'X'; 'Y'; 'Z'];
+      ['O'];
+    ] in
+
+    let expected = [
+      '1'; 'A'; 'W'; 'O'; 'X'; 'B'; '2'; '3'; 'Y'; 'Z'
+    ] in
+
+    let result = Tools.List.linearize input in
+
+    let to_string elems = begin
+      let result_buffer = Buffer.create 16 in
+      List.iter (Buffer.add_char result_buffer) elems;
+      Buffer.contents result_buffer
+    end in
+
+
+    assert_equal
+      ~msg:(Printf.sprintf "Expected %s but got %s" (to_string expected) (to_string result) )
+      expected
+      result
+
+
+  end
+
+  let tests = "list_test">::: [
+
+      "test_list_linearize"       >:: test_linearize;
+  ]
+
+end
+
 module TestString = struct
 
   let _msg ~expected ~result =
@@ -67,7 +105,7 @@ module TestDate = struct
 
   let test_get_julian_day ctx = begin
 
-    let result = Tools.Date.get_julian_day 2016 01 01
+    let result = Date.get_julian_day 2016 01 01
     and expected = (Num.num_of_int 42370) in
 
     (* Check that the num is round *)
@@ -88,7 +126,7 @@ module TestDate = struct
         y2 m2 d2
     in
 
-    let result = Tools.Date.date_from_julian_day @@ Num.num_of_int 734
+    let result = Date.date_from_julian_day @@ Num.num_of_int 734
     and expected = (1902, 01, 03) in
 
     assert_equal
@@ -99,7 +137,7 @@ module TestDate = struct
   end
 
   let test_parse_time ctx = begin
-    let result = Tools.Date.from_string "1902-01-03T12:34:56"
+    let result = Date.from_string "1902-01-03T12:34:56"
     and expected = (Num.num_of_string "3966431/5400") in
         (* =2415753.52425925925925925925 *)
     assert_equal
@@ -117,7 +155,7 @@ module TestDate = struct
         h2 m2 s2
     in
 
-    let result = Tools.Date.time_from_julian_day @@ Tools.Date.from_string "1902-01-03T12:34:56"
+    let result = Date.time_from_julian_day @@ Date.from_string "1902-01-03T12:34:56"
               |> Tools.Tuple3.map (Num.float_of_num)
     and expected = (12., 34., 56.) in
 
@@ -130,9 +168,9 @@ module TestDate = struct
   let test_time_add_hour ctx = begin
 
 
-    let (result:string) = Tools.Date.from_string "1902-01-03T12:34:56"
+    let (result:string) = Date.from_string "1902-01-03T12:34:56"
               |> Num.(add_num ((num_of_int 1) // (num_of_int 2)) )
-              |> Tools.Date.to_string in
+              |> Date.to_string in
 
     let expected = "1902-01-04T00:34:56" in
 
@@ -147,9 +185,9 @@ module TestDate = struct
   let test_time_add_hour2 ctx = begin
 
 
-    let (result:string) = Tools.Date.from_string "1902-01-03T12:34:56"
+    let (result:string) = Date.from_string "1902-01-03T12:34:56"
               |> Num.(add_num ((num_of_int 3) // (num_of_int 4)) )
-              |> Tools.Date.to_string in
+              |> Date.to_string in
 
     let expected = "1902-01-04T00:34:56" in
 
@@ -204,6 +242,7 @@ end
 let tests = "tools_test">::: [
 
   TestString.tests;
+  TestList.tests;
 
   "test_get_julian_day"       >:: TestDate.test_get_julian_day;
   "test_from_julian_day"      >:: TestDate.test_from_julian_day;
diff --git a/tools.ml b/tools.ml
index 33185ec..0954be1 100755
--- a/tools.ml
+++ b/tools.ml
@@ -177,6 +177,21 @@ module List = struct
     in Array.init (List.length l) build
   end
 
+  let linearize elems = begin
+    let rec _linearize acc (elems:'a list list) : 'a list = begin
+      let split (hds, tls) = function
+      | hd::tl -> hd::hds, tl::tls
+      | [] -> hds, tls
+      in
+      match elems with
+      | [] -> acc
+      | elems ->
+        let acc, tls = List.fold_left split (acc, []) elems in
+        _linearize acc tls
+    end in
+    List.rev @@ _linearize [] elems
+  end
+
 end
 
 module Tuple2 = struct
@@ -268,106 +283,7 @@ end
 
 module Date = struct
 
-  type t = Num.num
-
-  let get_julian_day year month day = begin
-    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 day = begin
-
-    let shift_day = Num.floor_num day
-      |> Num.add_num (Num.num_of_int 2415019) in
-
-    let z = Num.int_of_num shift_day in
-    let f =
-      if z >= 2299161 then
-        (* We use the Num module here to prevent overflow *)
-        let day' = Num.(((num_of_int 4) */ shift_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.(
-    let day = floor_num j in
-    let time = j -/ day in
-
-    let h = floor_num @@ time */ (num_of_int 24) in
-    let h_24 = (h // (num_of_int 24)) in
-    let m = floor_num @@ (num_of_int 1440) */ (time -/ h_24 ) in
-    let s = (num_of_int 86400) */ (time -/ h_24 -/ (m // (num_of_int 1440))) in
-    (h, m, s)
-  ) end
-
-  (** Compute the julian for a given date.
-
-      Integer return number of days since November 24, 4714 BC.
-      Fractionnal part return the time since midnight.
-  *)
-  let from_string str = begin
-    let n = Num.num_of_int in
-    let date_regex = Str.regexp "[0-9]+-[0-9]+-[0-9]+"
-    and time_regex = Str.regexp "[0-9]+-[0-9]+-[0-9]+T[0-9]+:[0-9]+:[0-9]" in
-    if Str.string_match time_regex str 0 then
-      Scanf.sscanf str "%d-%d-%dT%d:%d:%d" (fun year month day hour min sec ->
-      Num.(
-        let nhour = n hour // (n 24)
-        and nmin  = n min // (n 1440)
-        and nsec  = n sec // (n 86400) in
-        (get_julian_day year month day) +/ nhour +/ nmin +/ nsec
-      )
-    ) else if Str.string_match date_regex str 0 then
-      Scanf.sscanf str "%d-%d-%d" get_julian_day
-    else (
-      Num.num_of_int 0
-    )
-  end
-
-  let to_string date = begin
-    let y, m, d = date_from_julian_day date
-    and h, n, s = time_from_julian_day date in
-
-    Printf.sprintf "%d-%02d-%02dT%02d:%02d:%02g"
-      y
-      m
-      d
-      (Num.int_of_num h)
-      (Num.int_of_num n)
-      (Num.float_of_num s)
-
-  end
-
+  include Date
 
 end
 
@@ -435,6 +351,8 @@ module Map(Ord: COMPARABLE_TYPE) = struct
 
   type 'a key = 'a Ord.t
 
+  type wrapper = Ex: 'a key * 'a -> wrapper
+
   type t =
     | Empty : t
     | Node : t * 'a key * 'a * t * int -> t
@@ -513,4 +431,12 @@ module Map(Ord: COMPARABLE_TYPE) = struct
         | Gt -> mem x r
   end
 
+  let rec fold: ('a -> wrapper -> 'a) -> 'a -> t -> 'a =
+  begin fun f init t -> match t with
+  | Empty -> init
+  | Node(l, k, v, r, _) ->
+      let res_left = fold f init l in
+      let result = f res_left @@ Ex (k, v) in
+      fold f result r
+  end
 end