diff options
| -rwxr-xr-x | catalog.ml | 4 | ||||
| -rw-r--r-- | date.ml | 101 | ||||
| -rwxr-xr-x | evaluator.ml | 14 | ||||
| -rwxr-xr-x | expressionParser.mly | 8 | ||||
| -rwxr-xr-x | sheet.ml | 58 | ||||
| -rwxr-xr-x | tests/sheet_test.ml | 26 | ||||
| -rwxr-xr-x | tests/tools_test.ml | 55 | ||||
| -rwxr-xr-x | tools.ml | 126 |
8 files changed, 256 insertions, 136 deletions
@@ -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
@@ -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))))} @@ -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; @@ -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 |