summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xscript.it/script.ml103
-rwxr-xr-xscript.it/script_event/click.ml (renamed from script.it/script_event/out.ml)13
-rwxr-xr-xscript.it/script_event/complete_path.ml14
-rwxr-xr-xscript.it/script_event/delete.ml2
-rwxr-xr-xscript.it/script_event/export.ml30
-rwxr-xr-xscript.it/script_event/mouse_down.ml2
-rwxr-xr-xscript.it/script_event/property.ml52
-rwxr-xr-xscript.it/script_event/tick.ml20
-rwxr-xr-xscript.it/state/state.ml136
9 files changed, 202 insertions, 170 deletions
diff --git a/script.it/script.ml b/script.it/script.ml
index a21afa9..29bf2c9 100755
--- a/script.it/script.ml
+++ b/script.it/script.ml
@@ -87,7 +87,7 @@ type 'a param_events =
; angle : float S.t
; export : unit E.t
; delete : unit E.t
- ; rendering : ([> State.render_event] as 'a) E.t
+ ; rendering : State.events E.t
}
type slider =
@@ -160,11 +160,22 @@ let set_sidebar
Ev.change (fun _ ->
let raw_value = El.prop El.Prop.value render
|> Jstr.to_int in
- match raw_value with
- | Some 1 -> `Rendering `Fill
- | Some 2 -> `Rendering `Line
- | Some 3 -> `Rendering `Ductus
- | _ -> `Rendering `Fill
+ 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 update t state = { state with State.rendering = t }
+ end
+ in
+
+ State.E
+ ( render_type
+ , (module M: State.Handler with type t = Layer.Paths.printer ))
+
) rendering' in
let () =
@@ -358,22 +369,52 @@ let page_main id =
[ El.p El.[txt (Jv.Error.message e)]]
| Ok worker ->
+
+ let worker_event, worker_send = E.create () in
+
let delete_event = E.map
- (fun () -> `Generic (
- let module Delete = Script_event.Delete in
- State.E ( Delete.{ worker }
- , (module Delete: State.Handler with type t = Delete.t)
- )))
+ (fun () ->
+ let module Delete = Script_event.Delete in
+ State.E
+ ( Delete.{ worker }
+ , (module Delete: State.Handler with type t = Delete.t )))
parameters.delete
- and export_event = E.map (fun () -> `Export) parameters.export
+ and export_event =
+ E.map (fun () ->
+ let module Export = Script_event.Export in
+ State.E
+ ( ()
+ , (module Export: State.Handler with type t = Export.t )))
+ parameters.export
and angle_event = S.changes parameters.angle
- |> E.map (fun value -> `Angle value)
+ |> E.map (fun value ->
+ let module Property = Script_event.Property in
+ State.E
+ ( Property.{ value ; worker ; prop = `Angle }
+ , (module Property: State.Handler with type t = Property.t )))
+
and width_event = S.changes parameters.width
- |> E.map (fun value -> `Width value)
+ |> E.map (fun value ->
+ let module Property = Script_event.Property in
+ State.E
+ ( Property.{ value ; worker ; prop = `Width }
+ , (module Property: State.Handler with type t = Property.t )))
+ and worker_event = Note.E.filter_map
+ (function
+ | `Other t ->
+ Console.(log [t]);
+ None
+ | `Complete outline ->
+ let module Complete_path = Script_event.Complete_path in
+ Some (
+ State.E
+ ( outline
+ , (module Complete_path: State.Handler with type t = Complete_path.t ))))
+
+ worker_event
in
- let worker_event, worker_send = E.create () in
let my_host = Uri.host @@ Window.location @@ G.window in
if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then (
let target = Brr_webworkers.Worker.as_target worker in
@@ -396,35 +437,33 @@ let page_main id =
(function
| `MouseDown c ->
let module MouseDown = Script_event.Mouse_down in
- `Generic (
- State.E
- ( MouseDown.{ position = c
- ; timer
- }
- , (module MouseDown: State.Handler with type t = MouseDown.t)))
+ State.E
+ ( MouseDown.{ position = c ; timer }
+ , (module MouseDown: State.Handler with type t = MouseDown.t ))
| `Out c ->
- let module Out = Script_event.Out in
- `Generic (
- State.E
- ( Out.{ point = c
- ; worker
- ; timer
- }
- , (module Out: State.Handler with type t = Out.t)))
-
+ let module Click = Script_event.Click in
+ State.E
+ ( Click.{ point = c ; worker; timer }
+ , (module Click: State.Handler with type t = Click.t ))
) canva_events in
let tick_event =
S.sample_filter mouse_position
~on:tick
- (fun pos f -> Option.map (fun p -> `Point (f, p)) pos ) in
+ (fun pos f ->
+ let module Tick = Script_event.Tick in
+ Option.map (fun p ->
+ State.E
+ ( (f, p)
+ , (module Tick: State.Handler with type t = Tick.t )))
+ pos ) in
(* The first evaluation is the state. Which is the result of all the
successives events to the initial state *)
let state =
Application.run
- (State.do_action worker)
+ State.do_action
State.init
(E.select
[ worker_event
diff --git a/script.it/script_event/out.ml b/script.it/script_event/click.ml
index b8b8599..591887b 100755
--- a/script.it/script_event/out.ml
+++ b/script.it/script_event/click.ml
@@ -8,8 +8,11 @@ type t = { point : float * float
; worker : Brr_webworkers.Worker.t
}
-(** Long click, move the selected element if any *)
-let longClick mouse_coord state worker = function
+(** The drag function is incorrectly named, as we dont't care if we are
+ selecting an element or not.
+
+ But, in the case we are (point, path…), we effectively move the element with the mouse. *)
+let drag mouse_coord state worker = function
| State.Selection t ->
let mouse_v2 = Gg.V2.of_tuple mouse_coord in
begin match Selection.find_selection t state.State.paths with
@@ -24,10 +27,10 @@ let longClick mouse_coord state worker = function
State.post worker (`TranslatePath (path, delta));
state
end
- (* TODO Long click in out mode should translate the slate *)
+ (* TODO Long click in out mode should translate the whole slate *)
| _ -> state
-let apply {point; timer ; worker} state =
+let update {point; timer ; worker} state =
match state.State.mode with
| Edit ->
@@ -84,5 +87,5 @@ let apply {point; timer ; worker} state =
state
| _ ->
- longClick point state worker state.mode
+ drag point state worker state.mode
diff --git a/script.it/script_event/complete_path.ml b/script.it/script_event/complete_path.ml
new file mode 100755
index 0000000..99dd6ae
--- /dev/null
+++ b/script.it/script_event/complete_path.ml
@@ -0,0 +1,14 @@
+open StdLabels
+module State = Script_state.State
+
+type t = Outline.t
+
+let update newPath state =
+ let paths = List.map
+ state.State.paths
+ ~f:(fun line ->
+ match Outline.(newPath.id = line.id) with
+ | true -> newPath
+ | false -> line) in
+ { state with paths }
+
diff --git a/script.it/script_event/delete.ml b/script.it/script_event/delete.ml
index edd5d23..6aac5d2 100755
--- a/script.it/script_event/delete.ml
+++ b/script.it/script_event/delete.ml
@@ -7,7 +7,7 @@ module Selection = Script_state.Selection
type t = { worker : Brr_webworkers.Worker.t }
(* Click anywhere while in Out mode, we switch in edition *)
-let apply { worker } state =
+let update { worker } state =
match state.State.mode with
| Selection (Path id) ->
let paths = List.filter
diff --git a/script.it/script_event/export.ml b/script.it/script_event/export.ml
new file mode 100755
index 0000000..9e900c7
--- /dev/null
+++ b/script.it/script_event/export.ml
@@ -0,0 +1,30 @@
+open StdLabels
+open Brr
+module State = Script_state.State
+
+type t = unit
+
+let update () state =
+ let my_host = Uri.host @@ Window.location @@ G.window in
+ if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then (
+ (* Convert the path into an sVG element *)
+ let svg = Layer.Svg.svg
+ ~at:Brr.At.[
+ v (Jstr.v "xmlns") (Jstr.v "http://www.w3.org/2000/svg")
+ ; v (Jstr.v "xmlns:xlink") (Jstr.v "http://www.w3.org/1999/xlink") ]
+ (List.map state.State.paths
+ ~f:(fun path ->
+
+ Layer.Paths.to_svg
+ ~color:Blog.Nord.nord0
+ (module Path.Fixed)
+ Outline.(path.path, path.back)
+ state.State.rendering
+
+ )) in
+ let content = El.prop Elements.Prop.outerHTML svg in
+ Elements.Transfert.send
+ ~mime_type:(Jstr.v "image/svg+xml")
+ ~filename:(Jstr.v "out.svg")
+ content);
+ state
diff --git a/script.it/script_event/mouse_down.ml b/script.it/script_event/mouse_down.ml
index 04ea2fd..98e866a 100755
--- a/script.it/script_event/mouse_down.ml
+++ b/script.it/script_event/mouse_down.ml
@@ -4,7 +4,7 @@ module Selection = Script_state.Selection
type t = { position : float * float
; timer : Elements.Timer.t }
-let apply { position; timer } state =
+let update { position; timer } state =
match state.State.mode with
| Out ->
diff --git a/script.it/script_event/property.ml b/script.it/script_event/property.ml
new file mode 100755
index 0000000..e637ab7
--- /dev/null
+++ b/script.it/script_event/property.ml
@@ -0,0 +1,52 @@
+module State = Script_state.State
+module Selection = Script_state.Selection
+
+let update_property worker state value f = function
+ | None -> state
+ | Some (Selection.Path outline) ->
+ (* Change width for the whole path *)
+ let outline = { outline with
+ Outline.path = Path.Fixed.map outline.Outline.path (fun p ->
+ f p value)
+ } in
+ State.post worker (`Back outline);
+ state
+ | Some (Point (outline, point)) ->
+ let path = Path.Fixed.map
+ outline.path
+ (fun pt ->
+ match Path.Point.id pt = Path.Point.id point with
+ | false -> pt
+ | true -> f pt value)
+ in
+ let outline = {outline with path} in
+ State.post worker (`Back outline);
+ state
+
+type t = { prop : [`Angle | `Width ]
+ ; value : float
+ ; worker : Brr_webworkers.Worker.t
+ }
+
+let update { prop; value ; worker } state =
+ match prop with
+ | `Angle ->
+ let angle = value in
+ begin match state.State.mode with
+
+ | Selection t ->
+ let state = { state with angle } in
+ Selection.find_selection t state.paths
+ |> update_property worker state angle Path.Point.set_angle
+ | _ -> { state with angle }
+ end
+ | `Width ->
+ let width = value in
+ begin match state.State.mode with
+
+ | Selection t ->
+ let state = { state with width } in
+ Selection.find_selection t state.paths
+ |> update_property worker state width Path.Point.set_width
+ | _ -> { state with width }
+ end
diff --git a/script.it/script_event/tick.ml b/script.it/script_event/tick.ml
new file mode 100755
index 0000000..c927a2a
--- /dev/null
+++ b/script.it/script_event/tick.ml
@@ -0,0 +1,20 @@
+module State = Script_state.State
+
+type t = float * (float * float)
+
+(** Tick event
+
+ Tick only occurs when drawing a new path
+
+*)
+let update (delay, point) state =
+ match state.State.mode with
+ | Edit ->
+ (* Add the point in the list *)
+ let current = State.insert_or_replace
+ state
+ point
+ delay
+ state.current in
+ { state with current }
+ | _ -> state
diff --git a/script.it/state/state.ml b/script.it/state/state.ml
index 4cf6992..e8cd87e 100755
--- a/script.it/state/state.ml
+++ b/script.it/state/state.ml
@@ -1,17 +1,8 @@
-open StdLabels
-open Brr
-
type mode =
| Edit
| Selection of Selection.t
| Out
-(** Events *)
-type render_event =
- [
- `Rendering of Layer.Paths.printer
- ]
-
type worker_event = Worker_messages.from_worker
(*
@@ -32,21 +23,13 @@ module type Handler = sig
type t
- val apply: t -> state -> state
+ val update: t -> state -> state
end
type t = E : 'a * (module Handler with type t = 'a) -> t
-type events =
- [ `Export
- | render_event
- | worker_event
- | `Point of float * (float * float)
- | `Width of float
- | `Angle of float
- | `Generic of t
- ]
+type events = t
let post
: Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit
@@ -89,120 +72,11 @@ let select_segment _ (_, selected, p0, p1) state dist =
; angle
; width }
-(** Tick event
-
- Tick only occurs when drawing a new path
-
-*)
-let tick (delay, point) state =
- match state.mode with
- | Edit ->
- (* Add the point in the list *)
- let current = insert_or_replace
- state
- point
- delay
- state.current in
- { state with current }
- | _ -> state
-
-let update_property worker state value f = function
- | None -> state
- | Some (Selection.Path outline) ->
- (* Change width for the whole path *)
- let outline = { outline with
- Outline.path = Path.Fixed.map outline.Outline.path (fun p ->
- f p value)
- } in
- post worker (`Back outline);
- state
- | Some (Point (outline, point)) ->
- let path = Path.Fixed.map
- outline.path
- (fun pt ->
- match Path.Point.id pt = Path.Point.id point with
- | false -> pt
- | true -> f pt value)
- in
- let outline = {outline with path} in
- post worker (`Back outline);
- state
-
-let width worker width state =
- match state.mode with
-
- | Selection t ->
- let state = { state with width } in
- Selection.find_selection t state.paths
- |> update_property worker state width Path.Point.set_width
- | _ -> { state with width }
-
-let angle worker angle state =
- match state.mode with
-
- | Selection t ->
- let state = { state with angle } in
- Selection.find_selection t state.paths
- |> update_property worker state angle Path.Point.set_angle
- | _ -> { state with angle }
-
let do_action
- : Brr_webworkers.Worker.t -> (events, state) Application.t
- = fun worker event state ->
- match event, state.mode with
- | `Generic (E (t, (module Handler))), _ ->
- Handler.apply t state
- | `Point (delay, point), _ ->
- tick (delay, point) state
-
-
- | `Export, _ ->
- let my_host = Uri.host @@ Window.location @@ G.window in
- if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then (
- (* Convert the path into an sVG element *)
- let svg = Layer.Svg.svg
- ~at:Brr.At.[
- v (Jstr.v "xmlns") (Jstr.v "http://www.w3.org/2000/svg")
- ; v (Jstr.v "xmlns:xlink") (Jstr.v "http://www.w3.org/1999/xlink") ]
- (List.map state.paths
- ~f:(fun path ->
-
- Layer.Paths.to_svg
- ~color:Blog.Nord.nord0
- (module Path.Fixed)
- Outline.(path.path, path.back)
- state.rendering
-
- )) in
- let content = El.prop Elements.Prop.outerHTML svg in
- Elements.Transfert.send
- ~mime_type:(Jstr.v "image/svg+xml")
- ~filename:(Jstr.v "out.svg")
- content);
- state
-
- | `Angle value , _ ->
- angle worker value state
- | `Width value, _ ->
- width worker value state
-
-
- | `Rendering rendering, _ ->
- { state with rendering}
-
- | `Other t, _ ->
- Console.(log [t]);
- state
-
- | `Complete newPath, _ ->
- let paths = List.map
- state.paths
- ~f:(fun line ->
- match Outline.(newPath.id = line.id) with
- | true -> newPath
- | false -> line) in
- { state with paths }
+ : (events, state) Application.t
+ = fun (E (t, (module Handler))) state ->
+ Handler.update t state
let init =
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 01:40:16 +0000