aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/cell.ml63
-rw-r--r--src/dataType.ml104
-rw-r--r--src/expression.ml104
-rw-r--r--src/functions.ml276
-rw-r--r--src/tools.ml223
-rw-r--r--src/tree/pageMap.ml165
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 <http://www.gnu.org/licenses/>.
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 <http://www.gnu.org/licenses/>.
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 <http://www.gnu.org/licenses/>.
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-19 22:58:48 +0000