brr-lwd: add test for set of classes

Inspired by the discussions at https://discuss.ocaml.org/t/a-board-of-binary-switches-with-brr-lwd/13321
let-def · Oct 29, 2023 · 507278f · 507278f
1 parent 2b6188c
commit 507278f
Show file tree

Hide file tree

Showing 4 changed files with 113 additions and 0 deletions.
diff --git a/examples/cssclasstest-brr/Makefile b/examples/cssclasstest-brr/Makefile
@@ -0,0 +1,8 @@
+ROOT=$(realpath $(PWD)/../..)
+
+all:
+	dune build index.html main.js
+	@echo "open $(ROOT)/_build/default/examples/focustest-brr/index.html"
+
+clean:
+	dune clean
diff --git a/examples/cssclasstest-brr/dune b/examples/cssclasstest-brr/dune
@@ -0,0 +1,21 @@
+(executables
+ (names main)
+ (libraries js_of_ocaml brr lwd brr-lwd)
+ (modes byte))
+
+(rule
+ (targets main.js)
+ (action
+  (run
+   %{bin:js_of_ocaml}
+   --noruntime
+   %{lib:js_of_ocaml-compiler:runtime.js}
+   --source-map
+   %{dep:main.bc}
+   -o
+   %{targets}
+   --pretty)))
+
+(alias
+ (name default)
+ (deps main.js index.html))
diff --git a/examples/cssclasstest-brr/index.html b/examples/cssclasstest-brr/index.html
@@ -0,0 +1,27 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
+	  "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+  <head>
+    <title>Minesweeper</title>
+    <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+    <script type="text/javascript" src="main.js"></script>
+<style>
+.square {
+  width: 1px;;
+  height: 1px;
+  padding: 1px;
+  border: solid 1px;
+}
+.square-on {
+  background-color: yellow;
+}
+.square-off {
+  background-color: blue;
+}
+</style>
+  </head>
+  <body>
+    <div id="main"></div>
+  </body>
+</html>
diff --git a/examples/cssclasstest-brr/main.ml b/examples/cssclasstest-brr/main.ml
@@ -0,0 +1,57 @@
+open Brr
+open Brr_lwd
+
+type square = On | Off
+
+let flip = function On -> Off | Off -> On
+
+let class_of_state =
+  function
+  | On -> Jstr.v "square-on"
+  | Off -> Jstr.v "square-off"
+
+let lwd_table_row_map ~f row =
+  Lwd_table.get row |> Option.iter (fun v -> Lwd.set v (f (Lwd.peek v)))
+
+let ui =
+  let squares = Lwd_table.make () in
+  let add_square () =
+    let row = Lwd_table.append squares in
+    Lwd_table.set row (Lwd.var Off)
+  in
+  for _ = 1 to 20 * 25 do
+    add_square ()
+  done;
+  let board =
+    Lwd_table.map_reduce
+      (fun row state ->
+         Lwd_seq.element @@
+         Elwd.div
+           ~at:[
+             `P (At.class' (Jstr.v "square"));
+             `R ((Lwd.map ~f:(fun x -> At.class' (class_of_state x)) (Lwd.get state)));
+           ]
+           ~ev:[
+             `P (Elwd.handler Ev.click
+                   (fun _ -> lwd_table_row_map row ~f:(fun state -> flip state)))
+           ]
+           []
+      )
+      Lwd_seq.monoid
+      squares
+  in
+  Elwd.div ~at:[ `P (At.class' (Jstr.v "game-board")) ] [
+    `S (Lwd_seq.lift board)
+  ]
+
+let () =
+  let ui = Lwd.observe ui in
+  let on_invalidate _ =
+    ignore @@ G.request_animation_frame @@ fun _ ->
+      ignore @@ Lwd.quick_sample ui
+  in
+  let on_load _ =
+    El.append_children (Document.body G.document) [ Lwd.quick_sample ui ];
+    Lwd.set_on_invalidate ui on_invalidate
+  in
+  ignore @@ Ev.listen Ev.dom_content_loaded on_load (Window.as_target G.window)