Improve drawing performance (and fix a bug)

.github/workflows/playwright.yml

@@ -34,7 +34,7 @@ jobs:
     # In Playwright's Docker image, so that the rendering is the same as when
     # the screenshots were generated
     - name: Run Playwright tests
-      run: ./playwright-docker.sh
+      run: opam exec -- ./playwright-docker.sh
 
     - uses: actions/upload-artifact@v4
       if: ${{ !cancelled() }}

CHANGELOG.md

@@ -10,6 +10,8 @@
 
 - Precompiled binaries for macOS no longer rely on Homebrew libraries (#146)
 - Fixed some blurriness in Chrome related to zooming (#286)
+- Fixed wrong coordinates when focusing on drawings in fast mode (#287)
+- Improved drawing performance, especially in fast mode (#287)
 
 ## [v0.13.0] Juraslip Park (Satursday, the 5th of September, 2026)
 

src/engine/runtime/drawing/drawing_controller/preview.ml

@@ -3,49 +3,30 @@ open Drawing_state
 open Brr_lwd
 
 let ( !! ) = Jstr.v
+let empty_d = Lwd.pure (Brr.At.v (Jstr.v "d") Jstr.empty)
 
-let pfo_options width =
-  let size = width in
-  Perfect_freehand.Options.v ~thinning:0.5 ~smoothing:0.5 ~size ~streamline:0.5
-    ~last:true ()
-
-let make_d ~elapsed_time path path_to_svg =
-  (* TODO: DO NOT DELETE THIS COMMENT! *)
-  (* let$* end_at = end_at in *)
-  (* let$* should_continue = *)
-  (*   (\* I was hoping that when a value does not change, the recomputation *)
-  (*    stops. See https://github.com/let-def/lwd/issues/55 *\) *)
-  (*   let$ elapsed_time = elapsed_time in *)
-  (*   elapsed_time <= end_at *)
-  (* in *)
-  let with_path path =
-    (* Brr.Console.(log [ "offset_x"; offset.x ]); *)
-    let path =
-      List.map fst
-        (* (fun ((x, y), _) -> *)
-        (*   ( x -. (offset.x -. 2000. -. (offset.width /. 2.)), *)
-        (*     y -. (offset.y -. 2000. -. (offset.height /. 2.)) )) *)
-        path
-    in
-    let v = path_to_svg path in
-    Brr.At.v (Jstr.v "d") v
-  in
-  let$* path = Lwd.get path in
+let d ~elapsed_time ~starts_at ~end_at ~final_d ~scale ~path kind =
   match elapsed_time with
-  | None -> Lwd.pure @@ with_path path
-  | Some elapsed_time ->
-      let$ elapsed_time = elapsed_time in
-      let path = List.filter (fun (_, t) -> t < elapsed_time) path in
-      with_path path
+  | None -> final_d
+  | Some elapsed_time' ->
+      (* Built once, so that the bind below only chooses between existing
+         nodes, instead of building a new graph at each change of time. *)
+      let partial =
+        Drawing_state.Path_editing.make_d kind ~elapsed_time ~scale path
+      in
+      let$* starts_at = starts_at
+      and$ end_at = end_at
+      and$ elapsed_time' = elapsed_time' in
+      if end_at < elapsed_time' then final_d
+      else if elapsed_time' <= starts_at then empty_d
+      else partial
 
-let pen_attributes ~width ~elapsed_time ~scale ~path ~erased ~color ~id
-    ~selected ~preselected =
+let pen_attributes ~starts_at ~end_at ~final_d ~width ~elapsed_time ~scale ~path
+    ~erased ~color ~id ~selected ~preselected =
   let at =
     let d =
       let$* width = Lwd.get width in
-      make_d ~elapsed_time path @@ fun path ->
-      let options = pfo_options width in
-      Drawing_state.Path_editing.pfo_svg_path options scale path
+      d ~elapsed_time ~starts_at ~end_at ~final_d ~scale ~path (`Pfh width)
     in
     let fill =
       let$ color =
@@ -108,13 +89,10 @@ let pen_attributes ~width ~elapsed_time ~scale ~path ~erased ~color ~id
   in
   Elwd.v ~ns:`SVG ~at ~st (Jstr.v "path") []
 
-let highlight_attributes ~elapsed_time ~width ~path ~color ~selected
-    ~preselected ~erased ~scale ~id =
+let highlight_attributes ~starts_at ~end_at ~final_d ~elapsed_time ~width ~path
+    ~color ~selected ~preselected ~erased ~scale ~id =
   let at =
-    let d =
-      make_d ~elapsed_time path @@ fun path ->
-      Drawing_state.Path_editing.svg_path scale path
-    in
+    let d = d ~elapsed_time ~starts_at ~end_at ~final_d ~scale ~path `Normal in
     let stroke =
       let$ width =
         let$ width = Lwd.get width in
@@ -185,21 +163,22 @@ let create_elem_of_stroke ~elapsed_time
       width;
       stroker;
       path;
-      end_at = _;
-      starts_at = _;
+      end_at;
+      starts_at;
       selected;
       preselected;
       track = _;
       erased;
+      final_d;
     } =
   let$* scale = Lwd.get scale in
   match stroker with
   | Highlighter ->
-      highlight_attributes ~scale ~color ~id ~width ~path ~selected ~preselected
-        ~erased ~elapsed_time
+      highlight_attributes ~starts_at ~end_at ~final_d ~scale ~color ~id ~width
+        ~path ~selected ~preselected ~erased ~elapsed_time
   | Pen ->
-      pen_attributes ~scale ~color ~id ~width ~path ~selected ~preselected
-        ~erased ~elapsed_time
+      pen_attributes ~starts_at ~end_at ~final_d ~scale ~color ~id ~width ~path
+        ~selected ~preselected ~erased ~elapsed_time
 
 let draw ~elapsed_time strokes =
   Lwd_table.map_reduce

src/engine/runtime/drawing/drawing_controller/tools.ml

@@ -96,25 +96,10 @@ module Draw_stroke = struct
       [ (Translation.forward translation x y, now () -. started_time) ]
     in
     let el =
-      let path = Lwd.var path in
       let { Universe.Coordinates.scale; _ } = Universe.State.get_coord () in
       let scale = scale *. translation.scale in
-      let end_at = Lwd.map (Lwd.get path) ~f:end_at in
-      let starts_at = Lwd.map (Lwd.get path) ~f:starts_at in
-      {
-        id;
-        scale = Lwd.var scale;
-        path;
-        end_at;
-        starts_at;
-        color = Lwd.var color;
-        stroker;
-        width = Lwd.var width;
-        selected = Lwd.var false;
-        preselected = Lwd.var false;
-        track = Lwd.var 0;
-        erased = Lwd.var None;
-      }
+      Drawing_state.make_stro ~id ~scale ~path ~color ~width ~stroker ~track:0
+        ~erased:None
     in
     Lwd_table.append' strokes el;
     (started_time, el, translation)

src/engine/runtime/drawing/drawing_state/drawing_state.ml

@@ -178,39 +178,46 @@ let play ?(speedup = 1.) ?(continue = fun () -> `Continue) ~finish state =
     Lwd.set state.time next_time;
     finish ()
   in
-  let rec loop _ =
+  let if_continue f =
     match continue () with
     | `Stop -> ()
     | `Skip_to_next_pause -> skip_to_next_pause ()
-    | `Continue -> (
-        let frame = now () in
-        let time_before = time_of !previous_frame in
-        let new_time = time_of frame in
-        previous_frame := frame;
-        let crossed_pause =
-          Lwd_table.fold
-            (fun acc pause ->
-              let at = Lwd.peek pause.p_at in
-              if time_before < at && at <= new_time then
-                match acc with
-                | Some earliest when earliest < at -> acc
-                | _ -> Some at
-              else acc)
-            None state.recording.pauses
-        in
-        match crossed_pause with
-        | Some at ->
-            Lwd.set state.time at;
-            finish ()
-        | None ->
-            if new_time > max_time then (
-              Lwd.set state.time max_time;
-              finish ())
-            else (
-              Lwd.set state.time new_time;
-              let _animation_frame_id = Brr.G.request_animation_frame loop in
-              ()))
+    | `Continue -> f ()
+  in
+  let rec loop _ =
+    if_continue @@ fun () ->
+    let frame = now () in
+    let time_before = time_of !previous_frame in
+    let new_time = time_of frame in
+    previous_frame := frame;
+    let crossed_pause =
+      Lwd_table.fold
+        (fun acc pause ->
+          let at = Lwd.peek pause.p_at in
+          if time_before < at && at <= new_time then
+            match acc with
+            | Some earliest when earliest < at -> acc
+            | _ -> Some at
+          else acc)
+        None state.recording.pauses
+    in
+    match crossed_pause with
+    | Some at ->
+        Lwd.set state.time at;
+        finish ()
+    | None ->
+        if new_time > max_time then (
+          Lwd.set state.time max_time;
+          finish ())
+        else (
+          Lwd.set state.time new_time;
+          let _animation_frame_id = Brr.G.request_animation_frame loop in
+          ())
   in
+  (* Do not wait for a frame when we are not going to animate anything (e.g. in
+     fast mode): this would make fast-forwarding wait for one frame per drawing
+     action. *)
+  if_continue @@ fun () ->
   let _animation_frame_id = Brr.G.request_animation_frame loop in
   ()
 

src/engine/runtime/drawing/drawing_state/json.ml

@@ -64,6 +64,7 @@ module V1 = struct
         preselected = _;
         track;
         erased;
+        final_d = _;
       } =
     `List
       [
@@ -91,28 +92,9 @@ module V1 = struct
         ] ->
         let ( let* ) x y = Result.bind x y in
         let* path = to_path path in
-        let path = Lwd.var path in
-        let starts_at l = List.hd (List.rev l) |> snd in
-        let end_at l = List.hd l |> snd in
-        let end_at = Lwd.map (Lwd.get path) ~f:end_at in
-        let starts_at = Lwd.map (Lwd.get path) ~f:starts_at in
-        let* stroker = to_stroker stroker in
         let* erased = to_erased erased in
-        Ok
-          {
-            id;
-            scale = Lwd.var scale;
-            path;
-            end_at;
-            starts_at;
-            color = Lwd.var color;
-            stroker;
-            width = Lwd.var width;
-            selected = Lwd.var false;
-            preselected = Lwd.var false;
-            track = Lwd.var track;
-            erased = Lwd.var erased;
-          }
+        let* stroker = to_stroker stroker in
+        Ok (make_stro ~id ~scale ~path ~color ~width ~stroker ~track ~erased)
     | _ -> Error ()
 
   let of_strokes strokes =

src/engine/runtime/drawing/drawing_state/path_editing.ml

@@ -113,3 +113,34 @@ let svg_path scale path =
         :: List.map (fun (x, y) -> Format.sprintf "L %f,%f" x y) rest
   in
   String.concat " " res |> Jstr.of_string
+
+let pfo_options width =
+  let size = width in
+  Perfect_freehand.Options.v ~thinning:0.5 ~smoothing:0.5 ~size ~streamline:0.5
+    ~last:true ()
+
+let make_d_with ~elapsed_time path path_to_svg =
+  let open Lwd_infix in
+  let with_path path =
+    let path = List.map fst path in
+    let v = path_to_svg path in
+    Brr.At.v (Jstr.v "d") v
+  in
+  let$* path = Lwd.get path in
+  match elapsed_time with
+  | None -> Lwd.pure @@ with_path path
+  | Some elapsed_time ->
+      let$ elapsed_time = elapsed_time in
+      let path = List.filter (fun (_, t) -> t < elapsed_time) path in
+      with_path path
+
+let make_d kind ~elapsed_time ~scale path =
+  let path_to_svg =
+    match kind with
+    | `Pfh width ->
+        fun path ->
+          let options = pfo_options width in
+          pfo_svg_path options scale path
+    | `Normal -> fun path -> svg_path scale path
+  in
+  make_d_with ~elapsed_time path path_to_svg

src/engine/runtime/drawing/drawing_state/types.ml

@@ -32,8 +32,46 @@ type stro = {
   preselected : bool Lwd.var;
   track : int Lwd.var;
   erased : erased option Lwd.var;
+  final_d : Brr.At.t Lwd.t;
 }
 
+let make_stro ~id ~scale ~path ~color ~stroker ~width ~track ~erased =
+  let scale = Lwd.var scale
+  and path = Lwd.var path
+  and color = Lwd.var color
+  and width = Lwd.var width
+  and selected = Lwd.var false
+  and preselected = Lwd.var false
+  and track = Lwd.var track
+  and erased = Lwd.var erased in
+  let starts_at l = List.hd (List.rev l) |> snd in
+  let end_at l = List.hd l |> snd in
+  let end_at = Lwd.map (Lwd.get path) ~f:end_at in
+  let starts_at = Lwd.map (Lwd.get path) ~f:starts_at in
+  let final_d =
+    let open Lwd_infix in
+    let$* width = Lwd.get width and$ scale = Lwd.get scale in
+    let kind =
+      match stroker with Pen -> `Pfh width | Highlighter -> `Normal
+    in
+    Path_editing.make_d kind ~elapsed_time:None ~scale path
+  in
+  {
+    id;
+    scale;
+    path;
+    end_at;
+    starts_at;
+    color;
+    stroker;
+    width;
+    selected;
+    preselected;
+    track;
+    erased;
+    final_d;
+  }
+
 type strokes = stro Lwd_table.t
 
 type pause = {

test/README.md

@@ -16,22 +16,14 @@ dune test
 
 Browser tests take the form of screenshot tests, implemented using [playwright visual tests](https://playwright.dev/docs/test-snapshots).
 
-Running the tests is done in two steps, from the `screenshot-based` folder.
-
-First, generate the HTML files of all tests with dune:
-
-```shell
-dune build --profile release
-```
-
 Each test folder has a `dune` file that compiles its `.slp` and `.md` entries
 to HTML files next to them, with the same base name. When adding an entry to a
 `run.json`, add the corresponding rule.
 
 Then, run the tests in [Playwright's Docker image](https://playwright.dev/docs/docker).
 Browser rendering depends on the fonts and libraries of the host, so using the
 same image everywhere ensures that the screenshots are the same locally and in
-the CI. This only requires Docker, not OCaml nor the Playwright browsers:
+the CI. This requires Docker.
 
 ```shell
 ./playwright-docker.sh