diff options
Diffstat (limited to 'src/functions.ml')
| -rwxr-xr-x | src/functions.ml | 208 |
1 files changed, 194 insertions, 14 deletions
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
|