diff options
| -rwxr-xr-x | lib/elements/input.ml | 25 | ||||
| -rw-r--r-- | motus/js/fieldList.ml | 89 | ||||
| -rwxr-xr-x | script.it/script.ml | 392 |
3 files changed, 245 insertions, 261 deletions
diff --git a/lib/elements/input.ml b/lib/elements/input.ml index 5def7d4..8c4bcea 100755 --- a/lib/elements/input.ml +++ b/lib/elements/input.ml @@ -12,31 +12,27 @@ let slider : at:Brr.At.t list -> Brr.El.t * float S.t = let init_value = Jstr.to_float (El.prop El.Prop.value slider) in let event = - Evr.on_el - Ev.input + Evr.on_el Ev.input (fun _ -> let raw_value = El.prop El.Prop.value slider in - Jstr.to_float raw_value ) + Jstr.to_float raw_value) slider |> S.hold init_value in (slider, event) - -type file = - { file : File.t +type file = { + file : File.t ; content : Jstr.t - } +} (** Read the content from the file *) let file_loader : file Note.E.send -> File.t -> unit = fun event file -> let blob = File.as_blob file in - Fut.await - (Blob.text blob) + Fut.await (Blob.text blob) (Result.iter (fun content -> event { file; content })) - (** Create an imput which load a file. [file_loader (Jstr.v ".json"] will create an input which only accept json @@ -48,8 +44,7 @@ let file_loader : Jstr.t -> Brr.El.t * file Note.event = let add_file_event, add_file_sender = Note.E.create () in let i = - El.input - () + El.input () ~at:[ At.type' (Jstr.v "file"); (At.v (Jstr.v "accept")) selector ] in @@ -59,6 +54,10 @@ let file_loader : Jstr.t -> Brr.El.t * file Note.event = list. *) let on_change files = file_loader add_file_sender (List.hd files) in - Ev.listen Ev.change (fun _e -> on_change (El.Input.files i)) (El.as_target i); + let _ = + Ev.listen Ev.change + (fun _e -> on_change (El.Input.files i)) + (El.as_target i) + in (i, add_file_event) diff --git a/motus/js/fieldList.ml b/motus/js/fieldList.ml index 26b89bb..5af5e92 100644 --- a/motus/js/fieldList.ml +++ b/motus/js/fieldList.ml @@ -12,32 +12,26 @@ type elements = Brr.El.t list *) let get_validity_from_element : El.t -> Motus_lib.Validity.t = fun el -> - if El.class' (Jstr.v "missing") el - then Missing - else if El.class' (Jstr.v "misplaced") el - then Misplaced + if El.class' (Jstr.v "missing") el then Missing + else if El.class' (Jstr.v "misplaced") el then Misplaced else Wellplaced - let get_rules : elements -> State.proposition = fun t -> List.map ~f:(fun input -> let value = El.prop El.Prop.value input in - if Jstr.equal Jstr.empty value - then None + if Jstr.equal Jstr.empty value then None else let validity = get_validity_from_element input in - Some (value, validity) ) + Some (value, validity)) t - let get_class : Motus_lib.Validity.t -> Jstr.t = function | Wellplaced -> Jstr.v "wellplaced" | Misplaced -> Jstr.v "misplaced" | _ -> Jstr.v "missing" - (** Create the field list modifiied by the user *) let make : int -> (int * Jstr.t * Motus_lib.Validity.t) E.send -> elements = fun len change_sender -> @@ -46,7 +40,8 @@ let make : int -> (int * Jstr.t * Motus_lib.Validity.t) E.send -> elements = El.input ~at: At. - [ type' (Jstr.v "text") + [ + type' (Jstr.v "text") ; v (Jstr.v "maxLength") (Jstr.v "1") ; value Jstr.empty ; class' (Jstr.v "missing") @@ -55,27 +50,26 @@ let make : int -> (int * Jstr.t * Motus_lib.Validity.t) E.send -> elements = () in - Ev.listen - Ev.change - (fun _ -> - let validity = get_validity_from_element input in - change_sender (i, El.prop El.Prop.value input, validity) ) - (El.as_target input); - - Ev.listen - Ev.click - (fun _ -> - let validity = - match get_validity_from_element input with - | Missing -> Motus_lib.Validity.Misplaced - | Misplaced -> Motus_lib.Validity.Wellplaced - | Wellplaced -> Motus_lib.Validity.Missing - in - change_sender (i, El.prop El.Prop.value input, validity) ) - (El.as_target input); - - El.td [ input ] ) + let _ = + Ev.listen Ev.change + (fun _ -> + let validity = get_validity_from_element input in + change_sender (i, El.prop El.Prop.value input, validity)) + (El.as_target input) + and _ = + Ev.listen Ev.click + (fun _ -> + let validity = + match get_validity_from_element input with + | Missing -> Motus_lib.Validity.Misplaced + | Misplaced -> Motus_lib.Validity.Wellplaced + | Wellplaced -> Motus_lib.Validity.Missing + in + change_sender (i, El.prop El.Prop.value input, validity)) + (El.as_target input) + in + El.td [ input ]) (** Set the element class depending of the proposition validity for each letter *) @@ -115,8 +109,7 @@ let set_with_props : El.set_class (Jstr.v "missing") false hd; El.set_at (Jstr.v "readonly") (Some (Jstr.v "false")) hd; El.set_class (get_class validity) true hd - | _, [], _ -> () ) - + | _, [], _ -> ()) let build : El.t -> int S.t -> State.proposition S.t = fun container length -> @@ -128,27 +121,26 @@ let build : El.t -> int S.t -> State.proposition S.t = El.input ~at: At. - [ type' (Jstr.v "text") + [ + type' (Jstr.v "text") ; v (Jstr.v "maxLength") (Jstr.v "1") ; value Jstr.empty ] () in - input ) + input) in let events = List.mapi ~f:(fun i input -> - Evr.on_el - Ev.input + Evr.on_el Ev.input (fun _ -> let value = El.prop El.Prop.value input in - if Jstr.equal Jstr.empty value - then (i, None) + if Jstr.equal Jstr.empty value then (i, None) else let validity = Motus_lib.Validity.Wellplaced in - (i, Some (Jstr.uppercased value, validity)) ) - input ) + (i, Some (Jstr.uppercased value, validity))) + input) elements (* As the state is in a list, we have no way to be sure that the list length is the same as the number of elements… except to rely on the @@ -159,13 +151,14 @@ let build : El.t -> int S.t -> State.proposition S.t = and init_prop = List.init ~len ~f:(fun _ -> None) in (* Replace the children in the element *) - El.set_children - container - [ El.table - [ (* The table has only one row *) + El.set_children container + [ + El.table + [ + (* The table has only one row *) El.tr (List.map elements ~f:(fun el -> - El.td [ (* Each cell is the input element *) el ] ) ) + El.td [ (* Each cell is the input element *) el ])) ] ]; @@ -173,8 +166,8 @@ let build : El.t -> int S.t -> State.proposition S.t = E.select events |> E.map (fun (position, value) acc -> List.mapi acc ~f:(fun i prop -> - if i <> position then prop else value ) ) + if i <> position then prop else value)) in let initial_proposition = S.accum init_prop change in - initial_proposition ) + initial_proposition) 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 |