From a6b5a6bdd138a5ccc6827bcc73580df1e9218820 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Fri, 24 Nov 2017 09:22:24 +0100 Subject: Moved all the code to src directory --- Makefile | 2 +- UTF8.ml | 54 ----- UTF8.mli | 92 -------- actionParser.mly | 45 ---- actions.mli | 28 --- catalog.ml | 125 ----------- catalog.mli | 38 ---- cell.ml | 70 ------ cell.mli | 20 -- dataType.ml | 125 ----------- dataType.mli | 99 --------- date.ml | 120 ---------- date.mli | 38 ---- errors.ml | 14 -- evaluator.ml | 373 ------------------------------- evaluator.mli | 66 ------ expression.ml | 114 ---------- expression.mli | 29 --- expressionLexer.mll | 84 ------- expressionParser.mly | 113 ---------- functions.ml | 14 -- main.ml | 241 -------------------- odf/odf.ml | 346 ----------------------------- odf/odf_ExpressionLexer.mll | 93 -------- odf/odf_ExpressionParser.mly | 95 -------- odf/odf_ns.ml | 96 -------- scTypes.ml | 354 ------------------------------ scTypes.mli | 126 ----------- screen.ml | 459 --------------------------------------- screen.mli | 29 --- selection.ml | 73 ------- selection.mli | 20 -- sheet.ml | 334 ---------------------------- sheet.mli | 75 ------- splay.ml | 142 ------------ splay.mli | 30 --- src/UTF8.ml | 54 +++++ src/UTF8.mli | 92 ++++++++ src/actionParser.mly | 45 ++++ src/actions.mli | 28 +++ src/catalog.ml | 125 +++++++++++ src/catalog.mli | 38 ++++ src/cell.ml | 70 ++++++ src/cell.mli | 20 ++ src/dataType.ml | 125 +++++++++++ src/dataType.mli | 99 +++++++++ src/date.ml | 120 ++++++++++ src/date.mli | 38 ++++ src/errors.ml | 14 ++ src/evaluator.ml | 373 +++++++++++++++++++++++++++++++ src/evaluator.mli | 66 ++++++ src/expression.ml | 114 ++++++++++ src/expression.mli | 29 +++ src/expressionLexer.mll | 84 +++++++ src/expressionParser.mly | 113 ++++++++++ src/functions.ml | 14 ++ src/main.ml | 241 ++++++++++++++++++++ src/odf/odf.ml | 346 +++++++++++++++++++++++++++++ src/odf/odf_ExpressionLexer.mll | 93 ++++++++ src/odf/odf_ExpressionParser.mly | 95 ++++++++ src/odf/odf_ns.ml | 96 ++++++++ src/scTypes.ml | 354 ++++++++++++++++++++++++++++++ src/scTypes.mli | 126 +++++++++++ src/screen.ml | 459 +++++++++++++++++++++++++++++++++++++++ src/screen.mli | 29 +++ src/selection.ml | 73 +++++++ src/selection.mli | 20 ++ src/sheet.ml | 334 ++++++++++++++++++++++++++++ src/sheet.mli | 75 +++++++ src/splay.ml | 142 ++++++++++++ src/splay.mli | 30 +++ src/tools.ml | 392 +++++++++++++++++++++++++++++++++ src/unicode.ml | 51 +++++ src/unicode.mli | 27 +++ tools.ml | 392 --------------------------------- unicode.ml | 51 ----- unicode.mli | 27 --- 77 files changed, 4645 insertions(+), 4645 deletions(-) delete mode 100755 UTF8.ml delete mode 100755 UTF8.mli delete mode 100755 actionParser.mly delete mode 100755 actions.mli delete mode 100755 catalog.ml delete mode 100644 catalog.mli delete mode 100755 cell.ml delete mode 100755 cell.mli delete mode 100755 dataType.ml delete mode 100755 dataType.mli delete mode 100644 date.ml delete mode 100755 date.mli delete mode 100755 errors.ml delete mode 100755 evaluator.ml delete mode 100755 evaluator.mli delete mode 100755 expression.ml delete mode 100755 expression.mli delete mode 100755 expressionLexer.mll delete mode 100755 expressionParser.mly delete mode 100755 functions.ml delete mode 100755 main.ml delete mode 100755 odf/odf.ml delete mode 100755 odf/odf_ExpressionLexer.mll delete mode 100755 odf/odf_ExpressionParser.mly delete mode 100755 odf/odf_ns.ml delete mode 100755 scTypes.ml delete mode 100755 scTypes.mli delete mode 100755 screen.ml delete mode 100755 screen.mli delete mode 100755 selection.ml delete mode 100755 selection.mli delete mode 100755 sheet.ml delete mode 100755 sheet.mli delete mode 100644 splay.ml delete mode 100755 splay.mli create mode 100755 src/UTF8.ml create mode 100755 src/UTF8.mli create mode 100755 src/actionParser.mly create mode 100755 src/actions.mli create mode 100755 src/catalog.ml create mode 100644 src/catalog.mli create mode 100755 src/cell.ml create mode 100755 src/cell.mli create mode 100755 src/dataType.ml create mode 100755 src/dataType.mli create mode 100644 src/date.ml create mode 100755 src/date.mli create mode 100755 src/errors.ml create mode 100755 src/evaluator.ml create mode 100755 src/evaluator.mli create mode 100755 src/expression.ml create mode 100755 src/expression.mli create mode 100755 src/expressionLexer.mll create mode 100755 src/expressionParser.mly create mode 100755 src/functions.ml create mode 100755 src/main.ml create mode 100755 src/odf/odf.ml create mode 100755 src/odf/odf_ExpressionLexer.mll create mode 100755 src/odf/odf_ExpressionParser.mly create mode 100755 src/odf/odf_ns.ml create mode 100755 src/scTypes.ml create mode 100755 src/scTypes.mli create mode 100755 src/screen.ml create mode 100755 src/screen.mli create mode 100755 src/selection.ml create mode 100755 src/selection.mli create mode 100755 src/sheet.ml create mode 100755 src/sheet.mli create mode 100644 src/splay.ml create mode 100755 src/splay.mli create mode 100755 src/tools.ml create mode 100755 src/unicode.ml create mode 100755 src/unicode.mli delete mode 100755 tools.ml delete mode 100755 unicode.ml delete mode 100755 unicode.mli diff --git a/Makefile b/Makefile index cdda759..4be3178 100755 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ OCAMLBUILD ?= ocamlbuild PACKAGES=dynlink,curses,camlzip,ezxmlm,text,str,menhirLib,zarith -PATHS=.,odf +PATHS=src,src/odf MENHIR=-use-menhir diff --git a/UTF8.ml b/UTF8.ml deleted file mode 100755 index a955b1e..0000000 --- a/UTF8.ml +++ /dev/null @@ -1,54 +0,0 @@ -include Text - -let empty = "" - -let decode x = Text.decode x - -let encode x = - try Some (Text.encode x) - with Text.Invalid (_, _) -> None - -let raw_encode x = Text.encode x - -let from_utf8string x = x - -let to_utf8string x = x - -let trim x = Text.strip x - -let split str ~sep = - match Text.split ~max:1 ~sep str with - | [] -> "" - | hd::tl -> hd - -let replace text patt repl = Text.replace text ~patt ~repl - -module Buffer = struct - - include Buffer - - type buffer = t - - let add_char b c = Uchar.of_char c - |> Uchar.to_int - |> Text.char - |> Buffer.add_string b -end - -module Printf = struct - - include Printf - -end - -module Format = struct - - include Format - - let bprintf buffer fformat = begin - let to_b = formatter_of_buffer buffer in - let x = fprintf to_b fformat in - x - end - -end diff --git a/UTF8.mli b/UTF8.mli deleted file mode 100755 index a2e331e..0000000 --- a/UTF8.mli +++ /dev/null @@ -1,92 +0,0 @@ -(** UTF8 is used internally for all strings - - The module is intentionaly opaque. - - *) - -(** An UTF8 encoded string *) -type t - -val empty: t - -(** Decode a string in the current locale *) -val decode: string -> t - -(** Use this to with a known UTF8 encoded string *) -val from_utf8string: string -> t - -(** Encode to the string to the user locale *) -val encode: t -> string option - -(** Encode the string. - This function may raise Text.Invalid if the string cannot be encoded in current locale -*) -val raw_encode: t -> string - -val to_utf8string: t -> string - -val trim: t -> t - -val length: t -> int - -val get: t -> int -> t - -val rev_explode : t -> t list - -val split: t -> sep:t -> t - -val fold : (t -> 'a -> 'a) -> t -> 'a -> 'a - -val implode : t list -> t - -val rev_implode : t list -> t - -val compare: t -> t -> int - -val replace: t -> t -> t -> t - -val upper: t -> t - -val lower: t -> t - -val code: t -> int - -val char: int -> t - -val repeat: int -> t -> t - -val get: t -> int -> t - -val lchop: t -> t - -val rchop: t -> t - -val sub: t -> int -> int -> t - -module Buffer : sig - - type buffer - - val create : int -> buffer - - val contents : buffer -> t - - val add_string : buffer -> t -> unit - - val add_char: buffer -> char -> unit - -end - -module Printf : sig - - val bprintf : Buffer.buffer -> ('a, Buffer.buffer, unit) format -> 'a - -end - -module Format: sig - - val formatter_of_buffer : Buffer.buffer -> Format.formatter - - val fprintf : Format.formatter -> ('a, Format.formatter, unit) format -> 'a - -end diff --git a/actionParser.mly b/actionParser.mly deleted file mode 100755 index 6318ca6..0000000 --- a/actionParser.mly +++ /dev/null @@ -1,45 +0,0 @@ -%{ - open Actions - -%} - -%token ESC -%token EOF -%token LEFT RIGHT UP DOWN -%token NPAGE PPAGE HOME END -%token RESIZE -%token DELETE -%token SEARCH -%token E U V Y P -%token EQUAL -%token I -%token BUTTON1_CLICKED -%token BUTTON1_RELEASED -%token COMMAND - -%start normal -%% - - -normal: - | ESC { Escape } - | LEFT { Move (Left 1) } - | RIGHT { Move (Right 1) } - | UP { Move (Up 1) } - | DOWN { Move (Down 1) } - | RESIZE { Resize } - | DELETE { Delete } - | E { Edit } - | U { Undo } - | V { Visual } - | Y { Yank } - | P { Paste } - | SEARCH { Search } - | EQUAL { InsertFormula } - | NPAGE { Move (Down 10)} - | PPAGE { Move (Up 10)} - | HOME { Move (Left 10)} - | END { Move (Right 10)} - | BUTTON1_CLICKED { Button1_clicked $1} - | BUTTON1_RELEASED{ Button1_released $1} - | COMMAND { Command } diff --git a/actions.mli b/actions.mli deleted file mode 100755 index f955538..0000000 --- a/actions.mli +++ /dev/null @@ -1,28 +0,0 @@ -type direction = -| Up of int -| Down of int -| Left of int -| Right of int -| Absolute of int * int - -type modes = -| Normal -| Select -| Edit -| Command - -type actions = -| Move of direction -| Resize (* Resize event *) -| Escape -| Delete -| Yank -| Paste -| Search -| Undo -| Edit -| InsertFormula -| Visual -| Button1_clicked of (int * int) -| Button1_released of (int * int) -| Command diff --git a/catalog.ml b/catalog.ml deleted file mode 100755 index e4cd34b..0000000 --- a/catalog.ml +++ /dev/null @@ -1,125 +0,0 @@ -module T = Tools -module type DATA_SIG = sig - - type 'a typ - - type 'a returnType - - val compare_typ: 'a typ -> 'b typ -> ('a, 'b) T.cmp - - val repr: Format.formatter -> 'a typ -> unit - -end - -(** We cannot update an existing function. Any [registerX] function will raise - [RegisteredFunction] if a function with the same signature already exists in -the catalog. *) -exception RegisteredFunction - -(** Catalog for all functions *) -module Make(Data:DATA_SIG) = struct - - (** This is the way the function is store in the map. - We just the return type, and the function itself. *) - type _ t_function = - | Fn1: 'b Data.returnType * ('a -> 'b) -> 'a t_function - | Fn2: 'c Data.returnType * ('a -> 'b -> 'c) -> ('a * 'b) t_function - | Fn3: 'd Data.returnType * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function - - (** This is the key for storing functions in the map. *) - type _ sig_typ = - | T1: 'a Data.typ -> 'a t_function sig_typ - | T2: 'a Data.typ * 'b Data.typ -> ('a * 'b) t_function sig_typ - | T3: 'a Data.typ * 'b Data.typ * 'c Data.typ -> ('a * 'b * 'c) t_function sig_typ - - - let repr: type a. Format.formatter -> a sig_typ -> unit = fun formatter -> function - | T1 t -> Format.fprintf formatter "(%a)" Data.repr t - | T2 (t1, t2) -> Format.fprintf formatter "(%a,%a)" Data.repr t1 Data.repr t2 - | T3 (t1, t2, t3) -> Format.fprintf formatter "(%a,%a,%a)" Data.repr t1 Data.repr t2 Data.repr t3 - - module ComparableSignature = struct - - type 'a t = string * 'a sig_typ - - (* Type for pure equality *) - type (_, _) eq = Eq : ('a, 'a) eq - - (** Compare two signature *) - let comp: type a b. string * a sig_typ -> string * b sig_typ -> (a, b) T.cmp = begin fun (namea, a) (nameb, 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 - | T.Eq -> f Eq - | T.Lt -> T.Lt - | T.Gt -> T.Gt - end in - - if namea < nameb then - T.Lt - else if namea > nameb then - T.Gt - else match a, b with - - | T1(a), T1(b) -> cmp a b (fun Eq -> T.Eq) - | T1(_), _ -> T.Lt - | _, T1(_) -> T.Gt - - | T2(a, b), T2(c, d) -> - cmp a c (fun Eq -> - cmp b d (fun Eq -> T.Eq) - ) - | T2(_), _ -> T.Lt - | _, T2(_) -> T.Gt - - | T3(a, b, c), T3(d, e, f) -> - cmp a d (fun Eq -> - cmp b e (fun Eq -> - cmp c f (fun Eq -> T.Eq) - ) - ) - - end - - - let repr : type a. Format.formatter -> a t -> unit = begin fun formatter (str, typ) -> - Format.fprintf formatter "%s:%a" - str - repr typ - end - - end - - module Functions = Splay.Make(ComparableSignature) - - (* This is the map which contains all the registered functions. - Each name is binded with another map with contains the function for each - signature. - *) - type t = Functions.t - - let empty = Functions.empty - - (** - Register a function in the catalog. If the function is already defined, - raise an exception. - *) - let register t name signature f = begin - - let name' = String.uppercase_ascii name in - if Functions.member (name', signature) t then - raise RegisteredFunction - else - Functions.add (name', signature) f t - end - - (** Look in the catalog for a function with the given name and signature *) - let find_function: - type a. t -> string -> a t_function sig_typ -> a t_function = - begin fun t name signature -> - Functions.find ((String.uppercase_ascii name), signature) t - end - - let repr = Functions.repr - -end diff --git a/catalog.mli b/catalog.mli deleted file mode 100644 index e871378..0000000 --- a/catalog.mli +++ /dev/null @@ -1,38 +0,0 @@ -module type DATA_SIG = sig - - type 'a typ - - type 'a returnType - - val compare_typ: 'a typ -> 'b typ -> ('a, 'b) Tools.cmp - - val repr: Format.formatter -> 'a typ -> unit - -end - -module Make(D:DATA_SIG): sig - - type t - - type 'a t_function = - | Fn1: 'b D.returnType * ('a -> 'b) -> 'a t_function - | Fn2: 'c D.returnType * ('a -> 'b -> 'c) -> ('a * 'b) t_function - | Fn3: 'd D.returnType * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function - - type 'a sig_typ = - | T1: 'a D.typ -> 'a t_function sig_typ - | T2: 'a D.typ * 'b D.typ -> ('a * 'b) t_function sig_typ - | T3: 'a D.typ * 'b D.typ * 'c D.typ -> ('a * 'b * 'c) t_function sig_typ - - (** Empty catalog *) - val empty: t - - (** Register a new function in the catalog *) - val register : t -> string -> 'a t_function sig_typ -> 'a t_function -> t - - (** Find a function with the given name and signature *) - val find_function: t -> string -> 'a t_function sig_typ -> 'a t_function - - val repr: Format.formatter -> t -> unit - -end diff --git a/cell.ml b/cell.ml deleted file mode 100755 index e6ccd63..0000000 --- a/cell.ml +++ /dev/null @@ -1,70 +0,0 @@ -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 - let rec extract acc value = - if value > 0 then ( - let value' = value - 1 in - let rem = value' mod 26 in - let quot = (value' - rem) / 26 - in extract ((char_of_int (65 + rem))::acc) quot - ) else ( - acc - ) - 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 - - 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; - UTF8.Buffer.contents buff - -let to_buffer buff ((x, y), (fixed_x, fixed_y)) = begin - 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 - -module Set = (struct - include Set.Make(struct - type t = (int * int) - let compare = Pervasives.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 printb buff = - iter (fun x -> to_buffer buff (x, (false,false)); UTF8.Buffer.add_char buff ' ') - -end) - diff --git a/cell.mli b/cell.mli deleted file mode 100755 index 8f225a5..0000000 --- a/cell.mli +++ /dev/null @@ -1,20 +0,0 @@ -type t = (int * int) * (bool * bool) - -module Set : sig - - include Set.S with type elt = (int * int) - - val printb: UTF8.Buffer.buffer -> t -> unit - -end - -val to_pair: t -> (int * int) - -val from_string: bool * string -> bool * int -> t - -val to_hname: int -> UTF8.t - -val to_string: t -> UTF8.t - -val to_buffer: UTF8.Buffer.buffer -> t -> unit - diff --git a/dataType.ml b/dataType.ml deleted file mode 100755 index f30dd8c..0000000 --- a/dataType.ml +++ /dev/null @@ -1,125 +0,0 @@ -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 -end - -module Comparable = struct - - 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 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 - - 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 - - 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 - else - 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 - 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 - - if is_integer q_factor then - - 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) - -end - -module Bool = struct - - type t = bool - include Comparable - - let true_ = true - let false_ = false - - let or_ = (||) - let and_ = (&&) - let not = Pervasives.not - -end - -module String = struct - - type t = UTF8.t - include Comparable - -end - -module Date = Date.Make(Num) diff --git a/dataType.mli b/dataType.mli deleted file mode 100755 index 5c89c98..0000000 --- a/dataType.mli +++ /dev/null @@ -1,99 +0,0 @@ -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 -end - -module Num: sig - - type t - - val one: t - val zero: t - - val of_int: int -> t - val to_int: t -> int - - val to_float: t -> float - val of_float: float -> t - - val neg: t -> 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 add: t -> t -> t - val sub: t -> t -> t - val mult: t -> t -> t - val div: t -> t -> t - val pow: t -> t -> t - - val rnd: unit -> t - - val max: t -> t -> t - val min: t -> t -> t - - val abs: t -> t - - val round: t -> t - val floor: t -> t - val round_down: t -> t - - val gcd: t -> t -> t - val lcm: t -> t -> t - - val is_integer: t -> bool - -end - -module Bool: sig - type t = bool - - val true_ : bool - val false_: 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 - - val not: t -> t - val and_: t -> t -> t - val or_: t -> t -> t -end - -module String: sig - type t = UTF8.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 -end - -module Date: sig - - (** Create a date from a year month day *) - val get_julian_day : int -> int -> int -> Num.t - - (** Return the year, month and day from a date *) - val date_from_julian_day : Num.t -> int * int * int - - val time_from_julian_day : Num.t -> int * int * Num.t - - val from_string: string -> Num.t - - (** Print out the date *) - val to_string: Num.t -> string -end diff --git a/date.ml b/date.ml deleted file mode 100644 index 92cb9f6..0000000 --- a/date.ml +++ /dev/null @@ -1,120 +0,0 @@ -module type CALCULABLE = sig - - type t - - val add: t -> t -> t - - val sub: t -> t -> t - - val mult: t -> t -> t - - val div: t -> t -> t - - val floor: t -> t - - val of_int: int -> t - - val to_int: t -> int - - val to_float: t -> float - -end - - -module Make(C : CALCULABLE) = struct - - 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 *) - |> C.of_int - - end - - let date_from_julian_day day = begin - - let shift_day = C.add (C.floor day) (C.of_int 2415019) in - - let z = C.to_int shift_day in - let f = - if z >= 2299161 then - (* We use the Num module here to prevent overflow *) - let product = C.mult (C.of_int 4) shift_day in - let shifted = C.add product (C.of_int 274277) in - let div = C.div shifted (C.of_int 146097) in - let day' = C.to_int @@ C.floor div 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 - - let day = C.floor j in - let time = C.sub j day in - - let h = C.floor @@ C.mult time (C.of_int 24) in - let h_24 = C.div h (C.of_int 24) in - let m = C.floor @@ C.mult (C.of_int 1440) (C.sub time h_24) in - let s = C.mult (C.of_int 86400) (C.sub (C.sub time h_24) (C.div m (C.of_int 1440))) in - (C.to_int h, C.to_int 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 = C.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 -> - let nhour = C.div (n hour) (n 24) - and nmin = C.div (n min) (n 1440) - and nsec = C.div (n sec) (n 86400) in - C.add (C.add (C.add (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 ( - C.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 - - h n (C.to_float s) - - end - -end diff --git a/date.mli b/date.mli deleted file mode 100755 index dd24124..0000000 --- a/date.mli +++ /dev/null @@ -1,38 +0,0 @@ -module type CALCULABLE = sig - - type t - - val add: t -> t -> t - - val sub: t -> t -> t - - val mult: t -> t -> t - - val div: t -> t -> t - - val floor: t -> t - - val of_int: int -> t - - val to_int: t -> int - - val to_float: t -> float - -end - -module Make(C:CALCULABLE): sig - - (** Create a date from a year month day *) - val get_julian_day : int -> int -> int -> C.t - - (** Return the year, month and day from a date *) - val date_from_julian_day : C.t -> int * int * int - - val time_from_julian_day : C.t -> int * int * C.t - - val from_string: string -> C.t - - (** Print out the date *) - val to_string: C.t -> string - -end diff --git a/errors.ml b/errors.ml deleted file mode 100755 index 3751a60..0000000 --- a/errors.ml +++ /dev/null @@ -1,14 +0,0 @@ - -(** The function is undefined *) -exception Undefined of UTF8.t * string list - -exception TypeError - -exception Cycle - -let printf formatter = function - | Undefined (name, args) -> Format.fprintf formatter - "There is no function '%s' with signature %a" - (UTF8.to_utf8string name) - (Format.pp_print_list Format.pp_print_text) args - | _ -> Format.fprintf formatter "#Error" diff --git a/evaluator.ml b/evaluator.ml deleted file mode 100755 index f718e1f..0000000 --- a/evaluator.ml +++ /dev/null @@ -1,373 +0,0 @@ -module D = DataType -module T = Tools - -module Data = struct - -(** Data format *) - -type 'a dataFormat = 'a ScTypes.dataFormat - -(*** Type definitions *) - -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 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 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 - -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 - -type 'a returnType = 'a ScTypes.returnType - -(*** Values definitions *) - -type 'a value = - | Bool: D.Bool.t -> D.Bool.t value - | Num: D.Num.t ScTypes.dataFormat * D.Num.t -> D.Num.t value - | String: UTF8.t -> UTF8.t value - | List: 'a ScTypes.dataFormat * 'a list -> 'a list value - | Matrix: 'a ScTypes.dataFormat * 'a list list -> 'a list list value - -(** Get the value out of the box *) -let get_value_content: type a. a value -> a = function - | Bool b -> b - | Num (_, n) -> n - | String s -> s - | List (t, l) -> l - | Matrix (t, l) -> l - -(* Extract the type from a boxed value *) -let type_of_value: type a. a value -> a typ = function - | Bool b -> Bool - | Num (n, _) -> Num - | String s -> String - | List (t, l) -> List (typ_of_format t) - | Matrix (t, l) -> List (List (typ_of_format t)) - -end - -module C = Catalog.Make(Data) - - -type t = C.t - -let catalog = ref C.empty - -let get_catalog () = !catalog - -let repr = C.repr - -type existencialResult = - | Result : 'a Data.value -> existencialResult [@@unboxed] - -let inject: -type a. a Data.dataFormat -> a -> existencialResult = fun resultFormat res -> - begin match resultFormat with - | ScTypes.Bool -> Result (Data.Bool res) - | ScTypes.String -> Result (Data.String res) - | ScTypes.Number -> Result (Data.Num (resultFormat, res)) - | ScTypes.Date -> Result (Data.Num (resultFormat, res)) - end - - -(** Extract the format from a list of results *) -let build_format_list ll () = - - List.map (fun (Result x) -> - begin match x with - | Data.Bool _ -> ScTypes.DataFormat.F (ScTypes.Bool) - | Data.Num (x, _) -> ScTypes.DataFormat.F x - | Data.String _ -> ScTypes.DataFormat.F (ScTypes.String) - | Data.List (f, _) -> ScTypes.DataFormat.F f - | Data.Matrix (f, _) -> ScTypes.DataFormat.F f - end - ) ll - - -let register0 name returnType f = - catalog := C.register !catalog name (C.T1(Data.Unit)) (C.Fn1 (returnType, f)) - -let register1 name typ1 returnType f = - catalog := C.register !catalog name (C.T1(typ1)) (C.Fn1 (returnType, f)) - -let register2 name (typ1, typ2) result f = - catalog := C.register !catalog name (C.T2(typ1, typ2)) (C.Fn2 (result, f)) - -let register3 name (typ1, typ2, typ3) result f = - catalog := C.register !catalog name (C.T3(typ1, typ2, typ3)) (C.Fn3 (result, f)) - -let call name args = begin - let name' = UTF8.to_utf8string name in - begin try match args with - | [] -> - let C.Fn1(ret, f) = C.find_function !catalog name' (C.T1 Data.Unit) in - let returnType = ScTypes.DataFormat.guess_format_result ret (fun () -> raise Errors.TypeError) in - inject returnType (f ()) - - | (Result p1)::[] -> - let C.Fn1(ret, f) = - C.find_function !catalog name' (C.T1 (Data.type_of_value p1)) in - let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in - inject returnType (f (Data.get_value_content p1)) - - | (Result p1)::(Result p2)::[] -> - let C.Fn2(ret, f) = - C.find_function !catalog name' (C.T2 (Data.type_of_value p1, Data.type_of_value p2)) in - let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in - inject returnType (f (Data.get_value_content p1) (Data.get_value_content p2)) - - | (Result p1)::(Result p2)::(Result p3)::[] -> - let C.Fn3(ret, f) = - C.find_function !catalog name' (C.T3 (Data.type_of_value p1, Data.type_of_value p2, Data.type_of_value p3)) in - let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in - inject returnType (f (Data.get_value_content p1) (Data.get_value_content p2) (Data.get_value_content p3)) - - | _ -> raise Not_found - with Not_found -> - let signature = List.map (fun (Result x) -> - let formatter = Format.str_formatter in - Data.repr formatter (Data.type_of_value x); - Format.flush_str_formatter ()) args in - - raise (Errors.Undefined (name, signature)) - end -end - -let eval mapper value = begin - - (** Extract the value from a raw type. - If the value is Undefined, raise an exception. - *) - let extract_value : ScTypes.result -> existencialResult = begin function - | ScTypes.Result (ScTypes.Num (f, n)) -> Result (Data.Num (f, n)) - | ScTypes.Result (ScTypes.Bool b) -> Result (Data.Bool b) - | ScTypes.Result (ScTypes.Str s) -> Result (Data.String s) - | ScTypes.Error x -> raise x - end in - - (** Extract the value from an expression. - [extract typ expr] will evaluate the expression and return it. If the - result cannot be evaluated (because of references pointing to missing - values) a default value of type [typ] will be returned. - *) - let rec extract = begin function - (* For a reference to an external we first extract the value pointed *) - | ScTypes.Ref r -> ScTypes.Refs.( - begin match ScTypes.Refs.get_content @@ mapper r with - | C (Value (format, f)) -> begin match format with - | ScTypes.Date -> Result (Data.Num (format, f)) - | ScTypes.Number -> Result (Data.Num (format, f)) - | ScTypes.String -> Result (Data.String f) - | ScTypes.Bool -> Result (Data.Bool f) - end - | C (List (format, l)) -> Result (Data.List (format, l)) - | C (Matrix (format, l)) -> Result (Data.Matrix (format, l)) - end) - - (* Evaluate the expression *) - | ScTypes.Expression e -> extract e - | ScTypes.Value v -> extract_value (ScTypes.Result v) - | ScTypes.Call (name, args) -> - let args' = List.map extract args in - call name args' - end - in - let Result r = ((extract[@tailrec]) value) in - begin match r with - | Data.Bool b -> ScTypes.Result (ScTypes.boolean b) - | Data.String s -> ScTypes.Result (ScTypes.string s) - | Data.Num (format, n) -> begin match ScTypes.get_numeric_type format with - | ScTypes.Date -> ScTypes.Result (ScTypes.date n) - | ScTypes.Number -> ScTypes.Result (ScTypes.number n) - end - | _ -> raise Errors.TypeError - end -end - -let wrap f = - let old_catalog = !catalog in - Tools.try_finally - (fun () -> catalog := C.empty; f ()) - (fun () -> catalog := old_catalog) - - -(* Register the standard functions *) -type 'a returnType = 'a ScTypes.returnType - -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(C: D.COMPARABLE) = struct - - let register t = begin - register2 "=" (t, t) f_bool C.eq; - register2 "<>" (t, t) f_bool C.neq; - register2 ">" (t, t) f_bool C.gt; - register2 ">=" (t, t) f_bool C.ge; - register2 "<" (t, t) f_bool C.lt; - register2 "<=" (t, t) f_bool C.le; - end - -end - -type 'a typ = 'a Data.typ -let t_bool: DataType.Bool.t typ = Data.Bool -let t_int: DataType.Num.t typ = Data.Num -let t_string: UTF8.t typ = Data.String -let t_list (t: 'a typ): 'a list typ = Data.List t - -(* Helper for list functions : reduce over a list of elements *) -let reduce name typ res f = begin - register1 name (t_list typ) res (fun x -> - List.fold_left f (List.hd x) x); - register1 name (t_list (t_list typ)) res (fun x -> - List.fold_left (List.fold_left f) (List.hd (List.hd x)) x); -end - -(* Helper for list functions : fold over a list of elements *) -let fold name t_in t_out f init = begin - register1 name (t_list t_in) t_out (fun x -> - List.fold_left f init x); - register1 name (t_list (t_list t_in)) t_out (fun x -> - 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 - - (* Build a date *) - 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) - ); - - let module CompareNum = Make_Compare(D.Num) in - Data.( - CompareNum.register t_int; - register0 "rand" f_number D.Num.rnd; - - register0 "pi" f_number (fun () -> D.Num.of_float (4. *. atan 1.)); - register1 "sin" t_int f_number (fun x -> D.Num.of_float (sin @@ D.Num.to_float x)); - register1 "cos" t_int f_number (fun x -> D.Num.of_float (cos @@ D.Num.to_float x)); - register1 "tan" t_int f_number (fun x -> D.Num.of_float (tan @@ D.Num.to_float x)); - register1 "atan" t_int f_number (fun x -> D.Num.of_float (atan @@ D.Num.to_float x)); - register1 "asin" t_int f_number (fun x -> D.Num.of_float (asin @@ D.Num.to_float x)); - register1 "acos" t_int f_number (fun x -> D.Num.of_float (acos @@ D.Num.to_float x)); - register1 "sinh" t_int f_number (fun x -> D.Num.of_float (sinh @@ D.Num.to_float x)); - register1 "cosh" t_int f_number (fun x -> D.Num.of_float (cosh @@ D.Num.to_float x)); - register1 "tanh" t_int f_number (fun x -> D.Num.of_float (tanh @@ D.Num.to_float x)); - 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)) - ); - - register1 "sqrt" t_int f_number (fun x -> D.Num.of_float (sqrt @@ D.Num.to_float x)); - register1 "exp" t_int f_number (fun x -> D.Num.of_float (exp @@ D.Num.to_float x)); - register1 "ln" t_int f_number (fun x -> D.Num.of_float (log @@ D.Num.to_float x)); - - 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; - register1 "int" t_int f_number D.Num.floor; - register1 "rounddown" t_int f_number D.Num.round_down; - register1 "round" t_int f_number D.Num.round; - - register1 "trim" t_string f_string UTF8.trim; - register1 "right" t_string f_string (fun x -> UTF8.get x (-1)); - register2 "right" (t_string, t_int) f_string ( - fun t n -> - let n' = D.Num.to_int n in - UTF8.sub t (-(n')) n' - ); - register1 "left" t_string f_string (fun x -> UTF8.get x 0); - register2 "left" (t_string, t_int) f_string ( - fun t n -> - let n' = D.Num.to_int n in - UTF8.sub t 0 n' - ); - register1 "len" t_string f_number (fun x -> D.Num.of_int @@ UTF8.length x); - register1 "lenb" t_string f_number (fun x -> D.Num.of_int @@ String.length @@ UTF8.to_utf8string x); - register1 "lower" t_string f_string UTF8.lower; - register1 "unicode" t_string f_number (fun x -> D.Num.of_int @@ UTF8.code x); - register1 "unichar" t_int f_string (fun x -> UTF8.char @@ D.Num.to_int x); - register1 "upper" t_string f_string UTF8.upper; - register3 "substitute" (t_string, t_string, t_string) f_string UTF8.replace; - register2 "rept" (t_string, t_int) f_string (fun t n -> UTF8.repeat (D.Num.to_int n) t); - - 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_); - register1 "not" t_bool f_bool D.Bool.not; - register2 "and" (t_bool, t_bool) f_bool D.Bool.and_; -(* fold "and" t_bool f_bool D.Bool.and_ (D.Bool.true_); *) - register2 "or" (t_bool, t_bool) f_bool D.Bool.or_; -(* fold "or" t_bool f_bool D.Bool.or_ (D.Bool.false_); *) - register2 "xor" (t_bool, t_bool) f_bool D.Bool.neq; -(* fold "xor" t_bool f_bool D.Bool.neq (D.Bool.false_); *) - - let module CompareString = Make_Compare(D.String) in - 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); - - register2 "^" (t_int, t_int) f_number D.Num.pow; - register2 "power" (t_int, t_int) f_number D.Num.pow; - - register2 "gcd"(t_int, t_int) f_number D.Num.gcd; - register2 "lcm"(t_int, t_int) f_number D.Num.lcm; - register1 "+" t_int f_num (fun x -> x); - register1 "-" t_int f_num D.Num.neg; (* Unary negation *) - register2 "+" (t_int, t_int) f_num D.Num.add; - register2 "-" (t_int, t_int) f_num D.Num.sub; - register2 "*" (t_int, t_int) f_number D.Num.mult; - register2 "/" (t_int, t_int) f_number D.Num.div; - - ) - -end - diff --git a/evaluator.mli b/evaluator.mli deleted file mode 100755 index b296b90..0000000 --- a/evaluator.mli +++ /dev/null @@ -1,66 +0,0 @@ -type t - -val eval: (ScTypes.refs -> ScTypes.result option ScTypes.Refs.range) -> ScTypes.expression -> ScTypes.result - -val repr: Format.formatter -> t -> unit - -val get_catalog: unit -> t - -(** Type definitions *) - -type 'a typ -val t_bool: DataType.Bool.t typ -val t_int: DataType.Num.t typ -val t_string: UTF8.t typ -val t_list: 'a typ -> 'a list typ - -(** Result formats *) - -type 'a returnType - -(** Numeric (any format) *) -val f_num: DataType.Num.t returnType - -(** Date *) -val f_date: DataType.Num.t returnType - -(** Number *) -val f_number: DataType.Num.t returnType - -(** Boolean result *) -val f_bool: DataType.Bool.t returnType - -(** String *) -val f_string: DataType.String.t returnType - -(** Catalog *) - -val register0: - string -> (* The function name *) - 'a returnType -> (* The return type *) - (unit -> 'a) (* The function to call *) - -> unit - -val register1: - string -> (* The function name *) - 'a typ -> (* The signature *) - 'b returnType -> (* The return type *) - ('a -> 'b) (* The function to call *) - -> unit - -val register2: - string -> (* The function name *) - ('a typ * 'b typ) ->(* The signature *) - 'c returnType -> (* The return type *) - ( 'a -> 'b -> 'c) (* The function to call*) - -> unit - -val register3: - string -> (* The function name *) - ('a typ * 'b typ * 'c typ) ->(* The signature *) - 'd returnType -> (* The return type *) - ( 'a -> 'b -> 'c -> 'd) (* The function to call*) - -> unit - -(** [wrap f] run [f] inside a context where there is no functions *) -val wrap: (unit -> 'a) -> 'a diff --git a/expression.ml b/expression.ml deleted file mode 100755 index 20227ad..0000000 --- a/expression.ml +++ /dev/null @@ -1,114 +0,0 @@ -module Tuple2 = Tools.Tuple2 - -let u = UTF8.from_utf8string - -type t = - | Basic: 'a ScTypes.types -> t (** A direct type *) - | Formula: formula -> t (** A formula *) - | Undefined: t (** The content is not defined *) - -and formula = - | Expression of ScTypes.expression (** A valid expression *) - | Error of int * UTF8.t (** When the expression cannot be parsed *) - - -let is_defined = function - | Undefined -> false - | _ -> true - -let load content = begin - let content = UTF8.to_utf8string content in - 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 ( - (* 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 r = - ExpressionParser.content ExpressionLexer.read - @@ Lexing.from_string content' in - Basic r - with _ -> Basic (ScTypes.string (UTF8.from_utf8string content')) - ) - ) else ( - (* If the string in empty, build an undefined value *) - Undefined - ) -end - - -let load_expr expr = expr - - -(** Extract the parameters to give to a function. - return an Error if one of them is an error - *) -let eval expr sources = begin - - let eval_exp f = Evaluator.eval sources f in - - begin try match expr with - | Basic value -> ScTypes.Result value - | Formula (Expression f) -> eval_exp f - | Formula (Error (i, s)) -> ScTypes.Error ScTypes.Error - | Undefined -> ScTypes.Error Not_found - with ex -> ScTypes.Error ex - end - -end - -let collect_sources expr = begin - let rec collect refs = function - | ScTypes.Ref r -> - begin match ScTypes.Refs.collect r with - | ScTypes.Refs.Single r -> Cell.Set.add r refs - | ScTypes.Refs.Array1 a1 -> - List.fold_left (fun set elt -> Cell.Set.add elt set) refs a1 - | ScTypes.Refs.Array2 a2 -> - List.fold_left (List.fold_left (fun set elt -> Cell.Set.add elt set)) refs a2 - end - | ScTypes.Call (ident, params) -> List.fold_left collect refs params - | ScTypes.Expression f -> collect refs f - | _ -> refs - in match expr with - | Formula (Expression f) -> collect Cell.Set.empty f - | _ -> Cell.Set.empty -end - -let show e = - let buffer = UTF8.Buffer.create 16 in - begin match e with - | Formula (Expression f) -> - UTF8.Buffer.add_char buffer '='; - ScTypes.show_expr buffer f - | Basic b -> ScTypes.Type.show_full buffer b - | Formula (Error (i,s)) -> UTF8.Buffer.add_string buffer s - | Undefined -> () - end; - UTF8.Buffer.contents buffer - -let shift vector = - - let rec shift_exp: ScTypes.expression -> ScTypes.expression = function - | ScTypes.Value v -> ScTypes.Value v - | ScTypes.Call (ident, params) -> ScTypes.Call (ident, List.map shift_exp params) - | ScTypes.Ref r -> ScTypes.Ref (ScTypes.Refs.shift vector r) - | ScTypes.Expression expr -> ScTypes.Expression (shift_exp expr) - - in function - | Formula (Expression f) -> Formula (Expression (shift_exp f)) - | other -> other - -let (=) t1 t2 = match t1, t2 with - | Basic b1, Basic b2 -> ScTypes.Type.(=) b1 b2 - | o1, o2 -> Pervasives.(=) o1 o2 diff --git a/expression.mli b/expression.mli deleted file mode 100755 index 8cab479..0000000 --- a/expression.mli +++ /dev/null @@ -1,29 +0,0 @@ -type t = - | Basic: 'a ScTypes.types -> t (** A direct type *) - | Formula: formula -> t (** A formula *) - | Undefined: t (** The content is not defined *) - -and formula = - | Expression of ScTypes.expression (** A valid expression *) - | Error of int * UTF8.t (** When the expression cannot be parsed *) - - -(** Load an expression *) -val load: UTF8.t -> t - -val load_expr: t -> t - -val is_defined: t -> bool - -(** Evaluate the expression *) -val eval: t -> (ScTypes.refs -> ScTypes.result option ScTypes.Refs.range) -> ScTypes.result - -(** Collect all the cell referenced in the expression *) -val collect_sources: t -> Cell.Set.t - -(** Represent an expression *) -val show: t -> UTF8.t - -val shift: (int * int) -> t -> t - -val (=): t -> t -> bool diff --git a/expressionLexer.mll b/expressionLexer.mll deleted file mode 100755 index 2d2f87e..0000000 --- a/expressionLexer.mll +++ /dev/null @@ -1,84 +0,0 @@ -{ - open ExpressionParser - open Lexing - - exception SyntaxError of string -} - -let digit = ['0'-'9'] -let real = digit+ '.'? | digit* '.' digit+ - - -let newline = "\r\n" | '\n' | '\r' -let space = ['\t' ' '] | newline - -let letters = ['A'-'Z' 'a'-'z'] - -let text = letters | digit - -let cell = letters+ digit+ - -rule read = parse - | space+ { read lexbuf } - - | digit+ as _1 { NUM _1} - | real as _1 { REAL(Tools.String.filter_float _1)} - | '$' { DOLLAR } - - | '=' { EQ } - | "<>" { NEQ } - | '<' { LT } - | "<=" { LE } - | '>' { GT } - | ">=" { GE } - | '*' { TIMES } - | '+' { PLUS } - | '-' { MINUS } - | '/' { DIVIDE } - | '"' { read_string (Buffer.create 17) lexbuf } - | ';' { SEMICOLON } - | ':' { COLON } - | '(' { LPAREN } - | ')' { RPAREN } - | '^' { POW } - - | letters+ as _1 { LETTERS _1} - - | '\000' { EOF } - | eof { EOF } - -and read_string buf = parse - | '"' { STR (Buffer.contents buf) } - | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } - | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } - | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } - | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } - | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } - | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } - | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } - | '\\' '"' { Buffer.add_char buf '"'; read_string buf lexbuf } - | [^ '"' '\\' '\000']+ - { Buffer.add_string buf (Lexing.lexeme lexbuf); - read_string buf lexbuf - } - | '\000' { STR (Buffer.contents buf) } - | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } - | eof { STR ( Buffer.contents buf) } - -and quoteless_string buf = parse - | '\\' '/' { Buffer.add_char buf '/'; quoteless_string buf lexbuf } - | '\\' '\\' { Buffer.add_char buf '\\'; quoteless_string buf lexbuf } - | '\\' 'b' { Buffer.add_char buf '\b'; quoteless_string buf lexbuf } - | '\\' 'f' { Buffer.add_char buf '\012'; quoteless_string buf lexbuf } - | '\\' 'n' { Buffer.add_char buf '\n'; quoteless_string buf lexbuf } - | '\\' 'r' { Buffer.add_char buf '\r'; quoteless_string buf lexbuf } - | '\\' 't' { Buffer.add_char buf '\t'; quoteless_string buf lexbuf } - | '\\' '"' { Buffer.add_char buf '"'; quoteless_string buf lexbuf } - | [^ '\\' '\000']+ - { Buffer.add_string buf (Lexing.lexeme lexbuf); - quoteless_string buf lexbuf - } - | '\000' { STR (Buffer.contents buf) } - | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } - | eof { STR (Buffer.contents buf) } - diff --git a/expressionParser.mly b/expressionParser.mly deleted file mode 100755 index b7f77ae..0000000 --- a/expressionParser.mly +++ /dev/null @@ -1,113 +0,0 @@ -%{ - open ScTypes - module F = Functions - - let u = UTF8.from_utf8string - - let extractColumnNameFromNum (fixed, (str, value)) = (fixed, value) - -%} - -%token REAL -%token NUM -%token STR - -%token LETTERS - -%token DOLLAR - -%token LPAREN -%token RPAREN -%token PLUS -%token TIMES -%token DIVIDE -%token MINUS -%token EQ NEQ -%token LT LE GT GE -%token EOF -%token SEMICOLON -%token COLON -%token POW - -%nonassoc EQ NEQ LT LE GT GE -%left PLUS MINUS -%left TIMES DIVIDE -%left POW - -%start value -%start content - -%% - -value: - | EQ expr EOF {$2} - -content: - | basic EOF {$1} - -basic: - | PLUS num {Result (number $2)} - | MINUS num {Result (number (DataType.Num.neg $2))} - | num {Result (number $1)} - | NUM DIVIDE NUM DIVIDE NUM {Result ( - date ( - DataType.Date.get_julian_day - (int_of_string $1) - (int_of_string $3) - (int_of_string $5) - ))} - | NUM COLON NUM COLON NUM {Result ( - date ( - let nhour = DataType.Num.div (DataType.Num.of_int @@ int_of_string $1) (DataType.Num.of_int 24) - and nmin = DataType.Num.div (DataType.Num.of_int @@ int_of_string $3) (DataType.Num.of_int 1440) - and nsec = DataType.Num.div (DataType.Num.of_int @@ int_of_string $5) (DataType.Num.of_int 86400) - in DataType.Num.add (DataType.Num.add nhour nmin) nsec - ) - )} - -expr: - | num {Value (number ($1))} - | MINUS expr {Call (F.sub, [$2])} - | PLUS expr {Call (F.add, [$2])} - - | LETTERS ident LPAREN separated_list(SEMICOLON, expr) RPAREN { Call (u($1 ^ $2), $4) } - - - | cell {Ref (Cell $1)} - | cell COLON cell {Ref (Range ($1, $3))} - - - | LPAREN expr RPAREN {Expression $2} - | STR {Value (string (u $1))} - - (* Mathematical operators *) - | expr MINUS expr {Call (F.sub, [$1; $3])} - | expr DIVIDE expr {Call (F.div, [$1; $3])} - | expr TIMES expr {Call (F.mul, [$1; $3])} - | expr PLUS expr {Call (F.add, [$1; $3])} - | expr POW expr {Call (F.pow, [$1; $3])} - - (* Comparaison *) - | expr EQ expr {Call (F.eq, [$1; $3])} - | expr NEQ expr {Call (F.neq, [$1; $3])} - | expr LT expr {Call (F.lt, [$1; $3])} - | expr GT expr {Call (F.gt, [$1; $3])} - | expr LE expr {Call (F.le, [$1; $3])} - | expr GE expr {Call (F.ge, [$1; $3])} - -%inline cell: - | LETTERS NUM { Cell.from_string (false, $1) (false, int_of_string $2) } - | DOLLAR LETTERS NUM { Cell.from_string (true, $2) (false, int_of_string $3) } - | LETTERS DOLLAR NUM { Cell.from_string (false, $1) (true, int_of_string $3) } - | DOLLAR LETTERS DOLLAR NUM { Cell.from_string (true, $2) (true, int_of_string $4) } - -num: - | REAL {DataType.Num.of_float @@ float_of_string $1} - | NUM {DataType.Num.of_int @@ int_of_string $1} - -ident: - | text* { String.concat "" $1 } - -text: - | LETTERS { $1 } - | NUM { $1 } diff --git a/functions.ml b/functions.ml deleted file mode 100755 index 56d7530..0000000 --- a/functions.ml +++ /dev/null @@ -1,14 +0,0 @@ -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"-" diff --git a/main.ml b/main.ml deleted file mode 100755 index 3b83e85..0000000 --- a/main.ml +++ /dev/null @@ -1,241 +0,0 @@ -let u = UTF8.from_utf8string - -let redraw t screen = - let screen' = - Screen.draw t screen - |> Screen.draw_input t in - t, screen' - -let action f msg (t, screen) = begin - let t', count = f t in - let t', screen' = redraw t' screen in - Screen.status screen' @@ UTF8.from_utf8string (Printf.sprintf msg count); - t', screen' -end - -let f screen = ActionParser.( - begin match Screen.read_key screen with - | "\027" -> ESC - | "\001\002" -> DOWN - | "\001\003" -> UP - | "\001\004" -> LEFT - | "\001\005" -> RIGHT - | "\001\006" -> HOME - | "\001\104" -> END - - | "\001R" -> NPAGE - | "\001S" -> PPAGE - - (* See http://www.ibb.net/~anne/keyboard.html for thoses keycode. *) - | "\001\074"|"\127" -> DELETE - - | "e" -> E - | "u" -> U - | "v" -> V - | "y" -> Y - | "p" -> P - | "=" -> EQUAL - | "/" -> SEARCH - | ":" -> COMMAND - - | "\001\154" -> RESIZE - | "\001\153" -> - begin match Tools.NCurses.get_mouse_event () with - | None -> raise Not_found - | Some (id, ev, (x, y, z)) -> - if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_CLICKED ev then - BUTTON1_CLICKED(x, y) - else if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_PRESSED ev then - BUTTON1_CLICKED(x, y) - else if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_RELEASED ev then - BUTTON1_RELEASED(x, y) - else - raise Not_found - end - | _ -> raise Not_found -end) - -let parser screen = begin - let get_value () = f screen, Lexing.dummy_pos, Lexing.dummy_pos in - MenhirLib.Convert.Simplified.traditional2revised ActionParser.normal get_value -end - -let rec normal_mode (t, screen) = begin - match (parser screen) with - | exception x -> normal_mode (t, screen) - - | Actions.Visual -> - Screen.status screen @@ u"-- Selection --"; - selection_mode (t, screen) - - | Actions.Move direction -> - begin match Sheet.move direction t with - | Some t' -> normal_mode @@ redraw t' screen - | None -> normal_mode (t, screen) - end - - | Actions.Resize -> normal_mode (t, Screen.resize t screen) - - | Actions.Delete -> - let yank_before_delete = fun x -> Sheet.delete (fst (Sheet.yank x)) in - normal_mode @@ action yank_before_delete "Deleted %d cells" (t, screen) - - | Actions.Yank -> - normal_mode @@ action Sheet.yank "Yanked %d cells" (t, screen) - - | Actions.Paste -> - normal_mode @@ action Sheet.paste "Pasted %d cells" (t, screen) - - | Actions.Undo -> - begin match Sheet.undo t with - | Some t' -> normal_mode @@ redraw t' screen - | None -> normal_mode (t, screen) - end - - (* Edit a content *) - | Actions.Edit -> - let position = Selection.extract t.Sheet.selected in - let expr = Sheet.Raw.get_expr position t.Sheet.data - |> Expression.show in - begin match Screen.editor ~position ~prefix:(u"-> ") ~init:expr screen with - | None -> - (* Restore the previous value *) - Screen.status screen expr; - normal_mode (t, screen) - | Some content -> - let expr' = Expression.load content in - let _, t' = Sheet.add expr' t in - normal_mode @@ redraw t' screen - end - - (* Insert a new formula, the actual value will be erased *) - | Actions.InsertFormula -> - let position = Selection.extract t.Sheet.selected in - begin match Screen.editor ~position ~init:(u"=") screen with - | None -> - (* Restore the previous value *) - let expr = Sheet.Raw.get_expr position t.Sheet.data - |> Expression.show in - Screen.status screen expr; - normal_mode (t, screen) - | Some content -> - let expr = Expression.load content in - let _, t' = Sheet.add expr t in - normal_mode @@ redraw t' screen - end - - | Actions.Search -> - let expr = Screen.search screen - |> Expression.load in - let pattern = Expression.eval expr (fun _ -> ScTypes.Refs.Single None) in - begin match Sheet.search (`Pattern (Some pattern)) t with - | Some t' -> normal_mode @@ redraw t' screen - | None -> normal_mode (t, screen) - end - - | Actions.Button1_clicked coord -> - begin match Screen.get_cell screen coord with - | None -> normal_mode (t, screen) - | Some (x,y) -> begin match Sheet.move (Actions.Absolute (x,y)) t with - | Some t' -> normal_mode @@ redraw t' screen - | None -> normal_mode (t, screen) - end - end - - | Actions.Button1_released coord -> - begin match Screen.get_cell screen coord with - | Some (x,y) when (x,y) <> (Selection.extract t.Sheet.selected) -> - Screen.status screen @@ u"-- Selection -- "; - let t' = { t with - Sheet.selected = Selection.extends (Actions.Absolute (x,y)) t.Sheet.selected - } in - let screen' = Screen.draw t' screen in - selection_mode (t', screen') - | _ -> normal_mode (t, screen) - end - - | Actions.Command -> - begin match Screen.editor ~prefix:(u":") screen with - | None -> - normal_mode (t, screen) - | Some content -> - let args = try - UTF8.to_utf8string content - |> Tools.String.split ~by:' ' - with Not_found -> - (UTF8.to_utf8string content, "") in - command (t, screen) args - end - - | _ -> normal_mode (t, screen) - -end - -and selection_mode (t, screen) = begin - match (parser screen) with - | exception x -> selection_mode (t, screen) - - | Actions.Resize -> selection_mode (t, Screen.resize t screen) - - | Actions.Delete -> - let yank_before_delete = fun x -> Sheet.delete (fst (Sheet.yank x)) in - normal_mode @@ action yank_before_delete "Deleted %d cells" (t, screen) - - | Actions.Yank -> - normal_mode @@ action Sheet.yank "Yanked %d cells" (t, screen) - - | Actions.Escape -> - let t' = { t with Sheet.selected = Selection.create (Selection.extract t.Sheet.selected) } in - let screen' = Screen.draw t' screen - |> Screen.draw_input t' in - Screen.status screen UTF8.empty; - normal_mode (t', screen') - - | Actions.Move m -> - let t' = { t with Sheet.selected = Selection.extends m t.Sheet.selected } in - let screen' = Screen.draw t' screen in - selection_mode (t', screen') - - | Actions.Button1_clicked coord -> - begin match Screen.get_cell screen coord with - | None -> normal_mode (t, screen) - | Some (x,y) -> begin match Sheet.move (Actions.Absolute (x,y)) t with - | Some t' -> - Screen.status screen UTF8.empty; - normal_mode @@ redraw t' screen - | None -> normal_mode (t, screen) - end - end - - | _ -> selection_mode (t, screen) -end - -and command (t, screen) action = begin - match action with - | ("w", file) -> (* Save the file *) - Odf.save t.Sheet.data file; - normal_mode @@ redraw t screen - | ("repr", file) -> (* Save the file *) - let out_gv = open_out_bin file in - let form = Format.formatter_of_out_channel out_gv in - Evaluator.repr form (Evaluator.get_catalog ()); - close_out out_gv; - normal_mode @@ redraw t screen - | ("enew", _) -> (* Start a new spreadsheet *) - normal_mode @@ redraw (Sheet.create Sheet.Raw.empty) screen - | ("q", _) -> (* Quit *) - t - | _ -> normal_mode @@ redraw t screen -end - -let () = begin - - let sheet = - if Array.length Sys.argv = 1 then - Sheet.Raw.empty - else - Odf.load Sys.argv.(1) in - - Screen.run (fun window -> - ignore @@ normal_mode @@ redraw (Sheet.create sheet) window) -end diff --git a/odf/odf.ml b/odf/odf.ml deleted file mode 100755 index ae120d9..0000000 --- a/odf/odf.ml +++ /dev/null @@ -1,346 +0,0 @@ -module Xml = Ezxmlm -module T = Tools -module NS = Odf_ns - -let u = UTF8.from_utf8string - -type t - -(** Map for storing all the attributes *) -module AttributesMap = Map.Make (struct - type t = string * string - let compare = Pervasives.compare -end) - -let get_attr map key = begin - try Some (AttributesMap.find key map) with - Not_found -> None -end - -let load_formula formula = - let lineBuffer = Lexing.from_string formula in - try - Expression.Formula ( - Expression.Expression ( - Odf_ExpressionParser.value Odf_ExpressionLexer.read lineBuffer)) - with e -> - print_endline formula; - raise e - - -let load_content content = begin function - | "float" -> Expression.Basic ( - ScTypes.number ( - DataType.Num.of_float (float_of_string content) - )) - | "date" -> Expression.Basic ( - ScTypes.date ( - DataType.Num.of_float (float_of_string content) - )) - | _ -> Expression.Basic ( - ScTypes.string ( - UTF8.from_utf8string content)) -end - -(** Load the content from a cell *) -let load_cell sheet cell_num row_num changed (attrs, cell) = begin - - (* Load all the attributes from the xml element *) - let add_attr map (key, value) = AttributesMap.add key value map in - let attributes = List.fold_left add_attr AttributesMap.empty attrs in - - (* Check if the content is repeated *) - let repetition = match get_attr attributes NS.number_columns_repeat_attr with - | None -> 1 - | Some x -> int_of_string x - - (* cell width *) - and cell_width = match get_attr attributes NS.number_columns_spanned_attr with - | None -> 1 - | Some x -> int_of_string x in - - let vtype = - try List.assoc NS.ovalue_type_attr attrs - with Not_found -> "" in - - let formula = get_attr attributes NS.formula_attr - and value = get_attr attributes NS.value_attr in - - let expression, update = begin match formula, value with - | Some x, _ -> load_formula x, true - | _, Some x -> - (load_content x vtype) , true - | _ -> - begin try - Xml.member "p" cell - |> Xml.data_to_string - |> fun x -> (load_content x vtype, true) - with Xml.Tag_not_found _ -> Expression.Undefined, false - end - end in - - if update then ( - for i = 1 to repetition do - cell_num := !cell_num + cell_width; - sheet := snd @@ Sheet.Raw.add (!cell_num, !row_num) (Expression.load_expr expression) !sheet - done - ) else ( - cell_num := !cell_num + (repetition * cell_width ) - ); - changed || update -end - -let load_row sheet row_num (attrs, row) = begin - - let repetition = - try int_of_string @@ List.assoc (NS.table, "number-rows-repeated") attrs - with Not_found -> 1 in - - let cells = Xml.members_with_attr "table-cell" row in - - try - for i = 1 to repetition do - incr row_num; - let cell_num = ref 0 in - if not (List.fold_left (load_cell sheet cell_num row_num) false cells) then - (* No changes on the whole row. Do not repeat, and break the loop *) - raise Not_found - done - with Not_found -> row_num := !row_num + repetition - 1 -end - -let load_xml input = begin - - let sheet = ref Sheet.Raw.empty in - let row_num = ref 0 in - - let xml = - Xmlm.make_input ~enc:(Some `UTF_8) (`Channel input) - |> Xml.from_input - |> snd in - let rows = Xml.member "document-content" (xml::[]) - |> Xml.member "body" - |> Xml.member "spreadsheet" - |> Xml.member "table" - |> Xml.members_with_attr "table-row" in - List.iter (fun x -> (load_row sheet row_num) x) rows; - !sheet -end - - -let load file = - let tmp_file = Filename.temp_file "content" ".xml" in - Unix.unlink tmp_file; - - let zip = Zip.open_in file in - let content = Zip.find_entry zip "content.xml" in - Zip.copy_entry_to_file zip content tmp_file; - - let input = open_in_bin tmp_file in - Tools.try_finally - (fun () -> load_xml input) - (fun () -> - close_in input; - Unix.unlink tmp_file; - Zip.close_in zip - ) - - -let write_type ovalue_type cvalue_type attrs output value = begin - let attrs = - (NS.ovalue_type_attr, ovalue_type):: - (NS.cvalue_type_attr, cvalue_type):: - attrs in - - Xmlm.output output (`El_start (NS.table_cell_node, attrs)); - Xmlm.output output (`El_start (NS.text_node, [])); - Xmlm.output output (`Data value); - Xmlm.output output `El_end; - Xmlm.output output `El_end; -end - -(* Writers for differents types *) -let write_num = write_type "float" "float" -let write_str = write_type "string" "string" -let write_bool = write_type "bool" "bool" -let write_error = write_type "string" "error" -let write_date = write_type "date" "date" - -let write_basic: type a. 'b list -> Xmlm.output -> a ScTypes.types -> unit = fun attrs output types -> begin match types with - | ScTypes.Str s -> write_str attrs output (UTF8.to_utf8string s) - | ScTypes.Bool b -> write_bool attrs output (string_of_bool b) - | ScTypes.Num (data_type, d) -> - begin match ScTypes.get_numeric_type data_type with - | ScTypes.Number -> - let f = DataType.Num.to_float d in - let value = string_of_float f in - write_num ((NS.value_attr, value)::attrs) output value - | ScTypes.Date -> - let value = DataType.Date.to_string d in - write_date ((NS.date_value_attr, value)::attrs) output value - end -end - -let write_formula output attrs f = begin function - | ScTypes.Result x -> write_basic attrs output x - | ScTypes.Error exn -> write_str attrs output "#NAME?" -end - -let print_ref buffer c = - UTF8.Buffer.add_string buffer @@ u"[."; - begin match c with - | ScTypes.Cell c -> UTF8.Buffer.add_string buffer @@ Cell.to_string c; - | ScTypes.Range (c1, c2) -> - UTF8.Buffer.add_string buffer @@ Cell.to_string c1; - UTF8.Buffer.add_string buffer @@ u":."; - UTF8.Buffer.add_string buffer @@ Cell.to_string c2; - end; - UTF8.Buffer.add_string buffer @@ u"]" - -let rec print_expr : UTF8.Buffer.buffer -> ScTypes.expression -> unit = fun buffer -> begin function - | ScTypes.Value (ScTypes.Str s) -> - UTF8.Printf.bprintf buffer "\"%s\"" (UTF8.to_utf8string s) - | ScTypes.Value (ScTypes.Bool b) -> - u(string_of_bool b) - |> UTF8.Buffer.add_string buffer - | ScTypes.Value (ScTypes.Num (data_type, d)) -> - begin match ScTypes.get_numeric_type data_type with - | ScTypes.Number -> - let f = DataType.Num.to_float d in - UTF8.Buffer.add_string buffer @@ u(string_of_float f) - | ScTypes.Date -> - DataType.Date.to_string d - |> u - |> UTF8.Buffer.add_string buffer - end - | ScTypes.Ref r -> print_ref buffer r - | ScTypes.Expression x -> - UTF8.Buffer.add_char buffer '('; - print_expr buffer x; - UTF8.Buffer.add_char buffer ')'; - | ScTypes.Call (ident, params) -> - begin match (UTF8.to_utf8string ident) with - | "+" | "*" | "-" | "/" | "^" | "=" - | "<>" | "<=" | ">=" | "<" | ">" -> begin match params with - | v1::[] -> - UTF8.Printf.bprintf buffer "%s%a" - (UTF8.to_utf8string ident) - print_expr v1 - | v1::v2::[] -> - UTF8.Printf.bprintf buffer "%a%s%a" - print_expr v1 - (UTF8.to_utf8string ident) - print_expr v2 - | _ -> - UTF8.Buffer.add_string buffer ident; - Tools.List.printb ~sep:(u";") print_expr buffer params - end - | _ -> - UTF8.Buffer.add_string buffer ident; - Tools.List.printb ~sep:(u";") print_expr buffer params - end -end - -let write_cell output value = begin function - | Expression.Undefined -> () - | Expression.Basic b -> write_basic [] output b - | Expression.Formula (Expression.Expression f) -> - let buffer = UTF8.Buffer.create 10 in - print_expr buffer f; - let formula = UTF8.Buffer.contents buffer - |> UTF8.to_utf8string in - write_formula output [(NS.formula_attr, ("of:=" ^formula))] f value - | Expression.Formula (Expression.Error (i, s)) -> - write_error [(NS.formula_attr, ("of:" ^ (UTF8.to_utf8string s)))] output (UTF8.to_utf8string s) -end - -(** Jump to the wanted position *) -let goto output (from_x, from_y) (to_x, to_y) :unit = begin - - (** Insert as many rows than required *) - let insert_rows count = begin - (* Close the previous openend rows *) - Xmlm.output output `El_end; - - if (count > 1) then ( - Xmlm.output output ( - `El_start ( - NS.table_row_node, [(NS.table_row_repeat_attr, string_of_int (count-1))])); - Xmlm.output output (`El_start (NS.table_cell_node, [])); - Xmlm.output output `El_end; - Xmlm.output output `El_end; - ); - Xmlm.output output (`El_start (NS.table_row_node, [])); - 1 - end - - (** Insert as many cells as required *) - and insert_cells count = begin - Xmlm.output output ( - `El_start ( - NS.table_cell_node, [(NS.number_columns_repeat_attr, string_of_int count)])); - Xmlm.output output `El_end; - end in - - (* Insert empty rows or columns until the desired position *) - let jump_row = to_y - from_y in - let from_x' = - if jump_row > 0 then - insert_rows jump_row - else - from_x in - let jump_cell = to_x - from_x' in - if jump_cell > 0 then - insert_cells jump_cell -end - -(** Write the cell content and return the updated position *) -let f output cursor position (expr, value) = begin - - goto output cursor position; - - (* Write the value *) - write_cell output value expr; - - (* Return the update position *) - Tools.Tuple2.map1 ((+) 1) position -end - -let save sheet file = begin - let tmp_file = Filename.temp_file "content" ".xml" in - Unix.unlink tmp_file; - let out_channel = open_out_bin tmp_file in - let zip = Zip.open_out file in - - let manifest = "\ -\ -\ - -" in - - Tools.try_finally (fun () -> - - let output = Xmlm.make_output (`Channel out_channel) in - Xmlm.output output (`Dtd None); - Xmlm.output output (`El_start (NS.document_content_node, NS.name_spaces())); - Xmlm.output output (`El_start (NS.body_node, [])); - Xmlm.output output (`El_start (NS.spreadsheet_node, [])); - Xmlm.output output (`El_start (NS.table_node, [])); - - Xmlm.output output (`El_start (NS.table_row_node, [])); - ignore (Sheet.Raw.fold (f output) (1,1) sheet); - Xmlm.output output `El_end; - - Xmlm.output output `El_end; - Xmlm.output output `El_end; - Xmlm.output output `El_end; - Xmlm.output output `El_end; - - close_out out_channel; - Zip.copy_file_to_entry tmp_file zip "content.xml"; - Zip.add_entry manifest zip "META-INF/manifest.xml" - ) (fun () -> - Zip.close_out zip; - Unix.unlink tmp_file - ) -end diff --git a/odf/odf_ExpressionLexer.mll b/odf/odf_ExpressionLexer.mll deleted file mode 100755 index 7f6a55b..0000000 --- a/odf/odf_ExpressionLexer.mll +++ /dev/null @@ -1,93 +0,0 @@ -{ - open Odf_ExpressionParser - open Lexing - - exception SyntaxError of string -} - -let digit = ['0'-'9'] -let real = digit+ | digit* '.' digit+ | digit+ '.' digit* - - -let newline = "\r\n" | '\n' | '\r' -let space = ['\t' ' '] | newline - -let letters = ['A'-'Z' 'a'-'z'] - -(* Function identifier. - Valid identifiers are : - ORG.OPENOFFICE.DAYSINMONTH - it cannot end with a digit. - *) -let identifier = letters (letters | digit | ['-' '_' '.'])* letters+ - -let cell = letters+ digit+ - -rule read = parse - | space+ { read lexbuf } - - | digit+ as _1 { NUM _1} - | real as _1 { REAL (Tools.String.filter_float _1)} - | '$' { DOLLAR } - - | '=' { EQ } - | "<>" { NEQ } - | '<' { LT } - | "<=" { LE } - | '>' { GT } - | ">=" { GE } - | '*' { TIMES } - | '+' { PLUS } - | '-' { MINUS } - | '/' { DIVIDE } - | '"' { read_string (Buffer.create 16) lexbuf } - | ';' { SEMICOLON } - | ':' { COLON } - | '[' { L_SQ_BRACKET } - | ']' { R_SQ_BRACKET } - | '(' { LPAREN } - | ')' { RPAREN } - | '^' { POW } - | '.' { DOT } - - | letters+ as _1 { LETTERS _1} - | identifier as _1 { IDENT _1} - - | '\000' { EOF } - | eof { EOF } - -and read_string buf = parse - | '"' { STR (Buffer.contents buf) } - | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } - | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } - | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } - | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } - | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } - | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } - | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } - | '\\' '"' { Buffer.add_char buf '"'; read_string buf lexbuf } - | [^ '"' '\\' '\000']+ - { Buffer.add_string buf (Lexing.lexeme lexbuf); - read_string buf lexbuf - } - | '\000' { STR (Buffer.contents buf) } - | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } - | eof { STR ( Buffer.contents buf) } - -and quoteless_string buf = parse - | '\\' '/' { Buffer.add_char buf '/'; quoteless_string buf lexbuf } - | '\\' '\\' { Buffer.add_char buf '\\'; quoteless_string buf lexbuf } - | '\\' 'b' { Buffer.add_char buf '\b'; quoteless_string buf lexbuf } - | '\\' 'f' { Buffer.add_char buf '\012'; quoteless_string buf lexbuf } - | '\\' 'n' { Buffer.add_char buf '\n'; quoteless_string buf lexbuf } - | '\\' 'r' { Buffer.add_char buf '\r'; quoteless_string buf lexbuf } - | '\\' 't' { Buffer.add_char buf '\t'; quoteless_string buf lexbuf } - | '\\' '"' { Buffer.add_char buf '"'; quoteless_string buf lexbuf } - | [^ '\\' '\000']+ - { Buffer.add_string buf (Lexing.lexeme lexbuf); - quoteless_string buf lexbuf - } - | '\000' { STR (Buffer.contents buf) } - | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } - | eof { STR (Buffer.contents buf) } - diff --git a/odf/odf_ExpressionParser.mly b/odf/odf_ExpressionParser.mly deleted file mode 100755 index 6b571a9..0000000 --- a/odf/odf_ExpressionParser.mly +++ /dev/null @@ -1,95 +0,0 @@ -%{ - open ScTypes - module F = Functions - - let u = UTF8.from_utf8string - - let extractColumnNameFromNum (fixed, str) = (fixed, int_of_string str) - -%} - -%token REAL -%token NUM -%token STR - -%token LETTERS -%token IDENT - -%token DOLLAR -%token DOT - -%token LPAREN RPAREN -%token L_SQ_BRACKET R_SQ_BRACKET -%token PLUS -%token TIMES -%token DIVIDE -%token MINUS -%token EQ NEQ -%token LT LE GT GE -%token EOF -%token COLON SEMICOLON -%token POW - -%nonassoc EQ NEQ LT LE GT GE -%left PLUS MINUS -%left TIMES DIVIDE -%left POW - -%start value - -%% - -value: - | LETTERS COLON EQ expr EOF {$4} - -expr: - | num {Value (number ($1))} - | MINUS expr {Call (F.sub, [$2])} - | PLUS expr {Call (F.add, [$2])} - - - | L_SQ_BRACKET ref R_SQ_BRACKET {$2} - - | LPAREN expr RPAREN {Expression $2} - | STR {Value (string (u $1))} - - (* Mathematical operators *) - | expr MINUS expr {Call (F.sub, [$1; $3])} - | expr DIVIDE expr {Call (F.div, [$1; $3])} - | expr TIMES expr {Call (F.mul, [$1; $3])} - | expr PLUS expr {Call (F.add, [$1; $3])} - | expr POW expr {Call (F.pow, [$1; $3])} - - (* Comparaison *) - | expr EQ expr {Call (F.eq, [$1; $3])} - | expr NEQ expr {Call (F.neq, [$1; $3])} - | expr LT expr {Call (F.lt, [$1; $3])} - | expr GT expr {Call (F.gt, [$1; $3])} - | expr LE expr {Call (F.le, [$1; $3])} - | expr GE expr {Call (F.ge, [$1; $3])} - - | ident LPAREN separated_list(SEMICOLON, expr) RPAREN { Call (u $1, $3) } - - -ref: - | cell {Ref (Cell $1)} - | cell COLON cell {Ref (Range ($1, $3))} - -cell: - | DOT fixed(LETTERS) fixed(NUM){Cell.from_string $2 (extractColumnNameFromNum $3)} - -fixed(X): - | DOLLAR X {true, $2} - | X {false, $1} - -num: - | REAL {DataType.Num.of_float @@ float_of_string $1} - | NUM {DataType.Num.of_int @@ int_of_string $1} - -ident: - | IDENT { $1 } - | text+ { String.concat "" $1 } - -text: - | LETTERS { $1 } - | NUM { $1 } diff --git a/odf/odf_ns.ml b/odf/odf_ns.ml deleted file mode 100755 index 5a501da..0000000 --- a/odf/odf_ns.ml +++ /dev/null @@ -1,96 +0,0 @@ -let ooo = "http://openoffice.org/2004/office" -let ooow = "http://openoffice.org/2004/writer" -let oooc = "http://openoffice.org/2004/calc" -let rpt = "http://openoffice.org/2005/report" -let tableooo = "http://openoffice.org/2009/table" -let drawooo = "http://openoffice.org/2010/draw" - -let dc = "http://purl.org/dc/elements/1.1/" - -let xhtml = "http://www.w3.org/1999/xhtml" -let grddl = "http://www.w3.org/2003/g/data-view#" -let css3t = "http://www.w3.org/TR/css3-text/" -let xlink = "http://www.w3.org/1999/xlink" -let dom = "http://www.w3.org/2001/xml-events" -let xforms = "http://www.w3.org/2002/xforms" -let xsd = "http://www.w3.org/2001/XMLSchema" -let xsi = "http://www.w3.org/2001/XMLSchema-instance" -let math = "http://www.w3.org/1998/Math/MathML" - -let office = "urn:oasis:names:tc:opendocument:xmlns:office:1.0" -let style = "urn:oasis:names:tc:opendocument:xmlns:style:1.0" -let text = "urn:oasis:names:tc:opendocument:xmlns:text:1.0" -let table = "urn:oasis:names:tc:opendocument:xmlns:table:1.0" -let draw = "urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" -let fo = "urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" -let meta = "urn:oasis:names:tc:opendocument:xmlns:meta:1.0" -let number = "urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" -let presentation= "urn:oasis:names:tc:opendocument:xmlns:presentation:1.0" -let svg = "urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" -let chart = "urn:oasis:names:tc:opendocument:xmlns:chart:1.0" -let dr3d = "urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" -let form = "urn:oasis:names:tc:opendocument:xmlns:form:1.0" -let script = "urn:oasis:names:tc:opendocument:xmlns:script:1.0" -let oof = "urn:oasis:names:tc:opendocument:xmlns:of:1.2" - -let calcext = "urn:org:documentfoundation:names:experimental:calc:xmlns:calcext:1.0" -let loext = "urn:org:documentfoundation:names:experimental:office:xmlns:loext:1.0" - -let field = "urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0" -let formx = "urn:openoffice:names:experimental:ooxml-odf-interop:xmlns:form:1.0" - -let document_content_node = (office, "document-content") -let body_node = (office, "body") -let spreadsheet_node = (office, "spreadsheet") -let table_node = (table, "table") -let table_row_node = (table, "table-row") - let table_row_repeat_attr = (table, "number-rows-repeated") - -let table_cell_node = (table, "table-cell") - let number_columns_repeat_attr = (table, "number-columns-repeated") - let cvalue_type_attr = (calcext, "value-type") - let ovalue_type_attr = (office, "value-type") - let value_attr = (office, "value") - let formula_attr = (table, "formula") - let date_value_attr = (office, "date-value") - let number_columns_spanned_attr = (table, "number-columns-spanned") - -let text_node = (text, "p") - -let name_spaces () = [ - (Xmlm.ns_xmlns, "office"), office; - (Xmlm.ns_xmlns, "style"), style; - (Xmlm.ns_xmlns, "text"), text; - (Xmlm.ns_xmlns, "table"), table; - (Xmlm.ns_xmlns, "draw"), draw; - (Xmlm.ns_xmlns, "fo"), fo; - (Xmlm.ns_xmlns, "xlink"), xlink; - (Xmlm.ns_xmlns, "dc"), dc; - (Xmlm.ns_xmlns, "meta"), meta; - (Xmlm.ns_xmlns, "number"), number; - (Xmlm.ns_xmlns, "presentation"),presentation; - (Xmlm.ns_xmlns, "svg"), svg; - (Xmlm.ns_xmlns, "chart"), chart; - (Xmlm.ns_xmlns, "dr3d"), dr3d; - (Xmlm.ns_xmlns, "math"), math; - (Xmlm.ns_xmlns, "form"), form; - (Xmlm.ns_xmlns, "script"), script; - (Xmlm.ns_xmlns, "ooo"), ooo; - (Xmlm.ns_xmlns, "ooow"), ooow; - (Xmlm.ns_xmlns, "oooc"), oooc; - (Xmlm.ns_xmlns, "dom"), dom; - (Xmlm.ns_xmlns, "xforms"), xforms; - (Xmlm.ns_xmlns, "xsd"), xsd; - (Xmlm.ns_xmlns, "xsi"), xsi; - (Xmlm.ns_xmlns, "rpt"), rpt; - (Xmlm.ns_xmlns, "of"), oof; - (Xmlm.ns_xmlns, "xhtml"), xhtml; - (Xmlm.ns_xmlns, "grddl"), grddl; - (Xmlm.ns_xmlns, "tableooo"), tableooo; - (Xmlm.ns_xmlns, "drawooo"), drawooo; - (Xmlm.ns_xmlns, "calcext"), calcext; - (Xmlm.ns_xmlns, "loext"), loext; - (Xmlm.ns_xmlns, "field"), field; - (Xmlm.ns_xmlns, "formx"), formx; - (Xmlm.ns_xmlns, "css3t"), css3t; -] diff --git a/scTypes.ml b/scTypes.ml deleted file mode 100755 index 48e4d3c..0000000 --- a/scTypes.ml +++ /dev/null @@ -1,354 +0,0 @@ -(** All the types used in the spreadsheet. *) - -let u = UTF8.from_utf8string - -exception Error - -type cell = Cell.t - -type ident = UTF8.t - -type _ dataFormat = - | Date: DataType.Num.t dataFormat (* Date *) - | Number: DataType.Num.t dataFormat (* Number *) - | String: DataType.String.t dataFormat(* String *) - | Bool: DataType.Bool.t dataFormat (* Boolean *) - -type numericType = - | Date - | Number - -let get_numeric_type: DataType.Num.t dataFormat -> numericType = function - | Date -> Date - | Number -> Number - -type 'a types = - | Num : DataType.Num.t dataFormat * DataType.Num.t -> DataType.Num.t types (** A number *) - | Str : DataType.String.t -> DataType.String.t types (** A string *) - | Bool : DataType.Bool.t -> DataType.Bool.t types (** A boolean *) - -let number n = Num (Number, n) -let string s = Str s -let date d = Num (Date, d) -let boolean b = Bool b - - -type 'a returnType = - | Num : DataType.Num.t dataFormat option -> DataType.Num.t returnType (** A number *) - | Str : DataType.String.t returnType (** A string *) - | Bool : DataType.Bool.t returnType (** A boolean *) - - -let f_num: DataType.Num.t returnType = Num None -let f_date: DataType.Num.t returnType = Num (Some Date) -let f_number: DataType.Num.t returnType = Num (Some Number) -let f_string: DataType.String.t returnType = Str -let f_bool: DataType.Bool.t returnType = Bool - -type refs = - | Cell of cell (** A cell *) - | Range of cell * cell (** An area of cells *) - -type expression = - | Value : 'a types -> expression (** A direct value *) - | Ref : refs -> expression (** A reference to another cell *) - | Call : ident * expression list -> expression (** A call to a function *) - | Expression : expression -> expression (** An expression *) - -(** Result from a computation *) -type result = - | Result : 'a types -> result - | Error : exn -> result - -module DataFormat = struct - - type formats = F : 'a dataFormat -> formats [@@unboxed] - - let priority: type a. a dataFormat -> int = function - | Date -> 1 - | Number -> 0 - | String -> 0 - | Bool -> 0 - - let collect_format: DataType.Num.t dataFormat -> formats -> DataType.Num.t dataFormat = begin - fun dataFormat -> function - | F Date -> Date - | _ -> dataFormat - end - - let guess_format_result: type a. a returnType -> (unit -> formats list) -> a dataFormat = - fun return params -> begin match return with - | Str -> String - | Bool -> Bool - | Num (Some x) -> x - | Num None -> List.fold_left collect_format Number (params ()) - end - - let default_value_for: type a. a dataFormat -> a = function - | Date -> DataType.Num.zero - | Number -> DataType.Num.zero - | Bool -> false - | String -> UTF8.empty - - type ('a, 'b) equality = Eq : ('a, 'a) equality - - let compare_format: type a b. a dataFormat -> b dataFormat -> (a, b) equality = - fun a b -> begin match a, b with - | Date, Date -> Eq - | String, String -> Eq - | Number, Number -> Eq - | Date, Number -> Eq - | Number, Date -> Eq - | Bool, Bool -> Eq - | _, _ -> raise Errors.TypeError - end - -end - -module Type = struct - - let (=) : type a b. a types -> b types -> bool = fun t1 t2 -> - match t1, t2 with - | Num (_, n1), Num (_, n2) -> DataType.Num.eq n1 n2 - | Bool b1, Bool b2 -> b1 = b2 - | Str s1, Str s2 -> s1 = s2 - | _, _ -> false - - (** Show a list of elements - *) - let rec show_list printer buffer = begin function - | [] -> () - | hd::[] -> - UTF8.Printf.bprintf buffer "%a" - printer hd - | hd::tl -> - UTF8.Printf.bprintf buffer "%a, " - printer hd; - show_list printer buffer tl - end - - let show: type a. UTF8.Buffer.buffer -> a types -> unit = fun buffer -> begin function - | Str x -> UTF8.Buffer.add_string buffer x - | Bool b -> UTF8.Printf.bprintf buffer "%B" b - | Num (Number, n) -> - if DataType.Num.is_integer n then - 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 "%.2f" f; - Format.pp_print_flush to_b () - | Num (Date, n) -> - let y, m, d = DataType.Date.date_from_julian_day n in - UTF8.Printf.bprintf buffer "%d/%d/%d" y m d - end - - let show_full: type a. UTF8.Buffer.buffer -> a types -> unit = fun buffer -> begin function - | Str x -> UTF8.Buffer.add_string buffer x - | Bool b -> UTF8.Printf.bprintf buffer "%B" b - | Num (Number, n) -> - if DataType.Num.is_integer n then - 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 () - | Num (Date, n) -> - let y, m, d = DataType.Date.date_from_julian_day n in - UTF8.Printf.bprintf buffer "%d/%d/%d" y m d - end - - type t = - | Value: 'a dataFormat * 'a -> t - - let get_content : type a. a types -> t = begin function - | Num (format, data) -> Value (format, data) - | Str s -> Value (String, s) - | Bool b -> Value (Bool, b) - end - -end - -module Refs = struct - - type 'a range = - | Single of 'a - | Array1 of 'a list - | Array2 of 'a list list - - let collect = function - | Cell x -> Single (Pervasives.fst x) - | Range (fst, snd) -> - let (x1, y1) = Pervasives.fst fst - and (x2, y2) = Pervasives.fst snd in - let min_x = min x1 x2 - and max_x = max x1 x2 - and min_y = min y1 y2 - and max_y = max y1 y2 in - if (min_x = max_x) || (min_y = max_y) then ( - (* There is only a one dimension array *) - let elms = ref [] in - for x = min_x to max_x do - for y = min_y to max_y do - elms := (x, y)::!elms - done - done; - Array1 (!elms) - ) else ( - (* This a two-dimension array *) - let elmx = ref [] in - for x = min_x to max_x do - let elmy = ref [] in - for y = min_y to max_y do - elmy := (x, y)::!elmy - done; - elmx := !elmy::!elmx - done; - Array2 (!elmx) - ) - - let map f = function - | Single coord -> Single (f coord) - | Array1 values -> Array1 (List.map f values) - | Array2 values -> Array2 (List.map (List.map f) values) - - let shift (vector_x, vector_y) ref = - let _shift ((x, y), (fixed_x, fixed_y)) = - let x' = if fixed_x then x else x + vector_x - and y' = if fixed_y then y else y + vector_y in - (x', y'), (fixed_x, fixed_y) - in match ref with - | Cell x -> Cell (_shift x) - | Range (fst, snd) -> Range (_shift fst, _shift snd) - - let show buffer = begin function - | Cell r -> UTF8.Buffer.add_string buffer @@ Cell.to_string r - | Range (f,t) -> - Tools.Tuple2.printb ~first:"" ~last:"" ~sep:":" Cell.to_buffer Cell.to_buffer buffer (f,t) - end - - type 'a content = - | Value: 'a dataFormat * 'a -> 'a content - | List: 'a dataFormat * 'a list -> 'a list content - | Matrix: 'a dataFormat * 'a list list -> 'a list list content - - type refContent = - | C: 'a content -> refContent [@@unboxed] - - (** Add one element in a typed list. - - The function will raise Error.TypeError if the elements does not match - with the list type. - *) - let add_elem: type a b. a dataFormat * a list -> result option -> a dataFormat * a list = - fun (format, elements) result -> - begin match result with - | None -> format, (DataFormat.default_value_for format)::elements - | Some (Error x) -> raise x - | Some (Result r) -> - let Type.Value (format', element) = Type.get_content r in - let DataFormat.Eq = DataFormat.compare_format format format' in - let new_format = if (DataFormat.priority format) > (DataFormat.priority format') then - format - else - format' in - new_format, element::elements - end - - let get_content = begin function - | Single None -> raise Errors.TypeError - | Single (Some (Error x)) -> raise x - | Single (Some (Result r)) -> - let Type.Value (format, c) = Type.get_content r in C (Value (format, c)) - | Array1 l -> - (* Get the first element in the list in order to get the format *) - let Type.Value (format, _) = - begin match (Tools.List.find_map (fun x -> x) l) with - | Error x -> raise x - | Result r -> Type.get_content r - end in - (* Then build an unified list (if we can) *) - let format, values = List.fold_left add_elem (format, []) l in - C (List(format, List.rev values)) - | Array2 l -> - (* Get the first element in the list *) - let Type.Value (format, _) = - begin match (Tools.List.find_map2 (fun x -> x) l) with - | Error x -> raise x - | Result r -> Type.get_content r - end in - (* Then build an unified list *) - let format, values = List.fold_left (fun (format, result) elems -> - let format, elems = List.fold_left add_elem (format, []) elems in - (format, List.rev (elems::result)) - )(format, []) l in - C (Matrix(format, List.rev values)) - end - -end - -module Result = struct - let (=) t1 t2 = - match t1, t2 with - | Result v1, Result v2 -> Type.(=) v1 v2 - | _, _ -> t1 = t2 - - let show = begin function - | Error x -> - (* - let buffer = Buffer.create 16 in - let b = Format.formatter_of_buffer buffer in - Errors.printf b x; - Format.pp_print_flush b (); - u(Buffer.contents buffer) - *) - u"#Error" - | Result v -> - let buffer = UTF8.Buffer.create 16 in - Type.show buffer v; - UTF8.Buffer.contents buffer - end - -end - -(** Represent an expression. - *) -let rec show_expr buffer : expression -> unit = begin function - | Value (Str x) -> - (** Print the value with quotes *) - UTF8.Printf.bprintf buffer "\"%s\"" (UTF8.to_utf8string x) - | Value v -> Type.show buffer v - | Ref r -> Refs.show buffer r - | Call (ident, params) -> - let utf8ident = UTF8.to_utf8string ident in - begin match utf8ident with - | "+" | "*" | "-" | "/" | "^" | "=" - | "<>" | "<=" | ">=" | "<" | ">" -> begin match params with - | v1::[] -> - UTF8.Printf.bprintf buffer "%s%a" - utf8ident - show_expr v1 - | v1::v2::[] -> - UTF8.Printf.bprintf buffer "%a%s%a" - show_expr v1 - utf8ident - show_expr v2 - | _ -> - UTF8.Buffer.add_string buffer ident; - Tools.List.printb ~sep:(u";") show_expr buffer params - end - | _ -> - UTF8.Buffer.add_string buffer ident; - Tools.List.printb ~sep:(u";") show_expr buffer params - end - | Expression expr -> - UTF8.Printf.bprintf buffer "(%a)" show_expr expr -end - diff --git a/scTypes.mli b/scTypes.mli deleted file mode 100755 index 348f4fe..0000000 --- a/scTypes.mli +++ /dev/null @@ -1,126 +0,0 @@ -(** All the types used in the spreadsheet. *) - -exception Error - -type cell = (int * int) * (bool * bool) - -type ident = UTF8.t - -type 'a dataFormat = - | Date: DataType.Num.t dataFormat (* A date in julian day *) - | Number: DataType.Num.t dataFormat (* Number *) - | String: DataType.String.t dataFormat (* String *) - | Bool: DataType.Bool.t dataFormat (* Boolean *) - -type 'a returnType = - | Num : DataType.Num.t dataFormat option -> DataType.Num.t returnType (** A number *) - | Str : DataType.String.t returnType (** A string *) - | Bool : DataType.Bool.t returnType (** A boolean *) - -type numericType = - | Date - | Number - -val get_numeric_type: DataType.Num.t dataFormat -> numericType - -type 'a types = private - | Num : DataType.Num.t dataFormat * DataType.Num.t -> DataType.Num.t types (** A number *) - | Str : DataType.String.t -> DataType.String.t types (** A string *) - | Bool : DataType.Bool.t -> DataType.Bool.t types (** A boolean *) - -val number: DataType.Num.t -> DataType.Num.t types -val string: DataType.String.t -> DataType.String.t types -val boolean: DataType.Bool.t -> DataType.Bool.t types -val date: DataType.Num.t -> DataType.Num.t types - - -(** Numeric (any format) *) -val f_num: DataType.Num.t returnType - -(** Date *) -val f_date: DataType.Num.t returnType - -(** Number *) -val f_number: DataType.Num.t returnType - -(** Boolean result *) -val f_bool: DataType.Bool.t returnType - -(** String *) -val f_string: DataType.String.t returnType - -type refs = - | Cell of cell (** A cell *) - | Range of cell * cell (** An area of cells *) - -(** This is the cell content *) -type expression = - | Value : 'a types -> expression (** A direct value *) - | Ref : refs -> expression (** A reference to another cell *) - | Call : ident * expression list -> expression (** A call to a function *) - | Expression : expression -> expression (** An expression *) - -(** Result from a computation *) -type result = - | Result : 'a types -> result - | Error : exn -> result - -module DataFormat : sig - - type formats = F : 'a dataFormat -> formats [@@unboxed] - - val guess_format_result: 'a returnType -> (unit -> formats list) -> 'a dataFormat - -end - -module Type : sig - - type t = Value: 'a dataFormat * 'a -> t - - val (=) : 'a types -> 'b types -> bool - - val show: UTF8.Buffer.buffer -> 'a types -> unit - - val show_full: UTF8.Buffer.buffer -> 'a types -> unit - -end - -module Refs : sig - - type 'a range = - | Single of 'a - | Array1 of 'a list - | Array2 of 'a list list - - val collect: refs -> (int * int) range - - val map: ('a -> 'b) -> 'a range -> 'b range - - val shift: (int * int) -> refs -> refs - - type 'a content = - | Value: 'a dataFormat * 'a -> 'a content - | List: 'a dataFormat * 'a list -> 'a list content - | Matrix: 'a dataFormat * 'a list list -> 'a list list content - - type refContent = - | C: 'a content -> refContent [@@unboxed] - - (** extract the content from a range. - - May raise Errors.TypeError if the range cannot be unified. - *) - val get_content : result option range -> refContent - -end - -val show_expr: UTF8.Buffer.buffer -> expression -> unit - -module Result : sig - - val (=) : result -> result -> bool - - val show: result -> UTF8.t - -end - diff --git a/screen.ml b/screen.ml deleted file mode 100755 index c61efea..0000000 --- a/screen.ml +++ /dev/null @@ -1,459 +0,0 @@ -(** Curses submodules *) -module Attrs = Curses.A -module Color = Curses.Color - -module T2 = Tools.Tuple2 - -module Option = Tools.Option - -let cell_size = 10 - -let u = UTF8.from_utf8string - -type t = { - window: Curses.window; (* the main window *) - sheet: Curses.window; (* the spreadsheet *) - input: Curses.window; (* the input window *) - status: Curses.window; (* status bar *) - start: (int * int); (* Left corner *) - left_margin: int; (* Reserved margin for rows name *) - - mutable size: int * int; (* Terminal size *) -} - -let get_cell screen (x, y) = begin - - let x' = (fst screen.start) + (x - screen.left_margin) / cell_size - and y' = (snd screen.start) + y - 3 in - - if (x' < 1 || y' < 1) then - None - else - Some (x', y') -end - -let center data screen height width = begin - let height' = height - 3 - and width' = (width - screen.left_margin) / cell_size in - let end_x = (fst screen.start) + width' -1 in - let end_y = (snd screen.start) + height' -2 in - - let selected = Selection.extract data.Sheet.selected in - - let center_axis f replace max_limit shift screen = begin - let selected_axis = f selected in - match (selected_axis >= f screen.start), (selected_axis > max_limit) with - | true, false -> screen - | _ -> { screen with start = replace (max 1 (selected_axis - shift)) screen.start } - end in - center_axis T2.fst T2.replace1 end_x (width' / 2) screen - |> center_axis T2.snd T2.replace2 end_y (height' / 2) -end - -let status screen msg = begin - let height, width = screen.size in - UTF8.encode msg |> Option.iter (fun encoded -> - let status = Bytes.make (width -1) ' ' in - String.blit encoded 0 status 0 (String.length encoded); - Curses.werase screen.status; - if not ( - Curses.mvwaddstr screen.status 0 0 encoded - && Curses.wrefresh screen.status - ) then - raise (Failure "Status update") - ) -end - -(** Draw the spreadsheet *) -let draw data screen = begin - - let selected = Selection.extract data.Sheet.selected in - - let referenced = - Sheet.Raw.get_expr selected data.Sheet.data - |> Expression.collect_sources - - and sink = Sheet.Raw.get_sink selected data.Sheet.data in - - let height, width = screen.size in - let screen = center data screen height width in - - for y = 1 to (height-2) do - let pos_y = (y + (snd screen.start) - 1) in - if (Curses.has_colors ()) then begin - if Selection.is_selected (Selection.Vertical pos_y) data.Sheet.selected then - Curses.wattrset screen.sheet (Attrs.color_pair 2 ) - else - Curses.wattrset screen.sheet (Attrs.color_pair 1 ) - end; - ignore - @@ Curses.mvwaddstr screen.sheet y 0 - @@ Printf.sprintf "%-*d" screen.left_margin pos_y - done; - Curses.wattrset screen.sheet Attrs.normal; - - for x = 0 to ((width - cell_size - screen.left_margin) / cell_size) do - let pos_x = x + (fst screen.start) in - if (Curses.has_colors ()) then begin - if Selection.is_selected (Selection.Horizontal pos_x) data.Sheet.selected then - Curses.wattrset screen.sheet (Attrs.color_pair 2 ) - else - Curses.wattrset screen.sheet (Attrs.color_pair 1 ) - end; - - ignore - @@ Curses.mvwaddstr screen.sheet 0 (x * cell_size + screen.left_margin) - @@ Printf.sprintf "%-*s" cell_size (UTF8.raw_encode @@ Cell.to_hname pos_x); - - Curses.wattrset screen.sheet Attrs.normal; - - for y = 1 to (height-2) do - - let pos_y = y + (snd screen.start) - 1 in - - if (Curses.has_colors ()) then begin - if Selection.is_selected (Selection.Cell (pos_x, pos_y)) data.Sheet.selected then - Curses.wattrset screen.sheet (Attrs.color_pair 3 ) - else if Cell.Set.mem (pos_x, pos_y) referenced then - Curses.wattrset screen.sheet (Attrs.color_pair 4 ) - else if Cell.Set.mem (pos_x, pos_y) sink then - Curses.wattrset screen.sheet (Attrs.color_pair 5 ) - else - Curses.wattrset screen.sheet Attrs.normal; - end; - - - (* Get the content from the cell *) - let content = Sheet.Raw.get_value (pos_x, pos_y) data.Sheet.data - |> Option.map (fun x -> UTF8.split ~sep:(u"\n") (ScTypes.Result.show x)) - |> Option.default UTF8.empty in - - (* If the content is defined, try to encode it and print it*) - UTF8.encode content |> Tools.Option.iter (fun value -> - let length = UTF8.length content in - let strlength = String.length value in - let blank = cell_size - length in - let padding = if blank > 0 - then String.make blank ' ' - else "" in - ignore - @@ Curses.mvwaddnstr screen.sheet y (x * cell_size + screen.left_margin) - (Printf.sprintf "%s%s" value padding) - 0 (blank + strlength) - ) - done - done; - ignore @@ Curses.wrefresh screen.sheet; - screen - -end - -let init () = begin - (* Do not set delay after ESC keycode *) - begin try ignore @@ Unix.getenv "ESCDELAY" with - | Not_found -> Unix.putenv "ESCDELAY" "25" end; - - let window = Curses.initscr () in - let height, width = Curses.getmaxyx window in - - Tools.NCurses.set_mouse_event (Tools.NCurses.BUTTON1_CLICKED::[]); - - let init = Curses.keypad window true - && Curses.noecho () - && Curses.start_color () - && Curses.use_default_colors () - - (* Build the color map *) - && Curses.init_pair 1 Color.white Color.blue (* Titles *) - && Curses.init_pair 2 Color.blue Color.white (* Selected titles *) - && Curses.init_pair 3 Color.black Color.white (* Selected cell *) - && Curses.init_pair 4 Color.black Color.red (* referenced cell *) - && Curses.init_pair 5 Color.black Color.green (* sink cell *) - && Curses.curs_set 0 in - - if not init then - raise (Failure "Initialisation") - else - { - window = window; - input = Curses.subwin window 2 width 0 0; - sheet = Curses.subwin window (height - 3) width 2 0; - status = Curses.subwin window 1 width (height - 1) 0; - start = 1, 1; - left_margin = 4; - size = height, width; - } -end - -let close {window} = begin - ignore @@ (Curses.keypad window false && Curses.echo ()); - Curses.endwin() -end - -let draw_input t screen = begin - - let height, width = screen.size in - - let expr = Sheet.Raw.get_expr (Selection.extract t.Sheet.selected) t.Sheet.data - |> Expression.show in - - let result = Sheet.Raw.get_value (Selection.extract t.Sheet.selected) t.Sheet.data - |> Option.map ScTypes.Result.show - |> Option.default UTF8.empty in - - UTF8.encode result |> Option.iter (fun encoded_result -> - (* Compute the difference between number of bytes in the string, and the - number of character printed : Printf.sprintf format use the bytes number - in the string, while Curses print the characters in the user encoding *) - let result_length_delta = (UTF8.length result) - (String.length encoded_result) in - - ignore ( - encoded_result - |> Printf.sprintf "%-*s" (width - 11 - result_length_delta) - |> Curses.mvwaddstr screen.input 0 10 - - && Curses.wrefresh screen.input) - ); - status screen expr; - screen -end - -(** Wait for an event and return the key pressed - If the key code contains more than one char, they are both returned - *) -let read_key {window} = begin - let buff = Buffer.create 2 in - let int_val = Curses.wgetch window in - if int_val > 255 then - Buffer.add_string buff @@ Tools.String.string_of_ints int_val - else - Buffer.add_char buff @@ char_of_int int_val; - (** Check for a second key code *) - ignore @@ Curses.nodelay window true; - begin match Curses.wgetch window with - | -1 -> () - | x -> Buffer.add_char buff @@ char_of_int x; - end; - ignore @@ Curses.nodelay window false; - Buffer.contents buff -end - -let resize data t = begin - let size = Curses.getmaxyx t.window in - if (size <> t.size) then ( - let height, width = size in - t.size <- size; - ignore ( - Curses.wresize t.input 2 width - - && Curses.wresize t.sheet (height - 3) width - - (* The status window *) - && Curses.wresize t.status 1 width - && Curses.mvwin t.status (height - 1) 0); - Curses.wclear t.status; - ignore @@ Curses.wrefresh t.status; - draw data t - ) else t -end - -let editor ?position ?(prefix=UTF8.empty) ?(init=UTF8.empty) t = begin - let encodedPrefix = UTF8.raw_encode prefix - and encodedInit = UTF8.raw_encode init in - let with_refs, position = match position with - | None -> false, (1, 1) - | Some x -> true, x in - Curses.werase t.status; - ignore @@ Curses.mvwaddstr t.status 0 0 (encodedPrefix^encodedInit); - ignore @@ Curses.wrefresh t.status; - - (** Rewrite all the text after the cursor *) - let rewrite_after = begin function - | [] -> () - | elems -> ( (* Rewrite each char after the cursor *) - let y, x = Curses.getyx t.status in - List.iter (fun x -> ignore @@ Curses.waddstr t.status (UTF8.raw_encode x)) elems; - ignore @@ Curses.wmove t.status y x ) - end - - (** Delete the previous text (or block of text) *) - and delete_previous hd = begin - let y, x = Curses.getyx t.status in - let length = UTF8.length hd in - ignore @@ Curses.wmove t.status y (x - length); - for position = 1 to length do - ignore @@ Curses.wdelch t.status - done; - end in - - (* Text edition, handle the keycode. - - [before] contains all the caracters inserted before the cursor (reverse - ordered), and [after] contains all the caracters after the cursor. - *) - let rec _edit before after = begin function - | "\027" -> (* Escape, cancel the modifications *) - None - | "\010" -> (* Enter, validate the input *) - - (* We concatenate all the characters. This can create an invalid string in - * the current locale (if there are copy/paste, or other events). - *) - Some (UTF8.implode @@ (UTF8.rev_implode before)::after) - - | "\001\004" -> (* Left *) - begin match before with - | [] -> _edit before after @@ read_key t - | hd::tl -> - let y, x = Curses.getyx t.status - and length = UTF8.length hd in - ignore @@ Curses.wmove t.status y (x - length); - ignore @@ Curses.wrefresh t.status; - _edit tl (hd::after) @@ read_key t - end - - | "\001\005" -> (* Right *) - begin match after with - | [] -> _edit before after @@ read_key t - | hd::tl -> - let y, x = Curses.getyx t.status - and length = UTF8.length hd in - ignore @@ Curses.wmove t.status y (x + length); - ignore @@ Curses.wrefresh t.status; - _edit (hd::before) tl @@ read_key t - end - - | "\001\007" -> (* Backspace *) - begin match before with - | [] -> _edit before after @@ read_key t - | hd::tl -> - delete_previous hd; - ignore @@ Curses.wrefresh t.status; - _edit tl after @@ read_key t - end - - | "\001\006" -> (* Home *) - begin match before with - | [] -> _edit before after @@ read_key t - | elems -> - let to_left (size, after) elem = begin - let size' = size + UTF8.length elem in - size', elem::after - end in - let chars, after' = List.fold_left to_left (0, after) elems in - let y, x = Curses.getyx t.status in - ignore @@ Curses.wmove t.status y (x - chars); - ignore @@ Curses.wrefresh t.status; - _edit [] after' @@ read_key t - end - - | "\001\104" -> (* End *) - begin match after with - | [] -> _edit before after @@ read_key t - | elems -> - let to_rigth (size, before) elem = begin - let size' = size + UTF8.length elem in - size', elem::before - end in - let chars, before' = List.fold_left to_rigth (0, before) elems in - let y, x = Curses.getyx t.status in - ignore @@ Curses.wmove t.status y (x + chars); - ignore @@ Curses.wrefresh t.status; - _edit before' [] @@ read_key t - end - | "\001\074" - | "\127" -> (* Del *) - begin match after with - | [] -> _edit before after @@ read_key t - | hd::tl -> - let y, x = Curses.getyx t.status in - ignore @@ Curses.wmove t.status y (x + 1); - delete_previous hd; - ignore @@ Curses.wrefresh t.status; - _edit before tl @@ read_key t - end - - | ("\001\002" as key) (* Down *) - | ("\001\003" as key) (* Up *) - | ("\001\153" as key) -> (* click *) - if with_refs then - select_content position (UTF8.empty) before after key - else - _edit before after @@ read_key t - - | any -> - ignore @@ Curses.waddstr t.status any; - rewrite_after after; - ignore @@ Curses.wrefresh t.status; - _edit (UTF8.decode any::before) after @@ read_key t - end - - (* Selection mode, Left and Right keys allow to select a cell, and not to - move inside the edition *) - and select_content (x, y) name before after = begin - function - | "\001\002" -> (* Down *) insert_cell_name (x, y + 1) name before after - | "\001\005" -> (* Right *) insert_cell_name (x + 1, y) name before after - - | "\001\003" -> (* Up *) - if y > 1 then - insert_cell_name (x, y - 1) name before after - else select_content (x, y) name before after @@ read_key t - - | "\001\004" -> (* Left *) - if x > 1 then - insert_cell_name (x - 1, y) name before after - else select_content (x, y) name before after @@ read_key t - - | "\001\153" -> (* click *) - let position = - begin match Tools.NCurses.get_mouse_event () with - | None -> None - | Some (id, ev, (x, y, z)) -> - if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_CLICKED ev - || Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_PRESSED ev then - get_cell t (x,y) - else - None - end in - begin match position with - | None -> select_content (x, y) name before after @@ read_key t - | Some (x, y) -> insert_cell_name (x, y) name before after - end - - | key -> - _edit (UTF8.fold List.cons name before) after key - end - - and insert_cell_name position name before after = begin - let cell_name = Cell.to_string @@ (position, (false, false)) in - ignore @@ delete_previous name; - ignore @@ Curses.waddstr t.status (UTF8.raw_encode cell_name); - rewrite_after after; - ignore @@ Curses.wrefresh t.status; - select_content position cell_name before after @@ read_key t - end - in - - Tools.try_finally - (fun () -> - ignore @@ Curses.curs_set 1; - try _edit (UTF8.rev_explode init) [] @@ read_key t - with _ -> None) - (fun () -> ignore @@ Curses.curs_set 0) - -end - -let search screen = begin - let result = editor ~prefix:(u"/") screen in - begin match result with - | Some content -> content - | None -> UTF8.empty - end -end - -let run f = - let window = init () in - Tools.try_finally - (fun () -> f window) - (fun () -> ignore @@ close window ) diff --git a/screen.mli b/screen.mli deleted file mode 100755 index b5f74b2..0000000 --- a/screen.mli +++ /dev/null @@ -1,29 +0,0 @@ -(** Represent the {!module:Sheet} *) - -type t - -(** Run the screen *) -val run: (t -> 'a) -> 'a - -(** {2 Screen updates} *) - -val draw: Sheet.t -> t -> t - -val draw_input: Sheet.t -> t -> t - -val resize: Sheet.t -> t -> t - -(** Display a message in the status bar. *) -val status: t -> UTF8.t -> unit - -(** {2 User inputs} *) - -(** Wait for a keycode *) -val read_key : t -> string -(** The keycode is always NULL terminated *) - -val search: t -> UTF8.t - -val get_cell: t -> int * int -> (int * int) option - -val editor: ?position: int * int -> ?prefix:UTF8.t -> ?init:UTF8.t -> t -> UTF8.t option diff --git a/selection.ml b/selection.ml deleted file mode 100755 index 2bf41ce..0000000 --- a/selection.ml +++ /dev/null @@ -1,73 +0,0 @@ -module T2 = Tools.Tuple2 - -type t = - | Single of (int * int) - | Multiple of (int * int) * (int * int) - -let create c = Single c - -type axe = - | Horizontal of int - | Vertical of int - | Cell of (int * int) - -let is_selected sel_type t = match sel_type, t with - | Horizontal h , Single (x, y) -> h = x - | Vertical v , Single (x, y) -> v = y - | Cell c, Single x -> c = x - | Horizontal h, Multiple ((x1, _), (x2, _)) -> - let min_x = min x1 x2 - and max_x = max x1 x2 in - min_x <= h && h <= max_x - | Vertical v, Multiple ((_, y1), (_, y2)) -> - let min_y = min y1 y2 - and max_y = max y1 y2 in - min_y <= v && v <= max_y - | Cell (x, y), Multiple ((x1, y1), (x2, y2)) -> - let min_x = min x1 x2 - and max_x = max x1 x2 in - let min_y = min y1 y2 - and max_y = max y1 y2 in - min_x <= x && x <= max_x && min_y <= y && y <= max_y - -let extract = function - | Single x -> x - | Multiple (x,y) -> y - -let fold (f:('a -> int * int -> 'a)) (init:'a): t -> 'a = function - | Single x -> f init x - | Multiple ((x1, y1), (x2, y2)) -> - let min_x = min x1 x2 - and max_x = max x1 x2 - and min_y = min y1 y2 - and max_y = max y1 y2 in - let res = ref init in - for x = min_x to max_x do - for y = min_y to max_y do - res := f !res (x, y) - done - done; - !res - -(** Extends the selection in one direction *) -let extends direction t = begin - let extends position = match direction with - | Actions.Left amount -> T2.map1 (fun v -> max 1 @@ v - amount) position - | Actions.Right amount -> T2.map1 ((+) amount) position - | Actions.Up amount -> T2.map2 (fun v -> max 1 @@ v - amount) position - | Actions.Down amount -> T2.map2 ((+) amount) position - | Actions.Absolute (x, y) -> x, y in - - let start_pos, end_pos = match t with - | Single x -> x, (extends x) - | Multiple (x, y) -> x, (extends y) in - - if start_pos = end_pos then - Single start_pos - else - Multiple (start_pos, end_pos) -end - -let shift = function - | Single (start_x, start_y) -> fun (x, y) -> (x - start_x, y - start_y) - | Multiple ((start_x, start_y), _) -> fun (x, y) -> (x - start_x, y - start_y) diff --git a/selection.mli b/selection.mli deleted file mode 100755 index fb207e4..0000000 --- a/selection.mli +++ /dev/null @@ -1,20 +0,0 @@ -type t - -type axe = - | Horizontal of int - | Vertical of int - | Cell of (int * int) - -(** Create a new selection from a cell *) -val create: (int * int) -> t - -val is_selected: axe -> t -> bool - -(** Get the selection origin *) -val extract: t -> (int * int) - -val shift: t -> (int * int) -> (int * int) - -val fold: ('a -> int * int -> 'a) -> 'a -> t -> 'a - -val extends: Actions.direction -> t -> t diff --git a/sheet.ml b/sheet.ml deleted file mode 100755 index 67b1ee1..0000000 --- a/sheet.ml +++ /dev/null @@ -1,334 +0,0 @@ -module Option = Tools.Option - -type cell = int * int - -type search = [ - | `Pattern of ScTypes.result option - | `Next - | `Previous -] - -module Raw = struct - - module Map = Map.Make(struct - type t = cell - let compare (x1, y1) (x2, y2) = Pervasives.compare (y1, x1) (y2, x2) - end) - - type content = { - expr : Expression.t; (** The expression *) - value : ScTypes.result option; (** The content evaluated *) - sink : Cell.Set.t; (** All the cell which references this one *) - } - - (** The sheet is a map which always contains evaluated values. When a cell is - updated, all the cell which references this value are also updated. - *) - and t = content Map.t - - (** An empty cell which does contains nothing *) - let empty_cell = { - expr = Expression.Undefined; - value = None; - sink = Cell.Set.empty; - } - - let empty = Map.empty - - let get_value id t = begin - try (Map.find id t).value - with Not_found -> None - end - - let get_expr id t = begin - try (Map.find id t).expr - with Not_found -> empty_cell.expr - end - - (** Extract a value from a reference. - This function is given to the evaluator for getting the values from a reference. - *) - let get_ref from t ref : ScTypes.result option ScTypes.Refs.range = begin - - ScTypes.Refs.collect ref - |> ScTypes.Refs.map (fun coord -> get_value coord t) - - end - - (** Update the value for the given cell. - Evaluate the new expression and compare it with the previous value. - @return Some map if the map has been updated - *) - let update cell content t = begin - let new_val = Expression.eval content.expr (get_ref cell t) in - match content.value with - | None -> - (* If the previous value wasn't defined, update the map *) - Some (Map.add cell { content with value = Some new_val } t) - | Some old_value -> - (* If the previous value was defined, update only if result differs *) - if not (ScTypes.Result.(=) new_val old_value) then - Some (Map.add cell { content with value = Some new_val } t) - else - (* If there is no changes, do not update the map *) - None - end - - (** 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 exception Cycle of Cell.Set.t * t in - - let rec successors parents element (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 Errors.Cycle) in - - if content.value = cycle_error then ( - (* The content has already been updated, do not process it again *) - (succ, t) - ) else ( - 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, t = traverse set_error source (init, t) in - raise (Cycle (succ, t)) - ) - ) else ( - begin match f element content t with - | None -> - (* The content does not change, we do not update the successors *) - (succ, t) - | Some t' -> - let parents' = Cell.Set.add element parents - and succ' = Cell.Set.add element succ in - if (Cell.Set.is_empty content.sink) then - (succ', t') - else - Cell.Set.fold (successors parents') content.sink (succ', t') - end - ) - end in - try Cell.Set.fold (successors init) source.sink (init, t) - with Cycle (succ, t) -> (succ, t) - end - - (** Remove the cell from the sheet *) - let remove_element (id:cell) t : t * content option = begin - - (** Remove the references from each sources. - If the sources is not referenced anywhere, and is Undefined, remove it - *) - let remove_ref cell t = begin - try let c = Map.find cell t in - - (* Remove all the refs which points to the removed cell *) - let sink' = Cell.Set.filter ((<>) id) c.sink in - if Cell.Set.is_empty sink' && not (Expression.is_defined c.expr) then ( - Map.remove cell t ) - else - Map.add cell {c with sink = sink'} t - with Not_found -> t - end in - - begin try - let c = Map.find id t in - let t' = - (** Remove the references from each sources *) - let sources = Expression.collect_sources c.expr in - Cell.Set.fold remove_ref sources t in - - (** If there is no references on the cell, remove it *) - if Cell.Set.is_empty c.sink then ( - Map.remove id t', None) - else ( - let c = { empty_cell with sink = c.sink } in - Map.add id c t', (Some c) - ) - with Not_found -> t, None - end - end - - let remove id t = begin - match remove_element id t with - | t, None -> Cell.Set.empty, t - | t, Some content -> - (** Update all the successors *) - traverse update content (Cell.Set.singleton id, t) - end - - let add_element id f t = begin - - (** Add the references in each sources. - If the sources does not exists, create it. - *) - let add_ref cell t = begin - let c = - try Map.find cell t - with Not_found -> empty_cell in - let c' = { c with sink = Cell.Set.add id c.sink} in - Map.add cell c' t - end in - - let t', cell = remove_element id t in - let cell' = match cell with - | None -> empty_cell - | Some x -> x in - - let content = f cell' t' in - - let sources = Expression.collect_sources content.expr in - let updated = Map.add id content t' - |> Cell.Set.fold add_ref sources - in - - (** Update the value for each sink already evaluated *) - traverse update content (Cell.Set.singleton id, updated) - end - - let add id expression t = begin - if not (Expression.is_defined expression) then - (Cell.Set.empty, t) - else - let f cell t = { cell with - expr = expression ; - value = Some (Expression.eval expression (get_ref id t)) - } in - add_element id f t - end - - let paste id shift content t = begin - let expr = Expression.shift shift content.expr in - let f cell t = - { cell with - expr = expr ; - value = Some (Expression.eval expr (get_ref id t)) - } in - add_element id f t - end - - let search pattern t = begin - let exception Found of (int * int) in - - let _search key content = if content.value = pattern then raise (Found key) in - try - Map.iter _search t; - None - with Found key -> Some key - end - - let get_sink id t = - try (Map.find id t).sink - with Not_found -> Cell.Set.empty - - (** Fold over each defined value *) - let fold f a t = begin - Map.fold (fun key content a -> - match content.value with - | None -> a - | Some x -> - f a key (content.expr, x) - ) t a - end - -end - -type yank = cell * Raw.content - -type t = { - selected: Selection.t; (* The selected cell *) - data: Raw.t; - history: t list; (* Unlimited history *) - yank: (cell * Raw.content) list -} - -let undo t = begin match t.history with - | [] -> None - | hd::tl -> Some { hd with selected = t.selected } -end - -let move direction t = - let position = Selection.extract t.selected in - let position' = begin match direction with - | Actions.Left quant -> Tools.Tuple2.replace1 (max 1 ((fst position) - quant)) position - | Actions.Right quant -> Tools.Tuple2.replace1 ((fst position) + quant) position - | Actions.Up quant -> Tools.Tuple2.replace2 (max 1 ((snd position) - quant)) position - | Actions.Down quant -> Tools.Tuple2.replace2 ((snd position) + quant) position - | Actions.Absolute (x, y)-> (x, y) - end in - if position = position' then - None - else - Some {t with selected = Selection.create position'} - -let delete t = begin - let count, data' = Selection.fold (fun (count, c) t -> - (count + 1, snd @@ Raw.remove t c)) (0, t.data) t.selected in - let t' = { t with - data = data'; - history = t::t.history - } in - t', count -end - -let yank t = begin - - let shift = Selection.shift t.selected in - let origin = shift (0, 0) in - let _yank (count, extracted) cell = begin - let content = - try let content = (Raw.Map.find cell t.data) in - { content with Raw.expr = Expression.shift origin content.Raw.expr } - with Not_found -> Raw.empty_cell in - - count + 1, (shift cell,content)::extracted - end in - - let count, yanked = Selection.fold _yank (0, []) t.selected in - let t' = { t with yank = List.rev yanked; } in - t', count -end - -let paste t = begin - (* Origin of first cell *) - let (shift_x, shift_y) as shift = Selection.extract t.selected in - - let _paste (count, t) ((x, y), content) = begin - count + 1, snd @@ Raw.paste (shift_x + x, shift_y + y) shift content t - end in - - let count, data' = List.fold_left _paste (0, t.data) t.yank in - let t' = { t with data = data'; history = t::t.history } in - t', count -end - -let add expression t = begin - let id = Selection.extract t.selected in - let cells, data' = Raw.add id expression t.data in - cells, { t with data = data'; history = t::t.history} -end - -let search action t = begin match action with - | `Pattern pattern -> - begin match Raw.search pattern t.data with - | None -> None - | Some x -> Some {t with selected = Selection.create x} - end - | _ -> None -end - -let create data = { - data = data; - selected = Selection.create (1, 1); - history = []; - yank = []; -} diff --git a/sheet.mli b/sheet.mli deleted file mode 100755 index 11881cc..0000000 --- a/sheet.mli +++ /dev/null @@ -1,75 +0,0 @@ -(** This module represent a sheet *) - -type cell = int * int - -module Raw: sig - - type t - - (** An empty sheet *) - val empty: t - - (** Add a new value in the sheet. The previous value is replaced - @return All the successors to update and the new sheet. - *) - val add: cell -> Expression.t -> t -> Cell.Set.t * t - - val remove: cell -> t -> Cell.Set.t * t - - (** Get the value content. - @return None if the cell is not defined - *) - val get_value: cell -> t -> ScTypes.result option - - val get_expr: cell -> t -> Expression.t - - val get_sink: cell -> t -> Cell.Set.t - - (** Fold over all the defined values *) - val fold: ('a -> cell -> (Expression.t * ScTypes.result ) -> 'a) -> 'a -> t -> 'a - -end - -type yank - -type t = { - selected: Selection.t; (* The selected cell *) - data: Raw.t; - history: t list; (* Unlimited history *) - yank: yank list (* All the selected cells *) -} - -type search = [ - | `Pattern of ScTypes.result option - | `Next - | `Previous -] - -(** Undo the last action and return the previous state, if any *) -val undo: t -> t option - -(** Move the cursor in one direction, return the state updated if the move is - allowed *) -val move: Actions.direction -> t -> t option - -(** Delete the content of selected cells. - @return The sheet and the number of cells deleted -*) -val delete: t -> t * int - -(** Copy the selected cells - @return The sheet and the number of cells deleted -*) -val yank: t -> t * int - -(** Search for a pattern on the sheet - @return The state updated if the pattern has been found. *) -val search: search -> t -> t option - -val paste: t -> t * int - -val add: Expression.t -> t -> Cell.Set.t * t - -(** Create an empty sheet *) -val create: Raw.t -> t - diff --git a/splay.ml b/splay.ml deleted file mode 100644 index ec5750c..0000000 --- a/splay.ml +++ /dev/null @@ -1,142 +0,0 @@ -module type KEY = sig - - type 'a t - - val comp: 'a t -> 'b t -> ('a, 'b) Tools.cmp - - val repr: Format.formatter -> 'a t -> unit - -end - -module Make (El : KEY) = struct - - type 'a elem = 'a El.t - - type leaf (** Fantom type for typing the tree *) - type node (** Fantom type for typing the tree *) - - type 'a treeVal = - | Leaf : leaf treeVal - | Node : _ treeVal * ('a elem * 'a) * _ treeVal -> node treeVal - - type t = T : 'a treeVal ref -> t [@@unboxed] - - let empty = T (ref Leaf) - - let isEmpty (T tree) = match !tree with - | Leaf -> true - | _ -> false - - let rec splay : type a. a elem -> node treeVal -> node treeVal = fun x t -> begin - let Node (l, y, r) = t in - begin match El.comp x (fst y) with - | Tools.Eq -> t - | Tools.Lt -> - begin match l with - | Leaf -> t - | Node (ll, z, rr) -> - begin match El.comp x (fst z) with - | Tools.Eq -> Node (ll, z, Node (rr, y, r)) - | Tools.Lt -> - begin match ll with - | Leaf -> Node (ll, z, Node (rr, y, r)) - | Node _ as ll -> - let Node (newL, newV, newR) = splay x ll - in Node (newL, newV, Node (newR, z, Node (rr, y, r))) - end - | Tools.Gt -> - begin match rr with - | Leaf -> Node (ll, z, Node (rr, y, r)) - | Node _ as rr -> - let Node (newL, newV, newR) = splay x rr - in Node (Node (ll, z, newL), newV, Node (newR, y, r)) - end - end - end - | Tools.Gt -> - begin match r with - | Leaf -> t - | Node (ll, z, rr) -> - begin match El.comp x (fst z) with - | Tools.Eq -> Node (Node (l, y, ll), z, rr) - | Tools.Lt -> - begin match ll with - | Leaf -> Node (Node (l, y, ll), z, rr) - | Node _ as ll -> - let Node (newL, newV, newR) = splay x ll - in Node (Node (l, y, newL), newV, Node (newR, z, rr)) - end - | Tools.Gt -> - begin match rr with - | Leaf -> Node (Node (l, y, ll), z, rr) - | Node _ as rr -> - let Node (newL, newV, newR) = splay x rr - in Node (Node (Node(l, y, ll), z, newL), newV, newR) - end - end - end - end - end - - let member: type a. a elem -> t -> bool = fun x (T t) -> match !t with - | Leaf -> false - | Node _ as root -> - let root' = splay x root in - t := root'; - let Node (_, c', _) = root' in - begin match El.comp (fst c') x with - | Tools.Eq -> true - | _ -> false - end - - let find: type a. a elem -> t -> a = fun x (T t) -> match !t with - | Leaf -> raise Not_found - | Node _ as root -> - let root' = splay x root in - t := root'; - let Node (_, c', _) = root' in - begin match El.comp (fst c') x with - | Tools.Eq -> snd c' - | _ -> raise Not_found - end - - let add: type a. a elem -> a -> t -> t = fun key value (T t) -> match !t with - | Leaf -> T (ref (Node (Leaf, (key, value), Leaf))) - | Node _ as root -> - let root' = splay key root in - let Node (l, y, r) = root' in - begin match El.comp key (fst y) with - | Tools.Eq -> T (ref root') - | Tools.Lt -> T (ref (Node (l, (key, value), Node (Leaf, y, r)))) - | Tools.Gt -> T (ref (Node (Node (l, y, Leaf), (key, value), r))) - end - - let repr formatter (T t) = begin - - let repr_edge from formatter dest = begin - Format.fprintf formatter "\"%a\" -> \"%a\"\n" - El.repr from - El.repr dest - end in - - let rec repr': type a b. a El.t -> Format.formatter -> b treeVal -> unit = fun parent formatter -> function - | Leaf -> () - | Node (l, c, r) -> - let key = fst c in - Format.fprintf formatter "%a%a%a" - (repr_edge parent) key - (repr' key) l - (repr' key) r in - - begin match !t with - | Leaf -> Format.fprintf formatter "digraph G {}" - | Node (l, c, r) -> - let key = fst c in - Format.fprintf formatter "digraph G {\n%a%a}" - (repr' key) l - (repr' key) r - end - - end - -end diff --git a/splay.mli b/splay.mli deleted file mode 100755 index 41c1a5a..0000000 --- a/splay.mli +++ /dev/null @@ -1,30 +0,0 @@ -module type KEY = sig - - type 'a t - - val comp: 'a t -> 'b t -> ('a, 'b) Tools.cmp - - val repr: Format.formatter -> 'a t -> unit - -end - -module Make (El : KEY) : sig - - type t - - (** Create an empty tree *) - val empty: t - - (** Return the element in the tree with the given key *) - val find: 'a El.t -> t -> 'a - - (** Add one element in the tree *) - val add: 'a El.t -> 'a -> t -> t - - (** Check if the key exists *) - val member: 'a El.t -> t -> bool - - (** Represent the content in dot syntax *) - val repr: Format.formatter -> t -> unit - -end diff --git a/src/UTF8.ml b/src/UTF8.ml new file mode 100755 index 0000000..a955b1e --- /dev/null +++ b/src/UTF8.ml @@ -0,0 +1,54 @@ +include Text + +let empty = "" + +let decode x = Text.decode x + +let encode x = + try Some (Text.encode x) + with Text.Invalid (_, _) -> None + +let raw_encode x = Text.encode x + +let from_utf8string x = x + +let to_utf8string x = x + +let trim x = Text.strip x + +let split str ~sep = + match Text.split ~max:1 ~sep str with + | [] -> "" + | hd::tl -> hd + +let replace text patt repl = Text.replace text ~patt ~repl + +module Buffer = struct + + include Buffer + + type buffer = t + + let add_char b c = Uchar.of_char c + |> Uchar.to_int + |> Text.char + |> Buffer.add_string b +end + +module Printf = struct + + include Printf + +end + +module Format = struct + + include Format + + let bprintf buffer fformat = begin + let to_b = formatter_of_buffer buffer in + let x = fprintf to_b fformat in + x + end + +end diff --git a/src/UTF8.mli b/src/UTF8.mli new file mode 100755 index 0000000..a2e331e --- /dev/null +++ b/src/UTF8.mli @@ -0,0 +1,92 @@ +(** UTF8 is used internally for all strings + + The module is intentionaly opaque. + + *) + +(** An UTF8 encoded string *) +type t + +val empty: t + +(** Decode a string in the current locale *) +val decode: string -> t + +(** Use this to with a known UTF8 encoded string *) +val from_utf8string: string -> t + +(** Encode to the string to the user locale *) +val encode: t -> string option + +(** Encode the string. + This function may raise Text.Invalid if the string cannot be encoded in current locale +*) +val raw_encode: t -> string + +val to_utf8string: t -> string + +val trim: t -> t + +val length: t -> int + +val get: t -> int -> t + +val rev_explode : t -> t list + +val split: t -> sep:t -> t + +val fold : (t -> 'a -> 'a) -> t -> 'a -> 'a + +val implode : t list -> t + +val rev_implode : t list -> t + +val compare: t -> t -> int + +val replace: t -> t -> t -> t + +val upper: t -> t + +val lower: t -> t + +val code: t -> int + +val char: int -> t + +val repeat: int -> t -> t + +val get: t -> int -> t + +val lchop: t -> t + +val rchop: t -> t + +val sub: t -> int -> int -> t + +module Buffer : sig + + type buffer + + val create : int -> buffer + + val contents : buffer -> t + + val add_string : buffer -> t -> unit + + val add_char: buffer -> char -> unit + +end + +module Printf : sig + + val bprintf : Buffer.buffer -> ('a, Buffer.buffer, unit) format -> 'a + +end + +module Format: sig + + val formatter_of_buffer : Buffer.buffer -> Format.formatter + + val fprintf : Format.formatter -> ('a, Format.formatter, unit) format -> 'a + +end diff --git a/src/actionParser.mly b/src/actionParser.mly new file mode 100755 index 0000000..6318ca6 --- /dev/null +++ b/src/actionParser.mly @@ -0,0 +1,45 @@ +%{ + open Actions + +%} + +%token ESC +%token EOF +%token LEFT RIGHT UP DOWN +%token NPAGE PPAGE HOME END +%token RESIZE +%token DELETE +%token SEARCH +%token E U V Y P +%token EQUAL +%token I +%token BUTTON1_CLICKED +%token BUTTON1_RELEASED +%token COMMAND + +%start normal +%% + + +normal: + | ESC { Escape } + | LEFT { Move (Left 1) } + | RIGHT { Move (Right 1) } + | UP { Move (Up 1) } + | DOWN { Move (Down 1) } + | RESIZE { Resize } + | DELETE { Delete } + | E { Edit } + | U { Undo } + | V { Visual } + | Y { Yank } + | P { Paste } + | SEARCH { Search } + | EQUAL { InsertFormula } + | NPAGE { Move (Down 10)} + | PPAGE { Move (Up 10)} + | HOME { Move (Left 10)} + | END { Move (Right 10)} + | BUTTON1_CLICKED { Button1_clicked $1} + | BUTTON1_RELEASED{ Button1_released $1} + | COMMAND { Command } diff --git a/src/actions.mli b/src/actions.mli new file mode 100755 index 0000000..f955538 --- /dev/null +++ b/src/actions.mli @@ -0,0 +1,28 @@ +type direction = +| Up of int +| Down of int +| Left of int +| Right of int +| Absolute of int * int + +type modes = +| Normal +| Select +| Edit +| Command + +type actions = +| Move of direction +| Resize (* Resize event *) +| Escape +| Delete +| Yank +| Paste +| Search +| Undo +| Edit +| InsertFormula +| Visual +| Button1_clicked of (int * int) +| Button1_released of (int * int) +| Command diff --git a/src/catalog.ml b/src/catalog.ml new file mode 100755 index 0000000..e4cd34b --- /dev/null +++ b/src/catalog.ml @@ -0,0 +1,125 @@ +module T = Tools +module type DATA_SIG = sig + + type 'a typ + + type 'a returnType + + val compare_typ: 'a typ -> 'b typ -> ('a, 'b) T.cmp + + val repr: Format.formatter -> 'a typ -> unit + +end + +(** We cannot update an existing function. Any [registerX] function will raise + [RegisteredFunction] if a function with the same signature already exists in +the catalog. *) +exception RegisteredFunction + +(** Catalog for all functions *) +module Make(Data:DATA_SIG) = struct + + (** This is the way the function is store in the map. + We just the return type, and the function itself. *) + type _ t_function = + | Fn1: 'b Data.returnType * ('a -> 'b) -> 'a t_function + | Fn2: 'c Data.returnType * ('a -> 'b -> 'c) -> ('a * 'b) t_function + | Fn3: 'd Data.returnType * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function + + (** This is the key for storing functions in the map. *) + type _ sig_typ = + | T1: 'a Data.typ -> 'a t_function sig_typ + | T2: 'a Data.typ * 'b Data.typ -> ('a * 'b) t_function sig_typ + | T3: 'a Data.typ * 'b Data.typ * 'c Data.typ -> ('a * 'b * 'c) t_function sig_typ + + + let repr: type a. Format.formatter -> a sig_typ -> unit = fun formatter -> function + | T1 t -> Format.fprintf formatter "(%a)" Data.repr t + | T2 (t1, t2) -> Format.fprintf formatter "(%a,%a)" Data.repr t1 Data.repr t2 + | T3 (t1, t2, t3) -> Format.fprintf formatter "(%a,%a,%a)" Data.repr t1 Data.repr t2 Data.repr t3 + + module ComparableSignature = struct + + type 'a t = string * 'a sig_typ + + (* Type for pure equality *) + type (_, _) eq = Eq : ('a, 'a) eq + + (** Compare two signature *) + let comp: type a b. string * a sig_typ -> string * b sig_typ -> (a, b) T.cmp = begin fun (namea, a) (nameb, 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 + | T.Eq -> f Eq + | T.Lt -> T.Lt + | T.Gt -> T.Gt + end in + + if namea < nameb then + T.Lt + else if namea > nameb then + T.Gt + else match a, b with + + | T1(a), T1(b) -> cmp a b (fun Eq -> T.Eq) + | T1(_), _ -> T.Lt + | _, T1(_) -> T.Gt + + | T2(a, b), T2(c, d) -> + cmp a c (fun Eq -> + cmp b d (fun Eq -> T.Eq) + ) + | T2(_), _ -> T.Lt + | _, T2(_) -> T.Gt + + | T3(a, b, c), T3(d, e, f) -> + cmp a d (fun Eq -> + cmp b e (fun Eq -> + cmp c f (fun Eq -> T.Eq) + ) + ) + + end + + + let repr : type a. Format.formatter -> a t -> unit = begin fun formatter (str, typ) -> + Format.fprintf formatter "%s:%a" + str + repr typ + end + + end + + module Functions = Splay.Make(ComparableSignature) + + (* This is the map which contains all the registered functions. + Each name is binded with another map with contains the function for each + signature. + *) + type t = Functions.t + + let empty = Functions.empty + + (** + Register a function in the catalog. If the function is already defined, + raise an exception. + *) + let register t name signature f = begin + + let name' = String.uppercase_ascii name in + if Functions.member (name', signature) t then + raise RegisteredFunction + else + Functions.add (name', signature) f t + end + + (** Look in the catalog for a function with the given name and signature *) + let find_function: + type a. t -> string -> a t_function sig_typ -> a t_function = + begin fun t name signature -> + Functions.find ((String.uppercase_ascii name), signature) t + end + + let repr = Functions.repr + +end diff --git a/src/catalog.mli b/src/catalog.mli new file mode 100644 index 0000000..e871378 --- /dev/null +++ b/src/catalog.mli @@ -0,0 +1,38 @@ +module type DATA_SIG = sig + + type 'a typ + + type 'a returnType + + val compare_typ: 'a typ -> 'b typ -> ('a, 'b) Tools.cmp + + val repr: Format.formatter -> 'a typ -> unit + +end + +module Make(D:DATA_SIG): sig + + type t + + type 'a t_function = + | Fn1: 'b D.returnType * ('a -> 'b) -> 'a t_function + | Fn2: 'c D.returnType * ('a -> 'b -> 'c) -> ('a * 'b) t_function + | Fn3: 'd D.returnType * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function + + type 'a sig_typ = + | T1: 'a D.typ -> 'a t_function sig_typ + | T2: 'a D.typ * 'b D.typ -> ('a * 'b) t_function sig_typ + | T3: 'a D.typ * 'b D.typ * 'c D.typ -> ('a * 'b * 'c) t_function sig_typ + + (** Empty catalog *) + val empty: t + + (** Register a new function in the catalog *) + val register : t -> string -> 'a t_function sig_typ -> 'a t_function -> t + + (** Find a function with the given name and signature *) + val find_function: t -> string -> 'a t_function sig_typ -> 'a t_function + + val repr: Format.formatter -> t -> unit + +end diff --git a/src/cell.ml b/src/cell.ml new file mode 100755 index 0000000..e6ccd63 --- /dev/null +++ b/src/cell.ml @@ -0,0 +1,70 @@ +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 + let rec extract acc value = + if value > 0 then ( + let value' = value - 1 in + let rem = value' mod 26 in + let quot = (value' - rem) / 26 + in extract ((char_of_int (65 + rem))::acc) quot + ) else ( + acc + ) + 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 + + 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; + UTF8.Buffer.contents buff + +let to_buffer buff ((x, y), (fixed_x, fixed_y)) = begin + 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 + +module Set = (struct + include Set.Make(struct + type t = (int * int) + let compare = Pervasives.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 printb buff = + iter (fun x -> to_buffer buff (x, (false,false)); UTF8.Buffer.add_char buff ' ') + +end) + diff --git a/src/cell.mli b/src/cell.mli new file mode 100755 index 0000000..8f225a5 --- /dev/null +++ b/src/cell.mli @@ -0,0 +1,20 @@ +type t = (int * int) * (bool * bool) + +module Set : sig + + include Set.S with type elt = (int * int) + + val printb: UTF8.Buffer.buffer -> t -> unit + +end + +val to_pair: t -> (int * int) + +val from_string: bool * string -> bool * int -> t + +val to_hname: int -> UTF8.t + +val to_string: t -> UTF8.t + +val to_buffer: UTF8.Buffer.buffer -> t -> unit + diff --git a/src/dataType.ml b/src/dataType.ml new file mode 100755 index 0000000..f30dd8c --- /dev/null +++ b/src/dataType.ml @@ -0,0 +1,125 @@ +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 +end + +module Comparable = struct + + 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 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 + + 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 + + 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 + else + 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 + 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 + + if is_integer q_factor then + + 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) + +end + +module Bool = struct + + type t = bool + include Comparable + + let true_ = true + let false_ = false + + let or_ = (||) + let and_ = (&&) + let not = Pervasives.not + +end + +module String = struct + + type t = UTF8.t + include Comparable + +end + +module Date = Date.Make(Num) diff --git a/src/dataType.mli b/src/dataType.mli new file mode 100755 index 0000000..5c89c98 --- /dev/null +++ b/src/dataType.mli @@ -0,0 +1,99 @@ +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 +end + +module Num: sig + + type t + + val one: t + val zero: t + + val of_int: int -> t + val to_int: t -> int + + val to_float: t -> float + val of_float: float -> t + + val neg: t -> 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 add: t -> t -> t + val sub: t -> t -> t + val mult: t -> t -> t + val div: t -> t -> t + val pow: t -> t -> t + + val rnd: unit -> t + + val max: t -> t -> t + val min: t -> t -> t + + val abs: t -> t + + val round: t -> t + val floor: t -> t + val round_down: t -> t + + val gcd: t -> t -> t + val lcm: t -> t -> t + + val is_integer: t -> bool + +end + +module Bool: sig + type t = bool + + val true_ : bool + val false_: 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 + + val not: t -> t + val and_: t -> t -> t + val or_: t -> t -> t +end + +module String: sig + type t = UTF8.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 +end + +module Date: sig + + (** Create a date from a year month day *) + val get_julian_day : int -> int -> int -> Num.t + + (** Return the year, month and day from a date *) + val date_from_julian_day : Num.t -> int * int * int + + val time_from_julian_day : Num.t -> int * int * Num.t + + val from_string: string -> Num.t + + (** Print out the date *) + val to_string: Num.t -> string +end diff --git a/src/date.ml b/src/date.ml new file mode 100644 index 0000000..92cb9f6 --- /dev/null +++ b/src/date.ml @@ -0,0 +1,120 @@ +module type CALCULABLE = sig + + type t + + val add: t -> t -> t + + val sub: t -> t -> t + + val mult: t -> t -> t + + val div: t -> t -> t + + val floor: t -> t + + val of_int: int -> t + + val to_int: t -> int + + val to_float: t -> float + +end + + +module Make(C : CALCULABLE) = struct + + 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 *) + |> C.of_int + + end + + let date_from_julian_day day = begin + + let shift_day = C.add (C.floor day) (C.of_int 2415019) in + + let z = C.to_int shift_day in + let f = + if z >= 2299161 then + (* We use the Num module here to prevent overflow *) + let product = C.mult (C.of_int 4) shift_day in + let shifted = C.add product (C.of_int 274277) in + let div = C.div shifted (C.of_int 146097) in + let day' = C.to_int @@ C.floor div 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 + + let day = C.floor j in + let time = C.sub j day in + + let h = C.floor @@ C.mult time (C.of_int 24) in + let h_24 = C.div h (C.of_int 24) in + let m = C.floor @@ C.mult (C.of_int 1440) (C.sub time h_24) in + let s = C.mult (C.of_int 86400) (C.sub (C.sub time h_24) (C.div m (C.of_int 1440))) in + (C.to_int h, C.to_int 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 = C.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 -> + let nhour = C.div (n hour) (n 24) + and nmin = C.div (n min) (n 1440) + and nsec = C.div (n sec) (n 86400) in + C.add (C.add (C.add (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 ( + C.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 + + h n (C.to_float s) + + end + +end diff --git a/src/date.mli b/src/date.mli new file mode 100755 index 0000000..dd24124 --- /dev/null +++ b/src/date.mli @@ -0,0 +1,38 @@ +module type CALCULABLE = sig + + type t + + val add: t -> t -> t + + val sub: t -> t -> t + + val mult: t -> t -> t + + val div: t -> t -> t + + val floor: t -> t + + val of_int: int -> t + + val to_int: t -> int + + val to_float: t -> float + +end + +module Make(C:CALCULABLE): sig + + (** Create a date from a year month day *) + val get_julian_day : int -> int -> int -> C.t + + (** Return the year, month and day from a date *) + val date_from_julian_day : C.t -> int * int * int + + val time_from_julian_day : C.t -> int * int * C.t + + val from_string: string -> C.t + + (** Print out the date *) + val to_string: C.t -> string + +end diff --git a/src/errors.ml b/src/errors.ml new file mode 100755 index 0000000..3751a60 --- /dev/null +++ b/src/errors.ml @@ -0,0 +1,14 @@ + +(** The function is undefined *) +exception Undefined of UTF8.t * string list + +exception TypeError + +exception Cycle + +let printf formatter = function + | Undefined (name, args) -> Format.fprintf formatter + "There is no function '%s' with signature %a" + (UTF8.to_utf8string name) + (Format.pp_print_list Format.pp_print_text) args + | _ -> Format.fprintf formatter "#Error" diff --git a/src/evaluator.ml b/src/evaluator.ml new file mode 100755 index 0000000..f718e1f --- /dev/null +++ b/src/evaluator.ml @@ -0,0 +1,373 @@ +module D = DataType +module T = Tools + +module Data = struct + +(** Data format *) + +type 'a dataFormat = 'a ScTypes.dataFormat + +(*** Type definitions *) + +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 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 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 + +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 + +type 'a returnType = 'a ScTypes.returnType + +(*** Values definitions *) + +type 'a value = + | Bool: D.Bool.t -> D.Bool.t value + | Num: D.Num.t ScTypes.dataFormat * D.Num.t -> D.Num.t value + | String: UTF8.t -> UTF8.t value + | List: 'a ScTypes.dataFormat * 'a list -> 'a list value + | Matrix: 'a ScTypes.dataFormat * 'a list list -> 'a list list value + +(** Get the value out of the box *) +let get_value_content: type a. a value -> a = function + | Bool b -> b + | Num (_, n) -> n + | String s -> s + | List (t, l) -> l + | Matrix (t, l) -> l + +(* Extract the type from a boxed value *) +let type_of_value: type a. a value -> a typ = function + | Bool b -> Bool + | Num (n, _) -> Num + | String s -> String + | List (t, l) -> List (typ_of_format t) + | Matrix (t, l) -> List (List (typ_of_format t)) + +end + +module C = Catalog.Make(Data) + + +type t = C.t + +let catalog = ref C.empty + +let get_catalog () = !catalog + +let repr = C.repr + +type existencialResult = + | Result : 'a Data.value -> existencialResult [@@unboxed] + +let inject: +type a. a Data.dataFormat -> a -> existencialResult = fun resultFormat res -> + begin match resultFormat with + | ScTypes.Bool -> Result (Data.Bool res) + | ScTypes.String -> Result (Data.String res) + | ScTypes.Number -> Result (Data.Num (resultFormat, res)) + | ScTypes.Date -> Result (Data.Num (resultFormat, res)) + end + + +(** Extract the format from a list of results *) +let build_format_list ll () = + + List.map (fun (Result x) -> + begin match x with + | Data.Bool _ -> ScTypes.DataFormat.F (ScTypes.Bool) + | Data.Num (x, _) -> ScTypes.DataFormat.F x + | Data.String _ -> ScTypes.DataFormat.F (ScTypes.String) + | Data.List (f, _) -> ScTypes.DataFormat.F f + | Data.Matrix (f, _) -> ScTypes.DataFormat.F f + end + ) ll + + +let register0 name returnType f = + catalog := C.register !catalog name (C.T1(Data.Unit)) (C.Fn1 (returnType, f)) + +let register1 name typ1 returnType f = + catalog := C.register !catalog name (C.T1(typ1)) (C.Fn1 (returnType, f)) + +let register2 name (typ1, typ2) result f = + catalog := C.register !catalog name (C.T2(typ1, typ2)) (C.Fn2 (result, f)) + +let register3 name (typ1, typ2, typ3) result f = + catalog := C.register !catalog name (C.T3(typ1, typ2, typ3)) (C.Fn3 (result, f)) + +let call name args = begin + let name' = UTF8.to_utf8string name in + begin try match args with + | [] -> + let C.Fn1(ret, f) = C.find_function !catalog name' (C.T1 Data.Unit) in + let returnType = ScTypes.DataFormat.guess_format_result ret (fun () -> raise Errors.TypeError) in + inject returnType (f ()) + + | (Result p1)::[] -> + let C.Fn1(ret, f) = + C.find_function !catalog name' (C.T1 (Data.type_of_value p1)) in + let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in + inject returnType (f (Data.get_value_content p1)) + + | (Result p1)::(Result p2)::[] -> + let C.Fn2(ret, f) = + C.find_function !catalog name' (C.T2 (Data.type_of_value p1, Data.type_of_value p2)) in + let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in + inject returnType (f (Data.get_value_content p1) (Data.get_value_content p2)) + + | (Result p1)::(Result p2)::(Result p3)::[] -> + let C.Fn3(ret, f) = + C.find_function !catalog name' (C.T3 (Data.type_of_value p1, Data.type_of_value p2, Data.type_of_value p3)) in + let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in + inject returnType (f (Data.get_value_content p1) (Data.get_value_content p2) (Data.get_value_content p3)) + + | _ -> raise Not_found + with Not_found -> + let signature = List.map (fun (Result x) -> + let formatter = Format.str_formatter in + Data.repr formatter (Data.type_of_value x); + Format.flush_str_formatter ()) args in + + raise (Errors.Undefined (name, signature)) + end +end + +let eval mapper value = begin + + (** Extract the value from a raw type. + If the value is Undefined, raise an exception. + *) + let extract_value : ScTypes.result -> existencialResult = begin function + | ScTypes.Result (ScTypes.Num (f, n)) -> Result (Data.Num (f, n)) + | ScTypes.Result (ScTypes.Bool b) -> Result (Data.Bool b) + | ScTypes.Result (ScTypes.Str s) -> Result (Data.String s) + | ScTypes.Error x -> raise x + end in + + (** Extract the value from an expression. + [extract typ expr] will evaluate the expression and return it. If the + result cannot be evaluated (because of references pointing to missing + values) a default value of type [typ] will be returned. + *) + let rec extract = begin function + (* For a reference to an external we first extract the value pointed *) + | ScTypes.Ref r -> ScTypes.Refs.( + begin match ScTypes.Refs.get_content @@ mapper r with + | C (Value (format, f)) -> begin match format with + | ScTypes.Date -> Result (Data.Num (format, f)) + | ScTypes.Number -> Result (Data.Num (format, f)) + | ScTypes.String -> Result (Data.String f) + | ScTypes.Bool -> Result (Data.Bool f) + end + | C (List (format, l)) -> Result (Data.List (format, l)) + | C (Matrix (format, l)) -> Result (Data.Matrix (format, l)) + end) + + (* Evaluate the expression *) + | ScTypes.Expression e -> extract e + | ScTypes.Value v -> extract_value (ScTypes.Result v) + | ScTypes.Call (name, args) -> + let args' = List.map extract args in + call name args' + end + in + let Result r = ((extract[@tailrec]) value) in + begin match r with + | Data.Bool b -> ScTypes.Result (ScTypes.boolean b) + | Data.String s -> ScTypes.Result (ScTypes.string s) + | Data.Num (format, n) -> begin match ScTypes.get_numeric_type format with + | ScTypes.Date -> ScTypes.Result (ScTypes.date n) + | ScTypes.Number -> ScTypes.Result (ScTypes.number n) + end + | _ -> raise Errors.TypeError + end +end + +let wrap f = + let old_catalog = !catalog in + Tools.try_finally + (fun () -> catalog := C.empty; f ()) + (fun () -> catalog := old_catalog) + + +(* Register the standard functions *) +type 'a returnType = 'a ScTypes.returnType + +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(C: D.COMPARABLE) = struct + + let register t = begin + register2 "=" (t, t) f_bool C.eq; + register2 "<>" (t, t) f_bool C.neq; + register2 ">" (t, t) f_bool C.gt; + register2 ">=" (t, t) f_bool C.ge; + register2 "<" (t, t) f_bool C.lt; + register2 "<=" (t, t) f_bool C.le; + end + +end + +type 'a typ = 'a Data.typ +let t_bool: DataType.Bool.t typ = Data.Bool +let t_int: DataType.Num.t typ = Data.Num +let t_string: UTF8.t typ = Data.String +let t_list (t: 'a typ): 'a list typ = Data.List t + +(* Helper for list functions : reduce over a list of elements *) +let reduce name typ res f = begin + register1 name (t_list typ) res (fun x -> + List.fold_left f (List.hd x) x); + register1 name (t_list (t_list typ)) res (fun x -> + List.fold_left (List.fold_left f) (List.hd (List.hd x)) x); +end + +(* Helper for list functions : fold over a list of elements *) +let fold name t_in t_out f init = begin + register1 name (t_list t_in) t_out (fun x -> + List.fold_left f init x); + register1 name (t_list (t_list t_in)) t_out (fun x -> + 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 + + (* Build a date *) + 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) + ); + + let module CompareNum = Make_Compare(D.Num) in + Data.( + CompareNum.register t_int; + register0 "rand" f_number D.Num.rnd; + + register0 "pi" f_number (fun () -> D.Num.of_float (4. *. atan 1.)); + register1 "sin" t_int f_number (fun x -> D.Num.of_float (sin @@ D.Num.to_float x)); + register1 "cos" t_int f_number (fun x -> D.Num.of_float (cos @@ D.Num.to_float x)); + register1 "tan" t_int f_number (fun x -> D.Num.of_float (tan @@ D.Num.to_float x)); + register1 "atan" t_int f_number (fun x -> D.Num.of_float (atan @@ D.Num.to_float x)); + register1 "asin" t_int f_number (fun x -> D.Num.of_float (asin @@ D.Num.to_float x)); + register1 "acos" t_int f_number (fun x -> D.Num.of_float (acos @@ D.Num.to_float x)); + register1 "sinh" t_int f_number (fun x -> D.Num.of_float (sinh @@ D.Num.to_float x)); + register1 "cosh" t_int f_number (fun x -> D.Num.of_float (cosh @@ D.Num.to_float x)); + register1 "tanh" t_int f_number (fun x -> D.Num.of_float (tanh @@ D.Num.to_float x)); + 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)) + ); + + register1 "sqrt" t_int f_number (fun x -> D.Num.of_float (sqrt @@ D.Num.to_float x)); + register1 "exp" t_int f_number (fun x -> D.Num.of_float (exp @@ D.Num.to_float x)); + register1 "ln" t_int f_number (fun x -> D.Num.of_float (log @@ D.Num.to_float x)); + + 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; + register1 "int" t_int f_number D.Num.floor; + register1 "rounddown" t_int f_number D.Num.round_down; + register1 "round" t_int f_number D.Num.round; + + register1 "trim" t_string f_string UTF8.trim; + register1 "right" t_string f_string (fun x -> UTF8.get x (-1)); + register2 "right" (t_string, t_int) f_string ( + fun t n -> + let n' = D.Num.to_int n in + UTF8.sub t (-(n')) n' + ); + register1 "left" t_string f_string (fun x -> UTF8.get x 0); + register2 "left" (t_string, t_int) f_string ( + fun t n -> + let n' = D.Num.to_int n in + UTF8.sub t 0 n' + ); + register1 "len" t_string f_number (fun x -> D.Num.of_int @@ UTF8.length x); + register1 "lenb" t_string f_number (fun x -> D.Num.of_int @@ String.length @@ UTF8.to_utf8string x); + register1 "lower" t_string f_string UTF8.lower; + register1 "unicode" t_string f_number (fun x -> D.Num.of_int @@ UTF8.code x); + register1 "unichar" t_int f_string (fun x -> UTF8.char @@ D.Num.to_int x); + register1 "upper" t_string f_string UTF8.upper; + register3 "substitute" (t_string, t_string, t_string) f_string UTF8.replace; + register2 "rept" (t_string, t_int) f_string (fun t n -> UTF8.repeat (D.Num.to_int n) t); + + 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_); + register1 "not" t_bool f_bool D.Bool.not; + register2 "and" (t_bool, t_bool) f_bool D.Bool.and_; +(* fold "and" t_bool f_bool D.Bool.and_ (D.Bool.true_); *) + register2 "or" (t_bool, t_bool) f_bool D.Bool.or_; +(* fold "or" t_bool f_bool D.Bool.or_ (D.Bool.false_); *) + register2 "xor" (t_bool, t_bool) f_bool D.Bool.neq; +(* fold "xor" t_bool f_bool D.Bool.neq (D.Bool.false_); *) + + let module CompareString = Make_Compare(D.String) in + 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); + + register2 "^" (t_int, t_int) f_number D.Num.pow; + register2 "power" (t_int, t_int) f_number D.Num.pow; + + register2 "gcd"(t_int, t_int) f_number D.Num.gcd; + register2 "lcm"(t_int, t_int) f_number D.Num.lcm; + register1 "+" t_int f_num (fun x -> x); + register1 "-" t_int f_num D.Num.neg; (* Unary negation *) + register2 "+" (t_int, t_int) f_num D.Num.add; + register2 "-" (t_int, t_int) f_num D.Num.sub; + register2 "*" (t_int, t_int) f_number D.Num.mult; + register2 "/" (t_int, t_int) f_number D.Num.div; + + ) + +end + diff --git a/src/evaluator.mli b/src/evaluator.mli new file mode 100755 index 0000000..b296b90 --- /dev/null +++ b/src/evaluator.mli @@ -0,0 +1,66 @@ +type t + +val eval: (ScTypes.refs -> ScTypes.result option ScTypes.Refs.range) -> ScTypes.expression -> ScTypes.result + +val repr: Format.formatter -> t -> unit + +val get_catalog: unit -> t + +(** Type definitions *) + +type 'a typ +val t_bool: DataType.Bool.t typ +val t_int: DataType.Num.t typ +val t_string: UTF8.t typ +val t_list: 'a typ -> 'a list typ + +(** Result formats *) + +type 'a returnType + +(** Numeric (any format) *) +val f_num: DataType.Num.t returnType + +(** Date *) +val f_date: DataType.Num.t returnType + +(** Number *) +val f_number: DataType.Num.t returnType + +(** Boolean result *) +val f_bool: DataType.Bool.t returnType + +(** String *) +val f_string: DataType.String.t returnType + +(** Catalog *) + +val register0: + string -> (* The function name *) + 'a returnType -> (* The return type *) + (unit -> 'a) (* The function to call *) + -> unit + +val register1: + string -> (* The function name *) + 'a typ -> (* The signature *) + 'b returnType -> (* The return type *) + ('a -> 'b) (* The function to call *) + -> unit + +val register2: + string -> (* The function name *) + ('a typ * 'b typ) ->(* The signature *) + 'c returnType -> (* The return type *) + ( 'a -> 'b -> 'c) (* The function to call*) + -> unit + +val register3: + string -> (* The function name *) + ('a typ * 'b typ * 'c typ) ->(* The signature *) + 'd returnType -> (* The return type *) + ( 'a -> 'b -> 'c -> 'd) (* The function to call*) + -> unit + +(** [wrap f] run [f] inside a context where there is no functions *) +val wrap: (unit -> 'a) -> 'a diff --git a/src/expression.ml b/src/expression.ml new file mode 100755 index 0000000..20227ad --- /dev/null +++ b/src/expression.ml @@ -0,0 +1,114 @@ +module Tuple2 = Tools.Tuple2 + +let u = UTF8.from_utf8string + +type t = + | Basic: 'a ScTypes.types -> t (** A direct type *) + | Formula: formula -> t (** A formula *) + | Undefined: t (** The content is not defined *) + +and formula = + | Expression of ScTypes.expression (** A valid expression *) + | Error of int * UTF8.t (** When the expression cannot be parsed *) + + +let is_defined = function + | Undefined -> false + | _ -> true + +let load content = begin + let content = UTF8.to_utf8string content in + 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 ( + (* 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 r = + ExpressionParser.content ExpressionLexer.read + @@ Lexing.from_string content' in + Basic r + with _ -> Basic (ScTypes.string (UTF8.from_utf8string content')) + ) + ) else ( + (* If the string in empty, build an undefined value *) + Undefined + ) +end + + +let load_expr expr = expr + + +(** Extract the parameters to give to a function. + return an Error if one of them is an error + *) +let eval expr sources = begin + + let eval_exp f = Evaluator.eval sources f in + + begin try match expr with + | Basic value -> ScTypes.Result value + | Formula (Expression f) -> eval_exp f + | Formula (Error (i, s)) -> ScTypes.Error ScTypes.Error + | Undefined -> ScTypes.Error Not_found + with ex -> ScTypes.Error ex + end + +end + +let collect_sources expr = begin + let rec collect refs = function + | ScTypes.Ref r -> + begin match ScTypes.Refs.collect r with + | ScTypes.Refs.Single r -> Cell.Set.add r refs + | ScTypes.Refs.Array1 a1 -> + List.fold_left (fun set elt -> Cell.Set.add elt set) refs a1 + | ScTypes.Refs.Array2 a2 -> + List.fold_left (List.fold_left (fun set elt -> Cell.Set.add elt set)) refs a2 + end + | ScTypes.Call (ident, params) -> List.fold_left collect refs params + | ScTypes.Expression f -> collect refs f + | _ -> refs + in match expr with + | Formula (Expression f) -> collect Cell.Set.empty f + | _ -> Cell.Set.empty +end + +let show e = + let buffer = UTF8.Buffer.create 16 in + begin match e with + | Formula (Expression f) -> + UTF8.Buffer.add_char buffer '='; + ScTypes.show_expr buffer f + | Basic b -> ScTypes.Type.show_full buffer b + | Formula (Error (i,s)) -> UTF8.Buffer.add_string buffer s + | Undefined -> () + end; + UTF8.Buffer.contents buffer + +let shift vector = + + let rec shift_exp: ScTypes.expression -> ScTypes.expression = function + | ScTypes.Value v -> ScTypes.Value v + | ScTypes.Call (ident, params) -> ScTypes.Call (ident, List.map shift_exp params) + | ScTypes.Ref r -> ScTypes.Ref (ScTypes.Refs.shift vector r) + | ScTypes.Expression expr -> ScTypes.Expression (shift_exp expr) + + in function + | Formula (Expression f) -> Formula (Expression (shift_exp f)) + | other -> other + +let (=) t1 t2 = match t1, t2 with + | Basic b1, Basic b2 -> ScTypes.Type.(=) b1 b2 + | o1, o2 -> Pervasives.(=) o1 o2 diff --git a/src/expression.mli b/src/expression.mli new file mode 100755 index 0000000..8cab479 --- /dev/null +++ b/src/expression.mli @@ -0,0 +1,29 @@ +type t = + | Basic: 'a ScTypes.types -> t (** A direct type *) + | Formula: formula -> t (** A formula *) + | Undefined: t (** The content is not defined *) + +and formula = + | Expression of ScTypes.expression (** A valid expression *) + | Error of int * UTF8.t (** When the expression cannot be parsed *) + + +(** Load an expression *) +val load: UTF8.t -> t + +val load_expr: t -> t + +val is_defined: t -> bool + +(** Evaluate the expression *) +val eval: t -> (ScTypes.refs -> ScTypes.result option ScTypes.Refs.range) -> ScTypes.result + +(** Collect all the cell referenced in the expression *) +val collect_sources: t -> Cell.Set.t + +(** Represent an expression *) +val show: t -> UTF8.t + +val shift: (int * int) -> t -> t + +val (=): t -> t -> bool diff --git a/src/expressionLexer.mll b/src/expressionLexer.mll new file mode 100755 index 0000000..2d2f87e --- /dev/null +++ b/src/expressionLexer.mll @@ -0,0 +1,84 @@ +{ + open ExpressionParser + open Lexing + + exception SyntaxError of string +} + +let digit = ['0'-'9'] +let real = digit+ '.'? | digit* '.' digit+ + + +let newline = "\r\n" | '\n' | '\r' +let space = ['\t' ' '] | newline + +let letters = ['A'-'Z' 'a'-'z'] + +let text = letters | digit + +let cell = letters+ digit+ + +rule read = parse + | space+ { read lexbuf } + + | digit+ as _1 { NUM _1} + | real as _1 { REAL(Tools.String.filter_float _1)} + | '$' { DOLLAR } + + | '=' { EQ } + | "<>" { NEQ } + | '<' { LT } + | "<=" { LE } + | '>' { GT } + | ">=" { GE } + | '*' { TIMES } + | '+' { PLUS } + | '-' { MINUS } + | '/' { DIVIDE } + | '"' { read_string (Buffer.create 17) lexbuf } + | ';' { SEMICOLON } + | ':' { COLON } + | '(' { LPAREN } + | ')' { RPAREN } + | '^' { POW } + + | letters+ as _1 { LETTERS _1} + + | '\000' { EOF } + | eof { EOF } + +and read_string buf = parse + | '"' { STR (Buffer.contents buf) } + | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } + | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } + | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } + | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } + | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } + | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } + | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } + | '\\' '"' { Buffer.add_char buf '"'; read_string buf lexbuf } + | [^ '"' '\\' '\000']+ + { Buffer.add_string buf (Lexing.lexeme lexbuf); + read_string buf lexbuf + } + | '\000' { STR (Buffer.contents buf) } + | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } + | eof { STR ( Buffer.contents buf) } + +and quoteless_string buf = parse + | '\\' '/' { Buffer.add_char buf '/'; quoteless_string buf lexbuf } + | '\\' '\\' { Buffer.add_char buf '\\'; quoteless_string buf lexbuf } + | '\\' 'b' { Buffer.add_char buf '\b'; quoteless_string buf lexbuf } + | '\\' 'f' { Buffer.add_char buf '\012'; quoteless_string buf lexbuf } + | '\\' 'n' { Buffer.add_char buf '\n'; quoteless_string buf lexbuf } + | '\\' 'r' { Buffer.add_char buf '\r'; quoteless_string buf lexbuf } + | '\\' 't' { Buffer.add_char buf '\t'; quoteless_string buf lexbuf } + | '\\' '"' { Buffer.add_char buf '"'; quoteless_string buf lexbuf } + | [^ '\\' '\000']+ + { Buffer.add_string buf (Lexing.lexeme lexbuf); + quoteless_string buf lexbuf + } + | '\000' { STR (Buffer.contents buf) } + | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } + | eof { STR (Buffer.contents buf) } + diff --git a/src/expressionParser.mly b/src/expressionParser.mly new file mode 100755 index 0000000..b7f77ae --- /dev/null +++ b/src/expressionParser.mly @@ -0,0 +1,113 @@ +%{ + open ScTypes + module F = Functions + + let u = UTF8.from_utf8string + + let extractColumnNameFromNum (fixed, (str, value)) = (fixed, value) + +%} + +%token REAL +%token NUM +%token STR + +%token LETTERS + +%token DOLLAR + +%token LPAREN +%token RPAREN +%token PLUS +%token TIMES +%token DIVIDE +%token MINUS +%token EQ NEQ +%token LT LE GT GE +%token EOF +%token SEMICOLON +%token COLON +%token POW + +%nonassoc EQ NEQ LT LE GT GE +%left PLUS MINUS +%left TIMES DIVIDE +%left POW + +%start value +%start content + +%% + +value: + | EQ expr EOF {$2} + +content: + | basic EOF {$1} + +basic: + | PLUS num {Result (number $2)} + | MINUS num {Result (number (DataType.Num.neg $2))} + | num {Result (number $1)} + | NUM DIVIDE NUM DIVIDE NUM {Result ( + date ( + DataType.Date.get_julian_day + (int_of_string $1) + (int_of_string $3) + (int_of_string $5) + ))} + | NUM COLON NUM COLON NUM {Result ( + date ( + let nhour = DataType.Num.div (DataType.Num.of_int @@ int_of_string $1) (DataType.Num.of_int 24) + and nmin = DataType.Num.div (DataType.Num.of_int @@ int_of_string $3) (DataType.Num.of_int 1440) + and nsec = DataType.Num.div (DataType.Num.of_int @@ int_of_string $5) (DataType.Num.of_int 86400) + in DataType.Num.add (DataType.Num.add nhour nmin) nsec + ) + )} + +expr: + | num {Value (number ($1))} + | MINUS expr {Call (F.sub, [$2])} + | PLUS expr {Call (F.add, [$2])} + + | LETTERS ident LPAREN separated_list(SEMICOLON, expr) RPAREN { Call (u($1 ^ $2), $4) } + + + | cell {Ref (Cell $1)} + | cell COLON cell {Ref (Range ($1, $3))} + + + | LPAREN expr RPAREN {Expression $2} + | STR {Value (string (u $1))} + + (* Mathematical operators *) + | expr MINUS expr {Call (F.sub, [$1; $3])} + | expr DIVIDE expr {Call (F.div, [$1; $3])} + | expr TIMES expr {Call (F.mul, [$1; $3])} + | expr PLUS expr {Call (F.add, [$1; $3])} + | expr POW expr {Call (F.pow, [$1; $3])} + + (* Comparaison *) + | expr EQ expr {Call (F.eq, [$1; $3])} + | expr NEQ expr {Call (F.neq, [$1; $3])} + | expr LT expr {Call (F.lt, [$1; $3])} + | expr GT expr {Call (F.gt, [$1; $3])} + | expr LE expr {Call (F.le, [$1; $3])} + | expr GE expr {Call (F.ge, [$1; $3])} + +%inline cell: + | LETTERS NUM { Cell.from_string (false, $1) (false, int_of_string $2) } + | DOLLAR LETTERS NUM { Cell.from_string (true, $2) (false, int_of_string $3) } + | LETTERS DOLLAR NUM { Cell.from_string (false, $1) (true, int_of_string $3) } + | DOLLAR LETTERS DOLLAR NUM { Cell.from_string (true, $2) (true, int_of_string $4) } + +num: + | REAL {DataType.Num.of_float @@ float_of_string $1} + | NUM {DataType.Num.of_int @@ int_of_string $1} + +ident: + | text* { String.concat "" $1 } + +text: + | LETTERS { $1 } + | NUM { $1 } diff --git a/src/functions.ml b/src/functions.ml new file mode 100755 index 0000000..56d7530 --- /dev/null +++ b/src/functions.ml @@ -0,0 +1,14 @@ +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"-" diff --git a/src/main.ml b/src/main.ml new file mode 100755 index 0000000..3b83e85 --- /dev/null +++ b/src/main.ml @@ -0,0 +1,241 @@ +let u = UTF8.from_utf8string + +let redraw t screen = + let screen' = + Screen.draw t screen + |> Screen.draw_input t in + t, screen' + +let action f msg (t, screen) = begin + let t', count = f t in + let t', screen' = redraw t' screen in + Screen.status screen' @@ UTF8.from_utf8string (Printf.sprintf msg count); + t', screen' +end + +let f screen = ActionParser.( + begin match Screen.read_key screen with + | "\027" -> ESC + | "\001\002" -> DOWN + | "\001\003" -> UP + | "\001\004" -> LEFT + | "\001\005" -> RIGHT + | "\001\006" -> HOME + | "\001\104" -> END + + | "\001R" -> NPAGE + | "\001S" -> PPAGE + + (* See http://www.ibb.net/~anne/keyboard.html for thoses keycode. *) + | "\001\074"|"\127" -> DELETE + + | "e" -> E + | "u" -> U + | "v" -> V + | "y" -> Y + | "p" -> P + | "=" -> EQUAL + | "/" -> SEARCH + | ":" -> COMMAND + + | "\001\154" -> RESIZE + | "\001\153" -> + begin match Tools.NCurses.get_mouse_event () with + | None -> raise Not_found + | Some (id, ev, (x, y, z)) -> + if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_CLICKED ev then + BUTTON1_CLICKED(x, y) + else if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_PRESSED ev then + BUTTON1_CLICKED(x, y) + else if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_RELEASED ev then + BUTTON1_RELEASED(x, y) + else + raise Not_found + end + | _ -> raise Not_found +end) + +let parser screen = begin + let get_value () = f screen, Lexing.dummy_pos, Lexing.dummy_pos in + MenhirLib.Convert.Simplified.traditional2revised ActionParser.normal get_value +end + +let rec normal_mode (t, screen) = begin + match (parser screen) with + | exception x -> normal_mode (t, screen) + + | Actions.Visual -> + Screen.status screen @@ u"-- Selection --"; + selection_mode (t, screen) + + | Actions.Move direction -> + begin match Sheet.move direction t with + | Some t' -> normal_mode @@ redraw t' screen + | None -> normal_mode (t, screen) + end + + | Actions.Resize -> normal_mode (t, Screen.resize t screen) + + | Actions.Delete -> + let yank_before_delete = fun x -> Sheet.delete (fst (Sheet.yank x)) in + normal_mode @@ action yank_before_delete "Deleted %d cells" (t, screen) + + | Actions.Yank -> + normal_mode @@ action Sheet.yank "Yanked %d cells" (t, screen) + + | Actions.Paste -> + normal_mode @@ action Sheet.paste "Pasted %d cells" (t, screen) + + | Actions.Undo -> + begin match Sheet.undo t with + | Some t' -> normal_mode @@ redraw t' screen + | None -> normal_mode (t, screen) + end + + (* Edit a content *) + | Actions.Edit -> + let position = Selection.extract t.Sheet.selected in + let expr = Sheet.Raw.get_expr position t.Sheet.data + |> Expression.show in + begin match Screen.editor ~position ~prefix:(u"-> ") ~init:expr screen with + | None -> + (* Restore the previous value *) + Screen.status screen expr; + normal_mode (t, screen) + | Some content -> + let expr' = Expression.load content in + let _, t' = Sheet.add expr' t in + normal_mode @@ redraw t' screen + end + + (* Insert a new formula, the actual value will be erased *) + | Actions.InsertFormula -> + let position = Selection.extract t.Sheet.selected in + begin match Screen.editor ~position ~init:(u"=") screen with + | None -> + (* Restore the previous value *) + let expr = Sheet.Raw.get_expr position t.Sheet.data + |> Expression.show in + Screen.status screen expr; + normal_mode (t, screen) + | Some content -> + let expr = Expression.load content in + let _, t' = Sheet.add expr t in + normal_mode @@ redraw t' screen + end + + | Actions.Search -> + let expr = Screen.search screen + |> Expression.load in + let pattern = Expression.eval expr (fun _ -> ScTypes.Refs.Single None) in + begin match Sheet.search (`Pattern (Some pattern)) t with + | Some t' -> normal_mode @@ redraw t' screen + | None -> normal_mode (t, screen) + end + + | Actions.Button1_clicked coord -> + begin match Screen.get_cell screen coord with + | None -> normal_mode (t, screen) + | Some (x,y) -> begin match Sheet.move (Actions.Absolute (x,y)) t with + | Some t' -> normal_mode @@ redraw t' screen + | None -> normal_mode (t, screen) + end + end + + | Actions.Button1_released coord -> + begin match Screen.get_cell screen coord with + | Some (x,y) when (x,y) <> (Selection.extract t.Sheet.selected) -> + Screen.status screen @@ u"-- Selection -- "; + let t' = { t with + Sheet.selected = Selection.extends (Actions.Absolute (x,y)) t.Sheet.selected + } in + let screen' = Screen.draw t' screen in + selection_mode (t', screen') + | _ -> normal_mode (t, screen) + end + + | Actions.Command -> + begin match Screen.editor ~prefix:(u":") screen with + | None -> + normal_mode (t, screen) + | Some content -> + let args = try + UTF8.to_utf8string content + |> Tools.String.split ~by:' ' + with Not_found -> + (UTF8.to_utf8string content, "") in + command (t, screen) args + end + + | _ -> normal_mode (t, screen) + +end + +and selection_mode (t, screen) = begin + match (parser screen) with + | exception x -> selection_mode (t, screen) + + | Actions.Resize -> selection_mode (t, Screen.resize t screen) + + | Actions.Delete -> + let yank_before_delete = fun x -> Sheet.delete (fst (Sheet.yank x)) in + normal_mode @@ action yank_before_delete "Deleted %d cells" (t, screen) + + | Actions.Yank -> + normal_mode @@ action Sheet.yank "Yanked %d cells" (t, screen) + + | Actions.Escape -> + let t' = { t with Sheet.selected = Selection.create (Selection.extract t.Sheet.selected) } in + let screen' = Screen.draw t' screen + |> Screen.draw_input t' in + Screen.status screen UTF8.empty; + normal_mode (t', screen') + + | Actions.Move m -> + let t' = { t with Sheet.selected = Selection.extends m t.Sheet.selected } in + let screen' = Screen.draw t' screen in + selection_mode (t', screen') + + | Actions.Button1_clicked coord -> + begin match Screen.get_cell screen coord with + | None -> normal_mode (t, screen) + | Some (x,y) -> begin match Sheet.move (Actions.Absolute (x,y)) t with + | Some t' -> + Screen.status screen UTF8.empty; + normal_mode @@ redraw t' screen + | None -> normal_mode (t, screen) + end + end + + | _ -> selection_mode (t, screen) +end + +and command (t, screen) action = begin + match action with + | ("w", file) -> (* Save the file *) + Odf.save t.Sheet.data file; + normal_mode @@ redraw t screen + | ("repr", file) -> (* Save the file *) + let out_gv = open_out_bin file in + let form = Format.formatter_of_out_channel out_gv in + Evaluator.repr form (Evaluator.get_catalog ()); + close_out out_gv; + normal_mode @@ redraw t screen + | ("enew", _) -> (* Start a new spreadsheet *) + normal_mode @@ redraw (Sheet.create Sheet.Raw.empty) screen + | ("q", _) -> (* Quit *) + t + | _ -> normal_mode @@ redraw t screen +end + +let () = begin + + let sheet = + if Array.length Sys.argv = 1 then + Sheet.Raw.empty + else + Odf.load Sys.argv.(1) in + + Screen.run (fun window -> + ignore @@ normal_mode @@ redraw (Sheet.create sheet) window) +end diff --git a/src/odf/odf.ml b/src/odf/odf.ml new file mode 100755 index 0000000..ae120d9 --- /dev/null +++ b/src/odf/odf.ml @@ -0,0 +1,346 @@ +module Xml = Ezxmlm +module T = Tools +module NS = Odf_ns + +let u = UTF8.from_utf8string + +type t + +(** Map for storing all the attributes *) +module AttributesMap = Map.Make (struct + type t = string * string + let compare = Pervasives.compare +end) + +let get_attr map key = begin + try Some (AttributesMap.find key map) with + Not_found -> None +end + +let load_formula formula = + let lineBuffer = Lexing.from_string formula in + try + Expression.Formula ( + Expression.Expression ( + Odf_ExpressionParser.value Odf_ExpressionLexer.read lineBuffer)) + with e -> + print_endline formula; + raise e + + +let load_content content = begin function + | "float" -> Expression.Basic ( + ScTypes.number ( + DataType.Num.of_float (float_of_string content) + )) + | "date" -> Expression.Basic ( + ScTypes.date ( + DataType.Num.of_float (float_of_string content) + )) + | _ -> Expression.Basic ( + ScTypes.string ( + UTF8.from_utf8string content)) +end + +(** Load the content from a cell *) +let load_cell sheet cell_num row_num changed (attrs, cell) = begin + + (* Load all the attributes from the xml element *) + let add_attr map (key, value) = AttributesMap.add key value map in + let attributes = List.fold_left add_attr AttributesMap.empty attrs in + + (* Check if the content is repeated *) + let repetition = match get_attr attributes NS.number_columns_repeat_attr with + | None -> 1 + | Some x -> int_of_string x + + (* cell width *) + and cell_width = match get_attr attributes NS.number_columns_spanned_attr with + | None -> 1 + | Some x -> int_of_string x in + + let vtype = + try List.assoc NS.ovalue_type_attr attrs + with Not_found -> "" in + + let formula = get_attr attributes NS.formula_attr + and value = get_attr attributes NS.value_attr in + + let expression, update = begin match formula, value with + | Some x, _ -> load_formula x, true + | _, Some x -> + (load_content x vtype) , true + | _ -> + begin try + Xml.member "p" cell + |> Xml.data_to_string + |> fun x -> (load_content x vtype, true) + with Xml.Tag_not_found _ -> Expression.Undefined, false + end + end in + + if update then ( + for i = 1 to repetition do + cell_num := !cell_num + cell_width; + sheet := snd @@ Sheet.Raw.add (!cell_num, !row_num) (Expression.load_expr expression) !sheet + done + ) else ( + cell_num := !cell_num + (repetition * cell_width ) + ); + changed || update +end + +let load_row sheet row_num (attrs, row) = begin + + let repetition = + try int_of_string @@ List.assoc (NS.table, "number-rows-repeated") attrs + with Not_found -> 1 in + + let cells = Xml.members_with_attr "table-cell" row in + + try + for i = 1 to repetition do + incr row_num; + let cell_num = ref 0 in + if not (List.fold_left (load_cell sheet cell_num row_num) false cells) then + (* No changes on the whole row. Do not repeat, and break the loop *) + raise Not_found + done + with Not_found -> row_num := !row_num + repetition - 1 +end + +let load_xml input = begin + + let sheet = ref Sheet.Raw.empty in + let row_num = ref 0 in + + let xml = + Xmlm.make_input ~enc:(Some `UTF_8) (`Channel input) + |> Xml.from_input + |> snd in + let rows = Xml.member "document-content" (xml::[]) + |> Xml.member "body" + |> Xml.member "spreadsheet" + |> Xml.member "table" + |> Xml.members_with_attr "table-row" in + List.iter (fun x -> (load_row sheet row_num) x) rows; + !sheet +end + + +let load file = + let tmp_file = Filename.temp_file "content" ".xml" in + Unix.unlink tmp_file; + + let zip = Zip.open_in file in + let content = Zip.find_entry zip "content.xml" in + Zip.copy_entry_to_file zip content tmp_file; + + let input = open_in_bin tmp_file in + Tools.try_finally + (fun () -> load_xml input) + (fun () -> + close_in input; + Unix.unlink tmp_file; + Zip.close_in zip + ) + + +let write_type ovalue_type cvalue_type attrs output value = begin + let attrs = + (NS.ovalue_type_attr, ovalue_type):: + (NS.cvalue_type_attr, cvalue_type):: + attrs in + + Xmlm.output output (`El_start (NS.table_cell_node, attrs)); + Xmlm.output output (`El_start (NS.text_node, [])); + Xmlm.output output (`Data value); + Xmlm.output output `El_end; + Xmlm.output output `El_end; +end + +(* Writers for differents types *) +let write_num = write_type "float" "float" +let write_str = write_type "string" "string" +let write_bool = write_type "bool" "bool" +let write_error = write_type "string" "error" +let write_date = write_type "date" "date" + +let write_basic: type a. 'b list -> Xmlm.output -> a ScTypes.types -> unit = fun attrs output types -> begin match types with + | ScTypes.Str s -> write_str attrs output (UTF8.to_utf8string s) + | ScTypes.Bool b -> write_bool attrs output (string_of_bool b) + | ScTypes.Num (data_type, d) -> + begin match ScTypes.get_numeric_type data_type with + | ScTypes.Number -> + let f = DataType.Num.to_float d in + let value = string_of_float f in + write_num ((NS.value_attr, value)::attrs) output value + | ScTypes.Date -> + let value = DataType.Date.to_string d in + write_date ((NS.date_value_attr, value)::attrs) output value + end +end + +let write_formula output attrs f = begin function + | ScTypes.Result x -> write_basic attrs output x + | ScTypes.Error exn -> write_str attrs output "#NAME?" +end + +let print_ref buffer c = + UTF8.Buffer.add_string buffer @@ u"[."; + begin match c with + | ScTypes.Cell c -> UTF8.Buffer.add_string buffer @@ Cell.to_string c; + | ScTypes.Range (c1, c2) -> + UTF8.Buffer.add_string buffer @@ Cell.to_string c1; + UTF8.Buffer.add_string buffer @@ u":."; + UTF8.Buffer.add_string buffer @@ Cell.to_string c2; + end; + UTF8.Buffer.add_string buffer @@ u"]" + +let rec print_expr : UTF8.Buffer.buffer -> ScTypes.expression -> unit = fun buffer -> begin function + | ScTypes.Value (ScTypes.Str s) -> + UTF8.Printf.bprintf buffer "\"%s\"" (UTF8.to_utf8string s) + | ScTypes.Value (ScTypes.Bool b) -> + u(string_of_bool b) + |> UTF8.Buffer.add_string buffer + | ScTypes.Value (ScTypes.Num (data_type, d)) -> + begin match ScTypes.get_numeric_type data_type with + | ScTypes.Number -> + let f = DataType.Num.to_float d in + UTF8.Buffer.add_string buffer @@ u(string_of_float f) + | ScTypes.Date -> + DataType.Date.to_string d + |> u + |> UTF8.Buffer.add_string buffer + end + | ScTypes.Ref r -> print_ref buffer r + | ScTypes.Expression x -> + UTF8.Buffer.add_char buffer '('; + print_expr buffer x; + UTF8.Buffer.add_char buffer ')'; + | ScTypes.Call (ident, params) -> + begin match (UTF8.to_utf8string ident) with + | "+" | "*" | "-" | "/" | "^" | "=" + | "<>" | "<=" | ">=" | "<" | ">" -> begin match params with + | v1::[] -> + UTF8.Printf.bprintf buffer "%s%a" + (UTF8.to_utf8string ident) + print_expr v1 + | v1::v2::[] -> + UTF8.Printf.bprintf buffer "%a%s%a" + print_expr v1 + (UTF8.to_utf8string ident) + print_expr v2 + | _ -> + UTF8.Buffer.add_string buffer ident; + Tools.List.printb ~sep:(u";") print_expr buffer params + end + | _ -> + UTF8.Buffer.add_string buffer ident; + Tools.List.printb ~sep:(u";") print_expr buffer params + end +end + +let write_cell output value = begin function + | Expression.Undefined -> () + | Expression.Basic b -> write_basic [] output b + | Expression.Formula (Expression.Expression f) -> + let buffer = UTF8.Buffer.create 10 in + print_expr buffer f; + let formula = UTF8.Buffer.contents buffer + |> UTF8.to_utf8string in + write_formula output [(NS.formula_attr, ("of:=" ^formula))] f value + | Expression.Formula (Expression.Error (i, s)) -> + write_error [(NS.formula_attr, ("of:" ^ (UTF8.to_utf8string s)))] output (UTF8.to_utf8string s) +end + +(** Jump to the wanted position *) +let goto output (from_x, from_y) (to_x, to_y) :unit = begin + + (** Insert as many rows than required *) + let insert_rows count = begin + (* Close the previous openend rows *) + Xmlm.output output `El_end; + + if (count > 1) then ( + Xmlm.output output ( + `El_start ( + NS.table_row_node, [(NS.table_row_repeat_attr, string_of_int (count-1))])); + Xmlm.output output (`El_start (NS.table_cell_node, [])); + Xmlm.output output `El_end; + Xmlm.output output `El_end; + ); + Xmlm.output output (`El_start (NS.table_row_node, [])); + 1 + end + + (** Insert as many cells as required *) + and insert_cells count = begin + Xmlm.output output ( + `El_start ( + NS.table_cell_node, [(NS.number_columns_repeat_attr, string_of_int count)])); + Xmlm.output output `El_end; + end in + + (* Insert empty rows or columns until the desired position *) + let jump_row = to_y - from_y in + let from_x' = + if jump_row > 0 then + insert_rows jump_row + else + from_x in + let jump_cell = to_x - from_x' in + if jump_cell > 0 then + insert_cells jump_cell +end + +(** Write the cell content and return the updated position *) +let f output cursor position (expr, value) = begin + + goto output cursor position; + + (* Write the value *) + write_cell output value expr; + + (* Return the update position *) + Tools.Tuple2.map1 ((+) 1) position +end + +let save sheet file = begin + let tmp_file = Filename.temp_file "content" ".xml" in + Unix.unlink tmp_file; + let out_channel = open_out_bin tmp_file in + let zip = Zip.open_out file in + + let manifest = "\ +\ +\ + +" in + + Tools.try_finally (fun () -> + + let output = Xmlm.make_output (`Channel out_channel) in + Xmlm.output output (`Dtd None); + Xmlm.output output (`El_start (NS.document_content_node, NS.name_spaces())); + Xmlm.output output (`El_start (NS.body_node, [])); + Xmlm.output output (`El_start (NS.spreadsheet_node, [])); + Xmlm.output output (`El_start (NS.table_node, [])); + + Xmlm.output output (`El_start (NS.table_row_node, [])); + ignore (Sheet.Raw.fold (f output) (1,1) sheet); + Xmlm.output output `El_end; + + Xmlm.output output `El_end; + Xmlm.output output `El_end; + Xmlm.output output `El_end; + Xmlm.output output `El_end; + + close_out out_channel; + Zip.copy_file_to_entry tmp_file zip "content.xml"; + Zip.add_entry manifest zip "META-INF/manifest.xml" + ) (fun () -> + Zip.close_out zip; + Unix.unlink tmp_file + ) +end diff --git a/src/odf/odf_ExpressionLexer.mll b/src/odf/odf_ExpressionLexer.mll new file mode 100755 index 0000000..7f6a55b --- /dev/null +++ b/src/odf/odf_ExpressionLexer.mll @@ -0,0 +1,93 @@ +{ + open Odf_ExpressionParser + open Lexing + + exception SyntaxError of string +} + +let digit = ['0'-'9'] +let real = digit+ | digit* '.' digit+ | digit+ '.' digit* + + +let newline = "\r\n" | '\n' | '\r' +let space = ['\t' ' '] | newline + +let letters = ['A'-'Z' 'a'-'z'] + +(* Function identifier. + Valid identifiers are : + ORG.OPENOFFICE.DAYSINMONTH + it cannot end with a digit. + *) +let identifier = letters (letters | digit | ['-' '_' '.'])* letters+ + +let cell = letters+ digit+ + +rule read = parse + | space+ { read lexbuf } + + | digit+ as _1 { NUM _1} + | real as _1 { REAL (Tools.String.filter_float _1)} + | '$' { DOLLAR } + + | '=' { EQ } + | "<>" { NEQ } + | '<' { LT } + | "<=" { LE } + | '>' { GT } + | ">=" { GE } + | '*' { TIMES } + | '+' { PLUS } + | '-' { MINUS } + | '/' { DIVIDE } + | '"' { read_string (Buffer.create 16) lexbuf } + | ';' { SEMICOLON } + | ':' { COLON } + | '[' { L_SQ_BRACKET } + | ']' { R_SQ_BRACKET } + | '(' { LPAREN } + | ')' { RPAREN } + | '^' { POW } + | '.' { DOT } + + | letters+ as _1 { LETTERS _1} + | identifier as _1 { IDENT _1} + + | '\000' { EOF } + | eof { EOF } + +and read_string buf = parse + | '"' { STR (Buffer.contents buf) } + | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } + | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } + | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } + | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } + | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } + | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } + | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } + | '\\' '"' { Buffer.add_char buf '"'; read_string buf lexbuf } + | [^ '"' '\\' '\000']+ + { Buffer.add_string buf (Lexing.lexeme lexbuf); + read_string buf lexbuf + } + | '\000' { STR (Buffer.contents buf) } + | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } + | eof { STR ( Buffer.contents buf) } + +and quoteless_string buf = parse + | '\\' '/' { Buffer.add_char buf '/'; quoteless_string buf lexbuf } + | '\\' '\\' { Buffer.add_char buf '\\'; quoteless_string buf lexbuf } + | '\\' 'b' { Buffer.add_char buf '\b'; quoteless_string buf lexbuf } + | '\\' 'f' { Buffer.add_char buf '\012'; quoteless_string buf lexbuf } + | '\\' 'n' { Buffer.add_char buf '\n'; quoteless_string buf lexbuf } + | '\\' 'r' { Buffer.add_char buf '\r'; quoteless_string buf lexbuf } + | '\\' 't' { Buffer.add_char buf '\t'; quoteless_string buf lexbuf } + | '\\' '"' { Buffer.add_char buf '"'; quoteless_string buf lexbuf } + | [^ '\\' '\000']+ + { Buffer.add_string buf (Lexing.lexeme lexbuf); + quoteless_string buf lexbuf + } + | '\000' { STR (Buffer.contents buf) } + | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } + | eof { STR (Buffer.contents buf) } + diff --git a/src/odf/odf_ExpressionParser.mly b/src/odf/odf_ExpressionParser.mly new file mode 100755 index 0000000..6b571a9 --- /dev/null +++ b/src/odf/odf_ExpressionParser.mly @@ -0,0 +1,95 @@ +%{ + open ScTypes + module F = Functions + + let u = UTF8.from_utf8string + + let extractColumnNameFromNum (fixed, str) = (fixed, int_of_string str) + +%} + +%token REAL +%token NUM +%token STR + +%token LETTERS +%token IDENT + +%token DOLLAR +%token DOT + +%token LPAREN RPAREN +%token L_SQ_BRACKET R_SQ_BRACKET +%token PLUS +%token TIMES +%token DIVIDE +%token MINUS +%token EQ NEQ +%token LT LE GT GE +%token EOF +%token COLON SEMICOLON +%token POW + +%nonassoc EQ NEQ LT LE GT GE +%left PLUS MINUS +%left TIMES DIVIDE +%left POW + +%start value + +%% + +value: + | LETTERS COLON EQ expr EOF {$4} + +expr: + | num {Value (number ($1))} + | MINUS expr {Call (F.sub, [$2])} + | PLUS expr {Call (F.add, [$2])} + + + | L_SQ_BRACKET ref R_SQ_BRACKET {$2} + + | LPAREN expr RPAREN {Expression $2} + | STR {Value (string (u $1))} + + (* Mathematical operators *) + | expr MINUS expr {Call (F.sub, [$1; $3])} + | expr DIVIDE expr {Call (F.div, [$1; $3])} + | expr TIMES expr {Call (F.mul, [$1; $3])} + | expr PLUS expr {Call (F.add, [$1; $3])} + | expr POW expr {Call (F.pow, [$1; $3])} + + (* Comparaison *) + | expr EQ expr {Call (F.eq, [$1; $3])} + | expr NEQ expr {Call (F.neq, [$1; $3])} + | expr LT expr {Call (F.lt, [$1; $3])} + | expr GT expr {Call (F.gt, [$1; $3])} + | expr LE expr {Call (F.le, [$1; $3])} + | expr GE expr {Call (F.ge, [$1; $3])} + + | ident LPAREN separated_list(SEMICOLON, expr) RPAREN { Call (u $1, $3) } + + +ref: + | cell {Ref (Cell $1)} + | cell COLON cell {Ref (Range ($1, $3))} + +cell: + | DOT fixed(LETTERS) fixed(NUM){Cell.from_string $2 (extractColumnNameFromNum $3)} + +fixed(X): + | DOLLAR X {true, $2} + | X {false, $1} + +num: + | REAL {DataType.Num.of_float @@ float_of_string $1} + | NUM {DataType.Num.of_int @@ int_of_string $1} + +ident: + | IDENT { $1 } + | text+ { String.concat "" $1 } + +text: + | LETTERS { $1 } + | NUM { $1 } diff --git a/src/odf/odf_ns.ml b/src/odf/odf_ns.ml new file mode 100755 index 0000000..5a501da --- /dev/null +++ b/src/odf/odf_ns.ml @@ -0,0 +1,96 @@ +let ooo = "http://openoffice.org/2004/office" +let ooow = "http://openoffice.org/2004/writer" +let oooc = "http://openoffice.org/2004/calc" +let rpt = "http://openoffice.org/2005/report" +let tableooo = "http://openoffice.org/2009/table" +let drawooo = "http://openoffice.org/2010/draw" + +let dc = "http://purl.org/dc/elements/1.1/" + +let xhtml = "http://www.w3.org/1999/xhtml" +let grddl = "http://www.w3.org/2003/g/data-view#" +let css3t = "http://www.w3.org/TR/css3-text/" +let xlink = "http://www.w3.org/1999/xlink" +let dom = "http://www.w3.org/2001/xml-events" +let xforms = "http://www.w3.org/2002/xforms" +let xsd = "http://www.w3.org/2001/XMLSchema" +let xsi = "http://www.w3.org/2001/XMLSchema-instance" +let math = "http://www.w3.org/1998/Math/MathML" + +let office = "urn:oasis:names:tc:opendocument:xmlns:office:1.0" +let style = "urn:oasis:names:tc:opendocument:xmlns:style:1.0" +let text = "urn:oasis:names:tc:opendocument:xmlns:text:1.0" +let table = "urn:oasis:names:tc:opendocument:xmlns:table:1.0" +let draw = "urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" +let fo = "urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" +let meta = "urn:oasis:names:tc:opendocument:xmlns:meta:1.0" +let number = "urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" +let presentation= "urn:oasis:names:tc:opendocument:xmlns:presentation:1.0" +let svg = "urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" +let chart = "urn:oasis:names:tc:opendocument:xmlns:chart:1.0" +let dr3d = "urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" +let form = "urn:oasis:names:tc:opendocument:xmlns:form:1.0" +let script = "urn:oasis:names:tc:opendocument:xmlns:script:1.0" +let oof = "urn:oasis:names:tc:opendocument:xmlns:of:1.2" + +let calcext = "urn:org:documentfoundation:names:experimental:calc:xmlns:calcext:1.0" +let loext = "urn:org:documentfoundation:names:experimental:office:xmlns:loext:1.0" + +let field = "urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0" +let formx = "urn:openoffice:names:experimental:ooxml-odf-interop:xmlns:form:1.0" + +let document_content_node = (office, "document-content") +let body_node = (office, "body") +let spreadsheet_node = (office, "spreadsheet") +let table_node = (table, "table") +let table_row_node = (table, "table-row") + let table_row_repeat_attr = (table, "number-rows-repeated") + +let table_cell_node = (table, "table-cell") + let number_columns_repeat_attr = (table, "number-columns-repeated") + let cvalue_type_attr = (calcext, "value-type") + let ovalue_type_attr = (office, "value-type") + let value_attr = (office, "value") + let formula_attr = (table, "formula") + let date_value_attr = (office, "date-value") + let number_columns_spanned_attr = (table, "number-columns-spanned") + +let text_node = (text, "p") + +let name_spaces () = [ + (Xmlm.ns_xmlns, "office"), office; + (Xmlm.ns_xmlns, "style"), style; + (Xmlm.ns_xmlns, "text"), text; + (Xmlm.ns_xmlns, "table"), table; + (Xmlm.ns_xmlns, "draw"), draw; + (Xmlm.ns_xmlns, "fo"), fo; + (Xmlm.ns_xmlns, "xlink"), xlink; + (Xmlm.ns_xmlns, "dc"), dc; + (Xmlm.ns_xmlns, "meta"), meta; + (Xmlm.ns_xmlns, "number"), number; + (Xmlm.ns_xmlns, "presentation"),presentation; + (Xmlm.ns_xmlns, "svg"), svg; + (Xmlm.ns_xmlns, "chart"), chart; + (Xmlm.ns_xmlns, "dr3d"), dr3d; + (Xmlm.ns_xmlns, "math"), math; + (Xmlm.ns_xmlns, "form"), form; + (Xmlm.ns_xmlns, "script"), script; + (Xmlm.ns_xmlns, "ooo"), ooo; + (Xmlm.ns_xmlns, "ooow"), ooow; + (Xmlm.ns_xmlns, "oooc"), oooc; + (Xmlm.ns_xmlns, "dom"), dom; + (Xmlm.ns_xmlns, "xforms"), xforms; + (Xmlm.ns_xmlns, "xsd"), xsd; + (Xmlm.ns_xmlns, "xsi"), xsi; + (Xmlm.ns_xmlns, "rpt"), rpt; + (Xmlm.ns_xmlns, "of"), oof; + (Xmlm.ns_xmlns, "xhtml"), xhtml; + (Xmlm.ns_xmlns, "grddl"), grddl; + (Xmlm.ns_xmlns, "tableooo"), tableooo; + (Xmlm.ns_xmlns, "drawooo"), drawooo; + (Xmlm.ns_xmlns, "calcext"), calcext; + (Xmlm.ns_xmlns, "loext"), loext; + (Xmlm.ns_xmlns, "field"), field; + (Xmlm.ns_xmlns, "formx"), formx; + (Xmlm.ns_xmlns, "css3t"), css3t; +] diff --git a/src/scTypes.ml b/src/scTypes.ml new file mode 100755 index 0000000..48e4d3c --- /dev/null +++ b/src/scTypes.ml @@ -0,0 +1,354 @@ +(** All the types used in the spreadsheet. *) + +let u = UTF8.from_utf8string + +exception Error + +type cell = Cell.t + +type ident = UTF8.t + +type _ dataFormat = + | Date: DataType.Num.t dataFormat (* Date *) + | Number: DataType.Num.t dataFormat (* Number *) + | String: DataType.String.t dataFormat(* String *) + | Bool: DataType.Bool.t dataFormat (* Boolean *) + +type numericType = + | Date + | Number + +let get_numeric_type: DataType.Num.t dataFormat -> numericType = function + | Date -> Date + | Number -> Number + +type 'a types = + | Num : DataType.Num.t dataFormat * DataType.Num.t -> DataType.Num.t types (** A number *) + | Str : DataType.String.t -> DataType.String.t types (** A string *) + | Bool : DataType.Bool.t -> DataType.Bool.t types (** A boolean *) + +let number n = Num (Number, n) +let string s = Str s +let date d = Num (Date, d) +let boolean b = Bool b + + +type 'a returnType = + | Num : DataType.Num.t dataFormat option -> DataType.Num.t returnType (** A number *) + | Str : DataType.String.t returnType (** A string *) + | Bool : DataType.Bool.t returnType (** A boolean *) + + +let f_num: DataType.Num.t returnType = Num None +let f_date: DataType.Num.t returnType = Num (Some Date) +let f_number: DataType.Num.t returnType = Num (Some Number) +let f_string: DataType.String.t returnType = Str +let f_bool: DataType.Bool.t returnType = Bool + +type refs = + | Cell of cell (** A cell *) + | Range of cell * cell (** An area of cells *) + +type expression = + | Value : 'a types -> expression (** A direct value *) + | Ref : refs -> expression (** A reference to another cell *) + | Call : ident * expression list -> expression (** A call to a function *) + | Expression : expression -> expression (** An expression *) + +(** Result from a computation *) +type result = + | Result : 'a types -> result + | Error : exn -> result + +module DataFormat = struct + + type formats = F : 'a dataFormat -> formats [@@unboxed] + + let priority: type a. a dataFormat -> int = function + | Date -> 1 + | Number -> 0 + | String -> 0 + | Bool -> 0 + + let collect_format: DataType.Num.t dataFormat -> formats -> DataType.Num.t dataFormat = begin + fun dataFormat -> function + | F Date -> Date + | _ -> dataFormat + end + + let guess_format_result: type a. a returnType -> (unit -> formats list) -> a dataFormat = + fun return params -> begin match return with + | Str -> String + | Bool -> Bool + | Num (Some x) -> x + | Num None -> List.fold_left collect_format Number (params ()) + end + + let default_value_for: type a. a dataFormat -> a = function + | Date -> DataType.Num.zero + | Number -> DataType.Num.zero + | Bool -> false + | String -> UTF8.empty + + type ('a, 'b) equality = Eq : ('a, 'a) equality + + let compare_format: type a b. a dataFormat -> b dataFormat -> (a, b) equality = + fun a b -> begin match a, b with + | Date, Date -> Eq + | String, String -> Eq + | Number, Number -> Eq + | Date, Number -> Eq + | Number, Date -> Eq + | Bool, Bool -> Eq + | _, _ -> raise Errors.TypeError + end + +end + +module Type = struct + + let (=) : type a b. a types -> b types -> bool = fun t1 t2 -> + match t1, t2 with + | Num (_, n1), Num (_, n2) -> DataType.Num.eq n1 n2 + | Bool b1, Bool b2 -> b1 = b2 + | Str s1, Str s2 -> s1 = s2 + | _, _ -> false + + (** Show a list of elements + *) + let rec show_list printer buffer = begin function + | [] -> () + | hd::[] -> + UTF8.Printf.bprintf buffer "%a" + printer hd + | hd::tl -> + UTF8.Printf.bprintf buffer "%a, " + printer hd; + show_list printer buffer tl + end + + let show: type a. UTF8.Buffer.buffer -> a types -> unit = fun buffer -> begin function + | Str x -> UTF8.Buffer.add_string buffer x + | Bool b -> UTF8.Printf.bprintf buffer "%B" b + | Num (Number, n) -> + if DataType.Num.is_integer n then + 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 "%.2f" f; + Format.pp_print_flush to_b () + | Num (Date, n) -> + let y, m, d = DataType.Date.date_from_julian_day n in + UTF8.Printf.bprintf buffer "%d/%d/%d" y m d + end + + let show_full: type a. UTF8.Buffer.buffer -> a types -> unit = fun buffer -> begin function + | Str x -> UTF8.Buffer.add_string buffer x + | Bool b -> UTF8.Printf.bprintf buffer "%B" b + | Num (Number, n) -> + if DataType.Num.is_integer n then + 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 () + | Num (Date, n) -> + let y, m, d = DataType.Date.date_from_julian_day n in + UTF8.Printf.bprintf buffer "%d/%d/%d" y m d + end + + type t = + | Value: 'a dataFormat * 'a -> t + + let get_content : type a. a types -> t = begin function + | Num (format, data) -> Value (format, data) + | Str s -> Value (String, s) + | Bool b -> Value (Bool, b) + end + +end + +module Refs = struct + + type 'a range = + | Single of 'a + | Array1 of 'a list + | Array2 of 'a list list + + let collect = function + | Cell x -> Single (Pervasives.fst x) + | Range (fst, snd) -> + let (x1, y1) = Pervasives.fst fst + and (x2, y2) = Pervasives.fst snd in + let min_x = min x1 x2 + and max_x = max x1 x2 + and min_y = min y1 y2 + and max_y = max y1 y2 in + if (min_x = max_x) || (min_y = max_y) then ( + (* There is only a one dimension array *) + let elms = ref [] in + for x = min_x to max_x do + for y = min_y to max_y do + elms := (x, y)::!elms + done + done; + Array1 (!elms) + ) else ( + (* This a two-dimension array *) + let elmx = ref [] in + for x = min_x to max_x do + let elmy = ref [] in + for y = min_y to max_y do + elmy := (x, y)::!elmy + done; + elmx := !elmy::!elmx + done; + Array2 (!elmx) + ) + + let map f = function + | Single coord -> Single (f coord) + | Array1 values -> Array1 (List.map f values) + | Array2 values -> Array2 (List.map (List.map f) values) + + let shift (vector_x, vector_y) ref = + let _shift ((x, y), (fixed_x, fixed_y)) = + let x' = if fixed_x then x else x + vector_x + and y' = if fixed_y then y else y + vector_y in + (x', y'), (fixed_x, fixed_y) + in match ref with + | Cell x -> Cell (_shift x) + | Range (fst, snd) -> Range (_shift fst, _shift snd) + + let show buffer = begin function + | Cell r -> UTF8.Buffer.add_string buffer @@ Cell.to_string r + | Range (f,t) -> + Tools.Tuple2.printb ~first:"" ~last:"" ~sep:":" Cell.to_buffer Cell.to_buffer buffer (f,t) + end + + type 'a content = + | Value: 'a dataFormat * 'a -> 'a content + | List: 'a dataFormat * 'a list -> 'a list content + | Matrix: 'a dataFormat * 'a list list -> 'a list list content + + type refContent = + | C: 'a content -> refContent [@@unboxed] + + (** Add one element in a typed list. + + The function will raise Error.TypeError if the elements does not match + with the list type. + *) + let add_elem: type a b. a dataFormat * a list -> result option -> a dataFormat * a list = + fun (format, elements) result -> + begin match result with + | None -> format, (DataFormat.default_value_for format)::elements + | Some (Error x) -> raise x + | Some (Result r) -> + let Type.Value (format', element) = Type.get_content r in + let DataFormat.Eq = DataFormat.compare_format format format' in + let new_format = if (DataFormat.priority format) > (DataFormat.priority format') then + format + else + format' in + new_format, element::elements + end + + let get_content = begin function + | Single None -> raise Errors.TypeError + | Single (Some (Error x)) -> raise x + | Single (Some (Result r)) -> + let Type.Value (format, c) = Type.get_content r in C (Value (format, c)) + | Array1 l -> + (* Get the first element in the list in order to get the format *) + let Type.Value (format, _) = + begin match (Tools.List.find_map (fun x -> x) l) with + | Error x -> raise x + | Result r -> Type.get_content r + end in + (* Then build an unified list (if we can) *) + let format, values = List.fold_left add_elem (format, []) l in + C (List(format, List.rev values)) + | Array2 l -> + (* Get the first element in the list *) + let Type.Value (format, _) = + begin match (Tools.List.find_map2 (fun x -> x) l) with + | Error x -> raise x + | Result r -> Type.get_content r + end in + (* Then build an unified list *) + let format, values = List.fold_left (fun (format, result) elems -> + let format, elems = List.fold_left add_elem (format, []) elems in + (format, List.rev (elems::result)) + )(format, []) l in + C (Matrix(format, List.rev values)) + end + +end + +module Result = struct + let (=) t1 t2 = + match t1, t2 with + | Result v1, Result v2 -> Type.(=) v1 v2 + | _, _ -> t1 = t2 + + let show = begin function + | Error x -> + (* + let buffer = Buffer.create 16 in + let b = Format.formatter_of_buffer buffer in + Errors.printf b x; + Format.pp_print_flush b (); + u(Buffer.contents buffer) + *) + u"#Error" + | Result v -> + let buffer = UTF8.Buffer.create 16 in + Type.show buffer v; + UTF8.Buffer.contents buffer + end + +end + +(** Represent an expression. + *) +let rec show_expr buffer : expression -> unit = begin function + | Value (Str x) -> + (** Print the value with quotes *) + UTF8.Printf.bprintf buffer "\"%s\"" (UTF8.to_utf8string x) + | Value v -> Type.show buffer v + | Ref r -> Refs.show buffer r + | Call (ident, params) -> + let utf8ident = UTF8.to_utf8string ident in + begin match utf8ident with + | "+" | "*" | "-" | "/" | "^" | "=" + | "<>" | "<=" | ">=" | "<" | ">" -> begin match params with + | v1::[] -> + UTF8.Printf.bprintf buffer "%s%a" + utf8ident + show_expr v1 + | v1::v2::[] -> + UTF8.Printf.bprintf buffer "%a%s%a" + show_expr v1 + utf8ident + show_expr v2 + | _ -> + UTF8.Buffer.add_string buffer ident; + Tools.List.printb ~sep:(u";") show_expr buffer params + end + | _ -> + UTF8.Buffer.add_string buffer ident; + Tools.List.printb ~sep:(u";") show_expr buffer params + end + | Expression expr -> + UTF8.Printf.bprintf buffer "(%a)" show_expr expr +end + diff --git a/src/scTypes.mli b/src/scTypes.mli new file mode 100755 index 0000000..348f4fe --- /dev/null +++ b/src/scTypes.mli @@ -0,0 +1,126 @@ +(** All the types used in the spreadsheet. *) + +exception Error + +type cell = (int * int) * (bool * bool) + +type ident = UTF8.t + +type 'a dataFormat = + | Date: DataType.Num.t dataFormat (* A date in julian day *) + | Number: DataType.Num.t dataFormat (* Number *) + | String: DataType.String.t dataFormat (* String *) + | Bool: DataType.Bool.t dataFormat (* Boolean *) + +type 'a returnType = + | Num : DataType.Num.t dataFormat option -> DataType.Num.t returnType (** A number *) + | Str : DataType.String.t returnType (** A string *) + | Bool : DataType.Bool.t returnType (** A boolean *) + +type numericType = + | Date + | Number + +val get_numeric_type: DataType.Num.t dataFormat -> numericType + +type 'a types = private + | Num : DataType.Num.t dataFormat * DataType.Num.t -> DataType.Num.t types (** A number *) + | Str : DataType.String.t -> DataType.String.t types (** A string *) + | Bool : DataType.Bool.t -> DataType.Bool.t types (** A boolean *) + +val number: DataType.Num.t -> DataType.Num.t types +val string: DataType.String.t -> DataType.String.t types +val boolean: DataType.Bool.t -> DataType.Bool.t types +val date: DataType.Num.t -> DataType.Num.t types + + +(** Numeric (any format) *) +val f_num: DataType.Num.t returnType + +(** Date *) +val f_date: DataType.Num.t returnType + +(** Number *) +val f_number: DataType.Num.t returnType + +(** Boolean result *) +val f_bool: DataType.Bool.t returnType + +(** String *) +val f_string: DataType.String.t returnType + +type refs = + | Cell of cell (** A cell *) + | Range of cell * cell (** An area of cells *) + +(** This is the cell content *) +type expression = + | Value : 'a types -> expression (** A direct value *) + | Ref : refs -> expression (** A reference to another cell *) + | Call : ident * expression list -> expression (** A call to a function *) + | Expression : expression -> expression (** An expression *) + +(** Result from a computation *) +type result = + | Result : 'a types -> result + | Error : exn -> result + +module DataFormat : sig + + type formats = F : 'a dataFormat -> formats [@@unboxed] + + val guess_format_result: 'a returnType -> (unit -> formats list) -> 'a dataFormat + +end + +module Type : sig + + type t = Value: 'a dataFormat * 'a -> t + + val (=) : 'a types -> 'b types -> bool + + val show: UTF8.Buffer.buffer -> 'a types -> unit + + val show_full: UTF8.Buffer.buffer -> 'a types -> unit + +end + +module Refs : sig + + type 'a range = + | Single of 'a + | Array1 of 'a list + | Array2 of 'a list list + + val collect: refs -> (int * int) range + + val map: ('a -> 'b) -> 'a range -> 'b range + + val shift: (int * int) -> refs -> refs + + type 'a content = + | Value: 'a dataFormat * 'a -> 'a content + | List: 'a dataFormat * 'a list -> 'a list content + | Matrix: 'a dataFormat * 'a list list -> 'a list list content + + type refContent = + | C: 'a content -> refContent [@@unboxed] + + (** extract the content from a range. + + May raise Errors.TypeError if the range cannot be unified. + *) + val get_content : result option range -> refContent + +end + +val show_expr: UTF8.Buffer.buffer -> expression -> unit + +module Result : sig + + val (=) : result -> result -> bool + + val show: result -> UTF8.t + +end + diff --git a/src/screen.ml b/src/screen.ml new file mode 100755 index 0000000..c61efea --- /dev/null +++ b/src/screen.ml @@ -0,0 +1,459 @@ +(** Curses submodules *) +module Attrs = Curses.A +module Color = Curses.Color + +module T2 = Tools.Tuple2 + +module Option = Tools.Option + +let cell_size = 10 + +let u = UTF8.from_utf8string + +type t = { + window: Curses.window; (* the main window *) + sheet: Curses.window; (* the spreadsheet *) + input: Curses.window; (* the input window *) + status: Curses.window; (* status bar *) + start: (int * int); (* Left corner *) + left_margin: int; (* Reserved margin for rows name *) + + mutable size: int * int; (* Terminal size *) +} + +let get_cell screen (x, y) = begin + + let x' = (fst screen.start) + (x - screen.left_margin) / cell_size + and y' = (snd screen.start) + y - 3 in + + if (x' < 1 || y' < 1) then + None + else + Some (x', y') +end + +let center data screen height width = begin + let height' = height - 3 + and width' = (width - screen.left_margin) / cell_size in + let end_x = (fst screen.start) + width' -1 in + let end_y = (snd screen.start) + height' -2 in + + let selected = Selection.extract data.Sheet.selected in + + let center_axis f replace max_limit shift screen = begin + let selected_axis = f selected in + match (selected_axis >= f screen.start), (selected_axis > max_limit) with + | true, false -> screen + | _ -> { screen with start = replace (max 1 (selected_axis - shift)) screen.start } + end in + center_axis T2.fst T2.replace1 end_x (width' / 2) screen + |> center_axis T2.snd T2.replace2 end_y (height' / 2) +end + +let status screen msg = begin + let height, width = screen.size in + UTF8.encode msg |> Option.iter (fun encoded -> + let status = Bytes.make (width -1) ' ' in + String.blit encoded 0 status 0 (String.length encoded); + Curses.werase screen.status; + if not ( + Curses.mvwaddstr screen.status 0 0 encoded + && Curses.wrefresh screen.status + ) then + raise (Failure "Status update") + ) +end + +(** Draw the spreadsheet *) +let draw data screen = begin + + let selected = Selection.extract data.Sheet.selected in + + let referenced = + Sheet.Raw.get_expr selected data.Sheet.data + |> Expression.collect_sources + + and sink = Sheet.Raw.get_sink selected data.Sheet.data in + + let height, width = screen.size in + let screen = center data screen height width in + + for y = 1 to (height-2) do + let pos_y = (y + (snd screen.start) - 1) in + if (Curses.has_colors ()) then begin + if Selection.is_selected (Selection.Vertical pos_y) data.Sheet.selected then + Curses.wattrset screen.sheet (Attrs.color_pair 2 ) + else + Curses.wattrset screen.sheet (Attrs.color_pair 1 ) + end; + ignore + @@ Curses.mvwaddstr screen.sheet y 0 + @@ Printf.sprintf "%-*d" screen.left_margin pos_y + done; + Curses.wattrset screen.sheet Attrs.normal; + + for x = 0 to ((width - cell_size - screen.left_margin) / cell_size) do + let pos_x = x + (fst screen.start) in + if (Curses.has_colors ()) then begin + if Selection.is_selected (Selection.Horizontal pos_x) data.Sheet.selected then + Curses.wattrset screen.sheet (Attrs.color_pair 2 ) + else + Curses.wattrset screen.sheet (Attrs.color_pair 1 ) + end; + + ignore + @@ Curses.mvwaddstr screen.sheet 0 (x * cell_size + screen.left_margin) + @@ Printf.sprintf "%-*s" cell_size (UTF8.raw_encode @@ Cell.to_hname pos_x); + + Curses.wattrset screen.sheet Attrs.normal; + + for y = 1 to (height-2) do + + let pos_y = y + (snd screen.start) - 1 in + + if (Curses.has_colors ()) then begin + if Selection.is_selected (Selection.Cell (pos_x, pos_y)) data.Sheet.selected then + Curses.wattrset screen.sheet (Attrs.color_pair 3 ) + else if Cell.Set.mem (pos_x, pos_y) referenced then + Curses.wattrset screen.sheet (Attrs.color_pair 4 ) + else if Cell.Set.mem (pos_x, pos_y) sink then + Curses.wattrset screen.sheet (Attrs.color_pair 5 ) + else + Curses.wattrset screen.sheet Attrs.normal; + end; + + + (* Get the content from the cell *) + let content = Sheet.Raw.get_value (pos_x, pos_y) data.Sheet.data + |> Option.map (fun x -> UTF8.split ~sep:(u"\n") (ScTypes.Result.show x)) + |> Option.default UTF8.empty in + + (* If the content is defined, try to encode it and print it*) + UTF8.encode content |> Tools.Option.iter (fun value -> + let length = UTF8.length content in + let strlength = String.length value in + let blank = cell_size - length in + let padding = if blank > 0 + then String.make blank ' ' + else "" in + ignore + @@ Curses.mvwaddnstr screen.sheet y (x * cell_size + screen.left_margin) + (Printf.sprintf "%s%s" value padding) + 0 (blank + strlength) + ) + done + done; + ignore @@ Curses.wrefresh screen.sheet; + screen + +end + +let init () = begin + (* Do not set delay after ESC keycode *) + begin try ignore @@ Unix.getenv "ESCDELAY" with + | Not_found -> Unix.putenv "ESCDELAY" "25" end; + + let window = Curses.initscr () in + let height, width = Curses.getmaxyx window in + + Tools.NCurses.set_mouse_event (Tools.NCurses.BUTTON1_CLICKED::[]); + + let init = Curses.keypad window true + && Curses.noecho () + && Curses.start_color () + && Curses.use_default_colors () + + (* Build the color map *) + && Curses.init_pair 1 Color.white Color.blue (* Titles *) + && Curses.init_pair 2 Color.blue Color.white (* Selected titles *) + && Curses.init_pair 3 Color.black Color.white (* Selected cell *) + && Curses.init_pair 4 Color.black Color.red (* referenced cell *) + && Curses.init_pair 5 Color.black Color.green (* sink cell *) + && Curses.curs_set 0 in + + if not init then + raise (Failure "Initialisation") + else + { + window = window; + input = Curses.subwin window 2 width 0 0; + sheet = Curses.subwin window (height - 3) width 2 0; + status = Curses.subwin window 1 width (height - 1) 0; + start = 1, 1; + left_margin = 4; + size = height, width; + } +end + +let close {window} = begin + ignore @@ (Curses.keypad window false && Curses.echo ()); + Curses.endwin() +end + +let draw_input t screen = begin + + let height, width = screen.size in + + let expr = Sheet.Raw.get_expr (Selection.extract t.Sheet.selected) t.Sheet.data + |> Expression.show in + + let result = Sheet.Raw.get_value (Selection.extract t.Sheet.selected) t.Sheet.data + |> Option.map ScTypes.Result.show + |> Option.default UTF8.empty in + + UTF8.encode result |> Option.iter (fun encoded_result -> + (* Compute the difference between number of bytes in the string, and the + number of character printed : Printf.sprintf format use the bytes number + in the string, while Curses print the characters in the user encoding *) + let result_length_delta = (UTF8.length result) - (String.length encoded_result) in + + ignore ( + encoded_result + |> Printf.sprintf "%-*s" (width - 11 - result_length_delta) + |> Curses.mvwaddstr screen.input 0 10 + + && Curses.wrefresh screen.input) + ); + status screen expr; + screen +end + +(** Wait for an event and return the key pressed + If the key code contains more than one char, they are both returned + *) +let read_key {window} = begin + let buff = Buffer.create 2 in + let int_val = Curses.wgetch window in + if int_val > 255 then + Buffer.add_string buff @@ Tools.String.string_of_ints int_val + else + Buffer.add_char buff @@ char_of_int int_val; + (** Check for a second key code *) + ignore @@ Curses.nodelay window true; + begin match Curses.wgetch window with + | -1 -> () + | x -> Buffer.add_char buff @@ char_of_int x; + end; + ignore @@ Curses.nodelay window false; + Buffer.contents buff +end + +let resize data t = begin + let size = Curses.getmaxyx t.window in + if (size <> t.size) then ( + let height, width = size in + t.size <- size; + ignore ( + Curses.wresize t.input 2 width + + && Curses.wresize t.sheet (height - 3) width + + (* The status window *) + && Curses.wresize t.status 1 width + && Curses.mvwin t.status (height - 1) 0); + Curses.wclear t.status; + ignore @@ Curses.wrefresh t.status; + draw data t + ) else t +end + +let editor ?position ?(prefix=UTF8.empty) ?(init=UTF8.empty) t = begin + let encodedPrefix = UTF8.raw_encode prefix + and encodedInit = UTF8.raw_encode init in + let with_refs, position = match position with + | None -> false, (1, 1) + | Some x -> true, x in + Curses.werase t.status; + ignore @@ Curses.mvwaddstr t.status 0 0 (encodedPrefix^encodedInit); + ignore @@ Curses.wrefresh t.status; + + (** Rewrite all the text after the cursor *) + let rewrite_after = begin function + | [] -> () + | elems -> ( (* Rewrite each char after the cursor *) + let y, x = Curses.getyx t.status in + List.iter (fun x -> ignore @@ Curses.waddstr t.status (UTF8.raw_encode x)) elems; + ignore @@ Curses.wmove t.status y x ) + end + + (** Delete the previous text (or block of text) *) + and delete_previous hd = begin + let y, x = Curses.getyx t.status in + let length = UTF8.length hd in + ignore @@ Curses.wmove t.status y (x - length); + for position = 1 to length do + ignore @@ Curses.wdelch t.status + done; + end in + + (* Text edition, handle the keycode. + + [before] contains all the caracters inserted before the cursor (reverse + ordered), and [after] contains all the caracters after the cursor. + *) + let rec _edit before after = begin function + | "\027" -> (* Escape, cancel the modifications *) + None + | "\010" -> (* Enter, validate the input *) + + (* We concatenate all the characters. This can create an invalid string in + * the current locale (if there are copy/paste, or other events). + *) + Some (UTF8.implode @@ (UTF8.rev_implode before)::after) + + | "\001\004" -> (* Left *) + begin match before with + | [] -> _edit before after @@ read_key t + | hd::tl -> + let y, x = Curses.getyx t.status + and length = UTF8.length hd in + ignore @@ Curses.wmove t.status y (x - length); + ignore @@ Curses.wrefresh t.status; + _edit tl (hd::after) @@ read_key t + end + + | "\001\005" -> (* Right *) + begin match after with + | [] -> _edit before after @@ read_key t + | hd::tl -> + let y, x = Curses.getyx t.status + and length = UTF8.length hd in + ignore @@ Curses.wmove t.status y (x + length); + ignore @@ Curses.wrefresh t.status; + _edit (hd::before) tl @@ read_key t + end + + | "\001\007" -> (* Backspace *) + begin match before with + | [] -> _edit before after @@ read_key t + | hd::tl -> + delete_previous hd; + ignore @@ Curses.wrefresh t.status; + _edit tl after @@ read_key t + end + + | "\001\006" -> (* Home *) + begin match before with + | [] -> _edit before after @@ read_key t + | elems -> + let to_left (size, after) elem = begin + let size' = size + UTF8.length elem in + size', elem::after + end in + let chars, after' = List.fold_left to_left (0, after) elems in + let y, x = Curses.getyx t.status in + ignore @@ Curses.wmove t.status y (x - chars); + ignore @@ Curses.wrefresh t.status; + _edit [] after' @@ read_key t + end + + | "\001\104" -> (* End *) + begin match after with + | [] -> _edit before after @@ read_key t + | elems -> + let to_rigth (size, before) elem = begin + let size' = size + UTF8.length elem in + size', elem::before + end in + let chars, before' = List.fold_left to_rigth (0, before) elems in + let y, x = Curses.getyx t.status in + ignore @@ Curses.wmove t.status y (x + chars); + ignore @@ Curses.wrefresh t.status; + _edit before' [] @@ read_key t + end + | "\001\074" + | "\127" -> (* Del *) + begin match after with + | [] -> _edit before after @@ read_key t + | hd::tl -> + let y, x = Curses.getyx t.status in + ignore @@ Curses.wmove t.status y (x + 1); + delete_previous hd; + ignore @@ Curses.wrefresh t.status; + _edit before tl @@ read_key t + end + + | ("\001\002" as key) (* Down *) + | ("\001\003" as key) (* Up *) + | ("\001\153" as key) -> (* click *) + if with_refs then + select_content position (UTF8.empty) before after key + else + _edit before after @@ read_key t + + | any -> + ignore @@ Curses.waddstr t.status any; + rewrite_after after; + ignore @@ Curses.wrefresh t.status; + _edit (UTF8.decode any::before) after @@ read_key t + end + + (* Selection mode, Left and Right keys allow to select a cell, and not to + move inside the edition *) + and select_content (x, y) name before after = begin + function + | "\001\002" -> (* Down *) insert_cell_name (x, y + 1) name before after + | "\001\005" -> (* Right *) insert_cell_name (x + 1, y) name before after + + | "\001\003" -> (* Up *) + if y > 1 then + insert_cell_name (x, y - 1) name before after + else select_content (x, y) name before after @@ read_key t + + | "\001\004" -> (* Left *) + if x > 1 then + insert_cell_name (x - 1, y) name before after + else select_content (x, y) name before after @@ read_key t + + | "\001\153" -> (* click *) + let position = + begin match Tools.NCurses.get_mouse_event () with + | None -> None + | Some (id, ev, (x, y, z)) -> + if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_CLICKED ev + || Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_PRESSED ev then + get_cell t (x,y) + else + None + end in + begin match position with + | None -> select_content (x, y) name before after @@ read_key t + | Some (x, y) -> insert_cell_name (x, y) name before after + end + + | key -> + _edit (UTF8.fold List.cons name before) after key + end + + and insert_cell_name position name before after = begin + let cell_name = Cell.to_string @@ (position, (false, false)) in + ignore @@ delete_previous name; + ignore @@ Curses.waddstr t.status (UTF8.raw_encode cell_name); + rewrite_after after; + ignore @@ Curses.wrefresh t.status; + select_content position cell_name before after @@ read_key t + end + in + + Tools.try_finally + (fun () -> + ignore @@ Curses.curs_set 1; + try _edit (UTF8.rev_explode init) [] @@ read_key t + with _ -> None) + (fun () -> ignore @@ Curses.curs_set 0) + +end + +let search screen = begin + let result = editor ~prefix:(u"/") screen in + begin match result with + | Some content -> content + | None -> UTF8.empty + end +end + +let run f = + let window = init () in + Tools.try_finally + (fun () -> f window) + (fun () -> ignore @@ close window ) diff --git a/src/screen.mli b/src/screen.mli new file mode 100755 index 0000000..b5f74b2 --- /dev/null +++ b/src/screen.mli @@ -0,0 +1,29 @@ +(** Represent the {!module:Sheet} *) + +type t + +(** Run the screen *) +val run: (t -> 'a) -> 'a + +(** {2 Screen updates} *) + +val draw: Sheet.t -> t -> t + +val draw_input: Sheet.t -> t -> t + +val resize: Sheet.t -> t -> t + +(** Display a message in the status bar. *) +val status: t -> UTF8.t -> unit + +(** {2 User inputs} *) + +(** Wait for a keycode *) +val read_key : t -> string +(** The keycode is always NULL terminated *) + +val search: t -> UTF8.t + +val get_cell: t -> int * int -> (int * int) option + +val editor: ?position: int * int -> ?prefix:UTF8.t -> ?init:UTF8.t -> t -> UTF8.t option diff --git a/src/selection.ml b/src/selection.ml new file mode 100755 index 0000000..2bf41ce --- /dev/null +++ b/src/selection.ml @@ -0,0 +1,73 @@ +module T2 = Tools.Tuple2 + +type t = + | Single of (int * int) + | Multiple of (int * int) * (int * int) + +let create c = Single c + +type axe = + | Horizontal of int + | Vertical of int + | Cell of (int * int) + +let is_selected sel_type t = match sel_type, t with + | Horizontal h , Single (x, y) -> h = x + | Vertical v , Single (x, y) -> v = y + | Cell c, Single x -> c = x + | Horizontal h, Multiple ((x1, _), (x2, _)) -> + let min_x = min x1 x2 + and max_x = max x1 x2 in + min_x <= h && h <= max_x + | Vertical v, Multiple ((_, y1), (_, y2)) -> + let min_y = min y1 y2 + and max_y = max y1 y2 in + min_y <= v && v <= max_y + | Cell (x, y), Multiple ((x1, y1), (x2, y2)) -> + let min_x = min x1 x2 + and max_x = max x1 x2 in + let min_y = min y1 y2 + and max_y = max y1 y2 in + min_x <= x && x <= max_x && min_y <= y && y <= max_y + +let extract = function + | Single x -> x + | Multiple (x,y) -> y + +let fold (f:('a -> int * int -> 'a)) (init:'a): t -> 'a = function + | Single x -> f init x + | Multiple ((x1, y1), (x2, y2)) -> + let min_x = min x1 x2 + and max_x = max x1 x2 + and min_y = min y1 y2 + and max_y = max y1 y2 in + let res = ref init in + for x = min_x to max_x do + for y = min_y to max_y do + res := f !res (x, y) + done + done; + !res + +(** Extends the selection in one direction *) +let extends direction t = begin + let extends position = match direction with + | Actions.Left amount -> T2.map1 (fun v -> max 1 @@ v - amount) position + | Actions.Right amount -> T2.map1 ((+) amount) position + | Actions.Up amount -> T2.map2 (fun v -> max 1 @@ v - amount) position + | Actions.Down amount -> T2.map2 ((+) amount) position + | Actions.Absolute (x, y) -> x, y in + + let start_pos, end_pos = match t with + | Single x -> x, (extends x) + | Multiple (x, y) -> x, (extends y) in + + if start_pos = end_pos then + Single start_pos + else + Multiple (start_pos, end_pos) +end + +let shift = function + | Single (start_x, start_y) -> fun (x, y) -> (x - start_x, y - start_y) + | Multiple ((start_x, start_y), _) -> fun (x, y) -> (x - start_x, y - start_y) diff --git a/src/selection.mli b/src/selection.mli new file mode 100755 index 0000000..fb207e4 --- /dev/null +++ b/src/selection.mli @@ -0,0 +1,20 @@ +type t + +type axe = + | Horizontal of int + | Vertical of int + | Cell of (int * int) + +(** Create a new selection from a cell *) +val create: (int * int) -> t + +val is_selected: axe -> t -> bool + +(** Get the selection origin *) +val extract: t -> (int * int) + +val shift: t -> (int * int) -> (int * int) + +val fold: ('a -> int * int -> 'a) -> 'a -> t -> 'a + +val extends: Actions.direction -> t -> t diff --git a/src/sheet.ml b/src/sheet.ml new file mode 100755 index 0000000..67b1ee1 --- /dev/null +++ b/src/sheet.ml @@ -0,0 +1,334 @@ +module Option = Tools.Option + +type cell = int * int + +type search = [ + | `Pattern of ScTypes.result option + | `Next + | `Previous +] + +module Raw = struct + + module Map = Map.Make(struct + type t = cell + let compare (x1, y1) (x2, y2) = Pervasives.compare (y1, x1) (y2, x2) + end) + + type content = { + expr : Expression.t; (** The expression *) + value : ScTypes.result option; (** The content evaluated *) + sink : Cell.Set.t; (** All the cell which references this one *) + } + + (** The sheet is a map which always contains evaluated values. When a cell is + updated, all the cell which references this value are also updated. + *) + and t = content Map.t + + (** An empty cell which does contains nothing *) + let empty_cell = { + expr = Expression.Undefined; + value = None; + sink = Cell.Set.empty; + } + + let empty = Map.empty + + let get_value id t = begin + try (Map.find id t).value + with Not_found -> None + end + + let get_expr id t = begin + try (Map.find id t).expr + with Not_found -> empty_cell.expr + end + + (** Extract a value from a reference. + This function is given to the evaluator for getting the values from a reference. + *) + let get_ref from t ref : ScTypes.result option ScTypes.Refs.range = begin + + ScTypes.Refs.collect ref + |> ScTypes.Refs.map (fun coord -> get_value coord t) + + end + + (** Update the value for the given cell. + Evaluate the new expression and compare it with the previous value. + @return Some map if the map has been updated + *) + let update cell content t = begin + let new_val = Expression.eval content.expr (get_ref cell t) in + match content.value with + | None -> + (* If the previous value wasn't defined, update the map *) + Some (Map.add cell { content with value = Some new_val } t) + | Some old_value -> + (* If the previous value was defined, update only if result differs *) + if not (ScTypes.Result.(=) new_val old_value) then + Some (Map.add cell { content with value = Some new_val } t) + else + (* If there is no changes, do not update the map *) + None + end + + (** 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 exception Cycle of Cell.Set.t * t in + + let rec successors parents element (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 Errors.Cycle) in + + if content.value = cycle_error then ( + (* The content has already been updated, do not process it again *) + (succ, t) + ) else ( + 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, t = traverse set_error source (init, t) in + raise (Cycle (succ, t)) + ) + ) else ( + begin match f element content t with + | None -> + (* The content does not change, we do not update the successors *) + (succ, t) + | Some t' -> + let parents' = Cell.Set.add element parents + and succ' = Cell.Set.add element succ in + if (Cell.Set.is_empty content.sink) then + (succ', t') + else + Cell.Set.fold (successors parents') content.sink (succ', t') + end + ) + end in + try Cell.Set.fold (successors init) source.sink (init, t) + with Cycle (succ, t) -> (succ, t) + end + + (** Remove the cell from the sheet *) + let remove_element (id:cell) t : t * content option = begin + + (** Remove the references from each sources. + If the sources is not referenced anywhere, and is Undefined, remove it + *) + let remove_ref cell t = begin + try let c = Map.find cell t in + + (* Remove all the refs which points to the removed cell *) + let sink' = Cell.Set.filter ((<>) id) c.sink in + if Cell.Set.is_empty sink' && not (Expression.is_defined c.expr) then ( + Map.remove cell t ) + else + Map.add cell {c with sink = sink'} t + with Not_found -> t + end in + + begin try + let c = Map.find id t in + let t' = + (** Remove the references from each sources *) + let sources = Expression.collect_sources c.expr in + Cell.Set.fold remove_ref sources t in + + (** If there is no references on the cell, remove it *) + if Cell.Set.is_empty c.sink then ( + Map.remove id t', None) + else ( + let c = { empty_cell with sink = c.sink } in + Map.add id c t', (Some c) + ) + with Not_found -> t, None + end + end + + let remove id t = begin + match remove_element id t with + | t, None -> Cell.Set.empty, t + | t, Some content -> + (** Update all the successors *) + traverse update content (Cell.Set.singleton id, t) + end + + let add_element id f t = begin + + (** Add the references in each sources. + If the sources does not exists, create it. + *) + let add_ref cell t = begin + let c = + try Map.find cell t + with Not_found -> empty_cell in + let c' = { c with sink = Cell.Set.add id c.sink} in + Map.add cell c' t + end in + + let t', cell = remove_element id t in + let cell' = match cell with + | None -> empty_cell + | Some x -> x in + + let content = f cell' t' in + + let sources = Expression.collect_sources content.expr in + let updated = Map.add id content t' + |> Cell.Set.fold add_ref sources + in + + (** Update the value for each sink already evaluated *) + traverse update content (Cell.Set.singleton id, updated) + end + + let add id expression t = begin + if not (Expression.is_defined expression) then + (Cell.Set.empty, t) + else + let f cell t = { cell with + expr = expression ; + value = Some (Expression.eval expression (get_ref id t)) + } in + add_element id f t + end + + let paste id shift content t = begin + let expr = Expression.shift shift content.expr in + let f cell t = + { cell with + expr = expr ; + value = Some (Expression.eval expr (get_ref id t)) + } in + add_element id f t + end + + let search pattern t = begin + let exception Found of (int * int) in + + let _search key content = if content.value = pattern then raise (Found key) in + try + Map.iter _search t; + None + with Found key -> Some key + end + + let get_sink id t = + try (Map.find id t).sink + with Not_found -> Cell.Set.empty + + (** Fold over each defined value *) + let fold f a t = begin + Map.fold (fun key content a -> + match content.value with + | None -> a + | Some x -> + f a key (content.expr, x) + ) t a + end + +end + +type yank = cell * Raw.content + +type t = { + selected: Selection.t; (* The selected cell *) + data: Raw.t; + history: t list; (* Unlimited history *) + yank: (cell * Raw.content) list +} + +let undo t = begin match t.history with + | [] -> None + | hd::tl -> Some { hd with selected = t.selected } +end + +let move direction t = + let position = Selection.extract t.selected in + let position' = begin match direction with + | Actions.Left quant -> Tools.Tuple2.replace1 (max 1 ((fst position) - quant)) position + | Actions.Right quant -> Tools.Tuple2.replace1 ((fst position) + quant) position + | Actions.Up quant -> Tools.Tuple2.replace2 (max 1 ((snd position) - quant)) position + | Actions.Down quant -> Tools.Tuple2.replace2 ((snd position) + quant) position + | Actions.Absolute (x, y)-> (x, y) + end in + if position = position' then + None + else + Some {t with selected = Selection.create position'} + +let delete t = begin + let count, data' = Selection.fold (fun (count, c) t -> + (count + 1, snd @@ Raw.remove t c)) (0, t.data) t.selected in + let t' = { t with + data = data'; + history = t::t.history + } in + t', count +end + +let yank t = begin + + let shift = Selection.shift t.selected in + let origin = shift (0, 0) in + let _yank (count, extracted) cell = begin + let content = + try let content = (Raw.Map.find cell t.data) in + { content with Raw.expr = Expression.shift origin content.Raw.expr } + with Not_found -> Raw.empty_cell in + + count + 1, (shift cell,content)::extracted + end in + + let count, yanked = Selection.fold _yank (0, []) t.selected in + let t' = { t with yank = List.rev yanked; } in + t', count +end + +let paste t = begin + (* Origin of first cell *) + let (shift_x, shift_y) as shift = Selection.extract t.selected in + + let _paste (count, t) ((x, y), content) = begin + count + 1, snd @@ Raw.paste (shift_x + x, shift_y + y) shift content t + end in + + let count, data' = List.fold_left _paste (0, t.data) t.yank in + let t' = { t with data = data'; history = t::t.history } in + t', count +end + +let add expression t = begin + let id = Selection.extract t.selected in + let cells, data' = Raw.add id expression t.data in + cells, { t with data = data'; history = t::t.history} +end + +let search action t = begin match action with + | `Pattern pattern -> + begin match Raw.search pattern t.data with + | None -> None + | Some x -> Some {t with selected = Selection.create x} + end + | _ -> None +end + +let create data = { + data = data; + selected = Selection.create (1, 1); + history = []; + yank = []; +} diff --git a/src/sheet.mli b/src/sheet.mli new file mode 100755 index 0000000..11881cc --- /dev/null +++ b/src/sheet.mli @@ -0,0 +1,75 @@ +(** This module represent a sheet *) + +type cell = int * int + +module Raw: sig + + type t + + (** An empty sheet *) + val empty: t + + (** Add a new value in the sheet. The previous value is replaced + @return All the successors to update and the new sheet. + *) + val add: cell -> Expression.t -> t -> Cell.Set.t * t + + val remove: cell -> t -> Cell.Set.t * t + + (** Get the value content. + @return None if the cell is not defined + *) + val get_value: cell -> t -> ScTypes.result option + + val get_expr: cell -> t -> Expression.t + + val get_sink: cell -> t -> Cell.Set.t + + (** Fold over all the defined values *) + val fold: ('a -> cell -> (Expression.t * ScTypes.result ) -> 'a) -> 'a -> t -> 'a + +end + +type yank + +type t = { + selected: Selection.t; (* The selected cell *) + data: Raw.t; + history: t list; (* Unlimited history *) + yank: yank list (* All the selected cells *) +} + +type search = [ + | `Pattern of ScTypes.result option + | `Next + | `Previous +] + +(** Undo the last action and return the previous state, if any *) +val undo: t -> t option + +(** Move the cursor in one direction, return the state updated if the move is + allowed *) +val move: Actions.direction -> t -> t option + +(** Delete the content of selected cells. + @return The sheet and the number of cells deleted +*) +val delete: t -> t * int + +(** Copy the selected cells + @return The sheet and the number of cells deleted +*) +val yank: t -> t * int + +(** Search for a pattern on the sheet + @return The state updated if the pattern has been found. *) +val search: search -> t -> t option + +val paste: t -> t * int + +val add: Expression.t -> t -> Cell.Set.t * t + +(** Create an empty sheet *) +val create: Raw.t -> t + diff --git a/src/splay.ml b/src/splay.ml new file mode 100644 index 0000000..ec5750c --- /dev/null +++ b/src/splay.ml @@ -0,0 +1,142 @@ +module type KEY = sig + + type 'a t + + val comp: 'a t -> 'b t -> ('a, 'b) Tools.cmp + + val repr: Format.formatter -> 'a t -> unit + +end + +module Make (El : KEY) = struct + + type 'a elem = 'a El.t + + type leaf (** Fantom type for typing the tree *) + type node (** Fantom type for typing the tree *) + + type 'a treeVal = + | Leaf : leaf treeVal + | Node : _ treeVal * ('a elem * 'a) * _ treeVal -> node treeVal + + type t = T : 'a treeVal ref -> t [@@unboxed] + + let empty = T (ref Leaf) + + let isEmpty (T tree) = match !tree with + | Leaf -> true + | _ -> false + + let rec splay : type a. a elem -> node treeVal -> node treeVal = fun x t -> begin + let Node (l, y, r) = t in + begin match El.comp x (fst y) with + | Tools.Eq -> t + | Tools.Lt -> + begin match l with + | Leaf -> t + | Node (ll, z, rr) -> + begin match El.comp x (fst z) with + | Tools.Eq -> Node (ll, z, Node (rr, y, r)) + | Tools.Lt -> + begin match ll with + | Leaf -> Node (ll, z, Node (rr, y, r)) + | Node _ as ll -> + let Node (newL, newV, newR) = splay x ll + in Node (newL, newV, Node (newR, z, Node (rr, y, r))) + end + | Tools.Gt -> + begin match rr with + | Leaf -> Node (ll, z, Node (rr, y, r)) + | Node _ as rr -> + let Node (newL, newV, newR) = splay x rr + in Node (Node (ll, z, newL), newV, Node (newR, y, r)) + end + end + end + | Tools.Gt -> + begin match r with + | Leaf -> t + | Node (ll, z, rr) -> + begin match El.comp x (fst z) with + | Tools.Eq -> Node (Node (l, y, ll), z, rr) + | Tools.Lt -> + begin match ll with + | Leaf -> Node (Node (l, y, ll), z, rr) + | Node _ as ll -> + let Node (newL, newV, newR) = splay x ll + in Node (Node (l, y, newL), newV, Node (newR, z, rr)) + end + | Tools.Gt -> + begin match rr with + | Leaf -> Node (Node (l, y, ll), z, rr) + | Node _ as rr -> + let Node (newL, newV, newR) = splay x rr + in Node (Node (Node(l, y, ll), z, newL), newV, newR) + end + end + end + end + end + + let member: type a. a elem -> t -> bool = fun x (T t) -> match !t with + | Leaf -> false + | Node _ as root -> + let root' = splay x root in + t := root'; + let Node (_, c', _) = root' in + begin match El.comp (fst c') x with + | Tools.Eq -> true + | _ -> false + end + + let find: type a. a elem -> t -> a = fun x (T t) -> match !t with + | Leaf -> raise Not_found + | Node _ as root -> + let root' = splay x root in + t := root'; + let Node (_, c', _) = root' in + begin match El.comp (fst c') x with + | Tools.Eq -> snd c' + | _ -> raise Not_found + end + + let add: type a. a elem -> a -> t -> t = fun key value (T t) -> match !t with + | Leaf -> T (ref (Node (Leaf, (key, value), Leaf))) + | Node _ as root -> + let root' = splay key root in + let Node (l, y, r) = root' in + begin match El.comp key (fst y) with + | Tools.Eq -> T (ref root') + | Tools.Lt -> T (ref (Node (l, (key, value), Node (Leaf, y, r)))) + | Tools.Gt -> T (ref (Node (Node (l, y, Leaf), (key, value), r))) + end + + let repr formatter (T t) = begin + + let repr_edge from formatter dest = begin + Format.fprintf formatter "\"%a\" -> \"%a\"\n" + El.repr from + El.repr dest + end in + + let rec repr': type a b. a El.t -> Format.formatter -> b treeVal -> unit = fun parent formatter -> function + | Leaf -> () + | Node (l, c, r) -> + let key = fst c in + Format.fprintf formatter "%a%a%a" + (repr_edge parent) key + (repr' key) l + (repr' key) r in + + begin match !t with + | Leaf -> Format.fprintf formatter "digraph G {}" + | Node (l, c, r) -> + let key = fst c in + Format.fprintf formatter "digraph G {\n%a%a}" + (repr' key) l + (repr' key) r + end + + end + +end diff --git a/src/splay.mli b/src/splay.mli new file mode 100755 index 0000000..41c1a5a --- /dev/null +++ b/src/splay.mli @@ -0,0 +1,30 @@ +module type KEY = sig + + type 'a t + + val comp: 'a t -> 'b t -> ('a, 'b) Tools.cmp + + val repr: Format.formatter -> 'a t -> unit + +end + +module Make (El : KEY) : sig + + type t + + (** Create an empty tree *) + val empty: t + + (** Return the element in the tree with the given key *) + val find: 'a El.t -> t -> 'a + + (** Add one element in the tree *) + val add: 'a El.t -> 'a -> t -> t + + (** Check if the key exists *) + val member: 'a El.t -> t -> bool + + (** Represent the content in dot syntax *) + val repr: Format.formatter -> t -> unit + +end diff --git a/src/tools.ml b/src/tools.ml new file mode 100755 index 0000000..6dfe564 --- /dev/null +++ b/src/tools.ml @@ -0,0 +1,392 @@ +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 + + +end + +module String = struct + + include String + + let split str ~by:sep = begin + 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 + + let cut str ~by:sep = begin + try String.sub str 0 @@ String.index str sep with + | Not_found -> str + end + + let string_of_ints v = begin + let buff = Buffer.create 1 in + let rec convert value = begin + 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 x + end in + let res = convert v in + let buff' = Buffer.create @@ String.length res in + 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 buff = UTF8.Buffer.create 16 in + f buff t; + UTF8.Buffer.contents buff + end + + let filter_float str = begin + let l = String.length str in + if l > 0 && String.get str (l - 1) = '.' then + String.sub str 0 (l - 1) + else + str + end + +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 tl + end 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[@tailrec]) f tl + end + end + + let rec findOpt p = begin function + | [] -> None + | x::l -> + if p x then + Some(x) + else + findOpt p l + end + + and find_map2 p = begin function + | [] -> raise Not_found + | x::l -> + begin try find_map p x with + Not_found -> find_map2 p l + end + end + + (** Convert the list [l] as an array *) + let to_array l = begin + let elems = ref l in + let build = fun _ -> + begin match (!elems) with + | [] -> assert false + | hd::tl -> + elems := tl; + hd + end + 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 + + let fst = Pervasives.fst + + let snd = Pervasives.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 + +end + +module Tuple3 = struct + + let fst (a, b, c) = a + + let snd (a, b, c) = b + + let thd (a, b, c) = c + + let map f (a, b, c) = (f a, f b, f c) + + let map1 f (a, b, c) = (f a, b, c) + + let map2 f (a, b, c) = (a, f b, c) + + let map3 f (a, b, c) = (a, b, f c) + + let replace1 v (a, b, c) = (v, b, c) + + let replace2 v (a, b, c) = (a, v, c) + + let replace3 v (a, b, c) = (a, b, v) +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 + + 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 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 + except (); + res + with e -> + except (); + raise e + +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 + +module type COMPARABLE_TYPE = sig + + type 'a t + + val comp: 'a t -> 'b t -> ('a, 'b) cmp + +end + +module ArrayMap(Ord: COMPARABLE_TYPE) = struct + + type 'a key = 'a Ord.t + + type t = Val : ('a key * 'a) array -> t + + let find: type a. a key -> t -> a = begin fun k (Val map) -> + let rec find_ idx : a = begin + let x, v = Array.get map idx in + match Ord.comp x k with + | Eq -> v + | Lt -> find_ ((2 * idx) + 1) + | Gt -> find_ ((2 * idx) + 2) + end in + find_ 0 + end + + let from_list l = begin + let compare (key_x, _) (key_y, _) = match Ord.comp key_x key_y with + | Eq -> 0 + | Lt -> -1 + | Gt -> 1 + in + let arr = List.to_array l in + Array.sort compare arr; + Val arr + end + +end + +(** Map for any comparable value. + This map can bind 'a key -> 'a value as long as the key are comparable. + *) +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 + + let singleton x d = Node(Empty, x, d, Empty, 1) + + let empty = Empty + + let is_empty = function + | Empty -> true + | _ -> false + + let height = function + | Empty -> 0 + | Node(_,_,_,_,h) -> h + + let create l x d r = + let hl = height l and hr = height r in + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + + let bal l x d r = + let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in + if hl > hr + 2 then begin + match l with + Empty -> invalid_arg "Map.bal" + | Node(ll, lv, ld, lr, _) -> + if height ll >= height lr then + create ll lv ld (create lr x d r) + else begin + match lr with + Empty -> invalid_arg "Map.bal" + | Node(lrl, lrv, lrd, lrr, _)-> + create (create ll lv ld lrl) lrv lrd (create lrr x d r) + end + end else if hr > hl + 2 then begin + match r with + Empty -> invalid_arg "Map.bal" + | Node(rl, rv, rd, rr, _) -> + if height rr >= height rl then + create (create l x d rl) rv rd rr + else begin + match rl with + Empty -> invalid_arg "Map.bal" + | Node(rll, rlv, rld, rlr, _) -> + create (create l x d rll) rlv rld (create rlr rv rd rr) + end + end else + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + + + let rec add: type a. a key -> a -> t -> t = begin fun x data t -> match t with + | Empty -> Node(Empty, x, data, Empty, 1) + | Node(l, v, d, r, h) -> + match Ord.comp x v with + | Eq -> Node(l, x, data, r, h) + | Lt -> bal (add x data l) v d r + | Gt -> bal l v d (add x data r) + end + + let rec find: type a. a key -> t -> a = begin fun x t -> match t with + | Empty -> raise Not_found + | Node(l, k, v, r, _) -> + match Ord.comp x k with + | Eq -> v + | Lt -> find x l + | Gt -> find x r + end + + let rec mem: type a. a key -> t -> bool = begin fun x t -> match t with + | Empty -> false + | Node(l, k, v, r, _) -> + match Ord.comp x k with + | Eq -> true + | Lt -> mem x l + | 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 diff --git a/src/unicode.ml b/src/unicode.ml new file mode 100755 index 0000000..cc8c087 --- /dev/null +++ b/src/unicode.ml @@ -0,0 +1,51 @@ +type t = Uchar.t array + +type decoder_encoding = Uutf.decoder_encoding + +let array_from_rev_list l = begin + let length = (List.length l) - 1 in + let arr = Array.make (length + 1) (Obj.magic 0) in + List.iteri (fun i elem -> Array.set arr (length - i) elem) l; + arr +end + + +let decode ?encoding str = begin + let decoder = Uutf.decoder ?encoding (`String str) in + let rec loop buf = begin match Uutf.decode decoder with + | `Uchar u -> loop (u::buf) + | `Malformed _ -> loop (Uutf.u_rep::buf) + | `Await -> assert false + | `End -> ( + array_from_rev_list buf + ) + end in + loop [] +end + +let to_utf8 (t:t) = begin + let buf = Buffer.create 512 in + Array.iter (Uutf.Buffer.add_utf_8 buf) t; + Buffer.contents buf +end + +let length = Array.length + +let get t i = Uchar.of_int @@ Array.get t i + +let make i v = Array.make i @@ Uchar.to_int v + +let init s f = Array.init s (fun x -> Uchar.to_int @@ f x) + +let sub = Array.sub + +let blit = Array.blit + +let concat = Array.concat + +let iter f t = Array.iter (fun x -> f @@ Uchar.of_int x) t + + +let to_list t = + Array.map Uchar.of_int t + |> Array.to_list diff --git a/src/unicode.mli b/src/unicode.mli new file mode 100755 index 0000000..9a48807 --- /dev/null +++ b/src/unicode.mli @@ -0,0 +1,27 @@ +type t + +type decoder_encoding = [ `ISO_8859_1 | `US_ASCII | `UTF_16 | `UTF_16BE | `UTF_16LE | `UTF_8 ] + +val decode : ?encoding:[< decoder_encoding ] -> string -> t + +val to_utf8: t -> string + +(** String functions *) + +val length : t -> int + +val get : t -> int -> Uchar.t + +val make : int -> Uchar.t -> t + +val init : int -> (int -> Uchar.t) -> t + +val sub : t -> int -> int -> t + +val blit : t -> int -> t -> int -> int -> unit + +val concat : t list -> t + +val iter : (Uchar.t -> unit) -> t -> unit + +val to_list : t -> Uchar.t list diff --git a/tools.ml b/tools.ml deleted file mode 100755 index 6dfe564..0000000 --- a/tools.ml +++ /dev/null @@ -1,392 +0,0 @@ -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 - - -end - -module String = struct - - include String - - let split str ~by:sep = begin - 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 - - let cut str ~by:sep = begin - try String.sub str 0 @@ String.index str sep with - | Not_found -> str - end - - let string_of_ints v = begin - let buff = Buffer.create 1 in - let rec convert value = begin - 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 x - end in - let res = convert v in - let buff' = Buffer.create @@ String.length res in - 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 buff = UTF8.Buffer.create 16 in - f buff t; - UTF8.Buffer.contents buff - end - - let filter_float str = begin - let l = String.length str in - if l > 0 && String.get str (l - 1) = '.' then - String.sub str 0 (l - 1) - else - str - end - -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 tl - end 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[@tailrec]) f tl - end - end - - let rec findOpt p = begin function - | [] -> None - | x::l -> - if p x then - Some(x) - else - findOpt p l - end - - and find_map2 p = begin function - | [] -> raise Not_found - | x::l -> - begin try find_map p x with - Not_found -> find_map2 p l - end - end - - (** Convert the list [l] as an array *) - let to_array l = begin - let elems = ref l in - let build = fun _ -> - begin match (!elems) with - | [] -> assert false - | hd::tl -> - elems := tl; - hd - end - 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 - - let fst = Pervasives.fst - - let snd = Pervasives.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 - -end - -module Tuple3 = struct - - let fst (a, b, c) = a - - let snd (a, b, c) = b - - let thd (a, b, c) = c - - let map f (a, b, c) = (f a, f b, f c) - - let map1 f (a, b, c) = (f a, b, c) - - let map2 f (a, b, c) = (a, f b, c) - - let map3 f (a, b, c) = (a, b, f c) - - let replace1 v (a, b, c) = (v, b, c) - - let replace2 v (a, b, c) = (a, v, c) - - let replace3 v (a, b, c) = (a, b, v) -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 - - 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 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 - except (); - res - with e -> - except (); - raise e - -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 - -module type COMPARABLE_TYPE = sig - - type 'a t - - val comp: 'a t -> 'b t -> ('a, 'b) cmp - -end - -module ArrayMap(Ord: COMPARABLE_TYPE) = struct - - type 'a key = 'a Ord.t - - type t = Val : ('a key * 'a) array -> t - - let find: type a. a key -> t -> a = begin fun k (Val map) -> - let rec find_ idx : a = begin - let x, v = Array.get map idx in - match Ord.comp x k with - | Eq -> v - | Lt -> find_ ((2 * idx) + 1) - | Gt -> find_ ((2 * idx) + 2) - end in - find_ 0 - end - - let from_list l = begin - let compare (key_x, _) (key_y, _) = match Ord.comp key_x key_y with - | Eq -> 0 - | Lt -> -1 - | Gt -> 1 - in - let arr = List.to_array l in - Array.sort compare arr; - Val arr - end - -end - -(** Map for any comparable value. - This map can bind 'a key -> 'a value as long as the key are comparable. - *) -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 - - let singleton x d = Node(Empty, x, d, Empty, 1) - - let empty = Empty - - let is_empty = function - | Empty -> true - | _ -> false - - let height = function - | Empty -> 0 - | Node(_,_,_,_,h) -> h - - let create l x d r = - let hl = height l and hr = height r in - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - let bal l x d r = - let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in - if hl > hr + 2 then begin - match l with - Empty -> invalid_arg "Map.bal" - | Node(ll, lv, ld, lr, _) -> - if height ll >= height lr then - create ll lv ld (create lr x d r) - else begin - match lr with - Empty -> invalid_arg "Map.bal" - | Node(lrl, lrv, lrd, lrr, _)-> - create (create ll lv ld lrl) lrv lrd (create lrr x d r) - end - end else if hr > hl + 2 then begin - match r with - Empty -> invalid_arg "Map.bal" - | Node(rl, rv, rd, rr, _) -> - if height rr >= height rl then - create (create l x d rl) rv rd rr - else begin - match rl with - Empty -> invalid_arg "Map.bal" - | Node(rll, rlv, rld, rlr, _) -> - create (create l x d rll) rlv rld (create rlr rv rd rr) - end - end else - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - - let rec add: type a. a key -> a -> t -> t = begin fun x data t -> match t with - | Empty -> Node(Empty, x, data, Empty, 1) - | Node(l, v, d, r, h) -> - match Ord.comp x v with - | Eq -> Node(l, x, data, r, h) - | Lt -> bal (add x data l) v d r - | Gt -> bal l v d (add x data r) - end - - let rec find: type a. a key -> t -> a = begin fun x t -> match t with - | Empty -> raise Not_found - | Node(l, k, v, r, _) -> - match Ord.comp x k with - | Eq -> v - | Lt -> find x l - | Gt -> find x r - end - - let rec mem: type a. a key -> t -> bool = begin fun x t -> match t with - | Empty -> false - | Node(l, k, v, r, _) -> - match Ord.comp x k with - | Eq -> true - | Lt -> mem x l - | 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 diff --git a/unicode.ml b/unicode.ml deleted file mode 100755 index cc8c087..0000000 --- a/unicode.ml +++ /dev/null @@ -1,51 +0,0 @@ -type t = Uchar.t array - -type decoder_encoding = Uutf.decoder_encoding - -let array_from_rev_list l = begin - let length = (List.length l) - 1 in - let arr = Array.make (length + 1) (Obj.magic 0) in - List.iteri (fun i elem -> Array.set arr (length - i) elem) l; - arr -end - - -let decode ?encoding str = begin - let decoder = Uutf.decoder ?encoding (`String str) in - let rec loop buf = begin match Uutf.decode decoder with - | `Uchar u -> loop (u::buf) - | `Malformed _ -> loop (Uutf.u_rep::buf) - | `Await -> assert false - | `End -> ( - array_from_rev_list buf - ) - end in - loop [] -end - -let to_utf8 (t:t) = begin - let buf = Buffer.create 512 in - Array.iter (Uutf.Buffer.add_utf_8 buf) t; - Buffer.contents buf -end - -let length = Array.length - -let get t i = Uchar.of_int @@ Array.get t i - -let make i v = Array.make i @@ Uchar.to_int v - -let init s f = Array.init s (fun x -> Uchar.to_int @@ f x) - -let sub = Array.sub - -let blit = Array.blit - -let concat = Array.concat - -let iter f t = Array.iter (fun x -> f @@ Uchar.of_int x) t - - -let to_list t = - Array.map Uchar.of_int t - |> Array.to_list diff --git a/unicode.mli b/unicode.mli deleted file mode 100755 index 9a48807..0000000 --- a/unicode.mli +++ /dev/null @@ -1,27 +0,0 @@ -type t - -type decoder_encoding = [ `ISO_8859_1 | `US_ASCII | `UTF_16 | `UTF_16BE | `UTF_16LE | `UTF_8 ] - -val decode : ?encoding:[< decoder_encoding ] -> string -> t - -val to_utf8: t -> string - -(** String functions *) - -val length : t -> int - -val get : t -> int -> Uchar.t - -val make : int -> Uchar.t -> t - -val init : int -> (int -> Uchar.t) -> t - -val sub : t -> int -> int -> t - -val blit : t -> int -> t -> int -> int -> unit - -val concat : t list -> t - -val iter : (Uchar.t -> unit) -> t -> unit - -val to_list : t -> Uchar.t list -- cgit v1.2.3