From 4f262d6540281487f79870aff589ca92f5d2f6c6 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly 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 @@ + + + + + + + + Drawer + + + + + 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 @@ + + + + + + + Drawer + + + + + + + +
+ + +
+ + + 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