From 30075b876185002fd661b0af505727ab6fb38199 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Thu, 6 Jan 2022 09:20:08 +0100 Subject: ocamlformat --- src/cell.ml | 63 ++++++------ src/dataType.ml | 104 +++++++------------- src/expression.ml | 104 +++++++++----------- src/functions.ml | 276 +++++++++++++++++++++++++--------------------------- src/tools.ml | 223 +++++++++++++++--------------------------- src/tree/pageMap.ml | 165 ++++++++++++------------------- 6 files changed, 386 insertions(+), 549 deletions(-) diff --git a/src/cell.ml b/src/cell.ml index dc5dcdc..9e28f2d 100644 --- a/src/cell.ml +++ b/src/cell.ml @@ -20,31 +20,27 @@ type t = (int * int) * (bool * bool) let u = UTF8.from_utf8string let from_string (fixed_x, x_name) (fixed_y, y) = - let x = ref 0 in - String.iter (function - | 'a'..'z' as c -> x:= (!x * 26) + ((int_of_char c) - 96) - | 'A'..'Z' as c -> x:= (!x * 26) + ((int_of_char c) - 64) - | _ -> () - ) x_name; - (!x, y), (fixed_x, fixed_y) - -let to_hname x = begin + String.iter + (function + | 'a' .. 'z' as c -> x := (!x * 26) + (int_of_char c - 96) + | 'A' .. 'Z' as c -> x := (!x * 26) + (int_of_char c - 64) + | _ -> ()) + x_name; + ((!x, y), (fixed_x, fixed_y)) + +let to_hname x = let rec extract acc value = - if value > 0 then ( + if value > 0 then let value' = value - 1 in let rem = value' mod 26 in - let quot = (value' - rem) / 26 - in (extract[@tailcall]) ((char_of_int (65 + rem))::acc) quot - ) else ( - acc - ) + let quot = (value' - rem) / 26 in + (extract [@tailcall]) (char_of_int (65 + rem) :: acc) quot + else acc in - let res = extract [] x - and buff = UTF8.Buffer.create 4 in + let res = extract [] x and buff = UTF8.Buffer.create 4 in List.iter (fun c -> UTF8.Buffer.add_char buff c) res; UTF8.Buffer.contents buff -end let to_string ((x, y), (fixed_x, fixed_y)) = let buff = UTF8.Buffer.create 2 in @@ -55,33 +51,34 @@ let to_string ((x, y), (fixed_x, fixed_y)) = UTF8.Buffer.add_string buff @@ u @@ string_of_int y; UTF8.Buffer.contents buff -let to_buffer buff ((x, y), (fixed_x, fixed_y)) = begin +let to_buffer buff ((x, y), (fixed_x, fixed_y)) = if fixed_x then UTF8.Buffer.add_char buff '$'; UTF8.Buffer.add_string buff (to_hname x); if fixed_y then UTF8.Buffer.add_char buff '$'; UTF8.Buffer.add_string buff @@ u @@ string_of_int y -end let to_string t = let buff = UTF8.Buffer.create 2 in to_buffer buff t; UTF8.Buffer.contents buff -let to_pair = Pervasives.fst +let to_pair = Stdlib.fst + +module Set = struct + include Set.Make (struct + type t = int * int -module Set = (struct - include Set.Make(struct - type t = (int * int) - let compare = Pervasives.compare + let compare = Stdlib.compare end) - let show_int_tuple b t = Tools.Tuple2.printb - (fun b x -> UTF8.Buffer.add_string b @@u(string_of_int x)) - (fun b x -> UTF8.Buffer.add_string b @@u(string_of_int x)) - b t + let show_int_tuple b t = + Tools.Tuple2.printb + (fun b x -> UTF8.Buffer.add_string b @@ u (string_of_int x)) + (fun b x -> UTF8.Buffer.add_string b @@ u (string_of_int x)) + b t let printb buff = - iter (fun x -> to_buffer buff (x, (false,false)); UTF8.Buffer.add_char buff ' ') - -end) - + iter (fun x -> + to_buffer buff (x, (false, false)); + UTF8.Buffer.add_char buff ' ') +end diff --git a/src/dataType.ml b/src/dataType.ml index abac572..8d63d48 100644 --- a/src/dataType.ml +++ b/src/dataType.ml @@ -17,126 +17,94 @@ along with licht. If not, see . 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 + + 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 = (>=) - + let eq = ( = ) + let neq = ( <> ) + let lt = ( < ) + let le = ( <= ) + let gt = ( > ) + let ge = ( >= ) end module Num = struct - let rnd () = let value = Random.bits () in Q.make (Z.of_int value) (Z.of_int (1 lsl 30)) include Q - let is_integer t = (Q.den t) == Z.one - + let is_integer t = Q.den t == Z.one let eq = Q.equal - let neq a b = not (Q.equal a b) - let mult = Q.mul let floor t = - let num = Q.num t - and den = Q.den t in + let num = Q.num t and den = Q.den t in - if is_integer t then - Q.of_bigint num - else - Q.of_bigint @@ Z.fdiv num den + if is_integer t then Q.of_bigint num else Q.of_bigint @@ Z.fdiv num den let round_down t = - let num = Q.num t - and den = Q.den t in + let num = Q.num t and den = Q.den t in - if is_integer t then - Q.of_bigint num - else - Q.of_bigint @@ Z.div num den + if is_integer t then Q.of_bigint num else Q.of_bigint @@ Z.div num den let round t = - if is_integer t then - t + if is_integer t then t else - let t' = match Q.sign t with - | 1 -> Q.add t @@ Q.of_ints 1 2 + let t' = + match Q.sign t with + | 1 -> Q.add t @@ Q.of_ints 1 2 | -1 -> Q.add t @@ Q.of_ints (-1) 2 - | _ -> t in - let num = Q.num t' - and den = Q.den t' in + | _ -> t + in + let num = Q.num t' and den = Q.den t' in Q.of_bigint (Z.div num den) let ge = Q.geq - let ge = Q.geq - let le = Q.leq - let pow t q_factor = begin - + let pow t q_factor = if is_integer q_factor then - - let factor = Q.to_int q_factor - and num = Q.num t - and den = Q.den t in + let factor = Q.to_int q_factor and num = Q.num t and den = Q.den t in Q.make (Z.pow num factor) (Z.pow den factor) - else - let factor = Q.to_float q_factor and num = Z.to_float @@ Q.num t and den = Z.to_float @@ Q.den t in - Q.div - (Q.of_float (num ** factor)) - (Q.of_float (den ** factor)) - - end - - let gcd t1 t2 = - Q.of_bigint @@ Z.gcd (Q.to_bigint t1) (Q.to_bigint t2) - - let lcm t1 t2 = - Q.of_bigint @@ Z.lcm (Q.to_bigint t1) (Q.to_bigint t2) + Q.div (Q.of_float (num ** factor)) (Q.of_float (den ** factor)) + let gcd t1 t2 = Q.of_bigint @@ Z.gcd (Q.to_bigint t1) (Q.to_bigint t2) + let lcm t1 t2 = Q.of_bigint @@ Z.lcm (Q.to_bigint t1) (Q.to_bigint t2) end module Bool = struct - type t = bool + include Comparable let true_ = true let false_ = false - - let or_ = (||) - let and_ = (&&) - let not = Pervasives.not - + let or_ = ( || ) + let and_ = ( && ) + let not = Stdlib.not end module String = struct - type t = UTF8.t - include Comparable + include Comparable end -module Date = Date.Make(Num) +module Date = Date.Make (Num) diff --git a/src/expression.ml b/src/expression.ml index c2e4ec8..3afc37b 100644 --- a/src/expression.ml +++ b/src/expression.ml @@ -20,115 +20,99 @@ module Tuple2 = Tools.Tuple2 let u = UTF8.from_utf8string type t = - | Basic: 'a ScTypes.Type.t -> t (** A direct type *) - | Formula: formula -> t (** A formula *) - | Undefined: t (** The content is not defined *) + | Basic : 'a ScTypes.Type.t -> t (** A direct type *) + | Formula : formula -> t (** A formula *) + | Undefined : t (** The content is not defined *) and formula = | Expression of ScTypes.Expr.t (** A valid expression *) - | Error of int * UTF8.t (** When the expression cannot be parsed *) + | Error of int * UTF8.t (** When the expression cannot be parsed *) +let is_defined = function Undefined -> false | _ -> true -let is_defined = function - | Undefined -> false - | _ -> true - -let load content = begin +let load content = let content = UTF8.to_utf8string content in - if String.length content > 0 then ( - if content.[0] = '=' then ( + if String.length content > 0 then + if content.[0] = '=' then (* If the string start with a '=', load it as a formula *) - Formula ( - try - Expression ( - Lexing.from_string content - |> ExpressionParser.value ExpressionLexer.read) - with _ -> Error (1, UTF8.from_utf8string content) - ) - ) else ( + Formula + (try + Expression + (Lexing.from_string content + |> ExpressionParser.value ExpressionLexer.read) + with _ -> Error (1, UTF8.from_utf8string content)) + else (* First try to load the data with basic types, and fallback with string *) let content' = try String.sub content 0 (String.index content '\000') - with Not_found -> content in - try - let ScTypes.Result.Ok r = - ExpressionParser.content ExpressionLexer.read - @@ Lexing.from_string content' in - Basic r - with _ -> Basic (ScTypes.Type.string (UTF8.from_utf8string content')) - ) - ) else ( - (* If the string in empty, build an undefined value *) + with Not_found -> content + in + try + let (ScTypes.Result.Ok r) = + ExpressionParser.content ExpressionLexer.read + @@ Lexing.from_string content' + in + Basic r + with _ -> Basic (ScTypes.Type.string (UTF8.from_utf8string content')) + else (* If the string in empty, build an undefined value *) Undefined - ) -end - let load_expr expr = expr -module EvalExpr = ScTypes.Expr.Eval(Evaluate) +module EvalExpr = ScTypes.Expr.Eval (Evaluate) (** Extract the parameters to give to a function. return an Error if one of them is an error *) -let eval expr catalog mapper = begin - - begin try match expr with +let eval expr catalog mapper = + try + match expr with | Basic value -> ScTypes.Result.Ok value | Formula (Expression e) -> EvalExpr.eval e (catalog, mapper) | Formula (Error (i, s)) -> ScTypes.Result.Error ScTypes.Error | Undefined -> ScTypes.Result.Error Not_found - with ex -> ScTypes.Result.Error ex - end + with ex -> ScTypes.Result.Error ex -end +module EvalSources = ScTypes.Expr.Eval (Collect_sources) - -module EvalSources = ScTypes.Expr.Eval(Collect_sources) - -let collect_sources = begin function +let collect_sources = function | Formula (Expression f) -> EvalSources.eval f Cell.Set.empty | _ -> Cell.Set.empty -end -module Shifter = ScTypes.Expr.Eval(Shift_expr) -module Printer = ScTypes.Expr.Eval(Show_expr.Show_Expr(Show_ref)(Show_type)) +module Shifter = ScTypes.Expr.Eval (Shift_expr) +module Printer = ScTypes.Expr.Eval (Show_expr.Show_Expr (Show_ref) (Show_type)) (** Inherit the default representation, but print the float with all decimals *) -module LongPrinter = ScTypes.Type.Eval(struct - +module LongPrinter = ScTypes.Type.Eval (struct include Show_type let num n buffer = if DataType.Num.is_integer n then - DataType.Num.to_int n - |> string_of_int - |> UTF8.from_utf8string - |> UTF8.Buffer.add_string buffer + DataType.Num.to_int n |> string_of_int |> UTF8.from_utf8string + |> UTF8.Buffer.add_string buffer else let f = DataType.Num.to_float n and to_b = UTF8.Format.formatter_of_buffer buffer in ignore @@ UTF8.Format.fprintf to_b "%f" f; Format.pp_print_flush to_b () - end) let show e = let buffer = UTF8.Buffer.create 16 in - begin match e with + (match e with | Formula (Expression f) -> UTF8.Buffer.add_char buffer '='; Printer.eval f buffer | Basic b -> LongPrinter.eval b buffer - | Formula (Error (i,s)) -> UTF8.Buffer.add_string buffer s - | Undefined -> () - end; + | Formula (Error (i, s)) -> UTF8.Buffer.add_string buffer s + | Undefined -> ()); UTF8.Buffer.contents buffer let shift vector = function | Formula (Expression f) -> Formula (Expression (Shifter.eval f vector)) | other -> other -let (=) t1 t2 = match t1, t2 with - | Basic b1, Basic b2 -> ScTypes.Type.(=) b1 b2 - | o1, o2 -> Pervasives.(=) o1 o2 +let ( = ) t1 t2 = + match (t1, t2) with + | Basic b1, Basic b2 -> ScTypes.Type.( = ) b1 b2 + | o1, o2 -> Stdlib.( = ) o1 o2 diff --git a/src/functions.ml b/src/functions.ml index 491d968..87cff58 100644 --- a/src/functions.ml +++ b/src/functions.ml @@ -19,59 +19,52 @@ 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 + | 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 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.t -> a typ = function +let typ_of_format : type a. a ScTypes.DataFormat.t -> a typ = function | ScTypes.DataFormat.Date -> Num | ScTypes.DataFormat.Number -> Num | ScTypes.DataFormat.String -> String | ScTypes.DataFormat.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" +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[@tailcall]) t - -module C = Catalog.Make(struct + | List t -> Format.fprintf printer "List[%a]" (repr [@tailcall]) 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 + let rec compare_typ : type a b. a typ -> b typ -> (a, b) T.cmp = + 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 + | List l1, List l2 -> ( + 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 + | T.Gt -> T.Gt) + | x, y -> if T.Ex x > T.Ex y then T.Gt else T.Lt type 'a t = 'a typ - type 'a returnType = 'a ScTypes.ReturnType.t - end) let f_num = ScTypes.ReturnType.f_num @@ -80,131 +73,126 @@ let f_number = ScTypes.ReturnType.f_number let f_string = ScTypes.ReturnType.f_string let f_bool = ScTypes.ReturnType.f_bool -module Make_Compare(Comp: D.COMPARABLE) = struct - - let register t catalog = begin catalog - |> C.register2 "=" (t, t) f_bool Comp.eq +module Make_Compare (Comp : D.COMPARABLE) = struct + let register t catalog = + 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.gt |> C.register2 ">=" (t, t) f_bool Comp.ge - |> C.register2 "<" (t, t) f_bool Comp.lt + |> 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 - +let built_in catalog = + 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 + let reduce name typ res f c = + 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) + 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 fold name t_in t_out f init c = + 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) + in - - let if_: type a. bool -> a -> a -> a = fun a b c -> if a then b else c 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 + 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.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) - + |> 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 - + |> 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 + |> 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 diff --git a/src/tools.ml b/src/tools.ml index c9d78a7..88feade 100644 --- a/src/tools.ml +++ b/src/tools.ml @@ -18,213 +18,150 @@ along with licht. If not, see . let u = UTF8.from_utf8string module Option = struct - - let map f = function - | Some x -> Some (f x) - | None -> None - - let iter f = function - | Some x -> f x - | None -> () - - let bind f = function - | None -> None - | Some x -> f x - - let default v = function - | None -> v - | Some x -> x - - let test f v = begin - match f v with - | Some x -> x - | None -> v - end - - + let map f = function Some x -> Some (f x) | None -> None + let iter f = function Some x -> f x | None -> () + let bind f = function None -> None | Some x -> f x + let default v = function None -> v | Some x -> x + let test f v = match f v with Some x -> x | None -> v end module String = struct - include String - let split str ~by:sep = begin + let split str ~by:sep = let p = String.index str sep in let slen = String.length str in - String.sub str 0 p, String.sub str (p + 1) (slen - p - 1) - end + (String.sub str 0 p, String.sub str (p + 1) (slen - p - 1)) - let string_of_ints v = begin + let string_of_ints v = let buff = Buffer.create 1 in - let rec convert value = begin - Buffer.add_char buff @@ char_of_int @@ value land 0xFF; + let rec convert value = + Buffer.add_char buff @@ char_of_int @@ (value land 0xFF); let rem = value lsr 8 in - match rem with - | 0 -> Buffer.contents buff - | x -> (convert[@tailcall]) x - end in + match rem with 0 -> Buffer.contents buff | x -> (convert [@tailcall]) x + in let res = convert v in let buff' = Buffer.create @@ String.length res in - for i = ((String.length res) - 1) downto 0 do + for i = String.length res - 1 downto 0 do Buffer.add_char buff' @@ String.get res i done; Buffer.contents buff' - end - let print_buffer f t = begin + let print_buffer f t = let buff = UTF8.Buffer.create 16 in f buff t; UTF8.Buffer.contents buff - end - let filter_float str = begin + let filter_float str = let l = String.length str in - if l > 0 && String.get str (l - 1) = '.' then - String.sub str 0 (l - 1) - else - str - end - + if l > 0 && String.get str (l - 1) = '.' then String.sub str 0 (l - 1) + else str end module List = struct - (** fold_left over only the first element *) - let fst f init = function - | hd::tl -> f init hd - | [] -> init - - let printb ?(first=(u"(")) ?(last=(u")")) ?(sep=(u",")) f buffer elems = begin - - let rec print = begin function - | [] -> () - | hd::[] -> - f buffer hd; - | hd::tl -> - f buffer hd; - UTF8.Buffer.add_string buffer sep; - (print[@tailcall]) tl - end in + let fst f init = function hd :: tl -> f init hd | [] -> init + + let printb ?(first = u "(") ?(last = u ")") ?(sep = u ",") f buffer elems = + let rec print = function + | [] -> () + | [ hd ] -> f buffer hd + | hd :: tl -> + f buffer hd; + UTF8.Buffer.add_string buffer sep; + (print [@tailcall]) tl + in UTF8.Buffer.add_string buffer first; print elems; UTF8.Buffer.add_string buffer last - end - - let rec find_map f = begin function - | [] -> raise Not_found - | hd::tl -> begin match f hd with - | Some x -> x - | None -> (find_map[@tailcall]) f tl - end - end - - and find_map2 p = begin function - | [] -> raise Not_found - | x::l -> - begin try find_map p x with - Not_found -> (find_map2[@tailcall]) p l - end - end + let rec find_map f = function + | [] -> raise Not_found + | hd :: tl -> ( + match f hd with Some x -> x | None -> (find_map [@tailcall]) f tl) + + and find_map2 p = function + | [] -> raise Not_found + | x :: l -> ( + try find_map p x with Not_found -> (find_map2 [@tailcall]) p l) end module Tuple2 = struct - - let fst = Pervasives.fst - - let snd = Pervasives.snd - + let fst = Stdlib.fst + let snd = Stdlib.snd let map1 f (a, b) = (f a, b) - let map2 f (a, b) = (a, f b) - let replace1 v (a, b) = (v, b) - let replace2 v (a, b) = (a, v) - let printb ?(first="(") ?(last=")") ?(sep=",") format1 format2 out (a, b) = begin - UTF8.Printf.bprintf out "%s%a%s%a%s" - first - format1 a - sep - format2 b - last - end - + let printb ?(first = "(") ?(last = ")") ?(sep = ",") format1 format2 out (a, b) + = + UTF8.Printf.bprintf out "%s%a%s%a%s" first format1 a sep format2 b last end module NCurses = struct - type mouse_event = - | BUTTON1_PRESSED - | BUTTON1_RELEASED - | BUTTON1_CLICKED - | BUTTON1_DOUBLE_CLICKED - | BUTTON1_TRIPLE_CLICKED - | BUTTON2_PRESSED - | BUTTON2_RELEASED - | BUTTON2_CLICKED - | BUTTON2_DOUBLE_CLICKED - | BUTTON2_TRIPLE_CLICKED - | BUTTON3_PRESSED - | BUTTON3_RELEASED - | BUTTON3_CLICKED - | BUTTON3_DOUBLE_CLICKED - | BUTTON3_TRIPLE_CLICKED - | BUTTON4_PRESSED - | BUTTON4_RELEASED - | BUTTON4_CLICKED - | BUTTON4_DOUBLE_CLICKED - | BUTTON4_TRIPLE_CLICKED - | BUTTON_SHIFT - | BUTTON_CTRL - | BUTTON_ALT - | ALL_MOUSE_EVENTS - | REPORT_MOUSE_POSITION + | BUTTON1_PRESSED + | BUTTON1_RELEASED + | BUTTON1_CLICKED + | BUTTON1_DOUBLE_CLICKED + | BUTTON1_TRIPLE_CLICKED + | BUTTON2_PRESSED + | BUTTON2_RELEASED + | BUTTON2_CLICKED + | BUTTON2_DOUBLE_CLICKED + | BUTTON2_TRIPLE_CLICKED + | BUTTON3_PRESSED + | BUTTON3_RELEASED + | BUTTON3_CLICKED + | BUTTON3_DOUBLE_CLICKED + | BUTTON3_TRIPLE_CLICKED + | BUTTON4_PRESSED + | BUTTON4_RELEASED + | BUTTON4_CLICKED + | BUTTON4_DOUBLE_CLICKED + | BUTTON4_TRIPLE_CLICKED + | BUTTON_SHIFT + | BUTTON_CTRL + | BUTTON_ALT + | ALL_MOUSE_EVENTS + | REPORT_MOUSE_POSITION type event_type - external set_mouse_event: mouse_event list -> unit = "c_set_mouse_event" - - external get_mouse_event: unit -> (int * event_type * (int * int * int)) option = "c_get_mouse_event" + external set_mouse_event : mouse_event list -> unit = "c_set_mouse_event" - external is_event_of_type: mouse_event -> event_type -> bool = "c_is_event_of_type" + external get_mouse_event : + unit -> (int * event_type * (int * int * int)) option = "c_get_mouse_event" + external is_event_of_type : mouse_event -> event_type -> bool + = "c_is_event_of_type" end let try_finally f except = - try let res = f () in + try + let res = f () in except (); res with e -> except (); raise e -type (_,_) cmp = - | Eq : ('a,'a) cmp - | Lt : ('a,'b) cmp - | Gt : ('a,'b) cmp +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 +type existencial = Ex : 'a -> existencial module type COMPARABLE_TYPE = sig + type 'a t - type 'a t - - val comp: 'a t -> 'b t -> ('a, 'b) cmp - + val comp : 'a t -> 'b t -> ('a, 'b) cmp end let fold_for f a b init = - let rec _fold res i = begin - if i >= b then res - else - _fold (f i res) (i + 1) - end in - (_fold[@tailcall]) init a - + let rec _fold res i = if i >= b then res else _fold (f i res) (i + 1) in + (_fold [@tailcall]) init a diff --git a/src/tree/pageMap.ml b/src/tree/pageMap.ml index e18ba6f..967ccfe 100644 --- a/src/tree/pageMap.ml +++ b/src/tree/pageMap.ml @@ -18,178 +18,141 @@ along with licht. If not, see . type cell = int * int module type T_DEFAULT = sig - type t val default : t - end -module MapArray(T:T_DEFAULT) = struct - +module MapArray (T : T_DEFAULT) = struct + type t = int * T.t array array (** The type is composed by the number of defined cell in the page, and the page itself *) - type t = int * (T.t array array) - let find (x:int) (y:int) (t:t) : T.t = begin + let find (x : int) (y : int) (t : t) : T.t = let block = snd t in block.(y).(x) - end - let add (x:int) (y:int) (value:T.t) (t:t) : t = begin + let add (x : int) (y : int) (value : T.t) (t : t) : t = let n, block = t in - let n' = - if (block.(y).(x) == T.default) then - n + 1 - else - n in + let n' = if block.(y).(x) == T.default then n + 1 else n in block.(y).(x) <- value; - n', block - end + (n', block) - let remove (x:int) (y:int) (t:t) : t = begin + let remove (x : int) (y : int) (t : t) : t = let n, block = t in - if (block.(y).(x) = T.default) then - t + if block.(y).(x) = T.default then t + else if n = 1 then (* Do not keep empty block in memory *) + raise Not_found else ( - if n = 1 then - (* Do not keep empty block in memory *) - raise Not_found - else ( - block.(y).(x) <- T.default; - (n -1, block) - ) - ) - end + block.(y).(x) <- T.default; + (n - 1, block)) - let create array_size = begin - 0, Array.make_matrix array_size array_size T.default - end + let create array_size = (0, Array.make_matrix array_size array_size T.default) - let fold_line f y init t = begin - let n, block = t - and res = ref init in + let fold_line f y init t = + let n, block = t and res = ref init in let array_size = Array.length block in - for x = 0 to (array_size - 1) do + for x = 0 to array_size - 1 do let value = block.(y).(x) in - if value != T.default then - res := f x value !res; + if value != T.default then res := f x value !res done; !res - end - end -module SplayMap(T:T_DEFAULT) = struct - +module SplayMap (T : T_DEFAULT) = struct let array_size = 8 - module PageMap = MapArray(T) + module PageMap = MapArray (T) (** Module for the keys *) module K = struct - type 'a t = K : (int * int) -> PageMap.t t [@@unboxed] - let comp:type a b. a t -> b t -> (a, b) Tools.cmp = fun a b -> begin - match a, b with K (x1, y1), K (x2, y2) -> - let res = Pervasives.compare (y1, x1) (y2, x2) in - if res < 0 then - Tools.Lt - else if res > 0 then - Tools.Gt - else - Tools.Eq - end - - let repr: type a. Format.formatter -> a t -> unit = fun formatter (K (x, y)) -> - Format.fprintf formatter "%d, %d" x y + let comp : type a b. a t -> b t -> (a, b) Tools.cmp = + fun a b -> + match (a, b) with + | K (x1, y1), K (x2, y2) -> + let res = Stdlib.compare (y1, x1) (y2, x2) in + if res < 0 then Tools.Lt else if res > 0 then Tools.Gt else Tools.Eq + let repr : type a. Format.formatter -> a t -> unit = + fun formatter (K (x, y)) -> Format.fprintf formatter "%d, %d" x y end - module Map = Splay.Make(K) + module Map = Splay.Make (K) type t = Map.t (* Values are always positive *) - let get_bounded_values (x, y) = (max 0 x), (max 0 y) + let get_bounded_values (x, y) = (max 0 x, max 0 y) - let find (id:cell) (t:Map.t) : T.t = begin + let find (id : cell) (t : Map.t) : T.t = let x, y = get_bounded_values id in - let block_x = x / array_size - and block_y = y / array_size in + let block_x = x / array_size and block_y = y / array_size in try let block = Map.find (K (block_x, block_y)) t in PageMap.find (x mod array_size) (y mod array_size) block with Not_found -> T.default - end - let add (id:cell) (value:T.t) (t:Map.t) : Map.t = begin + let add (id : cell) (value : T.t) (t : Map.t) : Map.t = let x, y = get_bounded_values id in - let block_x = x / array_size - and block_y = y / array_size in + let block_x = x / array_size and block_y = y / array_size in let block = try Map.find (K (block_x, block_y)) t - with Not_found -> PageMap.create array_size in + with Not_found -> PageMap.create array_size + in let page = PageMap.add (x mod array_size) (y mod array_size) value block in Map.add (K (block_x, block_y)) page t - end - let remove (id:cell) (t:Map.t) : Map.t = begin + let remove (id : cell) (t : Map.t) : Map.t = let x, y = get_bounded_values id in - let block_x = x / array_size - and block_y = y / array_size in + let block_x = x / array_size and block_y = y / array_size in try let block = Map.find (K (block_x, block_y)) t in try - let block' = PageMap.remove (x mod array_size) (y mod array_size) block in + let block' = + PageMap.remove (x mod array_size) (y mod array_size) block + in Map.add (K (block_x, block_y)) block' t - with Not_found -> - Map.remove (K (block_x, block_y)) t + with Not_found -> Map.remove (K (block_x, block_y)) t with Not_found -> t - end (** Empty map *) let empty = Map.empty (** Fold over the elements in the Map.*) - let fold f (t:Map.t) init = begin + let fold f (t : Map.t) init = let res = ref init in - let call_function column row x value acc = begin - f (column + x, row) value acc - end in + let call_function column row x value acc = f (column + x, row) value acc in (* Call process_line for each block on the same row *) - let process_pages block_y acc = begin - let blocks = List.rev acc - and row_index = block_y * array_size in - for y = 0 to (array_size - 1) do + let process_pages block_y acc = + let blocks = List.rev acc and row_index = block_y * array_size in + for y = 0 to array_size - 1 do let row = row_index + y in - res := List.fold_left (fun init (column, block) -> - PageMap.fold_line (call_function column row) y init block - ) !res blocks; - + res := + List.fold_left + (fun init (column, block) -> + PageMap.fold_line (call_function column row) y init block) + !res blocks done - end in - - let fold_blocks (current_row, acc) (Map.C key_val) = begin - match key_val with ((K.K (block_x, block_y)), (block:PageMap.t)) -> - (* As long as the page lay in the same row, accumulate it *) - if current_row = block_y then - current_row, (block_x * array_size, block)::acc - else ( - (* We apply the function for each accumulated block in the row *) - process_pages current_row acc; - block_y, (block_x, block)::[] - ) - end in + in + + let fold_blocks (current_row, acc) (Map.C key_val) = + match key_val with + | K.K (block_x, block_y), (block : PageMap.t) -> + (* As long as the page lay in the same row, accumulate it *) + if current_row = block_y then + (current_row, (block_x * array_size, block) :: acc) + else ( + (* We apply the function for each accumulated block in the row *) + process_pages current_row acc; + (block_y, [ (block_x, block) ])) + in let row_number, acc = Map.fold fold_blocks (1, []) t in (* Apply the function to the last row *) process_pages row_number acc; !res - end - - end -- cgit v1.2.3