aboutsummaryrefslogtreecommitdiff
path: root/script.it/script.ml
diff options
context:
space:
mode:
Diffstat (limited to 'script.it/script.ml')
-rwxr-xr-xscript.it/script.ml678
1 files changed, 317 insertions, 361 deletions
diff --git a/script.it/script.ml b/script.it/script.ml
index eb12458..e4cec67 100755
--- a/script.it/script.ml
+++ b/script.it/script.ml
@@ -2,13 +2,13 @@ open StdLabels
open Note
open Brr
open Brr_note
-
module State = Script_state.State
module Selection = Script_state.Selection
+module Path = Script_path
+
+let post : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit =
+ Brr_webworkers.Worker.post
-let post
- : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit
- = Brr_webworkers.Worker.post
type canva_events =
[ `MouseDown of float * float
@@ -16,71 +16,54 @@ type canva_events =
]
(** Create the element in the page, and the event handler *)
-let canva
- : Brr.El.t -> canva_events Note.E.t * (float * float) option Note.S.t * Brr_canvas.Canvas.t
- = fun element ->
-
- (* Adapt the width to the window *)
- El.set_inline_style
- El.Style.width
- (Jstr.v "100%")
- element;
-
- (* See https://stackoverflow.com/a/14855870/13882826 *)
- El.set_inline_style
- El.Style.height
- (Jstr.v "100%")
- element;
-
- El.set_prop
- El.Prop.width
- (El.prop Elements.Prop.offsetWidth element)
- element;
-
- El.set_prop
- El.Prop.height
- (El.prop Elements.Prop.offsetHeight element)
- element;
-
- El.set_inline_style
- El.Style.width
- (Jstr.v "")
- element;
-
- let module C = Brr_canvas.Canvas in
- let c = C.of_el element in
-
- (* Mouse events *)
- let mouse = Brr_note_kit.Mouse.on_el
- ~normalize:false
- (fun x y -> (x, y)) element in
-
- let click =
- Brr_note_kit.Mouse.left_down mouse
- |> E.map (fun c -> `MouseDown c) in
-
- let up =
- Brr_note_kit.Mouse.left_up mouse
- |> E.map (fun c -> `Out c) in
-
- let position = Brr_note_kit.Mouse.pos mouse in
-
- let pos = S.l2
- (fun b pos ->
- if b then
- Some pos
- else
- None )
- (Brr_note_kit.Mouse.left mouse)
- position in
-
- E.select [click; up], pos, c
-
-let click_event el =
- Evr.on_el
- Ev.click
- Evr.unit
- el
+let canva :
+ Brr.El.t
+ -> canva_events Note.E.t
+ * (float * float) option Note.S.t
+ * Brr_canvas.Canvas.t =
+ fun element ->
+ (* Adapt the width to the window *)
+ El.set_inline_style El.Style.width (Jstr.v "100%") element;
+
+ (* See https://stackoverflow.com/a/14855870/13882826 *)
+ El.set_inline_style El.Style.height (Jstr.v "100%") element;
+
+ El.set_prop El.Prop.width (El.prop Elements.Prop.offsetWidth element) element;
+
+ El.set_prop
+ El.Prop.height
+ (El.prop Elements.Prop.offsetHeight element)
+ element;
+
+ El.set_inline_style El.Style.width (Jstr.v "") element;
+
+ let module C = Brr_canvas.Canvas in
+ let c = C.of_el element in
+
+ (* Mouse events *)
+ let mouse =
+ Brr_note_kit.Mouse.on_el ~normalize:false (fun x y -> (x, y)) element
+ in
+
+ let click =
+ Brr_note_kit.Mouse.left_down mouse |> E.map (fun c -> `MouseDown c)
+ in
+
+ let up = Brr_note_kit.Mouse.left_up mouse |> E.map (fun c -> `Out c) in
+
+ let position = Brr_note_kit.Mouse.pos mouse in
+
+ let pos =
+ S.l2
+ (fun b pos -> if b then Some pos else None)
+ (Brr_note_kit.Mouse.left mouse)
+ position
+ in
+
+ (E.select [ click; up ], pos, c)
+
+
+let click_event el = Evr.on_el Ev.click Evr.unit el
type 'a param_events =
{ width : float S.t
@@ -92,129 +75,124 @@ type 'a param_events =
type slider =
{ input : El.t
- ; legend : El.t }
-
-let set_sidebar
- : El.t -> State.state -> _ param_events * slider * slider
- = fun element state ->
-
- let delete =
- El.button
- [ El.i
- ~at:At.[ class' (Jstr.v "fas")
- ; class' (Jstr.v "fa-times-circle") ]
- []
- ; El.txt' "Delete "] in
-
- let delete_event = click_event delete in
-
- let export =
- El.button
- [ El.i
- ~at:At.[ class' (Jstr.v "fas")
- ; class' (Jstr.v "fa-download") ]
- []
- ; El.txt' "Download"] in
- let export_event = click_event export in
-
- let nib_size, nib_size_event =
- Elements.Input.slider
- ~at:At.[ type' (Jstr.v "range")
- ; v (Jstr.v "min") (Jstr.v "1")
- ; v (Jstr.v "max") (Jstr.v "50")
- ; At.value (Jstr.of_float state.width)
- ] in
-
- let width = El.div [] in
- let width_slider =
- { input = nib_size
- ; legend = width } in
-
- let input_angle, angle_event =
- Elements.Input.slider
- ~at:At.[ type' (Jstr.v "range")
- ; v (Jstr.v "min") (Jstr.v "0")
- ; v (Jstr.v "max") (Jstr.v "90")
- ; At.value (Jstr.of_float state.angle)
- ] in
-
- let angle = El.div [] in
- let angle_slider =
- { input = input_angle
- ; legend = angle } in
-
- let render =
- El.select
- [ El.option ~at:At.[value (Jstr.v "1")]
- [ El.txt' "Fill"]
- ; El.option ~at:At.[value (Jstr.v "3")]
- [ El.txt' "Ductus"]
- ] in
-
- let rendering' = El.div
- [ El.txt' "Rendering : "
- ; render ] in
-
- let render_event =
- Evr.on_el
- Ev.change (fun _ ->
- let raw_value = El.prop El.Prop.value render
- |> Jstr.to_int in
- let render_type = match raw_value with
- | Some 1 -> `Fill
- | Some 2 -> `Line
- | Some 3 -> `Ductus
- | _ -> `Fill in
-
- let module M = struct
- type t = Layer.Paths.printer
- let process t state = { state with State.rendering = t }
- end
- in
- State.dispatch (module M) render_type
+ ; legend : El.t
+ }
- ) rendering' in
+let set_sidebar : El.t -> State.state -> _ param_events * slider * slider =
+ fun element state ->
+ let delete =
+ El.button
+ [ El.i
+ ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-times-circle") ]
+ []
+ ; El.txt' "Delete "
+ ]
+ in
- let () =
- El.append_children element
- [ El.hr ()
- ; delete
- ; export
+ let delete_event = click_event delete in
- ; rendering'
+ let export =
+ El.button
+ [ El.i ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-download") ] []
+ ; El.txt' "Download"
+ ]
+ in
+ let export_event = click_event export in
+
+ let nib_size, nib_size_event =
+ Elements.Input.slider
+ ~at:
+ At.
+ [ type' (Jstr.v "range")
+ ; v (Jstr.v "min") (Jstr.v "1")
+ ; v (Jstr.v "max") (Jstr.v "50")
+ ; At.value (Jstr.of_float state.width)
+ ]
+ in
- ; El.hr ()
+ let width = El.div [] in
+ let width_slider = { input = nib_size; legend = width } in
+
+ let input_angle, angle_event =
+ Elements.Input.slider
+ ~at:
+ At.
+ [ type' (Jstr.v "range")
+ ; v (Jstr.v "min") (Jstr.v "0")
+ ; v (Jstr.v "max") (Jstr.v "90")
+ ; At.value (Jstr.of_float state.angle)
+ ]
+ in
+
+ let angle = El.div [] in
+ let angle_slider = { input = input_angle; legend = angle } in
- ; width
- ; nib_size
+ let render =
+ El.select
+ [ El.option ~at:At.[ value (Jstr.v "1") ] [ El.txt' "Fill" ]
+ ; El.option ~at:At.[ value (Jstr.v "3") ] [ El.txt' "Ductus" ]
+ ]
+ in
- ; angle
- ; input_angle
+ let rendering' = El.div [ El.txt' "Rendering : "; render ] in
+
+ let render_event =
+ Evr.on_el
+ Ev.change
+ (fun _ ->
+ let raw_value = El.prop El.Prop.value render |> Jstr.to_int in
+ let render_type =
+ match raw_value with
+ | Some 1 -> `Fill
+ | Some 2 -> `Line
+ | Some 3 -> `Ductus
+ | _ -> `Fill
+ in
+
+ let module M = struct
+ type t = Layer.Paths.printer
+
+ let process t state = { state with State.rendering = t }
+ end in
+ State.dispatch (module M) render_type )
+ rendering'
+ in
+
+ let () =
+ El.append_children
+ element
+ [ El.hr ()
+ ; delete
+ ; export
+ ; rendering'
+ ; El.hr ()
+ ; width
+ ; nib_size
+ ; angle
+ ; input_angle
+ ]
+ in
+ ( { delete = delete_event
+ ; angle = angle_event
+ ; width = nib_size_event
+ ; export = export_event
+ ; rendering = render_event
+ }
+ , angle_slider
+ , width_slider )
- ]
- in
- ( { delete = delete_event
- ; angle = angle_event
- ; width = nib_size_event
- ; export = export_event
- ; rendering = render_event }
- , angle_slider
- , width_slider
- )
let backgroundColor = Blog.Nord.nord0
+
let white = Jstr.v "#eceff4"
+
let green = Jstr.v "#a3be8c"
let draw_point point context =
let module Cd2d = Brr_canvas.C2d in
let x, y = Gg.V2.to_tuple @@ Path.Point.get_coord point in
- Cd2d.stroke_rect
- ~x:(x -. 5.)
- ~y:(y -. 5.)
- ~w:10.
- ~h:10.
- context
+ Cd2d.stroke_rect ~x:(x -. 5.) ~y:(y -. 5.) ~w:10. ~h:10. context
+
(** Redraw the canva on update *)
let on_change canva mouse_position timer state =
@@ -222,17 +200,14 @@ let on_change canva mouse_position timer state =
let pos_v2 = Option.map Gg.V2.of_tuple pos in
let module Cd2d = Brr_canvas.C2d in
-
- let w, h = Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) in
+ let w, h =
+ Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva)
+ in
let context = Cd2d.create canva in
Cd2d.set_fill_style context (Cd2d.color backgroundColor);
- Cd2d.fill_rect context
- ~x:0.0
- ~y:0.0
- ~w
- ~h;
+ Cd2d.fill_rect context ~x:0.0 ~y:0.0 ~w ~h;
Cd2d.set_stroke_style context (Cd2d.color white);
Cd2d.set_fill_style context (Cd2d.color white);
@@ -240,177 +215,170 @@ let on_change canva mouse_position timer state =
Otherwise, we would only display the previous registered point, which can
be far away in the past, and would give to the user a sensation of lag.
-
*)
let current =
- begin match state.State.mode, pos with
- | Edit, Some point ->
+ match (state.State.mode, pos) with
+ | Edit, Some point ->
let stamp = Elements.Timer.delay timer in
State.insert_or_replace state point stamp state.current
- | _ ->
- state.current
- end
+ | _ -> state.current
in
-
- let back = Path.Path_Builder.map
- current
- (fun pt -> Path.Point.copy pt @@ Path.Point.get_coord' pt) in
- Layer.Paths.to_canva (module Path.Path_Builder) (current, back) context state.rendering;
-
- List.iter state.paths
- ~f:(fun path ->
-
- let () = match state.mode with
- | Selection (Path id)
- | Selection (Point (id, _)) ->
- begin match id = path.Outline.id with
- | true ->
- (* If the element is the selected one, change the color *)
- Cd2d.set_fill_style context (Cd2d.color Blog.Nord.nord8);
- Cd2d.set_stroke_style context (Cd2d.color Blog.Nord.nord8)
- | false ->
- Cd2d.set_stroke_style context (Cd2d.color white);
- Cd2d.set_fill_style context (Cd2d.color white);
- end
- | _ -> ()
- in
-
- let p = path.Outline.path in
- Layer.Paths.to_canva (module Path.Fixed) (p, path.Outline.back) context state.rendering
- );
+ let back =
+ Path.Path_Builder.map current (fun pt ->
+ Path.Point.copy pt @@ Path.Point.get_coord' pt )
+ in
+ Layer.Paths.to_canva
+ (module Path.Path_Builder)
+ (current, back)
+ context
+ state.rendering;
+
+ List.iter state.paths ~f:(fun path ->
+ let () =
+ match state.mode with
+ | Selection (Path id) | Selection (Point (id, _)) ->
+ ( match id = path.Outline.id with
+ | true ->
+ (* If the element is the selected one, change the color *)
+ Cd2d.set_fill_style context (Cd2d.color Blog.Nord.nord8);
+ Cd2d.set_stroke_style context (Cd2d.color Blog.Nord.nord8)
+ | false ->
+ Cd2d.set_stroke_style context (Cd2d.color white);
+ Cd2d.set_fill_style context (Cd2d.color white) )
+ | _ -> ()
+ in
+
+ let p = path.Outline.path in
+ Layer.Paths.to_canva
+ (module Path.Fixed)
+ (p, path.Outline.back)
+ context
+ state.rendering );
(* Draw the selected path, and operate the modifications directly as a preview *)
- let () = match state.mode with
+ let () =
+ match state.mode with
| Selection t ->
- Cd2d.set_stroke_style context (Cd2d.color white);
- begin match pos_v2, Selection.find_selection t state.paths with
+ Cd2d.set_stroke_style context (Cd2d.color white);
+ ( match (pos_v2, Selection.find_selection t state.paths) with
(* The selected element does not exist, just do nothing *)
| _, None -> ()
-
(* There is no click on the canva, print the line *)
| None, Some (Path outline) ->
- Layer.Paths.to_canva
- (module Path.Fixed)
- (outline.path, outline.back)
- context
- `Line;
-
- (* The user is modifiying the path *)
+ Layer.Paths.to_canva
+ (module Path.Fixed)
+ (outline.path, outline.back)
+ context
+ `Line
+ (* The user is modifiying the path *)
| Some pos_v2, Some (Path outline) ->
- (* Translate the path *)
- let delta = Gg.V2.(pos_v2 - state.State.mouse_down_position) in
- let path = Path.Fixed.map
- outline.Outline.path
- (fun pt -> Path.Point.get_coord pt
- |> Gg.V2.add delta
- |> Path.Point.copy pt) in
- Layer.Paths.to_canva
- (module Path.Fixed)
- (path, path)
- context
- `Line;
-
- (* The user is modifiying the point *)
- | Some pos_v2, Some (Point (outline, point)) when Elements.Timer.delay timer > 0.3 ->
- let point' = Path.Point.copy point pos_v2 in
- let path = begin match Path.Fixed.replace_point outline.Outline.path point' with
- | None -> outline.Outline.path
- | Some p -> p
- end in
-
- Layer.Paths.to_canva
- (module Path.Fixed)
- (path, path)
- context
- `Line;
- draw_point point context
+ (* Translate the path *)
+ let delta = Gg.V2.(pos_v2 - state.State.mouse_down_position) in
+ let path =
+ Path.Fixed.map outline.Outline.path (fun pt ->
+ Path.Point.get_coord pt
+ |> Gg.V2.add delta
+ |> Path.Point.copy pt )
+ in
+ Layer.Paths.to_canva (module Path.Fixed) (path, path) context `Line
+ (* The user is modifiying the point *)
+ | Some pos_v2, Some (Point (outline, point))
+ when Elements.Timer.delay timer > 0.3 ->
+ let point' = Path.Point.copy point pos_v2 in
+ let path =
+ match Path.Fixed.replace_point outline.Outline.path point' with
+ | None -> outline.Outline.path
+ | Some p -> p
+ in
+ Layer.Paths.to_canva (module Path.Fixed) (path, path) context `Line;
+ draw_point point context
| _, Some (Point (outline, point)) ->
- Layer.Paths.to_canva
- (module Path.Fixed)
- (outline.path, outline.back)
- context
- `Line;
- draw_point point context
-
- end
+ Layer.Paths.to_canva
+ (module Path.Fixed)
+ (outline.path, outline.back)
+ context
+ `Line;
+ draw_point point context )
| _ -> ()
in
()
+
let spawn_worker () =
- try Ok (Brr_webworkers.Worker.create (Jstr.v "worker.js"))
- with Jv.Error e -> Error e
+ try Ok (Brr_webworkers.Worker.create (Jstr.v "worker.js")) with
+ | Jv.Error e -> Error e
-let page_main id =
+let page_main id =
let timer, tick = Elements.Timer.create () in
let parameters, angle_element, width_slider =
- begin match Blog.Sidebar.get () with
- | None ->
- Jv.throw (Jstr.v "No sidebar")
- | Some el ->
-
+ match Blog.Sidebar.get () with
+ | None -> Jv.throw (Jstr.v "No sidebar")
+ | Some el ->
Blog.Sidebar.clean el;
set_sidebar el State.init
- end in
-
- begin match (Jv.is_none id) with
- | true -> Console.(error [str "No element with id '%s' found"; id])
- | false ->
-
- match spawn_worker () with
- | Error e -> El.set_children (Jv.Id.of_jv id)
- [ El.p El.[txt (Jv.Error.message e)]]
-
- | Ok worker ->
+ in
+ match Jv.is_none id with
+ | true -> Console.(error [ str "No element with id '%s' found"; id ])
+ | false ->
+ ( match spawn_worker () with
+ | Error e ->
+ El.set_children
+ (Jv.Id.of_jv id)
+ [ El.p El.[ txt (Jv.Error.message e) ] ]
+ | Ok worker ->
let worker_event, worker_send = E.create () in
- let delete_event = E.map
+ let delete_event =
+ E.map
(fun () ->
- let module Delete = Script_event.Delete in
- State.dispatch (module Delete) Delete.{ worker })
+ let module Delete = Script_event.Delete in
+ State.dispatch (module Delete) Delete.{ worker } )
parameters.delete
-
and export_event =
- E.map (fun () ->
+ E.map
+ (fun () ->
let module Export = Script_event.Export in
- State.dispatch (module Export ) ())
+ State.dispatch (module Export) () )
parameters.export
- and angle_event = S.changes parameters.angle
- |> E.map (fun value ->
- let module Property = Script_event.Property in
- State.dispatch (module Property) (Property.{ value ; worker ; prop = `Angle}))
-
- and width_event = S.changes parameters.width
- |> E.map (fun value ->
- let module Property = Script_event.Property in
- State.dispatch (module Property) (Property.{ value ; worker ; prop = `Width }))
- and worker_event = Note.E.filter_map
+ and angle_event =
+ S.changes parameters.angle
+ |> E.map (fun value ->
+ let module Property = Script_event.Property in
+ State.dispatch
+ (module Property)
+ Property.{ value; worker; prop = `Angle } )
+ and width_event =
+ S.changes parameters.width
+ |> E.map (fun value ->
+ let module Property = Script_event.Property in
+ State.dispatch
+ (module Property)
+ Property.{ value; worker; prop = `Width } )
+ and worker_event =
+ Note.E.filter_map
(function
| `Other t ->
- Console.(log [t]);
- None
+ Console.(log [ t ]);
+ None
| `Complete outline ->
- let module Complete_path = Script_event.Complete_path in
- Some (
- State.dispatch (module Complete_path) outline))
-
+ let module Complete_path = Script_event.Complete_path in
+ Some (State.dispatch (module Complete_path) outline) )
worker_event
in
let my_host = Uri.host @@ Window.location @@ G.window in
- if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then (
+ ( if Hashtbl.hash my_host = Blog.Hash_host.expected_host
+ then
let target = Brr_webworkers.Worker.as_target worker in
- Ev.listen Brr_io.Message.Ev.message
- (fun t ->
- Ev.as_type t
- |> Brr_io.Message.Ev.data
- |> worker_send)
- target);
+ Ev.listen
+ Brr_io.Message.Ev.message
+ (fun t -> Ev.as_type t |> Brr_io.Message.Ev.data |> worker_send)
+ target );
(* Add the events to the canva :
@@ -420,25 +388,27 @@ let page_main id =
- Get also the click event for starting to draw
*)
let canva_events, mouse_position, canva = canva (Jv.Id.of_jv id) in
- let canva_events = Note.E.map
+ let canva_events =
+ Note.E.map
(function
| `MouseDown c ->
- let module MouseDown = Script_event.Mouse_down in
- State.dispatch (module MouseDown) MouseDown.{ position = c ; timer }
-
+ let module MouseDown = Script_event.Mouse_down in
+ State.dispatch
+ (module MouseDown)
+ MouseDown.{ position = c; timer }
| `Out c ->
- let module Click = Script_event.Click in
- State.dispatch (module Click) Click.{ point = c ; worker ; timer }
- ) canva_events in
+ let module Click = Script_event.Click in
+ State.dispatch
+ (module Click)
+ Click.{ point = c; worker; timer } )
+ canva_events
+ in
let tick_event =
- S.sample_filter mouse_position
- ~on:tick
- (fun pos f ->
- let module Tick = Script_event.Tick in
- Option.map (fun p ->
- State.dispatch (module Tick) (f, p))
- pos ) in
+ S.sample_filter mouse_position ~on:tick (fun pos f ->
+ let module Tick = Script_event.Tick in
+ Option.map (fun p -> State.dispatch (module Tick) (f, p)) pos )
+ in
(* The first evaluation is the state. Which is the result of all the
successives events to the initial state *)
@@ -453,69 +423,55 @@ let page_main id =
; width_event
; delete_event
; export_event
- ; parameters.rendering ])
+ ; parameters.rendering
+ ] )
in
(* The seconde evaluation is the canva refresh, which only occurs when
- the mouse is updated, or on delete events *)
+ the mouse is updated, or on delete events *)
let _ =
E.select
[ E.map (fun _ -> ()) (S.changes mouse_position)
; E.map (fun _ -> ()) parameters.rendering
; E.map (fun _ -> ()) worker_event
- ; parameters.delete ]
- |> fun ev -> E.log ev (fun _ ->
+ ; parameters.delete
+ ]
+ |> fun ev ->
+ E.log ev (fun _ ->
on_change canva mouse_position timer (S.value state) )
- |> Option.iter Logr.hold in
-
+ |> Option.iter Logr.hold
+ in
(* Ajust the angle slide according to the state *)
let angle_signal = S.map (fun s -> Jstr.of_float s.State.angle) state in
let _ =
- Elr.def_prop
- Elements.Prop.value
- angle_signal
- angle_element.input
-
- and _ = Elr.def_children
+ Elr.def_prop Elements.Prop.value angle_signal angle_element.input
+ and _ =
+ Elr.def_children
angle_element.legend
(S.map
- (fun v ->
- [ El.txt' "Angle : "
- ; El.txt v
- ; El.txt' "°" ] )
- angle_signal) in
+ (fun v -> [ El.txt' "Angle : "; El.txt v; El.txt' "°" ])
+ angle_signal )
+ in
let width_signal = S.map (fun s -> Jstr.of_float s.State.width) state in
- let _ =
- Elr.def_prop
- Elements.Prop.value
- width_signal
- width_slider.input
-
- and _ = Elr.def_children
+ let _ = Elr.def_prop Elements.Prop.value width_signal width_slider.input
+ and _ =
+ Elr.def_children
width_slider.legend
- (S.map (fun v ->
- [ El.txt' "Width : "
- ; El.txt v ]
- )
- width_signal
- ) in
+ (S.map (fun v -> [ El.txt' "Width : "; El.txt v ]) width_signal)
+ in
(* Draw the canva for first time *)
on_change canva mouse_position timer State.init;
(* Hold the state *)
let _ = Logr.hold (S.log state (fun _ -> ())) in
- ()
+ () )
- end
let () =
-
let open Jv in
- let drawer = obj
- [| "run", (repr page_main)
- |] in
+ let drawer = obj [| ("run", repr page_main) |] in
set global "drawer" drawer
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-05 05:56:53 +0000