From 098ac444e731d7674d8910264ae58fb876618a5a Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Fri, 24 Nov 2017 13:46:00 +0100 Subject: Move function in their own modules --- src/functions.ml | 208 +++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 194 insertions(+), 14 deletions(-) (limited to 'src/functions.ml') diff --git a/src/functions.ml b/src/functions.ml index 56d7530..62426e9 100755 --- a/src/functions.ml +++ b/src/functions.ml @@ -1,14 +1,194 @@ -let u = UTF8.from_utf8string - -let eq = u"=" -let neq = u"<>" -let lt = u"<" -let le = u"<=" -let gt = u">" -let ge = u">=" - -let add = u"+" -let mul = u"*" -let pow = u"^" -let div = u"/" -let sub = u"-" +module D = DataType +module T = Tools + +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_unit = Unit +let t_bool: DataType.Bool.t typ = Bool +let t_int: DataType.Num.t typ = Num +let t_string: UTF8.t typ = String +let t_list (t: 'a typ): 'a list typ = List t + +let typ_of_format: type a. a ScTypes.dataFormat -> a typ = function + | ScTypes.Date -> Num + | ScTypes.Number -> Num + | ScTypes.String -> String + | ScTypes.Bool -> Bool + + +let rec repr: +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]" + repr t + +module C = Catalog.Make(struct + + let repr = repr + + 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 + + type 'a t = 'a typ + + type 'a returnType = 'a ScTypes.returnType + + +end) + +let f_num = ScTypes.f_num +let f_date = ScTypes.f_date +let f_number = ScTypes.f_number +let f_string = ScTypes.f_string +let f_bool = ScTypes.f_bool + +module Make_Compare(Comp: D.COMPARABLE) = struct + + let register t catalog = begin catalog + |> C.register2 "=" (t, t) f_bool Comp.eq + |> C.register2 "<>" (t, t) f_bool Comp.neq + |> C.register2 ">" (t, t) f_bool Comp.gt + |> C.register2 ">=" (t, t) f_bool Comp.ge + |> C.register2 "<" (t, t) f_bool Comp.lt + |> C.register2 "<=" (t, t) f_bool Comp.le + end + +end + +let built_in catalog = begin + + let module CompareNum = Make_Compare(D.Num) in + let module CompareString = Make_Compare(D.String) in + let module CompareBool = Make_Compare(D.Bool) in + + (* Helper for list functions : reduce over a list of elements *) + let reduce name typ res f c = begin + C.register1 name (t_list typ) res (fun x -> + List.fold_left f (List.hd x) x) c + |> C.register1 name (t_list (t_list typ)) res (fun x -> + List.fold_left (List.fold_left f) (List.hd (List.hd x)) x); + end in + + (* Helper for list functions : fold over a list of elements *) + let fold name t_in t_out f init c = begin + C.register1 name (t_list t_in) t_out (fun x -> + List.fold_left f init x) c + |> C.register1 name (t_list (t_list t_in)) t_out (fun x -> + List.fold_left (List.fold_left f) init x) + end in + + + let if_: type a. bool -> a -> a -> a = fun a b c -> if a then b else c in + + (* Build a date *) + C.register3 "date" (t_int, t_int, t_int) f_date ( + fun year month day -> + D.Date.get_julian_day + (D.Num.to_int year) + (D.Num.to_int month) + (D.Num.to_int day) + ) catalog + |> CompareNum.register t_int + + |> C.register1 "rand" t_unit f_number D.Num.rnd + + |> C.register1 "pi" t_unit f_number (fun () -> D.Num.of_float (4. *. atan 1.)) + |> C.register1 "sin" t_int f_number (fun x -> D.Num.of_float (sin (D.Num.to_float x))) + |> C.register1 "cos" t_int f_number (fun x -> D.Num.of_float (cos (D.Num.to_float x))) + |> C.register1 "tan" t_int f_number (fun x -> D.Num.of_float (tan (D.Num.to_float x))) + |> C.register1 "atan" t_int f_number (fun x -> D.Num.of_float (atan (D.Num.to_float x))) + |> C.register1 "asin" t_int f_number (fun x -> D.Num.of_float (asin (D.Num.to_float x))) + |> C.register1 "acos" t_int f_number (fun x -> D.Num.of_float (acos (D.Num.to_float x))) + |> C.register1 "sinh" t_int f_number (fun x -> D.Num.of_float (sinh (D.Num.to_float x))) + |> C.register1 "cosh" t_int f_number (fun x -> D.Num.of_float (cosh (D.Num.to_float x))) + |> C.register1 "tanh" t_int f_number (fun x -> D.Num.of_float (tanh (D.Num.to_float x))) + |> C.register2 "atan2" (t_int, t_int)f_number (fun x y -> + D.Num.of_float (atan2 (D.Num.to_float x) (D.Num.to_float y)) + ) + + |> C.register1 "sqrt" t_int f_number (fun x -> D.Num.of_float (sqrt(D.Num.to_float x))) + |> C.register1 "exp" t_int f_number (fun x -> D.Num.of_float (exp (D.Num.to_float x))) + |> C.register1 "ln" t_int f_number (fun x -> D.Num.of_float (log (D.Num.to_float x))) + + |> C.register3 "if" (t_bool, t_int, t_int) f_number if_ + |> C.register3 "if" (t_bool, t_bool, t_bool) f_bool if_ + |> C.register3 "if" (t_bool, t_string, t_string) f_string if_ + + |> C.register1 "abs" t_int f_number D.Num.abs + |> C.register1 "int" t_int f_number D.Num.floor + |> C.register1 "rounddown" t_int f_number D.Num.round_down + |> C.register1 "round" t_int f_number D.Num.round + + |> C.register1 "trim" t_string f_string UTF8.trim + |> C.register1 "right" t_string f_string (fun x -> UTF8.get x (-1)) + |> C.register2 "right" (t_string, t_int) f_string ( + fun t n -> + let n' = D.Num.to_int n in + UTF8.sub t (-(n')) n' + ) + |> C.register1 "left" t_string f_string (fun x -> UTF8.get x 0) + |> C.register2 "left" (t_string, t_int) f_string ( + fun t n -> + let n' = D.Num.to_int n in + UTF8.sub t 0 n' + ) + |> C.register1 "len" t_string f_number (fun x -> D.Num.of_int (UTF8.length x)) + |> C.register1 "lenb" t_string f_number (fun x -> D.Num.of_int (String.length (UTF8.to_utf8string x))) + |> C.register1 "lower" t_string f_string UTF8.lower + |> C.register1 "unicode" t_string f_number (fun x -> D.Num.of_int (UTF8.code x)) + |> C.register1 "unichar" t_int f_string (fun x -> UTF8.char (D.Num.to_int x)) + |> C.register1 "upper" t_string f_string UTF8.upper + |> C.register3 "substitute" (t_string, t_string, t_string) f_string UTF8.replace + |> C.register2 "rept" (t_string, t_int) f_string (fun t n -> UTF8.repeat (D.Num.to_int n) t) + + |> CompareBool.register t_bool + |> C.register1 "true" t_unit f_bool (fun () -> D.Bool.true_) + |> C.register1 "false" t_unit f_bool (fun () -> D.Bool.false_) + |> C.register1 "not" t_bool f_bool D.Bool.not + |> C.register2 "and" (t_bool, t_bool) f_bool D.Bool.and_ + |> C.register2 "or" (t_bool, t_bool) f_bool D.Bool.or_ + |> C.register2 "xor" (t_bool, t_bool) f_bool D.Bool.neq + + |> CompareString.register t_string + + |> reduce "min" t_int f_num D.Num.min (* Minimum value from a list *) + |> reduce "max" t_int f_num D.Num.max (* Maximum value from a list *) + + |> fold "sum" t_int f_number D.Num.add (D.Num.zero) + |> fold "product" t_int f_number D.Num.mult (D.Num.one) + + |> C.register2 "^" (t_int, t_int) f_number D.Num.pow + |> C.register2 "power" (t_int, t_int) f_number D.Num.pow + + |> C.register2 "gcd"(t_int, t_int) f_number D.Num.gcd + |> C.register2 "lcm"(t_int, t_int) f_number D.Num.lcm + |> C.register1 "+" t_int f_num (fun x -> x) + |> C.register1 "-" t_int f_num D.Num.neg (* Unary negation *) + |> C.register2 "+" (t_int, t_int) f_num D.Num.add + |> C.register2 "-" (t_int, t_int) f_num D.Num.sub + |> C.register2 "*" (t_int, t_int) f_number D.Num.mult + |> C.register2 "/" (t_int, t_int) f_number D.Num.div + +end -- cgit v1.2.3