Base des marbrures: placer des gouttes d'encre

diff --git a/marbrures/main.ml b/marbrures/main.ml
index 0a736a7e88f546776d2c7d2de999f5586a3e80f4..67d65a3d4ec94af4e6331b93987d42fe7edc63cf 100644 (file)
--- a/marbrures/main.ml
+++ b/marbrures/main.ml
@@ -14,6 +14,10 @@
  * along with this program. If not, see <https://www.gnu.org/licenses/>.
  *)
 
+(* Formulas for marbling from:
+ * https://people.csail.mit.edu/jaffer/Marbling/Dropping-Paint
+ *)
+
 open Js_of_ocaml
 
 let canvas =
@@ -23,16 +27,45 @@ let canvas =
 
 let ctx = canvas##getContext Dom_html._2d_
 
-let circle =
+let apply_drop c r =
+        Shape.transform (fun p -> Shape.Vector.(Notation.(c + (sqrt (1. +. (r *. r /. dstSq p c)) * (p - c)))))
+
+let drop c r =
         Shape.from_f (fun t ->
             let t = Float.pi *. 2. *. t in
-            Shape.Vector.(add (400., 400.) (scale 250. (fromAngle t))))
+            Shape.Vector.(Notation.(c + (r * fromAngle t))))
+
+let marbling : (Shape.t * Js.js_string Js.t) list ref = ref []
+
+let add_drop c r color =
+        marbling :=
+          List.fold_right (fun (sh, color) rest -> (apply_drop c r sh, color) :: rest) !marbling [(drop c r, color)]
 
 let main () =
         ctx##.fillStyle := Js.string "#00001f";
         ctx##fillRect 0.0 0.0 (float_of_int canvas##.width) (float_of_int canvas##.height);
-        ctx##.fillStyle := Js.string "#ffffff";
-        Shape.path ctx circle;
-        ctx##fill
+        List.iter
+          (fun (shape, color) ->
+            ctx##.fillStyle := color;
+            Shape.path ctx shape;
+            ctx##fill)
+          !marbling
 
 let _interval_id = Dom_html.window##setInterval (Js.wrap_callback main) (1000.0 /. 60.0)
+
+let _mouse_listener =
+        Dom_html.addEventListener canvas Dom_html.Event.click
+          (Dom.handler (fun ev ->
+               add_drop
+                 (float_of_int ev##.offsetX, float_of_int ev##.offsetY)
+                 (Random.float 50. +. 25.)
+                 (Js.string
+                    ("rgb("
+                    ^ string_of_int (Random.int 128 + 127)
+                    ^ " "
+                    ^ string_of_int (Random.int 128 + 127)
+                    ^ " "
+                    ^ string_of_int (Random.int 128 + 127)
+                    ^ ")"));
+               Js.bool true))
+          (Js.bool false)

diff --git a/marbrures/shape.ml b/marbrures/shape.ml
index 08617ce7e6aec3b8513fdb198e1d633515313163..c34bdc83c65a3278b5f7f523892a293e1de3c534 100644 (file)
--- a/marbrures/shape.ml
+++ b/marbrures/shape.ml
@@ -14,7 +14,7 @@
  * along with this program. If not, see <https://www.gnu.org/licenses/>.
  *)
 
-let res = 20.0
+let res = 5.0
 
 module Vector = struct
   type t = float * float
@@ -28,12 +28,20 @@ module Vector = struct
   let scale f (x, y) = (x *. f, y *. f)
 
   let dstSq (x, y) (x', y') = ((x -. x') *. (x -. x')) +. ((y -. y') *. (y -. y'))
+
+  module Notation = struct
+    let ( + ) = add
+
+    let ( - ) = sub
+
+    let ( * ) = scale
+  end
 end
 
 (* f : [0..1] -> (x, y)
  * ps : (t, f t)
  *)
-type shape = { f: float -> Vector.t; ps: (float * Vector.t) list }
+type t = { f: float -> Vector.t; ps: (float * Vector.t) list }
 
 let balance_points { f; ps } =
         let rec aux ps =

diff --git a/marbrures/shape.mli b/marbrures/shape.mli
index 585d57aea2a453548981c54b979a8512397be1be..6e460280fbd7720fde7fad80c99140f156a5dccf 100644 (file)
--- a/marbrures/shape.mli
+++ b/marbrures/shape.mli
@@ -26,13 +26,21 @@ module Vector : sig
   val scale : float -> t -> t
 
   val dstSq : t -> t -> float
+
+  module Notation : sig
+    val ( + ) : t -> t -> t
+
+    val ( - ) : t -> t -> t
+
+    val ( * ) : float -> t -> t
+  end
 end
 
-type shape
+type t
 
 (* [0..1] -> (x, y) *)
-val from_f : (float -> Vector.t) -> shape
+val from_f : (float -> Vector.t) -> t
 
-val transform : (Vector.t -> Vector.t) -> shape -> shape
+val transform : (Vector.t -> Vector.t) -> t -> t
 
-val path : Js_of_ocaml.Dom_html.canvasRenderingContext2D Js_of_ocaml__.Js.t -> shape -> unit
+val path : Js_of_ocaml.Dom_html.canvasRenderingContext2D Js_of_ocaml__.Js.t -> t -> unit