diff options
Diffstat (limited to 'script.it/script.ml')
| -rwxr-xr-x | script.it/script.ml | 392 |
1 files changed, 192 insertions, 200 deletions
diff --git a/script.it/script.ml b/script.it/script.ml index e4cec67..fffc589 100755 --- a/script.it/script.ml +++ b/script.it/script.ml @@ -9,7 +9,6 @@ module Path = Script_path let post : Brr_webworkers.Worker.t -> Worker_messages.to_worker -> unit = Brr_webworkers.Worker.post - type canva_events = [ `MouseDown of float * float | `Out of float * float @@ -30,8 +29,7 @@ let canva : El.set_prop El.Prop.width (El.prop Elements.Prop.offsetWidth element) element; - El.set_prop - El.Prop.height + El.set_prop El.Prop.height (El.prop Elements.Prop.offsetHeight element) element; @@ -62,27 +60,27 @@ let canva : (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 +type 'a param_events = { + width : float S.t ; angle : float S.t ; export : unit E.t ; delete : unit E.t ; rendering : State.event E.t - } +} -type slider = - { input : El.t +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 + [ + El.i ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-times-circle") ] [] ; El.txt' "Delete " @@ -93,7 +91,8 @@ let set_sidebar : El.t -> State.state -> _ param_events * slider * slider = let export = El.button - [ El.i ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-download") ] [] + [ + El.i ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-download") ] [] ; El.txt' "Download" ] in @@ -103,7 +102,8 @@ let set_sidebar : El.t -> State.state -> _ param_events * slider * slider = Elements.Input.slider ~at: At. - [ type' (Jstr.v "range") + [ + 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) @@ -117,7 +117,8 @@ let set_sidebar : El.t -> State.state -> _ param_events * slider * slider = Elements.Input.slider ~at: At. - [ type' (Jstr.v "range") + [ + 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) @@ -129,7 +130,8 @@ let set_sidebar : El.t -> State.state -> _ param_events * slider * slider = let render = El.select - [ El.option ~at:At.[ value (Jstr.v "1") ] [ El.txt' "Fill" ] + [ + El.option ~at:At.[ value (Jstr.v "1") ] [ El.txt' "Fill" ] ; El.option ~at:At.[ value (Jstr.v "3") ] [ El.txt' "Ductus" ] ] in @@ -137,8 +139,7 @@ let set_sidebar : El.t -> State.state -> _ param_events * slider * slider = let rendering' = El.div [ El.txt' "Rendering : "; render ] in let render_event = - Evr.on_el - Ev.change + Evr.on_el Ev.change (fun _ -> let raw_value = El.prop El.Prop.value render |> Jstr.to_int in let render_type = @@ -154,14 +155,14 @@ let set_sidebar : El.t -> State.state -> _ param_events * slider * slider = let process t state = { state with State.rendering = t } end in - State.dispatch (module M) render_type ) + State.dispatch (module M) render_type) rendering' in let () = - El.append_children - element - [ El.hr () + El.append_children element + [ + El.hr () ; delete ; export ; rendering' @@ -172,7 +173,8 @@ let set_sidebar : El.t -> State.state -> _ param_events * slider * slider = ; input_angle ] in - ( { delete = delete_event + ( { + delete = delete_event ; angle = angle_event ; width = nib_size_event ; export = export_event @@ -181,11 +183,8 @@ let set_sidebar : El.t -> State.state -> _ param_events * slider * slider = , angle_slider , width_slider ) - let backgroundColor = Blog.Nord.nord0 - let white = Jstr.v "#eceff4" - let green = Jstr.v "#a3be8c" let draw_point point context = @@ -193,7 +192,6 @@ let draw_point point context = 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 - (** Redraw the canva on update *) let on_change canva mouse_position timer state = let pos = S.rough_value mouse_position in @@ -204,7 +202,7 @@ let on_change canva mouse_position timer state = Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) in - let context = Cd2d.create canva in + let context = Brr_canvas.C2d.get_context canva in Cd2d.set_fill_style context (Cd2d.color backgroundColor); Cd2d.fill_rect context ~x:0.0 ~y:0.0 ~w ~h; @@ -226,42 +224,38 @@ let on_change canva mouse_position timer state = let back = Path.Path_Builder.map current (fun pt -> - Path.Point.copy pt @@ Path.Point.get_coord' pt ) + Path.Point.copy pt @@ Path.Point.get_coord' pt) in Layer.Paths.to_canva (module Path.Path_Builder) - (current, back) - context - state.rendering; + (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) ) + | 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 ); + (p, path.Outline.back) context state.rendering); (* Draw the selected path, and operate the modifications directly as a preview *) let () = match state.mode with - | Selection t -> + | Selection t -> ( Cd2d.set_stroke_style context (Cd2d.color white); - ( match (pos_v2, Selection.find_selection t state.paths) with + 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 *) @@ -269,17 +263,15 @@ let on_change canva mouse_position timer state = Layer.Paths.to_canva (module Path.Fixed) (outline.path, outline.back) - context - `Line + 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 ) + 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 *) @@ -298,19 +290,16 @@ let on_change canva mouse_position timer state = Layer.Paths.to_canva (module Path.Fixed) (outline.path, outline.back) - context - `Line; - draw_point point context ) + 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 - let page_main id = let timer, tick = Elements.Timer.create () in @@ -324,151 +313,154 @@ let page_main id = 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 - (fun () -> - let module Delete = Script_event.Delete in - State.dispatch (module Delete) Delete.{ worker } ) - parameters.delete - and export_event = - E.map - (fun () -> - let module Export = Script_event.Export in - 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 - (function - | `Other t -> - Console.(log [ t ]); - None - | `Complete 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 - 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 ); - - (* Add the events to the canva : - - - The mouse position is a signal used for both the update and the - canva refresh - - - 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 - (function - | `MouseDown c -> - 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 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 - - (* The first evaluation is the state. Which is the result of all the - successives events to the initial state *) - let state = - State.run - State.init - (E.select - [ worker_event - ; canva_events - ; tick_event - ; angle_event - ; width_event - ; delete_event - ; export_event - ; parameters.rendering - ] ) - in - - (* The seconde evaluation is the canva refresh, which only occurs when - 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 _ -> - on_change canva mouse_position timer (S.value state) ) - |> 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 - angle_element.legend - (S.map - (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 - width_slider.legend - (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 - () ) - + | 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 + (fun () -> + let module Delete = Script_event.Delete in + State.dispatch (module Delete) Delete.{ worker }) + parameters.delete + and export_event = + E.map + (fun () -> + let module Export = Script_event.Export in + 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 + (function + | `Other t -> + Console.(log [ t ]); + None + | `Complete 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 + let target = Brr_webworkers.Worker.as_target worker in + let _ = + Ev.listen Brr_io.Message.Ev.message + (fun t -> Ev.as_type t |> Brr_io.Message.Ev.data |> worker_send) + target + in + ()); + + (* Add the events to the canva : + + - The mouse position is a signal used for both the update and the + canva refresh + + - 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 + (function + | `MouseDown c -> + 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 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 + + (* The first evaluation is the state. Which is the result of all the + successives events to the initial state *) + let state = + State.run State.init + (E.select + [ + worker_event + ; canva_events + ; tick_event + ; angle_event + ; width_event + ; delete_event + ; export_event + ; parameters.rendering + ]) + in + + (* The seconde evaluation is the canva refresh, which only occurs when + 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 _ -> + on_change canva mouse_position timer (S.value state)) + |> 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 angle_element.legend + (S.map + (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 width_slider.legend + (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 + ()) let () = let open Jv in |