aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rwxr-xr-xsrc/UTF8.ml54
-rwxr-xr-xsrc/UTF8.mli92
-rwxr-xr-xsrc/actionParser.mly45
-rwxr-xr-xsrc/actions.mli28
-rwxr-xr-xsrc/catalog.ml125
-rw-r--r--src/catalog.mli38
-rwxr-xr-xsrc/cell.ml70
-rwxr-xr-xsrc/cell.mli20
-rwxr-xr-xsrc/dataType.ml125
-rwxr-xr-xsrc/dataType.mli99
-rw-r--r--src/date.ml120
-rwxr-xr-xsrc/date.mli38
-rwxr-xr-xsrc/errors.ml14
-rwxr-xr-xsrc/evaluator.ml373
-rwxr-xr-xsrc/evaluator.mli66
-rwxr-xr-xsrc/expression.ml114
-rwxr-xr-xsrc/expression.mli29
-rwxr-xr-xsrc/expressionLexer.mll84
-rwxr-xr-xsrc/expressionParser.mly113
-rwxr-xr-xsrc/functions.ml14
-rwxr-xr-xsrc/main.ml241
-rwxr-xr-xsrc/odf/odf.ml346
-rwxr-xr-xsrc/odf/odf_ExpressionLexer.mll93
-rwxr-xr-xsrc/odf/odf_ExpressionParser.mly95
-rwxr-xr-xsrc/odf/odf_ns.ml96
-rwxr-xr-xsrc/scTypes.ml354
-rwxr-xr-xsrc/scTypes.mli126
-rwxr-xr-xsrc/screen.ml459
-rwxr-xr-xsrc/screen.mli29
-rwxr-xr-xsrc/selection.ml73
-rwxr-xr-xsrc/selection.mli20
-rwxr-xr-xsrc/sheet.ml334
-rwxr-xr-xsrc/sheet.mli75
-rw-r--r--src/splay.ml142
-rwxr-xr-xsrc/splay.mli30
-rwxr-xr-xsrc/tools.ml392
-rwxr-xr-xsrc/unicode.ml51
-rwxr-xr-xsrc/unicode.mli27
38 files changed, 4644 insertions, 0 deletions
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 <int*int>BUTTON1_CLICKED
+%token <int*int>BUTTON1_RELEASED
+%token COMMAND
+
+%start <Actions.actions> 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 <string> REAL
+%token <string> NUM
+%token <string> STR
+
+%token <string> 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<ScTypes.expression> value
+%start<ScTypes.result> 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 = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+<manifest:manifest xmlns:manifest=\"urn:oasis:names:tc:opendocument:xmlns:manifest:1.0\" manifest:version=\"1.2\">\
+<manifest:file-entry manifest:full-path=\"/\" manifest:version=\"1.2\" manifest:media-type=\"application/vnd.oasis.opendocument.spreadsheet\"/>\
+<manifest:file-entry manifest:full-path=\"content.xml\" manifest:media-type=\"text/xml\"/>
+</manifest: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 <string> REAL
+%token <string> NUM
+%token <string> STR
+
+%token <string> LETTERS
+%token <string> 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<ScTypes.expression> 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