From 4f262d6540281487f79870aff589ca92f5d2f6c6 Mon Sep 17 00:00:00 2001
From: Sébastien Dailly <sebastien@chimrod.com>
Date: Wed, 16 Dec 2020 14:39:42 +0100
Subject: Initial commit
---
.gitignore | 3 +
curves/bezier.ml | 197 +++++++++++++++++++
curves/bezier.mli | 40 ++++
curves/bspline.ml | 149 ++++++++++++++
curves/bspline.mli | 24 +++
curves/dd_splines.pdf | Bin 0 -> 184248 bytes
curves/dune | 7 +
draw/draw.ml | 233 ++++++++++++++++++++++
draw/dune | 8 +
draw/point.ml | 78 ++++++++
draw/point.mli | 13 ++
dune | 25 +++
dune-project | 1 +
events/dune | 7 +
events/timer.ml | 24 +++
events/timer.mli | 7 +
index.html | 14 ++
matrix/EltsI.ml | 28 +++
matrix/Helpers.ml | 16 ++
matrix/Matrix.ml | 529 ++++++++++++++++++++++++++++++++++++++++++++++++++
matrix/MatrixI.ml | 105 ++++++++++
matrix/Order.ml | 2 +
matrix/dune | 3 +
script.html | 48 +++++
script.ml | 275 ++++++++++++++++++++++++++
theme/dune | 7 +
theme/nord.ml | 39 ++++
theme/theme.ml | 1 +
tools/dune | 6 +
tools/utils.ml | 63 ++++++
tools/utils.mli | 21 ++
worker/dune | 9 +
worker/worker.ml | 5 +
33 files changed, 1987 insertions(+)
create mode 100755 .gitignore
create mode 100755 curves/bezier.ml
create mode 100755 curves/bezier.mli
create mode 100755 curves/bspline.ml
create mode 100755 curves/bspline.mli
create mode 100755 curves/dd_splines.pdf
create mode 100755 curves/dune
create mode 100755 draw/draw.ml
create mode 100755 draw/dune
create mode 100755 draw/point.ml
create mode 100755 draw/point.mli
create mode 100755 dune
create mode 100755 dune-project
create mode 100755 events/dune
create mode 100755 events/timer.ml
create mode 100755 events/timer.mli
create mode 100755 index.html
create mode 100755 matrix/EltsI.ml
create mode 100755 matrix/Helpers.ml
create mode 100755 matrix/Matrix.ml
create mode 100755 matrix/MatrixI.ml
create mode 100755 matrix/Order.ml
create mode 100755 matrix/dune
create mode 100755 script.html
create mode 100755 script.ml
create mode 100755 theme/dune
create mode 100755 theme/nord.ml
create mode 100755 theme/theme.ml
create mode 100755 tools/dune
create mode 100755 tools/utils.ml
create mode 100755 tools/utils.mli
create mode 100755 worker/dune
create mode 100755 worker/worker.ml
diff --git a/.gitignore b/.gitignore
new file mode 100755
index 0000000..d1a4873
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,3 @@
+_build/
+.merlin
+*.swp
diff --git a/curves/bezier.ml b/curves/bezier.ml
new file mode 100755
index 0000000..3dedc70
--- /dev/null
+++ b/curves/bezier.ml
@@ -0,0 +1,197 @@
+(**
+
+ Bezier curve
+*)
+
+module Utils = Tools.Utils
+
+type quadratic =
+ { p0:Gg.v2 (* The starting point *)
+ ; p1:Gg.v2 (* The end point *)
+ ; ctrl:Gg.v2 } (* The control point *)
+
+
+type t =
+ { p0:Gg.v2 (* The starting point *)
+ ; p1:Gg.v2 (* The end point *)
+ ; ctrl0:Gg.v2 (* The control point *)
+ ; ctrl1:Gg.v2 } (* The control point *)
+
+
+(**
+ Build a control point for a quadratic curve for passing throuht 3 points.
+ taken from https://xuhehuan.com/2608.html
+
+
+ also look to https://pomax.github.io/bezierinfo/#pointcurves
+*)
+let three_points_quadratic
+ : Gg.v2 -> Gg.v2 -> Gg.v2 -> quadratic
+ = fun p0 c1 p1 ->
+
+ let open Gg.V2 in
+
+ let vect_1 = p0 - c1
+ and vect_2 = p1 - c1 in
+ let norm1 = norm vect_1
+ and norm2 = norm vect_2 in
+ let v = (Float.sqrt (norm1 *. norm2)) /. 2. in
+
+ let ctrl = c1 - v * (( vect_1 / norm1) + (vect_2 / norm2)) in
+ {p0; p1; ctrl}
+
+(**
+
+ Convert a cubic bezier curve into a quadratic one
+
+*)
+let quadratic_to_cubic
+ : quadratic -> t
+ = fun {p0; p1; ctrl} ->
+
+ let coef = 2. /. 3. in
+
+ let open Gg.V2 in
+ { p0
+ ; p1
+ ; ctrl0 = mix p0 ctrl coef
+ ; ctrl1 = mix p1 ctrl coef }
+
+
+
+let abc_ratio
+ : int -> float -> float
+ = fun n t ->
+ let n' = Float.of_int n in
+ let bottom = (Float.pow t n') +. (Float.pow (1. -. t) n') in
+ let top = bottom -. 1. in
+ Float.abs (top /. bottom)
+
+let half_cubic_ratio = abc_ratio 3 0.5
+
+exception Not_found
+
+(**
+
+ https://pomax.github.io/bezierinfo/#pointcurves
+
+*)
+let three_points_cubic
+ : float -> Gg.v2 -> Gg.v2 -> Gg.v2 -> t
+ = fun f p0 p1 p2 ->
+
+ let open Gg.V2 in
+
+ let c = half ( p0 + p2) in
+ let a = p1 + ((p1 - c) / half_cubic_ratio) in
+
+ let vect1_0 = p1 - p0 in
+ let vect2_0 = p2 - p0 in
+
+ let d1 = norm vect1_0
+ and d2 = norm (p2 - p1) in
+ let t = d1 /. (d1 +. d2) in
+
+ let angle_1_0 = angle vect1_0
+ and angle_2_0 = angle vect2_0 in
+
+ (* get our e1-e2 distances *)
+ let angle = mod_float
+ (Gg.Float.two_pi
+ +. angle_2_0
+ -. angle_1_0)
+ Gg.Float.two_pi in
+
+ let distance = (norm vect2_0) *. f in
+
+ let bc =
+ if angle < 0. || angle > Gg.Float.pi then
+ Float.(neg distance)
+ else
+ distance in
+ let de1 = t *. bc
+ and de2 = (1. -. t) *. bc in
+
+ (* get the circle-aligned slope as normalized dx/dy *)
+ let center = Utils.center p0 p1 p2 in
+ match center with
+ | None -> raise Not_found
+ | Some center ->
+ let t' = p1 - center in
+ let tangent0 = v
+ ((x p1) -. (y t'))
+ ((y p1) +. (x t'))
+ and tangent1 = v
+ ((x p1) +. (y t'))
+ ((y p1) -. (x t')) in
+
+ let d = unit (tangent1 - tangent0) in
+
+ (* then set up an e1 and e2 parallel to the baseline *)
+ let e1 = p1 + de1 * d
+ and e2 = p1 - de2 * d in
+
+ (* then use those e1/e2 to derive the new hull coordinates *)
+ let v1 = a + (e1 - a) / (1. -. t)
+ and v2 = a + (e2 - a) / t in
+
+ let ctrl0 = p0 + (v1 - p0) / t
+ and ctrl1 = p2 + (v2 -p2) / (1. -. t) in
+
+ {p0; p1 = p2; ctrl0; ctrl1}
+
+(** Split a bezier curve in two at a given position *)
+let slice
+ : float -> t -> t * t
+ = fun t {p0; p1; ctrl0; ctrl1} ->
+
+ let mix p1 p2 = Gg.V2.mix p1 p2 t in
+
+ let p12 = mix p0 ctrl0
+ and p23 = mix ctrl0 ctrl1
+ and p34 = mix ctrl1 p1 in
+
+ let p123 = mix p12 p23
+ and p234 = mix p23 p34 in
+
+ let p1234 = mix p123 p234 in
+
+ ( { p0
+ ; ctrl0 = p12
+ ; ctrl1 = p123
+ ; p1 = p1234 }
+ , { p0 = p1234
+ ; ctrl0 = p234
+ ; ctrl1 = p34
+ ; p1 } )
+
+
+let rec get_closest_point
+ : Gg.v2 -> t -> Gg.v2
+ = fun point t ->
+ (* First devide the curve in two *)
+ let seq_0, seq_1 = slice 0.5 t in
+
+ let p0 = t.p0
+ and p1 = t.p1
+ and p01 = seq_0.p1 in (* seq_0.p1 = seq_1.p0 *)
+
+ let open Gg.V2 in
+ let center0 = mix p0 p01 0.5
+ and center1 = mix p01 p1 0.5 in
+
+ if Tools.Utils.equal_point 0.001 p0 p1 then
+ p01
+ else if (norm (point - center0)) < (norm (point - center1)) then
+ get_closest_point point seq_0
+ else
+ get_closest_point point seq_1
+
+let reverse
+ : t -> t
+ = fun bezier ->
+ {
+ p0 = bezier.p1
+ ; p1 = bezier.p0
+ ; ctrl0 = bezier.ctrl1
+ ; ctrl1 = bezier.ctrl0 }
diff --git a/curves/bezier.mli b/curves/bezier.mli
new file mode 100755
index 0000000..e90163c
--- /dev/null
+++ b/curves/bezier.mli
@@ -0,0 +1,40 @@
+type t =
+ { p0:Gg.v2 (* The starting point *)
+ ; p1:Gg.v2 (* The end point *)
+ ; ctrl0:Gg.v2 (* The control point *)
+ ; ctrl1:Gg.v2 } (* The control point *)
+
+type quadratic
+
+(**
+ Build a control point for a quadratic curve for passing throuht 3 points.
+ taken from https://xuhehuan.com/2608.html
+
+
+ also look to https://pomax.github.io/bezierinfo/#pointcurves
+*)
+val three_points_quadratic
+ : Gg.v2 -> Gg.v2 -> Gg.v2 -> quadratic
+
+(**
+ Create a curve from three points.
+
+ This is an implementation for
+ https://pomax.github.io/bezierinfo/#pointcurves
+
+*)
+val three_points_cubic
+ : float -> Gg.v2 -> Gg.v2 -> Gg.v2 -> t
+
+val quadratic_to_cubic
+ : quadratic -> t
+
+(** Split a bezier curve in two at a given position *)
+val slice
+ : float -> t -> t * t
+
+(** Return the closest point to the curve by approximation *)
+val get_closest_point
+ : Gg.v2 -> t -> Gg.v2
+
+val reverse: t -> t
diff --git a/curves/bspline.ml b/curves/bspline.ml
new file mode 100755
index 0000000..bb60227
--- /dev/null
+++ b/curves/bspline.ml
@@ -0,0 +1,149 @@
+open StdLabels
+
+type err = [`InvalidPath ]
+
+module M = Matrix.MakeMatrix (struct
+
+ type t = Float.t
+
+ let compare a b =
+
+ let v = Float.compare a b in
+ if v = 0 then Matrix.Order.Equal
+ else if v > 0 then Matrix.Order.Greater
+ else Matrix.Order.Less
+
+ let zero = Float.zero
+ let one = Float.one
+
+ let divide = (/.)
+ let multiply = ( *. )
+ let add = (+.)
+ let subtract = (-.)
+ exception NonElt
+
+
+ end)
+
+type t = Gg.v2 list
+
+let from_points
+ : Gg.v2 array -> (Gg.v2 array, [> `InvalidPath]) Result.t
+ = fun points ->
+
+ let n = (Array.length points - 2) in
+
+ if n <= 1 then
+ Result.error `InvalidPath
+ else
+
+ (* Create the initial matrix.
+
+ The matrix is augmented with two additionals columns, which will be
+ populated with the points from the path.
+ *)
+ let arr = Array.init n ~f:(fun line ->
+ Array.init (n +2) ~f:(fun row ->
+ match row - line with
+ | (-1) -> 1.
+ | 0 -> 4.
+ | 1 -> 1.
+ | _ -> 0.
+ )
+ ) in
+ let matrix = M.from_array arr in
+
+ (* Add the points from the augmented matrix *)
+ let points_array = points in
+ for line = 0 to (n -1) do
+
+ let point =
+ if line = 0 then
+ let p0 = points_array.(0)
+ and p1 = points_array.(1) in
+ Gg.V2.(6. * p1 - p0)
+ else if (line + 1) = n then
+ let p_n_2 = points_array.(n)
+ and p_n_1 = points_array.(n + 1) in
+ Gg.V2.(6. * p_n_2 - p_n_1)
+ else
+ let n' = line + 1 in
+ Gg.V2.(6. * points_array.(n'))
+ in
+ let x = (Gg.V2.x point)
+ and y = (Gg.V2.y point) in
+
+
+ M.set_elt matrix (line + 1, n + 1) x;
+ M.set_elt matrix (line + 1, n + 2) y;
+ done;
+
+ (* Resolve the matrix *)
+ let res' = M.row_reduce matrix in
+
+ (* Extract the result as points *)
+ let _, col_x = M.get_column res' (n + 1)
+ and _, col_y = M.get_column res' (n + 2) in
+
+ (* Build the result *)
+ let res = Array.make (n + 2) (Array.get points_array (n + 1) ) in
+ for i = 1 to n do
+ let point = Gg.V2.v col_x.(i - 1) col_y.(i - 1) in
+ Array.set res i point;
+ done;
+ Array.set res 0 (Array.get points_array 0);
+ Result.ok res
+
+let (let*) = Result.bind
+
+(** Build a continue curve from path
+
+ see https://www.math.ucla.edu/~baker/149.1.02w/handouts/dd_splines.pdf
+*)
+let to_bezier
+ : ?connexion0:Gg.v2 -> ?connexion1:Gg.v2 -> t -> (Bezier.t array, [> `InvalidPath]) Result.t
+ = fun ?connexion0 ?connexion1 points ->
+
+ let points' = match connexion0 with
+ | None -> points
+ | Some pt -> pt::points in
+
+ let arr_points = match connexion1 with
+ | None -> Array.of_list points'
+ | Some pt ->
+ let arr = Array.make (1 + (List.length points')) pt in
+ List.iteri points'
+ ~f:(fun i value -> Array.set arr i value);
+ arr in
+
+ let* bspline_points = from_points arr_points in
+
+ let start = match connexion0 with
+ | None -> 1
+ | Some _ -> 2
+ and end_ = match connexion1 with
+ | None -> (Array.length bspline_points) - 1
+ | Some _ -> (Array.length bspline_points) - 2 in
+
+ let result = Array.init (end_ - start + 1) ~f:(fun i ->
+
+ let i = i + start in
+
+ let prev_b = Array.get bspline_points (i - 1)
+ and bpoint = Array.get bspline_points i
+ and prev_p = Array.get arr_points (i - 1)
+ and point = Array.get arr_points i in
+ let ctrl0 = Gg.V2.(mix prev_b bpoint (1. /. 3.))
+ and ctrl1 = Gg.V2.(mix prev_b bpoint (2. /. 3.)) in
+
+ let bezier =
+ { Bezier.p0 = prev_p
+ ; Bezier.p1 = point
+ ; Bezier.ctrl0
+ ; Bezier.ctrl1 } in
+
+ bezier
+
+ ) in
+ Result.Ok result
+
diff --git a/curves/bspline.mli b/curves/bspline.mli
new file mode 100755
index 0000000..074658d
--- /dev/null
+++ b/curves/bspline.mli
@@ -0,0 +1,24 @@
+type t
+
+type err =
+ [ `InvalidPath (* Too few points in the path for building the curve *)
+ ]
+
+(** Convert a list of points into a beziers curves.
+
+ At least 4 points are required for building the path.
+
+ [to_bezier ~connexion points] create a list of beziers segments joining all
+ the points together.
+
+ [connexion0] add a virtual point in the begining for helping to get the
+ appropriate tangent when connecting path together
+
+ [connexion1] does the same at the end
+
+*)
+val to_bezier
+ : ?connexion0:Gg.v2
+ -> ?connexion1:Gg.v2
+ -> Gg.v2 list
+ -> (Bezier.t array, [> err]) Result.t
diff --git a/curves/dd_splines.pdf b/curves/dd_splines.pdf
new file mode 100755
index 0000000..2618162
Binary files /dev/null and b/curves/dd_splines.pdf differ
diff --git a/curves/dune b/curves/dune
new file mode 100755
index 0000000..34c87fb
--- /dev/null
+++ b/curves/dune
@@ -0,0 +1,7 @@
+(library
+ (name curves)
+ (libraries
+ tools
+ matrix
+ )
+ )
diff --git a/draw/draw.ml b/draw/draw.ml
new file mode 100755
index 0000000..12a1abc
--- /dev/null
+++ b/draw/draw.ml
@@ -0,0 +1,233 @@
+open StdLabels
+module Path = Brr_canvas.C2d.Path
+
+module Point = Point
+
+(** Translate the point in the canva area *)
+let translate_point
+ : area:Gg.v2 -> Gg.v2 -> (float * float)
+ = fun ~area point ->
+ let x, y = Gg.V2.(to_tuple @@ mul area point) in
+ x, ((Gg.V2.y area) -. y)
+
+let translate_point'
+ : area:Gg.v2 -> Gg.v2 -> Gg.v2 -> (float * float)
+ = fun ~area vect point ->
+ let open Gg.V2 in
+ translate_point ~area
+ (point + vect)
+
+
+(* Draw a straight line between two points *)
+let line
+ : Gg.v2 -> p1:Point.t -> Path.t -> unit
+ = fun area ~p1 path ->
+ let x, y = translate_point ~area (Point.get_coord p1) in
+ Path.line_to path ~x ~y
+
+(* Draw a simple bezier curve from the three given points *)
+let three_points
+ : Gg.v2 -> p0:Point.t -> p1:Point.t -> p2:Point.t -> Path.t -> unit
+ = fun area ~p0 ~p1 ~p2 path ->
+ let p0 = Point.get_coord p0
+ and p1 = Point.get_coord p1
+ and p2 = Point.get_coord p2 in
+ let bezier = Curves.Bezier.three_points_quadratic p0 p1 p2
+ |> Curves.Bezier.quadratic_to_cubic in
+ let cx, cy = translate_point ~area bezier.Curves.Bezier.ctrl0
+ and cx', cy' = translate_point ~area bezier.Curves.Bezier.ctrl1
+ and x, y = translate_point ~area bezier.Curves.Bezier.p1 in
+
+ Path.ccurve_to path
+ ~cx ~cy
+ ~cx' ~cy'
+ ~x ~y
+
+let multi_points
+ : ?connexion:Gg.v2 -> Gg.v2 -> Point.t list -> Path.t -> unit
+ = fun ?connexion area points path ->
+
+ let (let*) v f =
+ match v with
+ | Ok beziers -> f beziers
+ | _ -> () in
+
+ let points = List.map ~f:Point.get_coord points in
+
+ let* beziers = Curves.Bspline.to_bezier ?connexion1:connexion points in
+ Array.iter beziers
+ ~f:(fun bezier ->
+ let cx, cy = translate_point ~area bezier.Curves.Bezier.ctrl0
+ and cx', cy' = translate_point ~area bezier.Curves.Bezier.ctrl1
+ and x, y = translate_point ~area bezier.Curves.Bezier.p1 in
+
+ Path.ccurve_to path
+ ~cx ~cy
+ ~cx' ~cy'
+ ~x ~y
+ )
+
+let circle
+ : Gg.v2 -> center:Gg.v2 -> float -> Path.t -> Path.t
+ = fun area ~center r path ->
+
+ let cx, cy = translate_point ~area center in
+ Path.arc
+ path
+ ~cx ~cy
+ ~r
+ ~start:0.
+ ~stop:Gg.Float.two_pi;
+ path
+
+type path =
+ | Empty
+ | Line of Point.t * Point.t
+ | Three_point of Point.t * Point.t * Point.t
+ | Curve of Curves.Bezier.t array
+
+type t =
+ { id : int
+ ; path : path }
+
+let move_to
+ : area:Gg.v2 -> Brr_canvas.C2d.Path.t -> path -> unit
+ = fun ~area canvaPath path ->
+ match path with
+ | Empty -> ()
+ | Line (p0, _)
+ | Three_point (p0, _, _) ->
+ let x, y = translate_point ~area (Point.get_coord p0) in
+ Path.move_to canvaPath ~x ~y
+ | Curve beziers ->
+ try
+ let bezier = Array.get beziers 0 in
+ let x, y = translate_point ~area bezier.Curves.Bezier.p0 in
+ Path.move_to canvaPath ~x ~y
+ with _ -> ()
+
+let draw
+ : ?connexion:Point.t -> area:Gg.v2 -> Brr_canvas.C2d.Path.t -> path -> unit
+ = fun ?connexion ~area canvaPath path ->
+ match connexion, path with
+
+ | _, Empty -> ()
+ | None, Line (_, p1) ->
+ ignore @@ line area ~p1 canvaPath
+
+ | Some p0, Line (p1, p2)
+ | None, Three_point (p0, p1, p2)
+ | Some _, Three_point (p0, p1, p2) ->
+ ignore @@ three_points area ~p0 ~p1 ~p2 canvaPath
+
+ | _, Curve beziers ->
+ Array.iter beziers
+ ~f:(fun bezier ->
+
+ let cx, cy = translate_point ~area bezier.Curves.Bezier.ctrl0
+ and cx', cy' = translate_point ~area bezier.Curves.Bezier.ctrl1
+ and x, y = translate_point ~area bezier.Curves.Bezier.p1 in
+
+ Path.ccurve_to canvaPath
+ ~cx ~cy
+ ~cx' ~cy'
+ ~x ~y
+ )
+
+let go_back
+ : ?connexion:Point.t -> area:Gg.v2 -> Brr_canvas.C2d.Path.t -> path -> unit
+ = fun ?connexion ~area canvaPath path ->
+ let vect = Gg.V2.of_polar @@ Gg.V2.v
+ 0.02
+ Gg.Float.pi_div_4
+ in
+ match connexion, path with
+ | _, Empty -> ()
+ | _, Three_point (p0, p1, p2) ->
+ let open Point in
+ let p0' = p0 + vect
+ and p1' = p1 + vect
+ and p2' = p2 + vect in
+
+ let x, y = translate_point' ~area vect @@ Point.get_coord p2 in
+ Path.line_to canvaPath ~x ~y;
+ ignore @@ three_points area ~p0:p2' ~p1:p1' ~p2:p0' canvaPath
+ | _, Curve beziers ->
+ let last = Array.get beziers ((Array.length beziers) -1) in
+
+ let x, y =
+ last.Curves.Bezier.p1
+ |> translate_point' vect ~area in
+
+ Path.line_to canvaPath ~x ~y;
+
+ for i = 1 to Array.length beziers do
+
+ let i = (Array.length beziers) - i in
+ let bezier = Array.get beziers i in
+
+ let cx, cy = translate_point' vect ~area bezier.Curves.Bezier.ctrl1
+ and cx', cy' = translate_point' vect ~area bezier.Curves.Bezier.ctrl0
+ and x, y = translate_point' vect ~area bezier.Curves.Bezier.p0 in
+
+ Path.ccurve_to canvaPath
+ ~cx ~cy
+ ~cx' ~cy'
+ ~x ~y
+ done;
+ let x, y =
+ (Array.get beziers 0).Curves.Bezier.p0
+ |> translate_point' vect ~area in
+ Path.line_to canvaPath ~x ~y;
+
+ | _ -> ()
+
+type quick_path = Point.t list * Curves.Bezier.t list
+
+let id = ref 0
+
+let to_path
+ : quick_path -> t
+ = fun (points, beziers) ->
+
+ incr id;
+ let id = !id in
+ match beziers with
+ | [] ->
+ begin match points with
+ | p0::p1::[] -> {id; path=Line (p0, p1)}
+ | p0::p1::p2::[] -> {id; path=Three_point (p0, p1, p2)}
+ | points ->
+
+ let (let*) v f =
+ match v with
+ | Ok beziers -> f beziers
+ | _ -> {id; path=Empty} in
+
+ let points' = List.map ~f:Point.get_coord points in
+
+ let* beziers = Curves.Bspline.to_bezier points' in
+ {id; path=Curve beziers}
+ end
+ | _ ->
+ let (let*) v f =
+ match v with
+ | Ok beziers -> f beziers
+ | _ -> {id; path=Curve (Array.of_list beziers)} in
+
+ let connexion = match beziers with
+ | hd::_ -> Some hd.Curves.Bezier.p1
+ | _ -> None in
+
+ let* beziers' = Curves.Bspline.to_bezier
+ ?connexion1:connexion
+ (List.map points ~f:Point.get_coord) in
+
+
+ (* Create a new array with both lenght *)
+ let t = Array.append
+ beziers'
+ (Array.of_list beziers)
+ in
+
+ {id; path = Curve t}
diff --git a/draw/dune b/draw/dune
new file mode 100755
index 0000000..1791604
--- /dev/null
+++ b/draw/dune
@@ -0,0 +1,8 @@
+(library
+ (name draw)
+ (libraries
+ gg
+ brr
+ curves
+ )
+ )
diff --git a/draw/point.ml b/draw/point.ml
new file mode 100755
index 0000000..150bc8e
--- /dev/null
+++ b/draw/point.ml
@@ -0,0 +1,78 @@
+open StdLabels
+
+type t =
+ { p: Gg.v2
+ ; size : float
+ ; angle: float
+ }
+
+let create x y =
+ { p = Gg.V2.v x y
+ ; size = 0.1
+ ; angle = Gg.Float.pi_div_4
+ }
+
+let (+) p1 p2 =
+ { p1 with p = Gg.V2.(+) p1.p p2 }
+
+let get_coord { p; _ } = p
+
+let get_coord'
+ : t -> Gg.v2
+ = fun t ->
+ let open Gg.V2 in
+ let trans = of_polar @@ v t.size t.angle in
+ t.p + trans
+
+let return_segment
+ : Curves.Bezier.t -> Curves.Bezier.t list -> Curves.Bezier.t list
+ = fun bezier beziers ->
+ (* We gave the points in reverse order, so we have to revert the
+ curve *)
+ let bezier' = Curves.Bezier.reverse bezier in
+ bezier'::beziers
+
+
+let get_new_segment connexion0 p5 p4 p3 p2 p1 =
+ let p5' = get_coord p5
+ and p4' = get_coord p4
+ and p3' = get_coord p3
+ and p2' = get_coord p2
+ and p1' = get_coord p1 in
+
+ let points_to_link =
+ [ p1'
+ ; p2'
+ ; p3'
+ ; p4'
+ ; p5' ] in
+ Curves.Bspline.to_bezier ?connexion0 points_to_link
+
+let add_point_in_path
+ : float -> float -> t list -> Curves.Bezier.t list -> t list * Curves.Bezier.t list
+ = fun x y path beziers ->
+ let lastClick = create x y in
+ let (let*) v f =
+ match v with
+ | Ok bezier ->
+ if Array.length bezier > 0 then
+ f (Array.get bezier 0)
+ else
+ lastClick::path, beziers
+ | _ ->
+ lastClick::path, beziers
+ in
+
+ let connexion0 = match beziers with
+ | hd::_ -> Some hd.Curves.Bezier.p1
+ | _ -> None in
+
+ match path with
+ | p4::p3::p2::p1::_ ->
+ let* bezier = get_new_segment connexion0
+ lastClick p4 p3 p2 p1 in
+ (* We remove the last point and add the bezier curve in the list*)
+ let firsts = lastClick::p4::p3::p2::[] in
+ firsts, return_segment bezier beziers
+ | _ ->
+ lastClick::path, beziers
diff --git a/draw/point.mli b/draw/point.mli
new file mode 100755
index 0000000..8e3f5aa
--- /dev/null
+++ b/draw/point.mli
@@ -0,0 +1,13 @@
+type t
+
+val (+): t -> Gg.v2 -> t
+
+val get_coord : t -> Gg.v2
+
+val create: float -> float -> t
+
+val add_point_in_path
+ : float -> float -> t list -> Curves.Bezier.t list -> t list * Curves.Bezier.t list
+
+val get_coord'
+ : t -> Gg.v2
diff --git a/dune b/dune
new file mode 100755
index 0000000..36edb56
--- /dev/null
+++ b/dune
@@ -0,0 +1,25 @@
+(executables
+ (names script)
+ (libraries
+ js_of_ocaml
+ brr
+ brr.note
+ vg
+ vg.htmlc
+ messages
+ messages_json
+ worker
+ draw
+ curves
+ tools
+ events
+ )
+ (modes js)
+ (preprocess (pps js_of_ocaml-ppx))
+ (link_flags (:standard -no-check-prims))
+ )
+
+(rule
+ (targets script.js)
+ (deps script.bc.js)
+ (action (run cp %{deps} %{targets})))
diff --git a/dune-project b/dune-project
new file mode 100755
index 0000000..45acd3f
--- /dev/null
+++ b/dune-project
@@ -0,0 +1 @@
+(lang dune 2.7)
diff --git a/events/dune b/events/dune
new file mode 100755
index 0000000..68e2dd2
--- /dev/null
+++ b/events/dune
@@ -0,0 +1,7 @@
+(library
+ (name events)
+ (libraries
+ brr
+ brr.note
+ )
+)
diff --git a/events/timer.ml b/events/timer.ml
new file mode 100755
index 0000000..def9a81
--- /dev/null
+++ b/events/timer.ml
@@ -0,0 +1,24 @@
+type t = Brr.G.timer_id ref * unit Note.E.send
+
+let create
+ : unit -> (t * unit Note.E.t)
+ = fun () ->
+ let event, send = Note.E.create () in
+ (ref (-1), send), event
+
+let stop
+ : t -> unit
+ = fun (id, _) ->
+ Brr.G.stop_timer !id
+
+let start
+ : t -> float -> unit
+ = fun (id, send) d ->
+
+ Brr.G.stop_timer !id;
+ let timer_id = Brr.G.set_interval
+ ~ms:(int_of_float @@ d *. 1000.)
+ (fun () -> send ()) in
+ ignore @@ Brr.G.set_timeout ~ms:0 send;
+ id:= timer_id;
+
diff --git a/events/timer.mli b/events/timer.mli
new file mode 100755
index 0000000..4bf8a9b
--- /dev/null
+++ b/events/timer.mli
@@ -0,0 +1,7 @@
+type t
+
+val create : unit -> t * unit Note.E.t
+
+val start: t -> float -> unit
+
+val stop: t -> unit
diff --git a/index.html b/index.html
new file mode 100755
index 0000000..26ba7fa
--- /dev/null
+++ b/index.html
@@ -0,0 +1,14 @@
+<!DOCTYPE html>
+<html lang="en">
+<head>
+ <meta charset="utf-8">
+ <meta name="viewport" content="width=device-width,
+ initial-scale=1.0">
+ <script type="text/javascript" defer="defer" src="_build/default/canva.bc.js"></script>
+ <style type="text/css"> body \{ background-color: black; margin: 3em; \}</style>
+ <title>Drawer</title>
+</head>
+<body>
+ <noscript>Sorry, you need to enable JavaScript to see this page.</noscript>
+</body>
+</html>
diff --git a/matrix/EltsI.ml b/matrix/EltsI.ml
new file mode 100755
index 0000000..fcfdb50
--- /dev/null
+++ b/matrix/EltsI.ml
@@ -0,0 +1,28 @@
+module type ORDERED_AND_OPERATIONAL =
+sig
+
+ (* Exception for from_string. Is raised when from_string is passed something
+ * that is not an elt *)
+ exception NonElt
+
+ type t
+
+ (* The zero element *)
+ val zero : t
+
+ (* The one element *)
+ val one: t
+
+ (* ts must be comparable *)
+ val compare : t -> t -> Order.order
+
+ (* Basic mathematical operations must be possible *)
+ val add: t -> t -> t
+
+ val subtract: t -> t -> t
+
+ val multiply: t -> t -> t
+
+ val divide: t -> t -> t
+
+end
diff --git a/matrix/Helpers.ml b/matrix/Helpers.ml
new file mode 100755
index 0000000..6980052
--- /dev/null
+++ b/matrix/Helpers.ml
@@ -0,0 +1,16 @@
+(* Takes in a string and a separator, and separates the string into a list of
+ * substrings where each substring is between two separators or between a
+ * separator and the beginning/end of the string *)
+let explode (s: string) (space: string) : string list =
+ let rec build (curr: string) (buffer: string) (lst: string list) : string list =
+ let len = String.length curr in
+ if len = 0 then buffer::lst
+ else
+ let c = String.sub curr (len - 1) 1 in
+ if len = 1 then (c ^ buffer)::lst
+ else
+ let s' = String.sub curr 0 (len - 1) in
+ if c = space then build s' "" (buffer::lst)
+ else build s' (c ^ buffer) lst in
+ build (String.trim s) "" []
+
diff --git a/matrix/Matrix.ml b/matrix/Matrix.ml
new file mode 100755
index 0000000..7f1d54b
--- /dev/null
+++ b/matrix/Matrix.ml
@@ -0,0 +1,529 @@
+open Order
+
+module Order = Order
+
+(*************** Exceptions ***************)
+
+exception NonSquare
+exception ImproperDimensions
+
+(* Functor so we can Abstract away! *)
+module MakeMatrix (C: EltsI.ORDERED_AND_OPERATIONAL) :
+ (MatrixI.MATRIX with type elt = C.t) =
+struct
+
+
+ (*************** End Exceptions ***************)
+
+ (*************** Types ***************)
+
+ type elt = C.t
+
+ (* A matrix is a pair of dimension (n x p) and a array of arrays
+ * the first array is the row (n) and the second the column (p) *)
+ type matrix = (int * int) * (elt array array)
+
+ (*************** End Types ***************)
+
+ (*************** Base Functions ***************)
+
+ (* catching negative dimensions AND 0 dimensions and too large
+ * of a dimension so we don't have to worry about it later *)
+ let empty (rows: int) (columns: int) : matrix =
+ if rows > 0 && columns > 0 then
+ try
+ let m = Array.make_matrix rows columns C.zero in ((rows,columns),m)
+ with _ ->
+ raise ImproperDimensions
+ else (* dimension is negative or 0 *)
+ raise ImproperDimensions
+
+ (*************** End Base Functions ***************)
+
+ (*************** Helper Functions ***************)
+
+ (* get's the nth row of a matrix and returns (r, row) where r is the length
+ * of the row and row is a COPY of the original row. For example, calling
+ * calling get_row m 1 will return (3, |1 3 4 |)
+ * ________
+ * m = | 1 3 4 |
+ * |*2 5 6 |
+ *)
+ (* aside: we don't check whether n < 1 because of our matrix invariant *)
+ let get_row (((n,p),m): matrix) (row: int) : int * elt array =
+ if row <= n then
+ let row' = Array.map (fun x -> x) m.(row - 1) in
+ (p, row')
+ else
+ raise (Failure "Row out of bounds.")
+
+ (* similar to get_row. For m, get_column m 1 will return (2, |1 2|) *)
+ let get_column (((n,p),m): matrix) (column: int) : int * elt array =
+ if column <= p then
+ begin
+ let column' = Array.make n C.zero in
+ for i = 0 to n - 1 do
+ column'.(i) <- m.(i).(column - 1)
+ done;
+ (n, column')
+ end
+ else
+ raise (Failure "Column out of bounds.")
+
+ (* sets the nth row of the matrix m to the specified array a.
+ * This is done IN-PLACE. Therefore the function returns unit. You should
+ * nonetheless enfore immutability whenever possible. For a clarification on
+ * what nth row means, look at comment for get_row above. *)
+ let set_row (((n, p), m): matrix) (row: int) (a: elt array) : unit =
+ if row <= n then
+ begin
+ assert(Array.length a = p);
+ for i = 0 to p - 1 do
+ m.(row - 1).(i) <- a.(i)
+ done;
+ end
+ else
+ raise (Failure "Row out of bounds.")
+
+ (* Similar to set_row but sets the nth column instead *)
+ let set_column (((n,p),m): matrix) (column: int) (a: elt array) : unit =
+ if column <= p then
+ begin
+ assert(Array.length a = n);
+ for i = 0 to n - 1 do
+ m.(i).(column - 1) <- a.(i)
+ done;
+ end
+ else
+ raise (Failure "Column out of bounds.")
+
+ (* returns the ij-th element of a matrix (not-zero indexed) *)
+ let get_elt (((n,p),m): matrix) ((i,j): int*int) : elt =
+ if i <= n && j <= p then
+ m.(i - 1).(j - 1)
+ else
+ raise ImproperDimensions
+
+ (* Changes the i,j-th element of a matrix to e. Is not zero-indexed, and
+ * changes the matrix in place *)
+ let set_elt (((n,p),m): matrix) ((i,j): int*int) (e: elt) : unit =
+ if i <= n && j <= p then
+ m.(i - 1).(j - 1) <- e
+ else
+ raise ImproperDimensions
+
+ (* similar to map, but applies to function to the entire matrix
+ * Returns a new matrix *)
+ let map (f: elt -> elt) (mat: matrix) : matrix =
+ let (dim,m) = mat in
+ (dim, Array.map (Array.map f) m)
+
+ (* Just some wrapping of Array.iter made for Matrices! *)
+ let iter (f: elt -> unit) (mat: matrix) : unit =
+ let _, m = mat in
+ Array.iter (Array.iter f) m
+
+ (* Just some wrapping of Array.iteri. Useful for pretty
+ * printing matrix. The index is (i,j). NOT zero-indexed *)
+ let iteri (f: int -> int -> elt -> unit) (mat: matrix) : unit =
+ let _, m = mat in
+ Array.iteri (fun i row -> Array.iteri (fun j e -> f i j e) row) m
+
+ (* folds over each row using base case u and function f *)
+ (* could be a bit more efficient? *)
+ let reduce (f: 'a -> elt -> 'a) (u: 'a) (((p,q),m): matrix) : 'a =
+ let total = ref u in
+ for i = 0 to p - 1 do
+ for j = 0 to q - 1 do
+ total := f (!total) m.(i).(j)
+ done;
+ done;
+ !total
+
+ let fold_row ~(f: elt array -> 'b) ((_,m): matrix) : 'b list =
+
+ let call_row acc v = (f v)::acc in
+ Array.fold_left call_row [] m
+ |> List.rev
+
+
+
+
+ (* given two arrays, this will calculate their dot product *)
+ (* It seems a little funky, but this is done for efficiency's sake.
+ * In short, it tries to multiply each element by it's respective
+ * element until the one array is indexed out of bounds. If the
+ * other array is also out of bounds, then it returns their value.
+ * Otherwise, the arrays were the wrong size and raises ImproperDimension
+
+ THE ABOVE COMMENT HAS NOT BEEN IMPLEMENTED
+
+ Instead we calculate the length before starting
+ *)
+ let dot (v1: elt array) (v2: elt array) : elt =
+ let rec dotting (i: int) (total: elt) : elt =
+ if i = 0 then total
+ else
+ let curr = C.multiply v1.(i-1) v2.(i-1) in
+ dotting (i - 1) (C.add curr total) in
+ let len1, len2 = Array.length v1, Array.length v2 in
+ if len1 = len2 then dotting len1 C.zero
+ else raise ImproperDimensions
+
+ (* function to expose the dimensions of a matrix *)
+ let get_dimensions (m: matrix) : (int * int) =
+ let ((x,y), _) = m in (x,y)
+
+ (*************** End Helper Functions ***************)
+
+
+ (*************** Primary Matrix Functions ***************)
+
+ (* scales a matrix by the appropriate factor *)
+ let scale (m: matrix) (sc: elt) : matrix = map (C.multiply sc) m
+
+ (* Generates a matrix from a list of lists. The inners lists are the rows *)
+ let from_list (lsts : elt list list) : matrix =
+ let check_length (length: int) (lst: elt list) : int =
+ if List.length lst = length then length
+ else raise ImproperDimensions in
+ let p = List.length lsts in
+ match lsts with
+ | [] -> raise ImproperDimensions
+ | hd::tl ->
+ let len = List.length hd in
+ if List.fold_left check_length len tl = len then
+ ((p,len),Array.map Array.of_list (Array.of_list lsts))
+ else
+ raise ImproperDimensions
+
+ (* Generates a matrix from a list of lists. The inners lists are the rows *)
+ let from_array (arrs : elt array array) : matrix =
+ let check_length (length: int) (arr: elt array) : unit =
+ if Array.length arr = length then ()
+ else raise ImproperDimensions in
+ let p = Array.length arrs in
+ match Array.length arrs with
+ | 0 -> raise ImproperDimensions
+ | _ ->
+ let len = Array.length (Array.get arrs 0) in
+ Array.iter (check_length len) arrs;
+ ((p, len), arrs)
+
+ (* Adds two matrices. They must have the same dimensions *)
+ let add ((dim1,m1): matrix) ((dim2,m2): matrix) : matrix =
+ if dim1 = dim2 then
+ let n, p = dim1 in
+ let (dim', sum_m) = empty n p in
+ for i = 0 to n - 1 do
+ for j = 0 to p - 1 do
+ sum_m.(i).(j) <- C.add m1.(i).(j) m2.(i).(j)
+ done;
+ done;
+ (dim',sum_m)
+ else
+ raise ImproperDimensions
+
+
+ (* Multiplies two matrices. If the matrices have dimensions m x n and p x q, n
+ * and p must be equal, and the resulting matrix will have dimension n x q *)
+ let mult (matrix1: matrix) (matrix2: matrix) : matrix =
+ let ((m,n), _), ((p,q), _) = matrix1, matrix2 in
+ if n = p then
+ let (dim, result) = empty m q in
+ for i = 0 to m - 1 do
+ for j = 0 to q - 1 do
+ let (_,row), (_,column) = get_row matrix1 (i + 1),
+ get_column matrix2 (j + 1) in
+ result.(i).(j) <- dot row column
+ done;
+ done;
+ (dim,result)
+ else
+ raise ImproperDimensions
+
+ (*************** Helper Functions for Row Reduce ***************)
+
+ (*
+ (* returns the index of the first non-zero elt in an array*)
+ let zero (arr: elt array) : int option =
+ let index = ref 1 in
+ let empty (i: int option) (e: elt) : int option =
+ match i, C.compare e C.zero with
+ | None, Equal -> (index := !index + 1; None)
+ | None, _ -> Some (!index)
+ | _, _ -> i in
+ Array.fold_left empty None arr
+
+ (* returns the the location of the nth non-zero
+ * element in the matrix. Scans column wise. So the nth non-zero element is
+ * the FIRST non-zero element in the nth non-zero column *)
+ let nth_nz_location (m: matrix) (_: int): (int*int) option =
+ let ((n,p), _) = m in
+ let rec check_col (to_skip: int) (j: int) =
+ if j <= p then
+ let (_,col) = get_column m j in
+ match zero col with
+ | None -> check_col to_skip (j + 1)
+ | Some i ->
+ if to_skip = 0 then
+ Some (i,j)
+ else (* we want a later column *)
+ check_col (to_skip - 1) (j + 1)
+ else None in
+ check_col (n - 1) 1
+
+ (* returns the the location of the first
+ * non-zero and non-one elt. Scans column wise, from
+ * left to right. Basically, it ignores columns
+ * that are all zero or that *)
+ let fst_nz_no_loc (m: matrix): (int*int) option =
+ let ((_, p), _) = m in
+ let rec check_col (j: int) =
+ if j <= p then
+ let (_,col) = get_column m j in
+ match zero col with
+ | None -> check_col (j + 1)
+ | Some i ->
+ match C.compare col.(i-1) C.one with
+ | Equal -> check_col (j + 1)
+ | _ -> Some (i,j)
+ else None in
+ check_col 1
+ *)
+
+ (* Compares two elements in an elt array and returns the greater and its
+ * index. Is a helper function for find_max_col_index *)
+ let compare_helper (e1: elt) (e2: elt) (ind1: int) (ind2: int) : (elt*int) =
+ match C.compare e1 e2 with
+ | Equal -> (e2, ind2)
+ | Greater -> (e1, ind1)
+ | Less -> (e2, ind2)
+
+ (* Finds the element with the greatest absolute value in a column. Is not
+ * 0-indexed. If two elements are both the maximum value, returns the one with
+ * the lowest index. Returns None if this element is zero (if column is all 0)
+ *)
+ let find_max_col_index (array1: elt array) (start_index: int) : int option =
+ let rec find_index (max_index: int) (curr_max: elt) (curr_index: int)
+ (arr: elt array) =
+ if curr_index = Array.length arr then
+ (if curr_max = C.zero then None
+ else Some (max_index+1)) (* Arrays are 0-indexed but matrices aren't *)
+ else
+ (match C.compare arr.(curr_index) C.zero with
+ | Equal -> find_index max_index curr_max (curr_index+1) arr
+ | Greater ->
+ (let (el, index) = compare_helper (arr.(curr_index))
+ curr_max curr_index max_index in
+ find_index index el (curr_index+1) arr)
+ | Less ->
+ (let abs_curr_elt = C.subtract C.zero arr.(curr_index) in
+ let (el, index) = compare_helper abs_curr_elt curr_max curr_index
+ max_index in
+ find_index index el (curr_index+1) arr))
+ in
+ find_index 0 C.zero (start_index -1) array1
+
+ (* Basic row operations *)
+ (* Scales a row by sc *)
+ let scale_row (m: matrix) (num: int) (sc: elt) : unit =
+ let (_, row) = get_row m num in
+ let new_row = Array.map (C.multiply sc) row in
+ set_row m num new_row
+
+ (* Swaps two rows of a matrix *)
+ let swap_row (m: matrix) (r1: int) (r2: int) : unit =
+ let (len1, row1) = get_row m r1 in
+ let (len2, row2) = get_row m r2 in
+ let _ = assert (len1 = len2) in
+ let _ = set_row m r1 row2 in
+ let _ = set_row m r2 row1 in
+ ()
+
+ (* Subtracts a multiple of r2 from r1 *)
+ let sub_mult (m: matrix) (r1: int) (r2: int) (sc: elt) : unit =
+ let (len1, row1) = get_row m r1 in
+ let (len2, row2) = get_row m r2 in
+ let _ = assert (len1 = len2) in
+ for i = 0 to len1 - 1 do (* Arrays are 0-indexed *)
+ row1.(i) <- C.subtract row1.(i) (C.multiply sc row2.(i))
+ done;
+ set_row m r1 row1
+
+ (*************** End Helper Functions for Row Reduce ***************)
+
+ (* Returns the row reduced form of a matrix. Is not done in place, but creates
+ * a new matrix *)
+ let row_reduce (mat: matrix) : matrix =
+ let[@tailcall] rec row_reduce_h (n_row: int) (n_col: int) (mat2: matrix) : unit =
+ let ((num_row, _), _) = mat2 in
+ if (n_col = num_row + 1) then ()
+ else
+ let (_,col) = get_column mat2 n_col in
+ match find_max_col_index col n_row with
+ | None (* Column all 0s *) -> row_reduce_h n_row (n_col+1) mat2
+ | Some index ->
+ begin
+ swap_row mat2 index n_row;
+ let pivot = get_elt mat2 (n_row, n_col) in
+ scale_row mat2 (n_row) (C.divide C.one pivot);
+ for i = 1 to num_row do
+ if i <> n_row then sub_mult mat2 i n_row (get_elt mat2 (i,n_col))
+ done;
+ row_reduce_h (n_row+1) (n_col+1) mat2
+ end
+ in
+ (* Copies the matrix *)
+ let ((n,p),m) = mat in
+ let (dim,mat_cp) = empty n p in
+ for i = 0 to n - 1 do
+ for j = 0 to p - 1 do
+ mat_cp.(i).(j) <- m.(i).(j)
+ done;
+ done;
+ let _ = row_reduce_h 1 1 (dim,mat_cp) in (dim,mat_cp)
+
+ (*************** End Main Functions ***************)
+
+ (*************** Optional module functions ***************)
+
+ (* calculates the trace of a matrix *)
+ let trace (((n,p),m): matrix) : elt =
+ let rec build (elt: elt) (i: int) =
+ if i > -1 then
+ build (C.add m.(i).(i) elt) (i - 1)
+ else
+ elt in
+ if n = p then build C.zero (n - 1)
+ else raise ImproperDimensions
+
+ (* calculates the transpose of a matrix and retuns a new one *)
+ let transpose (((n,p),m): matrix) =
+ let (dim,m') = empty p n in
+ for i = 0 to n - 1 do
+ for j = 0 to p - 1 do
+ m'.(j).(i) <- m.(i).(j)
+ done;
+ done;
+ assert(dim = (p,n));
+ ((p,n),m')
+
+ (* Returns the inverse of a matrix. Uses a pretty simple algorithm *)
+ let inverse (mat: matrix) : matrix =
+ let ((n, p), _) = mat in
+ if n = p then
+ (* create augmented matrix *)
+ let augmented = empty n (2*n) in
+ for i = 1 to n do
+ let (dim,col) = get_column mat i in
+ let arr = Array.make n C.zero in
+ begin
+ assert(dim = n);
+ arr.(i-1) <- C.one;
+ set_column augmented i col;
+ set_column augmented (n + i) arr
+ end
+ done;
+ let augmented' = row_reduce augmented in
+ (* create the inverted matrix and fill in with appropriate values *)
+ let inverse = empty n n in
+ for i = 1 to n do
+ let (dim, col) = get_column augmented' (n + i) in
+ let _ = assert(dim = n) in
+ let _ = set_column inverse i col in
+ ()
+ done;
+ inverse
+ else
+ raise NonSquare
+
+ (***************** HELPER FUNCTIONS FOR DETERMINANT *****************)
+ (* creates an identity matrix of size n*)
+ let create_identity (n:int) : matrix =
+ let (dim,m) = empty n n in
+ for i = 0 to n - 1 do
+ m.(i).(i) <- C.one
+ done;
+ (dim,m)
+
+ (* Finds the index of the maximum value of an array *)
+ let find_max_index (arr: elt array) (start_index : int) : int =
+ let rec find_index (max_index: int) (curr_index: int) =
+ if curr_index = Array.length arr then max_index+1
+ else
+ match C.compare arr.(curr_index) arr.(max_index) with
+ | Equal | Less -> find_index max_index (curr_index + 1)
+ | Greater -> find_index curr_index (curr_index + 1) in
+ find_index (start_index - 1) start_index
+
+ (* Creates the pivoting matrix for A. Returns swqps. Adapted from
+ * http://rosettacode.org/wiki/LU_decomposition#Common_Lisp *)
+ let pivotize (((n,p),m): matrix) : matrix * int =
+ if n = p then
+ let swaps = ref 0 in
+ let pivot_mat = create_identity n in
+ for j = 1 to n do
+ let (_,col) = get_column ((n,p),m) j in
+ let max_index = find_max_index col j in
+ if max_index <> j then
+ (swaps := !swaps + 1; swap_row pivot_mat max_index j)
+ else ()
+ done;
+ (pivot_mat,!swaps)
+ else raise ImproperDimensions
+
+ (* decomposes a matrix into a lower triangualar, upper triangualar
+ * and a pivot matrix. It returns (L,U,P). Adapted from
+ * http://rosettacode.org/wiki/LU_decomposition#Common_Lisp *)
+ let lu_decomposition (((n,p),m): matrix) : (matrix*matrix*matrix)*int =
+ if n = p then
+ let mat = ((n,p),m) in
+ let lower, upper, (pivot,s) = empty n n, empty n n, pivotize mat in
+ let (_ ,l),(_ ,u), _ = lower,upper,pivot in
+ let ((_, _),mat') = mult pivot mat in
+ for j = 0 to n - 1 do
+ l.(j).(j) <- C.one;
+ for i = 0 to j do
+ let sum = ref C.zero in
+ for k = 0 to i - 1 do
+ sum := C.add (!sum) (C.multiply u.(k).(j) l.(i).(k))
+ done;
+ u.(i).(j) <- C.subtract mat'.(i).(j) (!sum)
+ done;
+ for i = j to n - 1 do
+ let sum = ref C.zero in
+ for k = 0 to j - 1 do
+ sum := C.add (!sum) (C.multiply u.(k).(j) l.(i).(k))
+ done;
+ let sub = C.subtract mat'.(i).(j) (!sum) in
+ l.(i).(j) <- C.divide sub u.(j).(j)
+ done;
+ done;
+ (lower,upper,pivot),s
+ else raise ImproperDimensions
+
+ (* Computes the determinant of a matrix *)
+ let determinant (m: matrix) : elt =
+ try
+ let ((n,p), _) = m in
+ if n = p then
+ let rec triangualar_det (a,mat) curr_index acc =
+ if curr_index < n then
+ let acc' = C.multiply mat.(curr_index).(curr_index) acc in
+ triangualar_det (a,mat) (curr_index + 1) acc'
+ else acc in
+ let ((dim1,l),(dim2,u), _),s = lu_decomposition m in
+ let det1, det2 = triangualar_det (dim1,l) 0 C.one,
+ triangualar_det (dim2,u) 0 C.one in
+ if s mod 2 = 0 then C.multiply det1 det2
+ else C.subtract C.zero (C.multiply det1 det2)
+ else raise ImproperDimensions
+ with
+ | _ -> C.zero
+
+
+ (*************** Optional module functions ***************)
+
+
+end
diff --git a/matrix/MatrixI.ml b/matrix/MatrixI.ml
new file mode 100755
index 0000000..fbc4e21
--- /dev/null
+++ b/matrix/MatrixI.ml
@@ -0,0 +1,105 @@
+exception NonSquare
+exception ImproperDimensions
+
+module type MATRIX =
+sig
+
+ (******** TYPES ********)
+ type elt
+
+ type matrix
+
+ (* empty matrix of nxp dimensions *)
+ val empty : int -> int -> matrix
+
+ (* Takes a list of lists and converts that to a matrix *)
+ val from_list : (elt list list) -> matrix
+
+ val from_array: elt array array -> matrix
+
+ (******** OPERATIONS ON ONE MATRIX ********)
+ (* Takes in a matrix and returns its dimensions. ie, nxp *)
+ val get_dimensions : matrix -> (int * int)
+
+ (* get's the row of a matrix: Not zero-indexed. *)
+ val get_row : matrix -> int -> (int * elt array)
+
+ (* similar to get_row *)
+ val get_column: matrix -> int -> (int * elt array)
+
+ (* sets the row of a matrix in place! Not zero-index *)
+ val set_row: matrix -> int -> elt array -> unit
+
+ (* similar to set_row, but for a column *)
+ val set_column: matrix -> int -> elt array -> unit
+
+ (* gets the element at the specified index. *)
+ val get_elt: matrix -> (int * int) -> elt
+
+ (* sets the element at the specified index *)
+ val set_elt: matrix -> (int * int) -> elt -> unit
+
+ (* Scales every element in the matrix by another elt *)
+ val scale : matrix -> elt -> matrix
+
+
+ (******** MORE ADVANCED SINGLE MATRIX OPERATIONS ********)
+ (* Returns the row reduced form of a matrix *)
+ val row_reduce: matrix -> matrix
+ (* We will implement the algorithm found in the link above *)
+
+ (* Returns the inverse of a matrix *)
+ val inverse: matrix -> matrix
+
+ (*Transposes a matrix. If the input has dimensions m x n, the output will
+ * have dimensions n x m *)
+ val transpose: matrix -> matrix
+
+ (* Returns the trace of the matrix *)
+ val trace: matrix -> elt
+
+ (******** OPERATIONS ON TWO MATRICES ********)
+ (* Adds two matrices. They must have the same dimensions *)
+ val add : matrix -> matrix -> matrix
+
+ (* Multiplies two matrices. If the matrices have dimensions m x n and p x q, n
+ * and p must be equal, and the resulting matrix will have dimension m x q *)
+ val mult: matrix -> matrix -> matrix
+
+ (**** Other Library Functions ***)
+ (* Function to make over our matrices *)
+ val map : (elt -> elt) -> matrix -> matrix
+
+ (*val iter : (elt -> unit) -> matrix -> unit*)
+
+ (* Returns the LUP decomposition of a matrix *)
+ val lu_decomposition : matrix -> (matrix * matrix * matrix) * int
+
+ (* Returns the determinant of the matrix *)
+ val determinant: matrix -> elt
+
+ (************** Other Library Functions *************)
+ val iter : (elt -> unit) -> matrix -> unit
+
+ val iteri : (int -> int -> elt -> unit) -> matrix -> unit
+
+ (* folds over each row using base case u and function f *)
+ val reduce: ('a -> elt -> 'a) -> 'a -> matrix -> 'a
+
+ val fold_row: f:(elt array -> 'b) -> matrix -> 'b list
+
+ (********** Specific for Simplex Algorithm ***********)
+ (** All of the following functions will raise ImproperDimensions
+ * Exception if the matrix is not the right size for the operation
+ **)
+
+ (* Scales a row *)
+ val scale_row: matrix -> int -> elt -> unit
+
+ (* Swaps two rows *)
+ val swap_row: matrix -> int -> int -> unit
+
+ (* Subtracts a multiple of one row (the 2nd int) from another (the 1st int) *)
+ val sub_mult: matrix -> int -> int -> elt -> unit
+
+end
diff --git a/matrix/Order.ml b/matrix/Order.ml
new file mode 100755
index 0000000..5f2aa22
--- /dev/null
+++ b/matrix/Order.ml
@@ -0,0 +1,2 @@
+(* Defines a general ordering type *)
+type order = Equal | Less | Greater
diff --git a/matrix/dune b/matrix/dune
new file mode 100755
index 0000000..1c0cab6
--- /dev/null
+++ b/matrix/dune
@@ -0,0 +1,3 @@
+(library
+ (name matrix)
+)
diff --git a/script.html b/script.html
new file mode 100755
index 0000000..cd40d37
--- /dev/null
+++ b/script.html
@@ -0,0 +1,48 @@
+<!DOCTYPE html>
+<html lang="en">
+<head>
+ <meta charset="utf-8">
+ <meta name="viewport" content="width=device-width,
+ initial-scale=1.0">
+ <style type="text/css">
+ html,
+body {
+ margin: 0;
+ padding: 0;
+}
+
+body {
+ font: 14px 'Helvetica Neue', Helvetica, Arial, sans-serif;
+ line-height: 1.4em;
+ background: #f5f5f5;
+ color: #4d4d4d;
+ min-width: 230px;
+ max-width: 550px;
+ margin: 0 auto;
+ -webkit-font-smoothing: antialiased;
+ -moz-osx-font-smoothing: grayscale;
+ font-weight: 300;
+}
+
+ </style>
+ <title>Drawer</title>
+</head>
+<body>
+ <noscript>Sorry, you need to enable JavaScript to see this page.</noscript>
+ <script id="drawer_js" type="text/javascript" defer="defer" src="script.js"></script>
+ <script>
+ var script = document.getElementById('drawer_js');
+ script.addEventListener('load', function() {
+ var app = document.getElementById('slate');
+ drawer.run(app);
+ });
+ </script>
+
+
+ <section class="todoapp" id="app">
+ <canvas id="slate" class="drawing-zone" width="800" height="800">
+ </canvas>
+ </section>
+ <footer class="info"> </footer>
+</body>
+</html>
diff --git a/script.ml b/script.ml
new file mode 100755
index 0000000..f97eed2
--- /dev/null
+++ b/script.ml
@@ -0,0 +1,275 @@
+open StdLabels
+open Note
+open Brr
+
+module Timer = Events.Timer
+
+module Point = Draw.Point
+
+type mode =
+ | Edit
+ | Out
+
+type current =
+ { points : Point.t list (* The list of points to draw *)
+ ; beziers : Curves.Bezier.t list (* All the points already fixed *)
+ }
+
+type state =
+ { mode : mode
+ ; paths : Draw.t list (* All the previous paths *)
+ ; current : current
+ ; timer : Timer.t
+ }
+
+(** Events *)
+type canva_events =
+ [ `Click of float * float
+ | `Out of float * float
+ ]
+
+type events =
+ [ canva_events
+ | `Point of float * float ]
+
+type canva_signal = Point.t
+
+module Mouse = Brr_note_kit.Mouse
+
+(** Create the element in the page, and the event handler *)
+let canva
+ : Brr.El.t -> [> canva_events] Note.E.t * (float * float) option Note.S.t * Brr_canvas.Canvas.t
+ = fun element ->
+ let module C = Brr_canvas.Canvas in
+ let c = C.of_el element in
+
+ (* Mouse events *)
+ let mouse = Brr_note_kit.Mouse.on_el
+ (fun x y -> (x, y)) element in
+
+ let click =
+ Brr_note_kit.Mouse.left_down mouse
+ |> E.map (fun c -> `Click c) in
+
+ let up =
+ Brr_note_kit.Mouse.left_up mouse
+ |> E.map (fun c -> `Out c) in
+
+ let position = Mouse.pos mouse in
+
+ let pos = S.l2 (fun b pos ->
+ if b then
+ Some pos
+ else
+ None
+ ) (Mouse.left mouse) position in
+
+ E.select [click; up], pos, c
+
+let do_action
+ : events -> state -> state
+ = fun event state ->
+ match event, state.mode with
+ | `Point (x, y), Edit ->
+ (* Add the point in the list *)
+ let points, beziers = Point.add_point_in_path
+ x y
+ state.current.points
+ state.current.beziers in
+
+ let current= {points; beziers} in
+
+ { state with current }
+ | `Click _, Out ->
+ Timer.start state.timer 0.3;
+ { state with mode = Edit }
+ | `Out (x, y), _ ->
+ Timer.stop state.timer;
+ (* Add the point in the list *)
+ let points, beziers = Point.add_point_in_path
+ x y
+ state.current.points
+ state.current.beziers in
+ let beziers = Draw.to_path (points, beziers) in
+
+ let paths = beziers::state.paths
+ and current = { points = []; beziers = []} in
+ { state with mode = Out; paths; current }
+ | _ -> state
+
+let backgroundColor = Jstr.v "#2e3440"
+let white = Jstr.v "#eceff4"
+let green = Jstr.v "#a3be8c"
+let nord8 = Jstr.v "#81a1c1"
+
+let draw
+ : ?connexion:Gg.v2 -> area:Gg.v2 -> Point.t list -> Brr_canvas.C2d.Path.t
+ = fun ?connexion ~area points ->
+
+ let open Brr_canvas.C2d in
+ let path = Path.create () in
+
+
+ let () = match points with
+ | [] -> ()
+ | hd::_ ->
+ let vect = Draw.Line (hd, Point.create 0. 0.) in
+ Draw.move_to ~area path vect in
+
+ let _ = match points with
+ | []
+ | _::[] -> ()
+ | _::p1::[] ->
+ Draw.line area ~p1 path
+ | p0::p1::p2::[] ->
+ Draw.three_points area ~p0 ~p1 ~p2 path
+ | _ ->
+ Draw.multi_points ?connexion area points path
+ in path
+
+let draw_path area points beziers =
+ let open Brr_canvas.C2d in
+ let connexion = match beziers with
+ | [] -> None
+ | hd ::_ -> Some hd.Curves.Bezier.p1 in
+ (* Firt draw all the points most recent points *)
+ let path = draw ?connexion ~area points in
+
+ (* Then add the fixed ones *)
+ let path = List.fold_left beziers
+ ~init:path
+ ~f:(fun path bezier ->
+
+ let cx, cy = Draw.translate_point ~area bezier.Curves.Bezier.ctrl0
+ and cx', cy' = Draw.translate_point ~area bezier.Curves.Bezier.ctrl1
+ and x, y = Draw.translate_point ~area bezier.Curves.Bezier.p1 in
+
+ Path.ccurve_to path
+ ~cx ~cy
+ ~cx' ~cy'
+ ~x ~y;
+ path
+ ) in
+ path
+
+let on_change canva mouse_position state =
+ let open Brr_canvas.C2d in
+
+ let w, h = Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) in
+ let area = Gg.V2.v w h in
+
+ let context = create canva in
+
+ set_fill_style context (color backgroundColor);
+ fill_rect context
+ ~x:0.0
+ ~y:0.0
+ ~w
+ ~h;
+ set_stroke_style context (color white);
+ set_fill_style context (color white);
+
+ (* If we are in edit mode, we add a point under the cursor.
+
+ Otherwise, we would only display the previous registered point, which can
+ be far away in the past, and would give to the user a sensation of lag.
+
+ *)
+ let pos = S.rough_value mouse_position in
+ let points =
+ match state.mode, pos with
+ | Edit, Some (x, y) -> (Point.create x y)::state.current.points
+ | _ -> state.current.points in
+
+ let path = draw_path area (points) state.current.beziers in
+ stroke context path;
+
+ List.iter state.paths
+ ~f:(fun path ->
+ let p = Path.create () in
+ Draw.move_to ~area p path.Draw.path;
+ Draw.draw ~area p path.Draw.path;
+ Draw.go_back ~area p path.Draw.path;
+ fill ~fill_rule:Fill_rule.nonzero context p;
+
+(*
+ match path.Draw.path with
+ | Curve c ->
+ let c' = Array.init
+ (Array.length c)
+ ~f:(fun i ->
+ Curves.Bezier.reverse @@ Array.get c ((Array.length c) -i - 1)
+ )
+ in
+ let p' = Draw.Curve c' in
+ Draw.move_to ~area p p';
+ Draw.draw ~area p p';
+ Draw.go_back ~area p p';
+ fill ~fill_rule:Fill_rule.nonzero context p;
+ ()
+ | _ -> ()
+*)
+
+ );
+ ()
+
+
+let page_main id =
+
+ let timer, tick = Timer.create () in
+
+ let init =
+ { paths = []
+ ; current = { points = []
+ ; beziers = [] }
+ ; mode = Out
+ ; timer
+ } in
+
+ (*begin match Document.find_el_by_id G.document id with*)
+ begin match (Jv.is_none id) with
+ | true -> Console.(error [str "No element with id '%s' found"; id])
+ | false ->
+
+ let canva_events, mouse_position, canva = canva (Jv.Id.of_jv id) in
+
+ let tick_event =
+ S.sample_filter mouse_position
+ ~on:tick
+ (fun pos () -> Option.map (fun p -> `Point p) pos ) in
+
+ (* The first evaluation is the state. Which is the result of all the
+ successives events to the initial state *)
+ let state =
+ E.select [canva_events; tick_event]
+ |> E.map do_action
+ |> Note.S.accum init in
+
+ (* The seconde evaluation is the canva refresh, which only occurs when
+ the mouse is updated *)
+ let v =
+ E.map (fun _ -> state) (S.changes mouse_position)
+ |> E.map (fun x -> on_change canva mouse_position (S.value x) )
+ |> fun ev -> E.log ev (fun _ -> ()) in
+
+ (* Draw the canva for first time *)
+ on_change canva mouse_position init;
+
+ let _ = Logr.hold (S.log state (fun _ -> ())) in
+ let _ = match v with
+ | None -> ()
+ | Some log -> Logr.hold log in
+ ()
+
+ end
+
+let () =
+ if Brr_webworkers.Worker.ami () then
+ ()
+ else
+ let open Jv in
+ let drawer = obj
+ [| "run", (repr page_main)
+ |] in
+
+ set global "drawer" drawer
diff --git a/theme/dune b/theme/dune
new file mode 100755
index 0000000..a812bef
--- /dev/null
+++ b/theme/dune
@@ -0,0 +1,7 @@
+(library
+ (name theme)
+ (libraries
+ color
+ gg
+ )
+ )
diff --git a/theme/nord.ml b/theme/nord.ml
new file mode 100755
index 0000000..4748d83
--- /dev/null
+++ b/theme/nord.ml
@@ -0,0 +1,39 @@
+open StdLabels
+
+let default = Color.of_rgb 5 255 255
+
+let theme =
+ [| "#2e3440"
+ ; "#3b4252"
+ ; "#434c5e"
+ ; "#4c566a"
+ (* Bright *)
+ ; "#d8dee9"
+ ; ""
+ ; "#eceff4"
+ (* Frost *)
+ ; "#8fbcbb"
+ ; ""
+ ; ""
+ ; ""
+ (* Aurora 11 - *)
+ ; "#bf616a" (* Redd color *)
+ ; ""
+ ; ""
+ ; "#a3be8c" (* Green color *)
+
+
+ |]
+ |> Array.map ~f:(fun f ->
+ Color.of_hexstring f
+ |> Option.value ~default
+ )
+
+let set_color t f =
+ let Color.Rgba'.{r; g; b; _ } = Color.to_rgba' (Array.get theme t) in
+ f r g b
+
+
+let to_gg t =
+ let Color.Rgba'.{r; g; b; _ } = Color.to_rgba' (Array.get theme t) in
+ Gg.Color.of_srgb (Gg.V4.v r g b 1.)
diff --git a/theme/theme.ml b/theme/theme.ml
new file mode 100755
index 0000000..39974b1
--- /dev/null
+++ b/theme/theme.ml
@@ -0,0 +1 @@
+module Nord = Nord
diff --git a/tools/dune b/tools/dune
new file mode 100755
index 0000000..a2c3fdb
--- /dev/null
+++ b/tools/dune
@@ -0,0 +1,6 @@
+(library
+ (name tools)
+ (libraries
+ gg
+ )
+ )
diff --git a/tools/utils.ml b/tools/utils.ml
new file mode 100755
index 0000000..b8a473f
--- /dev/null
+++ b/tools/utils.ml
@@ -0,0 +1,63 @@
+open Gg.V2
+
+let norm_angle vect =
+ mod_float
+ ((angle vect) +. Gg.Float.two_pi)
+ Gg.Float.two_pi
+
+
+let intersection
+ : (Gg.v2 * Gg.v2) -> (Gg.v2 * Gg.v2) -> Gg.v2 option
+ = fun (p0, p1) (p2, p3) ->
+ let i = p1 - p0
+ and j = p3 - p2 in
+
+ let d = (x i *. y j) -. (y i *. x j) in
+ if Float.( (abs d) <= 0.01 ) then
+ None
+ else
+ let m = ((x i) *. (y p0)
+ -. (x i) *. (y p2)
+ -. (y i) *. (x p0)
+ +. (y i) *. (x p2)) /. d in
+ Some (p2 + m * j)
+ (*
+ let k = ((x j) *. (y p0)
+ -. (x j) *. (y p2)
+ -. (y j) *. (x p0)
+ +. (y j) *. (x p2)) /. d in
+ Some (p0 + k * i)
+ *)
+
+
+let center
+ : Gg.v2 -> Gg.v2 -> Gg.v2 -> Gg.v2 option
+ = fun p0 p1 p2 ->
+ (* deltas *)
+ let d1 = p1 - p0
+ and d2 = p2 - p1 in
+
+ (* perpendiculars *)
+ let d1p = ortho d1
+ and d2p = ortho d2 in
+
+ (* Chord midpoints *)
+ let m1 = half (p0 + p1)
+ and m2 = half (p1 + p2) in
+
+ (* midpoint offsets *)
+ let m1n = m1 + d1p
+ and m2n = m2 + d2p in
+
+ intersection (m1, m1n) (m2, m2n)
+
+let rotate
+ : Gg.v2 -> float -> Gg.v2
+ = fun p0 theta ->
+ let r = x (to_polar p0) in
+ of_polar (v r theta)
+
+let equal_point
+ : float -> Gg.v2 -> Gg.v2 -> bool
+ = fun eps p0 p1 ->
+ Gg.V2.equal_f (fun v0 v1 -> (Float.abs (v1 -. v0)) <= eps ) p0 p1
diff --git a/tools/utils.mli b/tools/utils.mli
new file mode 100755
index 0000000..4e12906
--- /dev/null
+++ b/tools/utils.mli
@@ -0,0 +1,21 @@
+(** Return a normalize angle *)
+val norm_angle
+ : Gg.v2 -> float
+
+(** return the interesction for two segments *)
+val intersection
+ : (Gg.v2 * Gg.v2) -> (Gg.v2 * Gg.v2) -> Gg.v2 option
+
+(** Return the center of the cercle for three points
+ None if the point cannot be evaluated
+*)
+val center
+ : Gg.v2 -> Gg.v2 -> Gg.v2 -> Gg.v2 option
+
+(** Rotate the vector by the given angle *)
+val rotate
+ : Gg.v2 -> float -> Gg.v2
+
+(** Test equality between two points *)
+val equal_point
+ : float -> Gg.v2 -> Gg.v2 -> bool
diff --git a/worker/dune b/worker/dune
new file mode 100755
index 0000000..9f95cf8
--- /dev/null
+++ b/worker/dune
@@ -0,0 +1,9 @@
+(library
+ (name worker)
+ (libraries
+ gg
+ brr
+ note
+ curves
+ )
+ )
diff --git a/worker/worker.ml b/worker/worker.ml
new file mode 100755
index 0000000..7a8d09a
--- /dev/null
+++ b/worker/worker.ml
@@ -0,0 +1,5 @@
+open Brr_webworkers
+
+let spawn_worker name =
+ try Ok (Worker.create name) with
+ | Jv.Error e -> Error e
--
cgit v1.2.3