Lwt pour les évènements, plutôt que des EventListeners js.

diff --git a/dune-project b/dune-project
index 2ba338d3429e2d5a15adb8f8640556168acdc2d1..de53f5a994f077b738d2633ed5b03e9ae6b79117 100644 (file)
--- a/dune-project
+++ b/dune-project
@@ -18,5 +18,5 @@
  (name marbrures)
  (synopsis "Marbrures mathématiques")
  (description "Code js_of_ocaml pour faire des marbrures mathématiques dans un navigateur.")
- (depends ocaml dune js_of_ocaml)
+ (depends ocaml dune js_of_ocaml js_of_ocaml-lwt lwt)
  (tags ("marbling" "js_of_ocaml" "mathematical marbling")))

diff --git a/marbrures/dune b/marbrures/dune
index 40ffcea0aea10740203422b3d06092cae900c2c3..0634aa035f949411980f383188042588492b5673 100644 (file)
--- a/marbrures/dune
+++ b/marbrures/dune
@@ -1,7 +1,7 @@
 (executables
  (names main)
  (modes js)
- (libraries js_of_ocaml)
+ (libraries js_of_ocaml js_of_ocaml-lwt lwt)
  (preprocess
   (pps js_of_ocaml-ppx)))
 

diff --git a/marbrures/main.ml b/marbrures/main.ml
index 750ecfc9819873e2df241e2642ef72cdf5dbbb07..686a113c55de3edcc10644040063222d311ecd6b 100644 (file)
--- a/marbrures/main.ml
+++ b/marbrures/main.ml
@@ -19,11 +19,14 @@
  *)
 
 open Js_of_ocaml
+open Js_of_ocaml_lwt
 
-let canvas =
-        match Dom_html.getElementById_coerce "canvas" Dom_html.CoerceTo.canvas with
+let get_elem_id id coercion =
+        match Dom_html.getElementById_coerce id coercion with
         | Some canvas -> canvas
-        | None -> failwith "No canvas."
+        | None -> failwith ("No " ^ id ^ ".")
+
+let canvas = get_elem_id "canvas" Dom_html.CoerceTo.canvas
 
 let ctx = canvas##getContext Dom_html._2d_
 
@@ -35,55 +38,54 @@ let drop c r =
             let t = Float.pi *. 2. *. t in
             Shape.Vector.(Notation.(c + (r * fromAngle t))))
 
-let marbling : (Shape.t * Js.js_string Js.t) list ref = ref []
-
-let marbling_view : (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);
-        List.iter
-          (fun (shape, color) ->
-            ctx##.fillStyle := color;
-            Shape.path ctx shape;
-            ctx##fill)
-          !marbling_view
+open Lwt.Syntax
 
-let _interval_id = Dom_html.window##setInterval (Js.wrap_callback main) (1000.0 /. 60.0)
+type event = Click of (float * float) | Unclick of (float * float) | Move of (float * float) | Out
 
-let _mousemove_listener, _mousedown_listener, _mouseout_listener =
-        let r = ref 0.
-        and color = ref (Js.string "") in
-        let reset () =
-                r := Random.float 50. +. 25.;
-                color :=
-                  Js.string
-                    ("rgb("
-                    ^ string_of_int (Random.int 128 + 127)
-                    ^ " "
-                    ^ string_of_int (Random.int 128 + 127)
-                    ^ " "
-                    ^ string_of_int (Random.int 128 + 127)
-                    ^ ")")
+let rec main marbling p () =
+        let r = Random.float 50. +. 25.
+        and color =
+                Js.string
+                  ("rgb("
+                  ^ string_of_int (Random.int 128 + 127)
+                  ^ " "
+                  ^ string_of_int (Random.int 128 + 127)
+                  ^ " "
+                  ^ string_of_int (Random.int 128 + 127)
+                  ^ ")")
         in
-        reset ();
-        ( Dom_html.addEventListener canvas Dom_html.Event.mousemove
-            (Dom.handler (fun ev ->
-                 marbling_view := add_drop (float_of_int ev##.offsetX, float_of_int ev##.offsetY) !r !color !marbling;
-                 Js.bool true))
-            (Js.bool false),
-          Dom_html.addEventListener canvas Dom_html.Event.mousedown
-            (Dom.handler (fun ev ->
-                 marbling := add_drop (float_of_int ev##.offsetX, float_of_int ev##.offsetY) !r !color !marbling;
-                 reset ();
-                 marbling_view := add_drop (float_of_int ev##.offsetX, float_of_int ev##.offsetY) !r !color !marbling;
-                 Js.bool true))
-            (Js.bool false),
-          Dom_html.addEventListener canvas Dom_html.Event.mouseout
-            (Dom.handler (fun _ev ->
-                 marbling_view := !marbling;
-                 Js.bool true))
-            (Js.bool false) )
+        let rec with_drop_info marbling_view =
+                ctx##.fillStyle := Js.string "#00001f";
+                ctx##fillRect 0.0 0.0 (float_of_int canvas##.width) (float_of_int canvas##.height);
+                List.iter
+                  (fun (shape, color) ->
+                    ctx##.fillStyle := color;
+                    Shape.path ctx shape;
+                    ctx##fill)
+                  marbling_view;
+                let* ev =
+                        Lwt.pick
+                          Lwt_js_events.
+                            [
+                              (let+ ev = mousedown canvas in
+                               Click (float_of_int ev##.offsetX, float_of_int ev##.offsetY));
+                              (let+ ev = mouseup canvas in
+                               Unclick (float_of_int ev##.offsetX, float_of_int ev##.offsetY));
+                              (let+ ev = mousemove canvas in
+                               Move (float_of_int ev##.offsetX, float_of_int ev##.offsetY));
+                              (let+ _ = mouseout canvas in
+                               Out);
+                            ]
+                in
+                match ev with
+                | Click p -> with_drop_info (add_drop p r color marbling)
+                | Unclick p -> main (add_drop p r color marbling) p ()
+                | Move p -> with_drop_info (add_drop p r color marbling)
+                | Out -> with_drop_info marbling
+        in
+        with_drop_info (add_drop p r color marbling)
+
+let () = Lwt.async (main [] (400., 400.))