diff options
| -rwxr-xr-x | elements/prop.ml | 5 | ||||
| -rwxr-xr-x | path/fixed.ml | 6 | ||||
| -rwxr-xr-x | path/fixed.mli | 2 | ||||
| -rwxr-xr-x | path/point.ml | 4 | ||||
| -rwxr-xr-x | path/point.mli | 4 | ||||
| -rwxr-xr-x | script.it/script.ml | 88 | ||||
| -rwxr-xr-x | script.it/state.ml | 52 |
7 files changed, 101 insertions, 60 deletions
diff --git a/elements/prop.ml b/elements/prop.ml index 715adec..054864c 100755 --- a/elements/prop.ml +++ b/elements/prop.ml @@ -13,3 +13,8 @@ let offsetHeight let outerHTML : Jstr.t t = El.Prop.jstr (Jstr.v "outerHTML") + + +let value + : Jstr.t t + = El.Prop.jstr (Jstr.v "value") diff --git a/path/fixed.ml b/path/fixed.ml index d20c897..7ee0705 100755 --- a/path/fixed.ml +++ b/path/fixed.ml @@ -141,7 +141,7 @@ module Make(Point:P) = struct (** Return the distance between a given point and the curve. May return None if the point is out of the curve *) let distance - : Gg.v2 -> t -> (Gg.v2 * float) option + : Gg.v2 -> t -> (Gg.v2 * float * Point.t * Point.t) option = fun point beziers -> Array.fold_left beziers.path @@ -171,8 +171,8 @@ module Make(Point:P) = struct let _, point' = Shapes.Bezier.get_closest_point point bezier' in let distance = Gg.V2.( norm (point - point') ) in match res with - | None -> Some (point', distance) - | Some (_, d) -> if d < distance then res else (Some (point', distance)) + | None -> Some (point', distance, bezier.p0, bezier.p1) + | Some (_, d, _, _) -> if d < distance then res else (Some (point', distance, bezier.p0, bezier.p1)) end ) diff --git a/path/fixed.mli b/path/fixed.mli index c84b51d..c6af84d 100755 --- a/path/fixed.mli +++ b/path/fixed.mli @@ -38,7 +38,7 @@ module Make(Point:P) : sig (** Return the distance between a given point and the curve. May return None if the point is out of the curve *) val distance - : Gg.v2 -> t -> (Gg.v2 * float) option + : Gg.v2 -> t -> (Gg.v2 * float * Point.t * Point.t) option val map_point : t -> (Point.t -> Point.t) -> t diff --git a/path/point.ml b/path/point.ml index 031e1e0..046c2e7 100755 --- a/path/point.ml +++ b/path/point.ml @@ -25,9 +25,13 @@ let copy point p = let set_angle p angle = { p with angle = Gg.Float.rad_of_deg (180. -. angle) } +let get_angle { angle; _} = 180. -. (Gg.Float.deg_of_rad angle) + let set_width p size = { p with size } +let get_width { size; _} = size + let (+) p1 p2 = { p1 with p = Gg.V2.(+) p1.p p2 } diff --git a/path/point.mli b/path/point.mli index db87a71..c897195 100755 --- a/path/point.mli +++ b/path/point.mli @@ -14,7 +14,11 @@ val copy : t -> Gg.v2 -> t val set_angle : t -> float -> t +val get_angle : t -> float + val set_width: t -> float -> t +val get_width: t -> float + val get_coord' : t -> Gg.v2 diff --git a/script.it/script.ml b/script.it/script.ml index 131ea39..95272fb 100755 --- a/script.it/script.ml +++ b/script.it/script.ml @@ -77,9 +77,6 @@ let click_event el = Evr.unit el -let show_value input = - El.txt (Jstr.of_float input) - type 'a param_events = { width : float S.t ; angle : float S.t @@ -88,8 +85,12 @@ type 'a param_events = ; rendering : ([> State.render_event] as 'a) E.t } +type slider = + { input : El.t + ; legend : El.t } + let set_sidebar - : El.t -> State.state -> _ param_events + : El.t -> State.state -> _ param_events * slider * slider = fun element state -> let open El in @@ -122,14 +123,9 @@ let set_sidebar ] in let width = El.div [] in - Elr.def_children - width - (nib_size_event - |> S.map (fun v -> - [ txt' "Width : " - ; show_value v ] - ) - ); + let width_slider = + { input = nib_size + ; legend = width } in let input_angle, angle_event = Elements.Input.slider @@ -140,15 +136,9 @@ let set_sidebar ] in let angle = El.div [] in - Elr.def_children - angle - (angle_event - |> S.map (fun v -> - [ txt' "Angle : " - ; show_value v - ; txt' "°" ] - ) - ); + let angle_slider = + { input = input_angle + ; legend = angle } in let render = El.select @@ -156,10 +146,6 @@ let set_sidebar [ txt' "Fill"] ; El.option ~at:At.[value (Jstr.v "2")] [ txt' "Ductus"] -(* - ; El.option ~at:At.[value (Jstr.v "3")] - [ txt' "Line"] -*) ] in let rendering' = El.div @@ -196,12 +182,14 @@ let set_sidebar ] in - { delete = delete_event - ; angle = angle_event - ; width = nib_size_event - ; export = export_event - ; rendering = render_event - } + ( { 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" @@ -275,7 +263,7 @@ let page_main id = let timer, tick = Elements.Timer.create () in - let parameters = + let parameters, angle_element, width_slider = begin match Blog.Sidebar.get () with | None -> Jv.throw (Jstr.v "No sidebar") @@ -284,6 +272,8 @@ let page_main id = Blog.Sidebar.clean el; set_sidebar el State.init end in + + let delete_event = E.map (fun () -> `Delete) parameters.delete and export_event = E.map (fun () -> `Export) parameters.export and angle_event = S.changes parameters.angle @@ -359,6 +349,40 @@ let page_main id = |> 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; diff --git a/script.it/state.ml b/script.it/state.ml index cfde0b0..53cc861 100755 --- a/script.it/state.ml +++ b/script.it/state.ml @@ -77,7 +77,7 @@ let insert_or_replace state ((x, y) as p) stamp path = let threshold = 20. let check_selection - : (float * float) -> Path.Fixed.t list -> (Gg.v2 * Path.Fixed.t) option + : (float * float) -> Path.Fixed.t list -> (Gg.v2 * Path.Fixed.t * Path.Point.t * Path.Point.t) option = fun position paths -> let point = Gg.V2.of_tuple position in (* If the user click on a curve, select it *) @@ -85,8 +85,8 @@ let check_selection ~init:(threshold, None) ~f:(fun (dist, selection) path -> match Path.Fixed.distance point path with - | Some (point', p) when p < dist -> - dist, Some (point', path) + | Some (point', p, p0, p1) when p < dist -> + dist, Some (point', path, p0, p1) | _ -> dist, selection ) in res @@ -104,6 +104,24 @@ let update_selection id state f = ) in { state with paths } + +let select_segment point (p, selected, p0, p1) state = + let angle0 = Path.Point.get_angle p0 + and angle1 = Path.Point.get_angle p1 in + let width0 = Path.Point.get_width p0 + and width1 = Path.Point.get_width p1 in + + let dist = Gg.V2.(norm ( p - (Gg.V2.of_tuple point))) in + + let angle = angle0 +. dist *. ( angle1 -. angle0 ) in + let width = width0 +. dist *. ( width1 -. width0 ) in + + let id = Path.Fixed.id selected in + { state with + mode = (Selection id) + ; angle + ; width } + let do_action : Brr_webworkers.Worker.t -> Elements.Timer.t -> events -> state -> state = fun worker timer event state -> @@ -130,7 +148,7 @@ let do_action | None -> (* Start a new path with the point clicked *) Path.Point.create ~x ~y ~angle ~width ~stamp - | Some (p, _) -> + | Some (p, _, _, _) -> (* If the point is close to an existing path, we use the closest point in the path instead *) let x, y = Gg.V2.to_tuple p in @@ -149,14 +167,8 @@ let do_action | None -> { state with mode = Out } - | Some (_, selected) -> - - (* Start the timer in order to handle the mouse moves *) - - let id = Path.Fixed.id selected in - Elements.Timer.start timer 0.3; - { state with - mode = (Selection id)} + | Some selection -> + select_segment position selection state end | `Out point, Edit -> @@ -167,12 +179,6 @@ let do_action creation. And we add the new point in the current path *) | Some _ -> -(* - let point = match check_selection point state.paths with - | None -> point - | Some (p, _) -> Gg.V2.to_tuple p in -*) - let current = insert_or_replace state point stamp state.current in let paths = let last = Path.Fixed.to_fixed @@ -191,7 +197,7 @@ let do_action mode = Out ; paths; current } - (* Else, check if there is a curve undre the cursor, and remove it *) + (* Else, check if there is a curve under the cursor, and remove it *) | None -> let current = Path.Path_Builder.empty in begin match check_selection point state.paths with @@ -200,11 +206,9 @@ let do_action mode = Out ; current } - | Some (_, selected) -> - let id = Path.Fixed.id selected in - { state with - mode = (Selection id) - ; current } + | Some selection -> + select_segment point selection { state with current } + end end | `Delete, Selection id -> |