From 140e5561210f0df6e02309359e7bc5e2437dbe92 Mon Sep 17 00:00:00 2001
From: =?utf8?q?Am=C3=A9lia=20Coutard-Sander?= <git@ameliathe1st.gay>
Date: Sat, 26 Jul 2025 23:11:00 +0200
Subject: [PATCH] Base des marbrures: placer des gouttes d'encre

---
 marbrures/main.ml   | 43 ++++++++++++++++++++++++++++++++++++++-----
 marbrures/shape.ml  | 12 ++++++++++--
 marbrures/shape.mli | 16 ++++++++++++----
 3 files changed, 60 insertions(+), 11 deletions(-)

diff --git a/marbrures/main.ml b/marbrures/main.ml
index 9717d70..900f458 100644
--- 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 352a67c..b19572d 100644
--- 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 115830e..f792185 100644
--- 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
-- 
2.51.0