summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xelements/prop.ml5
-rwxr-xr-xpath/fixed.ml6
-rwxr-xr-xpath/fixed.mli2
-rwxr-xr-xpath/point.ml4
-rwxr-xr-xpath/point.mli4
-rwxr-xr-xscript.it/script.ml88
-rwxr-xr-xscript.it/state.ml52
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 ->