summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xMakefile11
-rwxr-xr-xblog/hash_host/hash_localhost.ml2
-rwxr-xr-xelements/timer.ml1
-rwxr-xr-xlayer/dune2
-rwxr-xr-xlayer/fillPrinter.ml (renamed from path/fillPrinter.ml)5
-rwxr-xr-xlayer/linePrinter.ml69
-rwxr-xr-xlayer/paths.ml107
-rwxr-xr-xlayer/wireFramePrinter.ml (renamed from path/wireFramePrinter.ml)4
-rwxr-xr-xlayer/wireFramePrinter.mli27
-rwxr-xr-xpath/dune2
-rwxr-xr-xpath/fixed.ml8
-rwxr-xr-xpath/fixed.mli15
-rwxr-xr-xpath/linePrinter.ml54
-rwxr-xr-xpath/path.ml107
-rwxr-xr-xpath/point.ml7
-rwxr-xr-xpath/point.mli4
-rwxr-xr-xpath/wireFramePrinter.mli27
-rwxr-xr-xscript.it/drawer.html135
-rwxr-xr-xscript.it/dune35
-rwxr-xr-xscript.it/script.ml196
-rwxr-xr-xscript.it/state.ml69
-rwxr-xr-xscript.it/worker.ml64
-rwxr-xr-xshapes/bezier.ml25
-rwxr-xr-xworker/dune9
-rwxr-xr-xworker/worker.ml5
25 files changed, 680 insertions, 310 deletions
diff --git a/Makefile b/Makefile
new file mode 100755
index 0000000..849544b
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,11 @@
+all:
+ dune build
+
+release:
+ dune build --profile=release
+
+serve:
+ cd _build/default && python3 -m http.server 5000
+
+clean:
+ dune clean
diff --git a/blog/hash_host/hash_localhost.ml b/blog/hash_host/hash_localhost.ml
index c652b6a..a41022e 100755
--- a/blog/hash_host/hash_localhost.ml
+++ b/blog/hash_host/hash_localhost.ml
@@ -1 +1 @@
-let expected_host = [%static_hash ""]
+let expected_host = [%static_hash "localhost"]
diff --git a/elements/timer.ml b/elements/timer.ml
index bd676fd..28516fc 100755
--- a/elements/timer.ml
+++ b/elements/timer.ml
@@ -30,7 +30,6 @@ let start
(fun () ->
let span = Time.counter_value t.counter in
- t.counter <- Time.counter ();
send span) in
t.id <- timer_id
diff --git a/layer/dune b/layer/dune
index f0b1b13..3c617ad 100755
--- a/layer/dune
+++ b/layer/dune
@@ -3,6 +3,6 @@
(libraries
gg
brr
- shapes
+ path
)
)
diff --git a/path/fillPrinter.ml b/layer/fillPrinter.ml
index 76056c7..2297d15 100755
--- a/path/fillPrinter.ml
+++ b/layer/fillPrinter.ml
@@ -1,4 +1,5 @@
-module Make(Repr: Layer.Repr.PRINTER) = struct
+module Point = Path.Point
+module Make(Repr: Repr.PRINTER) = struct
type t = Point.t
@@ -16,7 +17,7 @@ module Make(Repr: Layer.Repr.PRINTER) = struct
(* Start a new path. *)
let start
- : Point.t -> repr -> repr
+ : Path.Point.t -> repr -> repr
= fun t {close ; path } ->
let path = Repr.move_to (Point.get_coord t) path in
{ close
diff --git a/layer/linePrinter.ml b/layer/linePrinter.ml
new file mode 100755
index 0000000..3ed1c3c
--- /dev/null
+++ b/layer/linePrinter.ml
@@ -0,0 +1,69 @@
+module Make(Repr: Repr.PRINTER) = struct
+
+ type t = Path.Point.t
+
+ type repr =
+ { path: (Repr.t)
+ }
+
+ let create_path
+ : 'b -> repr
+ = fun _ ->
+ { path = Repr.create ()
+ }
+
+ (* Start a new path. *)
+ let start
+ : Path.Point.t -> repr -> repr
+ = fun t {path} ->
+ let path = Repr.move_to (Path.Point.get_coord t) path in
+ let path = Repr.line_to (Path.Point.get_coord' t) path in
+ { path
+ }
+
+ let line_to
+ : Path.Point.t -> Path.Point.t -> repr -> repr
+ = fun _ t {path} ->
+ let path = Repr.move_to (Path.Point.get_coord t) path in
+ let path = Repr.line_to (Path.Point.get_coord' t) path in
+ { path
+ }
+
+ let quadratic_to
+ : Path.Point.t -> Gg.v2 -> Gg.v2 -> Path.Point.t -> repr -> repr
+ = fun p0 ctrl0 ctrl1 p1 { path } ->
+
+ let path = ref path in
+
+ let bezier =
+ { Shapes.Bezier.p0 = Path.Point.get_coord p0
+ ; ctrl0
+ ; ctrl1
+ ; p1 = Path.Point.get_coord p1
+ } in
+
+ (* Mark each point on the bezier curve. The first point is the most
+ recent point *)
+ let delay =
+ ((Path.Point.get_stamp p0) -. (Path.Point.get_stamp p1))
+ *. 100. /. 3.
+ in
+ for i = 0 to (Int.of_float delay) do
+ let bezier', _ = Shapes.Bezier.slice (0.1 *. (Float.of_int i)) bezier in
+ let point = Path.Point.copy p1 bezier'.Shapes.Bezier.p1 in
+ path := Repr.move_to (Path.Point.get_coord point) !path;
+ path := Repr.line_to (Path.Point.get_coord' point) !path;
+ done;
+
+ { path = !path }
+
+ let stop
+ : repr -> repr
+ = fun path -> path
+
+
+ let get
+ : repr -> Repr.t
+ = fun {path; _} ->
+ path
+end
diff --git a/layer/paths.ml b/layer/paths.ml
new file mode 100755
index 0000000..3cedd6d
--- /dev/null
+++ b/layer/paths.ml
@@ -0,0 +1,107 @@
+(** Common module for ensuring that the function is evaluated only once *)
+
+module type REPRESENTABLE = sig
+ type t
+
+ (** Represent the path *)
+ val repr
+ : t -> (module Path.Repr.M with type t = Path.Point.t and type repr = 's) -> 's -> 's
+end
+
+(* Canva representation *)
+
+module FillCanvaRepr = FillPrinter.Make(CanvaPrinter)
+module LineCanvaRepr = LinePrinter.Make(CanvaPrinter)
+module WireCanvaRepr = WireFramePrinter.Make(CanvaPrinter)
+
+(* SVG representation *)
+
+module FillSVGRepr = FillPrinter.Make(Svg)
+module LineSVGRepr = LinePrinter.Make(Svg)
+module WireSVGRepr = WireFramePrinter.Make(Svg)
+
+
+type printer =
+ [ `Fill
+ | `Line
+ | `Ductus ]
+
+(** Draw a path to a canva *)
+let to_canva
+ : (module REPRESENTABLE with type t = 's) -> 's -> Brr_canvas.C2d.t -> printer -> unit
+ = fun (type s) (module R:REPRESENTABLE with type t = s) path ctx -> function
+ | `Fill ->
+ R.repr
+ path
+ (module FillCanvaRepr)
+ (FillCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
+ |> FillCanvaRepr.get
+ |> Brr_canvas.C2d.stroke ctx
+ | `Line ->
+ R.repr
+ path
+ (module LineCanvaRepr)
+ (LineCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
+ |> LineCanvaRepr.get
+ |> Brr_canvas.C2d.stroke ctx
+ | `Ductus ->
+ R.repr
+ path
+ (module WireCanvaRepr)
+ (WireCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
+ |> WireCanvaRepr.get
+ |> Brr_canvas.C2d.stroke ctx
+
+
+(** Draw a path and represent it as SVG *)
+let to_svg
+ : (module REPRESENTABLE with type t = 's) -> color:Jstr.t -> 's -> printer -> Brr.El.t
+ = fun (type s) (module R:REPRESENTABLE with type t = s) ~color path -> function
+ | `Fill ->
+
+ (* In order to deal with over crossing path, I cut the path in as
+ many segment as there is curve, and fill them all. Then, all of theme
+ are grouped inside a single element *)
+ let paths = ref [] in
+ let _ = R.repr
+ path
+ (module FillSVGRepr)
+ (FillSVGRepr.create_path
+ (fun p ->
+ let repr = Svg.path
+ ~at:Brr.At.[ v (Jstr.v "d") p ]
+ [] in
+
+ paths := repr::!paths;
+ Jstr.empty)) in
+
+ Brr.El.v (Jstr.v "g")
+ ~at:Brr.At.[
+ v (Jstr.v "fill") color
+ ; v (Jstr.v "stroke") color]
+ !paths
+
+ | `Line ->
+ let svg_path = R.repr
+ path
+ (module LineSVGRepr)
+ (LineSVGRepr.create_path (fun _ -> ()))
+ |> LineSVGRepr.get in
+ Svg.path
+ ~at:Brr.At.[
+ v (Jstr.v "fill") color
+ ; v (Jstr.v "stroke") color
+ ; v (Jstr.v "d") svg_path ]
+ []
+ | `Ductus ->
+ let svg_path = R.repr
+ path
+ (module WireSVGRepr)
+ (WireSVGRepr.create_path (fun _ -> ()))
+ |> WireSVGRepr.get in
+ Svg.path
+ ~at:Brr.At.[
+ v (Jstr.v "fill") color
+ ; v (Jstr.v "stroke") color
+ ; v (Jstr.v "d") svg_path ]
+ []
diff --git a/path/wireFramePrinter.ml b/layer/wireFramePrinter.ml
index 796bbd9..81ab271 100755
--- a/path/wireFramePrinter.ml
+++ b/layer/wireFramePrinter.ml
@@ -1,4 +1,6 @@
-module Make(Repr: Layer.Repr.PRINTER) = struct
+module Point = Path.Point
+
+module Make(Repr: Repr.PRINTER) = struct
type t = Point.t
type repr =
diff --git a/layer/wireFramePrinter.mli b/layer/wireFramePrinter.mli
new file mode 100755
index 0000000..b198d58
--- /dev/null
+++ b/layer/wireFramePrinter.mli
@@ -0,0 +1,27 @@
+module Make(Repr:Repr.PRINTER): sig
+
+ type repr
+
+ type t = Path.Point.t
+
+ val create_path
+ : 'b -> repr
+
+ (* Start a new path. *)
+ val start
+ : Path.Point.t -> repr -> repr
+
+ val line_to
+ : Path.Point.t -> Path.Point.t -> repr -> repr
+
+ val quadratic_to
+ : Path.Point.t -> Gg.v2 -> Gg.v2 -> Path.Point.t -> repr -> repr
+
+ val stop
+ : repr -> repr
+
+
+ val get
+ : repr -> Repr.t
+
+end
diff --git a/path/dune b/path/dune
index 42965db..863c768 100755
--- a/path/dune
+++ b/path/dune
@@ -2,8 +2,6 @@
(name path)
(libraries
gg
- brr
- layer
shapes
)
)
diff --git a/path/fixed.ml b/path/fixed.ml
index 0ff4aad..d20c897 100755
--- a/path/fixed.ml
+++ b/path/fixed.ml
@@ -41,6 +41,10 @@ module Make(Point:P) = struct
: t -> int
= fun {id; _} -> id
+ let path
+ : t -> path array
+ = fun {path; _} -> path
+
module ToFixed = struct
type t = Point.t
@@ -183,4 +187,8 @@ module Make(Point:P) = struct
) in
{id; path}
+ let update
+ : t -> path array -> t
+ = fun {id; _} path -> {id; path}
+
end
diff --git a/path/fixed.mli b/path/fixed.mli
index 1f02aed..c84b51d 100755
--- a/path/fixed.mli
+++ b/path/fixed.mli
@@ -43,4 +43,19 @@ module Make(Point:P) : sig
val map_point
: t -> (Point.t -> Point.t) -> t
+ type bezier =
+ { p0:Point.t (* The starting point *)
+ ; p1:Point.t (* The end point *)
+ ; ctrl0:Gg.v2 (* The control point *)
+ ; ctrl1:Gg.v2 } (* The control point *)
+
+ type path =
+ | Empty
+ | Line of Point.t * Point.t
+ | Curve of bezier
+
+ val path : t -> path array
+
+ val update : t -> path array -> t
+
end
diff --git a/path/linePrinter.ml b/path/linePrinter.ml
deleted file mode 100755
index c0a7d58..0000000
--- a/path/linePrinter.ml
+++ /dev/null
@@ -1,54 +0,0 @@
-module Make(Repr: Layer.Repr.PRINTER) = struct
-
- type t = Point.t
-
- type repr =
- { path: (Repr.t)
- }
-
- let create_path
- : 'b -> repr
- = fun _ ->
- { path = Repr.create ()
- }
-
- (* Start a new path. *)
- let start
- : Point.t -> repr -> repr
- = fun t {path} ->
- let path = Repr.move_to (Point.get_coord t) path in
- let path = Repr.line_to (Point.get_coord' t) path in
- { path
- }
-
- let line_to
- : Point.t -> Point.t -> repr -> repr
- = fun _ t {path} ->
- let path = Repr.move_to (Point.get_coord t) path in
- let path = Repr.line_to (Point.get_coord' t) path in
- { path
- }
-
- let quadratic_to
- : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr
- = fun _p0 _ctrl0 _ctrl1 p1 {path} ->
-
- let path = Repr.move_to (Point.get_coord p1) path in
- let path = Repr.line_to (Point.get_coord' p1) path in
-
- { path
- }
-
- let stop
- : repr -> repr
- = fun {path} ->
-
-
- { path
- }
-
- let get
- : repr -> Repr.t
- = fun {path; _} ->
- path
-end
diff --git a/path/path.ml b/path/path.ml
index 9b6b9c4..ea90de4 100755
--- a/path/path.ml
+++ b/path/path.ml
@@ -1,112 +1,7 @@
(** Common module for ensuring that the function is evaluated only once *)
module Point = Point
-
-module type REPRESENTABLE = sig
- type t
-
- (** Represent the path *)
- val repr
- : t -> (module Repr.M with type t = Point.t and type repr = 's) -> 's -> 's
-end
-
+module Repr = Repr
module Path_Builder = Builder.Make(Point)
module Fixed = Fixed.Make(Point)
-(* Canva representation *)
-
-module FillCanvaRepr = FillPrinter.Make(Layer.CanvaPrinter)
-module LineCanvaRepr = LinePrinter.Make(Layer.CanvaPrinter)
-module WireCanvaRepr = WireFramePrinter.Make(Layer.CanvaPrinter)
-
-(* SVG representation *)
-
-module FillSVGRepr = FillPrinter.Make(Layer.Svg)
-module LineSVGRepr = LinePrinter.Make(Layer.Svg)
-module WireSVGRepr = WireFramePrinter.Make(Layer.Svg)
-
-
-type printer =
- [ `Fill
- | `Line
- | `Wire ]
-
-(** Draw a path to a canva *)
-let to_canva
- : (module REPRESENTABLE with type t = 's) -> 's -> Brr_canvas.C2d.t -> printer -> unit
- = fun (type s) (module R:REPRESENTABLE with type t = s) path ctx -> function
- | `Fill ->
- R.repr
- path
- (module FillCanvaRepr)
- (FillCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
- |> FillCanvaRepr.get
- |> Brr_canvas.C2d.stroke ctx
- | `Line ->
- R.repr
- path
- (module LineCanvaRepr)
- (LineCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
- |> LineCanvaRepr.get
- |> Brr_canvas.C2d.stroke ctx
- | `Wire ->
- R.repr
- path
- (module WireCanvaRepr)
- (WireCanvaRepr.create_path (fun p -> Brr_canvas.C2d.fill ctx p; p))
- |> WireCanvaRepr.get
- |> Brr_canvas.C2d.stroke ctx
-
-
-(** Draw a path and represent it as SVG *)
-let to_svg
- : (module REPRESENTABLE with type t = 's) -> color:Jstr.t -> 's -> printer -> Brr.El.t
- = fun (type s) (module R:REPRESENTABLE with type t = s) ~color path -> function
- | `Fill ->
-
- (* In order to deal with over crossing path, I cut the path in as
- many segment as there is curve, and fill them all. Then, all of theme
- are grouped inside a single element *)
- let paths = ref [] in
- let _ = R.repr
- path
- (module FillSVGRepr)
- (FillSVGRepr.create_path
- (fun p ->
- let repr = Layer.Svg.path
- ~at:Brr.At.[ v (Jstr.v "d") p ]
- [] in
-
- paths := repr::!paths;
- Jstr.empty)) in
-
- Brr.El.v (Jstr.v "g")
- ~at:Brr.At.[
- v (Jstr.v "fill") color
- ; v (Jstr.v "stroke") color]
- !paths
-
- | `Line ->
- let svg_path = R.repr
- path
- (module LineSVGRepr)
- (LineSVGRepr.create_path (fun _ -> ()))
- |> LineSVGRepr.get in
- Layer.Svg.path
- ~at:Brr.At.[
- v (Jstr.v "fill") color
- ; v (Jstr.v "stroke") color
- ; v (Jstr.v "d") svg_path ]
- []
- | `Wire ->
- let svg_path = R.repr
- path
- (module WireSVGRepr)
- (WireSVGRepr.create_path (fun _ -> ()))
- |> WireSVGRepr.get in
- Layer.Svg.path
- ~at:Brr.At.[
- v (Jstr.v "fill") color
- ; v (Jstr.v "stroke") color
- ; v (Jstr.v "d") svg_path ]
- []
diff --git a/path/point.ml b/path/point.ml
index 06eb635..031e1e0 100755
--- a/path/point.ml
+++ b/path/point.ml
@@ -2,18 +2,21 @@ type t =
{ p: Gg.v2
; size : float
; angle: float
+ ; stamp : float
}
let empty =
{ p = Gg.V2.of_tuple (0., 0.)
; size = 0.
; angle = 0.
+ ; stamp = 0.
}
-let create ~angle ~width ~x ~y =
+let create ~angle ~width ~stamp ~x ~y =
{ p = Gg.V2.v x y
; size = width
; angle = Gg.Float.rad_of_deg (180. -. angle )
+ ; stamp
}
let copy point p =
@@ -30,6 +33,8 @@ let (+) p1 p2 =
let get_coord { p; _ } = p
+let get_stamp { stamp; _} = stamp
+
let get_coord'
: t -> Gg.v2
= fun t ->
diff --git a/path/point.mli b/path/point.mli
index 649a3be..db87a71 100755
--- a/path/point.mli
+++ b/path/point.mli
@@ -6,7 +6,9 @@ val (+): t -> Gg.v2 -> t
val get_coord : t -> Gg.v2
-val create: angle:float -> width:float -> x:float -> y:float -> t
+val get_stamp : t -> float
+
+val create: angle:float -> width:float -> stamp:float -> x:float -> y:float -> t
val copy : t -> Gg.v2 -> t
diff --git a/path/wireFramePrinter.mli b/path/wireFramePrinter.mli
deleted file mode 100755
index fa8a5a8..0000000
--- a/path/wireFramePrinter.mli
+++ /dev/null
@@ -1,27 +0,0 @@
-module Make(Repr:Layer.Repr.PRINTER): sig
-
- type repr
-
- type t = Point.t
-
- val create_path
- : 'b -> repr
-
- (* Start a new path. *)
- val start
- : Point.t -> repr -> repr
-
- val line_to
- : Point.t -> Point.t -> repr -> repr
-
- val quadratic_to
- : Point.t -> Gg.v2 -> Gg.v2 -> Point.t -> repr -> repr
-
- val stop
- : repr -> repr
-
-
- val get
- : repr -> Repr.t
-
-end
diff --git a/script.it/drawer.html b/script.it/drawer.html
new file mode 100755
index 0000000..c55a849
--- /dev/null
+++ b/script.it/drawer.html
@@ -0,0 +1,135 @@
+
+<!DOCTYPE html>
+<html lang="fr_fr">
+<head>
+ <meta charset="utf-8" />
+ <meta http-equiv="X-UA-Compatible" content="IE=edge" />
+ <meta name="HandheldFriendly" content="True" />
+ <meta name="viewport" content="width=device-width, initial-scale=1.0" />
+ <meta name="robots" content="noindex, nofollow" />
+
+ <link href="https://fonts.googleapis.com/css2?family=Source+Code+Pro:ital,wght@0,400;0,700;1,400&family=Source+Sans+Pro:ital,wght@0,300;0,400;0,700;1,400&display=swap" rel="stylesheet">
+
+ <link rel="stylesheet" type="text/css" href="/theme/stylesheet/style.min.css">
+
+
+ <link id="pygments-light-theme" rel="stylesheet" type="text/css"
+ href="//localhost:8000/theme/pygments/monokai.min.css">
+
+
+ <link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/fontawesome.css">
+ <link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/brands.css">
+ <link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/solid.css">
+
+ <link href="//localhost:8000/custom.css" rel="stylesheet">
+
+ <link href="//localhost:8000/feeds/all.atom.xml" type="application/atom+xml" rel="alternate" title="Chimrod Atom">
+
+
+
+
+
+ <meta name="author" content="Chimrod" />
+ <meta name="description" content="" />
+<meta property="og:site_name" content="Chimrod"/>
+<meta property="og:type" content="blog"/>
+<meta property="og:title" content="Chimrod"/>
+<meta property="og:description" content=""/>
+<meta property="og:locale" content="en_US"/>
+<meta property="og:url" content="//localhost:8000"/>
+<meta property="og:image" content="/images/profile.png">
+
+
+
+ <title>Chimrod &ndash; Drawer</title>
+
+</head>
+<body class="light-theme">
+ <aside>
+ <div>
+ <a href="//localhost:8000">
+ <img src="/profile.png" alt="Chimrod" title="Chimrod">
+ </a>
+
+ <h1>
+ <a href="//localhost:8000">Chimrod</a>
+ </h1>
+
+
+
+ <nav>
+ <ul class="list">
+
+
+
+ <li>
+ <a target="_self" href="http://git.chimrod.com" >git</a>
+ </li>
+ </ul>
+ </nav>
+
+ <ul class="social">
+ </ul>
+ </div>
+
+ </aside>
+ <main>
+
+ <nav>
+ <a href="//localhost:8000">Accueil</a>
+
+
+ <a href="//localhost:8000/feeds/all.atom.xml">Atom</a>
+
+ </nav>
+
+<article class="single">
+ <header>
+
+ <h1 id="drawer">Drawer</h1>
+ </header>
+ <div>
+
+ <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">
+ </section>
+
+ Cliquez dans l&#8217;ardoise pour commencer à dessiner<span style="white-space:nowrap">&thinsp;</span>!
+
+ <footer class="info"> </footer>
+ </div>
+</article>
+
+ <footer>
+<p>&copy; </p>
+<p>
+Construit avec <a href="http://getpelican.com" target="_blank">Pelican</a> utilisant le thème <a href="http://bit.ly/flex-pelican" target="_blank">Flex</a>
+</p> </footer>
+ </main>
+
+
+
+
+<script type="application/ld+json">
+{
+ "@context" : "http://schema.org",
+ "@type" : "Blog",
+ "name": " Chimrod ",
+ "url" : "//localhost:8000",
+ "image": "./profile.png",
+ "description": ""
+}
+</script>
+
+
+</body>
+</html>
diff --git a/script.it/dune b/script.it/dune
index 1536f2b..e7ca0dc 100755
--- a/script.it/dune
+++ b/script.it/dune
@@ -1,26 +1,39 @@
-(executables
- (names script)
+(executable
+ (name script)
(libraries
- js_of_ocaml
brr
brr.note
- vg
- vg.htmlc
- messages
- messages_json
- worker
shapes
- tools
elements
blog
- path
+ layer
)
(modes js)
- (preprocess (pps ppx_hash))
+ (modules script state)
+ (preprocess (pps ppx_hash js_of_ocaml-ppx))
(link_flags (:standard -no-check-prims))
)
+
(rule
(targets script.js)
(deps script.bc.js)
(action (run cp %{deps} %{targets})))
+
+(executable
+ (name worker)
+ (modules worker)
+ (libraries
+ js_of_ocaml
+ shapes
+ path
+ )
+ (modes js)
+ (preprocess (pps ppx_hash js_of_ocaml-ppx))
+ (link_flags (:standard -no-check-prims))
+ )
+
+(rule
+ (targets worker.js)
+ (deps worker.bc.js)
+ (action (run cp %{deps} %{targets})))
diff --git a/script.it/script.ml b/script.it/script.ml
index 3e52f5c..131ea39 100755
--- a/script.it/script.ml
+++ b/script.it/script.ml
@@ -80,8 +80,16 @@ let click_event el =
let show_value input =
El.txt (Jstr.of_float input)
+type 'a param_events =
+ { width : float S.t
+ ; angle : float S.t
+ ; export : unit E.t
+ ; delete : unit E.t
+ ; rendering : ([> State.render_event] as 'a) E.t
+ }
+
let set_sidebar
- : El.t -> State.state -> unit E.t * float S.t * float S.t *unit E.t
+ : El.t -> State.state -> _ param_events
= fun element state ->
let open El in
@@ -130,6 +138,7 @@ let set_sidebar
; v (Jstr.v "max") (Jstr.v "90")
; At.value (Jstr.of_float state.angle)
] in
+
let angle = El.div [] in
Elr.def_children
angle
@@ -143,17 +152,32 @@ let set_sidebar
let render =
El.select
- [ El.option ~at:At.[value (Jstr.v "Fill")]
+ [ El.option ~at:At.[value (Jstr.v "1")]
[ txt' "Fill"]
- ; El.option ~at:At.[value (Jstr.v "Wireframe")]
- [ txt' "Wireframe"]
- ; El.option ~at:At.[value (Jstr.v "Ductus")]
+ ; El.option ~at:At.[value (Jstr.v "2")]
[ txt' "Ductus"]
+(*
+ ; El.option ~at:At.[value (Jstr.v "3")]
+ [ txt' "Line"]
+*)
] in
+
let rendering' = El.div
[ txt' "Rendering : "
; render ] in
+ let render_event =
+ Evr.on_el
+ Ev.change (fun _ ->
+ let raw_value = El.prop El.Prop.value render
+ |> Jstr.to_int in
+ match raw_value with
+ | Some 1 -> `Rendering `Fill
+ | Some 2 -> `Rendering `Line
+ | Some 3 -> `Rendering `Ductus
+ | _ -> `Rendering `Fill
+ ) rendering' in
+
let () =
El.append_children element
[ hr ()
@@ -172,14 +196,19 @@ let set_sidebar
]
in
- delete_event, angle_event, nib_size_event, export_event
+ { delete = delete_event
+ ; angle = angle_event
+ ; width = nib_size_event
+ ; export = export_event
+ ; rendering = render_event
+ }
let backgroundColor = Blog.Nord.nord0
let white = Jstr.v "#eceff4"
let green = Jstr.v "#a3be8c"
(** Redraw the canva on update *)
-let on_change canva mouse_position state =
+let on_change canva mouse_position timer state =
let module Cd2d = Brr_canvas.C2d in
let w, h = Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) in
@@ -206,15 +235,14 @@ let on_change canva mouse_position state =
let current =
begin match state.State.mode, pos with
| Edit, Some point ->
- State.insert_or_replace state point state.current
+ let stamp = Elements.Timer.delay timer in
+ State.insert_or_replace state point stamp state.current
| _ ->
state.current
end
in
- let repr = `Fill in
-
- Path.to_canva (module Path.Path_Builder) current context repr;
+ Layer.Paths.to_canva (module Path.Path_Builder) current context state.rendering;
List.iter state.paths
~f:(fun path ->
@@ -233,14 +261,21 @@ let on_change canva mouse_position state =
| _ -> ()
in
- Path.to_canva (module Path.Fixed) path context repr
+ Layer.Paths.to_canva (module Path.Fixed) path context state.rendering
);
()
+let spawn_worker () =
+ try
+ Ok (Brr_webworkers.Worker.create (Jstr.v "worker.js"))
+ with
+ | Jv.Error e -> Error e
let page_main id =
- let delete_event', angle_signal', width_signal', export_event' =
+ let timer, tick = Elements.Timer.create () in
+
+ let parameters =
begin match Blog.Sidebar.get () with
| None ->
Jv.throw (Jstr.v "No sidebar")
@@ -249,11 +284,11 @@ let page_main id =
Blog.Sidebar.clean el;
set_sidebar el State.init
end in
- let delete_event = E.map (fun () -> `Delete) delete_event'
- and export_event = E.map (fun () -> `Export) export_event'
- and angle_event = S.changes angle_signal'
+ let delete_event = E.map (fun () -> `Delete) parameters.delete
+ and export_event = E.map (fun () -> `Export) parameters.export
+ and angle_event = S.changes parameters.angle
|> E.map (fun value -> `Angle value)
- and width_event = S.changes width_signal'
+ and width_event = S.changes parameters.width
|> E.map (fun value -> `Width value)
in
@@ -263,64 +298,81 @@ let page_main id =
| true -> Console.(error [str "No element with id '%s' found"; id])
| false ->
- (* Add the events to the canva :
-
- - The mouse position is a signal used for both the update and the
- canva refresh
-
- - Get also the click event for starting to draw
- *)
-
- let canva_events, mouse_position, canva = canva (Jv.Id.of_jv id) in
-
- let tick_event =
- S.sample_filter mouse_position
- ~on:State.tick
- (fun pos f -> Option.map (fun p -> `Point (f, 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
- ; angle_event
- ; width_event
- ; delete_event
- ; export_event ]
- |> E.map State.do_action
- |> Note.S.accum State.init in
-
- (* The seconde evaluation is the canva refresh, which only occurs when
- the mouse is updated, or on delete events *)
- let _ =
- E.select
- [ E.map (fun _ -> ()) (S.changes mouse_position)
- ; E.map (fun _ -> ()) (S.changes angle_signal')
- ; E.map (fun _ -> ()) (S.changes width_signal')
- ; delete_event' ]
- |> fun ev -> E.log ev (fun _ -> on_change canva mouse_position (S.value state) )
- |> Option.iter Logr.hold in
-
-
- (* Draw the canva for first time *)
- on_change canva mouse_position State.init;
-
- (* Hold the state *)
- let _ = Logr.hold (S.log state (fun _ -> ())) in
- ()
+ match spawn_worker () with
+ | Error e -> El.set_children (Jv.Id.of_jv id)
+ [ El.p El.[txt (Jv.Error.message e)]]
+ | Ok worker ->
+
+ let worker_event, worker_send = E.create () in
+ let my_host = Uri.host @@ Window.location @@ G.window in
+ if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then (
+ let target = Brr_webworkers.Worker.as_target worker in
+ Ev.listen Brr_io.Message.Ev.message
+ (fun t ->
+ Ev.as_type t
+ |> Brr_io.Message.Ev.data
+ |> worker_send)
+ target);
+
+ (* Add the events to the canva :
+
+ - The mouse position is a signal used for both the update and the
+ canva refresh
+
+ - Get also the click event for starting to draw
+ *)
+
+ 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 f -> Option.map (fun p -> `Point (f, 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
+ [ worker_event
+ ; canva_events
+ ; tick_event
+ ; angle_event
+ ; width_event
+ ; delete_event
+ ; export_event
+ ; parameters.rendering
+ ]
+ |> E.map (State.do_action worker timer)
+ |> Note.S.accum State.init in
+
+ (* The seconde evaluation is the canva refresh, which only occurs when
+ the mouse is updated, or on delete events *)
+ let _ =
+ E.select
+ [ E.map (fun _ -> ()) (S.changes mouse_position)
+ ; E.map (fun _ -> ()) (S.changes parameters.angle)
+ ; E.map (fun _ -> ()) (S.changes parameters.width)
+ ; E.map (fun _ -> ()) parameters.rendering
+ ; E.map (fun _ -> ()) worker_event
+ ; parameters.delete ]
+ |> fun ev -> E.log ev (fun _ -> on_change canva mouse_position timer (S.value state) )
+ |> Option.iter Logr.hold in
+
+
+ (* Draw the canva for first time *)
+ on_change canva mouse_position timer State.init;
+
+ (* Hold the state *)
+ let _ = Logr.hold (S.log state (fun _ -> ())) in
+ ()
end
let () =
- if Brr_webworkers.Worker.ami () then
- ()
- else (
- let open Jv in
- let drawer = obj
- [| "run", (repr page_main)
- |] in
+ let open Jv in
+ let drawer = obj
+ [| "run", (repr page_main)
+ |] in
- set global "drawer" drawer
- )
+ set global "drawer" drawer
diff --git a/script.it/state.ml b/script.it/state.ml
index 5a1ef8f..cfde0b0 100755
--- a/script.it/state.ml
+++ b/script.it/state.ml
@@ -1,12 +1,8 @@
open StdLabels
open Brr
-let expected_host = Blog.Hash_host.expected_host
-
let backgroundColor = Blog.Nord.nord0
-let timer, tick = Elements.Timer.create ()
-
type mode =
| Edit
| Selection of int
@@ -22,10 +18,21 @@ type button_events =
[ `Delete
| `Export
]
+type render_event =
+ [
+ `Rendering of Layer.Paths.printer
+ ]
+
+type worker_event =
+ [ `Basic of Jv.t
+ | `Complete of (int * (Path.Fixed.path array))
+ ]
type events =
[ canva_events
| button_events
+ | render_event
+ | worker_event
| `Point of float * (float * float)
| `Width of float
| `Angle of float
@@ -41,12 +48,13 @@ type state =
; current : Path.Path_Builder.t
; width : float
; angle : float
+ ; rendering : Layer.Paths.printer
}
-let insert_or_replace state ((x, y) as p) path =
+let insert_or_replace state ((x, y) as p) stamp path =
let width = state.width
and angle = state.angle in
- let point = Path.Point.create ~x ~y ~angle ~width in
+ let point = Path.Point.create ~x ~y ~angle ~width ~stamp in
match Path.Path_Builder.peek path with
| None ->
Path.Path_Builder.add_point
@@ -97,14 +105,15 @@ let update_selection id state f =
{ state with paths }
let do_action
- : events -> state -> state
- = fun event state ->
+ : Brr_webworkers.Worker.t -> Elements.Timer.t -> events -> state -> state
+ = fun worker timer event state ->
match event, state.mode with
- | `Point (_delay, point), Edit ->
+ | `Point (delay, point), Edit ->
(* Add the point in the list *)
let current = insert_or_replace
state
point
+ delay
state.current in
{ state with current }
@@ -115,16 +124,17 @@ let do_action
let width = state.width
and angle = state.angle in
+ let stamp = 0. in
let point =
match check_selection p state.paths with
| None ->
(* Start a new path with the point clicked *)
- Path.Point.create ~x ~y ~angle ~width
+ Path.Point.create ~x ~y ~angle ~width ~stamp
| Some (p, _) ->
(* If the point is close to an existing path, we use the closest
point in the path instead *)
let x, y = Gg.V2.to_tuple p in
- Path.Point.create ~x ~y ~angle ~width
+ Path.Point.create ~x ~y ~angle ~width ~stamp
in
let current = Path.Path_Builder.add_point
@@ -150,6 +160,7 @@ let do_action
end
| `Out point, Edit ->
+ let stamp = Elements.Timer.delay timer in
Elements.Timer.stop timer;
begin match Path.Path_Builder.peek2 state.current with
(* If there is at last two points selected, handle this as a curve
@@ -162,14 +173,20 @@ let do_action
| Some (p, _) -> Gg.V2.to_tuple p in
*)
- let current = insert_or_replace state point state.current in
+ let current = insert_or_replace state point stamp state.current in
let paths =
let last = Path.Fixed.to_fixed
(module Path.Path_Builder)
current
in
+
+ let id = Path.Fixed.id last
+ and path = Path.Fixed.path last in
+ let () = Brr_webworkers.Worker.post worker (`Complete (id, path)) in
last::state.paths
and current = Path.Path_Builder.empty in
+
+
{ state with
mode = Out
; paths; current }
@@ -198,8 +215,7 @@ let do_action
| `Export, _ ->
let my_host = Uri.host @@ Window.location @@ G.window in
-
- if (Hashtbl.hash my_host) = expected_host then (
+ if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then (
(* Convert the path into an sVG element *)
let svg = Layer.Svg.svg
~at:Brr.At.[
@@ -208,11 +224,11 @@ let do_action
(List.map state.paths
~f:(fun path ->
- Path.to_svg
+ Layer.Paths.to_svg
~color:backgroundColor
(module Path.Fixed)
path
- `Fill
+ state.rendering
)) in
let content = El.prop Elements.Prop.outerHTML svg in
@@ -248,6 +264,26 @@ let do_action
| `Delete, Out
-> state
+ | `Rendering rendering, _ ->
+ { state with rendering}
+
+
+ | `Basic t, _ ->
+ Console.(log [t]);
+ state
+
+ | `Complete (id, paths), _ ->
+ let paths = List.map state.paths
+ ~f:(fun path ->
+ let id' = Path.Fixed.id path in
+ match id = id' with
+ | false -> path
+ | true ->
+ Path.Fixed.update path paths
+ ) in
+ { state with paths }
+
+
(* Some non possible cases *)
| `Out _, Out
| `Point _, Out
@@ -263,4 +299,5 @@ let init =
; mode = Out
; angle = 30.
; width = 10.
+ ; rendering = `Fill
}
diff --git a/script.it/worker.ml b/script.it/worker.ml
new file mode 100755
index 0000000..3150869
--- /dev/null
+++ b/script.it/worker.ml
@@ -0,0 +1,64 @@
+open StdLabels
+open Js_of_ocaml
+
+type message = [
+ | `Complete of (int * (Path.Fixed.path array))
+]
+
+exception Empty_Element
+
+let get_point
+ : Path.Fixed.path -> Gg.v2
+ = function
+ | Empty -> raise Empty_Element
+ | Line (_, p1) -> Path.Point.get_coord p1
+ | Curve bezier -> Path.Point.get_coord bezier.Path.Fixed.p1
+
+let first_point
+ : Path.Fixed.path -> Gg.v2
+ = function
+ | Empty -> raise Empty_Element
+ | Line (p0, _) -> Path.Point.get_coord p0
+ | Curve bezier -> Path.Point.get_coord bezier.Path.Fixed.p0
+
+let assoc_point
+ : Shapes.Bezier.t -> Path.Fixed.path -> Path.Fixed.path
+ = fun bezier -> function
+ | Empty -> raise Empty_Element
+ | Line (p0, p1)
+ | Curve {p0; p1; _} ->
+ let p0' = Path.Point.copy p0 bezier.Shapes.Bezier.p0
+ and p1' = Path.Point.copy p1 bezier.Shapes.Bezier.p1 in
+ Curve
+ { Path.Fixed.p0 = p0'
+ ; Path.Fixed.p1 = p1'
+ ; Path.Fixed.ctrl0 = bezier.Shapes.Bezier.ctrl0
+ ; Path.Fixed.ctrl1 = bezier.Shapes.Bezier.ctrl1
+ }
+
+let execute (command: [> message]) =
+ match command with
+ | `Complete (id, paths) ->
+ (* Convert all the points in list *)
+ let points = List.init
+ ~len:((Array.length paths) )
+ ~f:(fun i -> get_point (Array.get paths i)) in
+ let p0 = first_point (Array.get paths 0)in
+
+ let points = p0::points in
+
+ (* We process the whole curve in a single block *)
+ begin match Shapes.Bspline.to_bezier points with
+ | Error `InvalidPath -> ()
+ | Ok beziers ->
+
+ (* Now for each point, reassociate the same point information,
+ We should have as many points as before *)
+ let rebuilded = Array.map2 beziers paths ~f:assoc_point in
+ Worker.post_message (`Complete (id, rebuilded))
+ end
+ | any ->
+ Worker.post_message (`Other any)
+
+let () =
+ Worker.set_onmessage execute
diff --git a/shapes/bezier.ml b/shapes/bezier.ml
index bf7aaaa..f5f288c 100755
--- a/shapes/bezier.ml
+++ b/shapes/bezier.ml
@@ -201,3 +201,28 @@ let reverse
; p1 = bezier.p0
; ctrl0 = bezier.ctrl1
; ctrl1 = bezier.ctrl0 }
+
+(**
+
+ see https://github.com/Pomax/BezierInfo-2/blob/master/docs/js/graphics-element/lib/bezierjs/bezier.js#L504
+
+ let root
+ : t -> 'a
+ = fun bezier ->
+
+ let accept
+ : float -> bool
+ = fun t ->
+ 0. <= t && t <= 1. in
+
+ let cuberoot v =
+ if v < 0. then
+ Float.pow (Float.neg v) ( 1. /. 3.)
+ |> Float.neg
+ else Float.pow v (1. /. 3.) in
+
+
+
+
+ failwith "Non implemented"
+*)
diff --git a/worker/dune b/worker/dune
deleted file mode 100755
index 508055e..0000000
--- a/worker/dune
+++ /dev/null
@@ -1,9 +0,0 @@
-(library
- (name worker)
- (libraries
- gg
- brr
- note
- shapes
- )
- )
diff --git a/worker/worker.ml b/worker/worker.ml
deleted file mode 100755
index 7a8d09a..0000000
--- a/worker/worker.ml
+++ /dev/null
@@ -1,5 +0,0 @@
-open Brr_webworkers
-
-let spawn_worker name =
- try Ok (Worker.create name) with
- | Jv.Error e -> Error e