summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xblog/dune14
-rwxr-xr-xblog/hash_prod/hash_blog.ml1
-rwxr-xr-xblog/hash_prod/hash_localhost.ml1
-rwxr-xr-xblog/nord.ml1
-rwxr-xr-xblog/sidebar.ml1
-rwxr-xr-xelements/input.ml2
-rwxr-xr-xpath/builder.ml17
-rwxr-xr-xpath/builder.mli3
-rwxr-xr-xpath/point.ml6
-rwxr-xr-xpath/point.mli4
-rwxr-xr-xpaths.ml2
-rwxr-xr-xscript.ml45
-rwxr-xr-xstate.ml39
13 files changed, 105 insertions, 31 deletions
diff --git a/blog/dune b/blog/dune
index afbefdb..fef8506 100755
--- a/blog/dune
+++ b/blog/dune
@@ -1,9 +1,21 @@
+(rule
+ (targets hash_host.ml)
+ (enabled_if (= %{profile} dev))
+ (action (run cp hash_prod/hash_localhost.ml hash_host.ml)))
+
+(rule
+ (targets hash_host.ml)
+ (enabled_if (<> %{profile} dev))
+ (action (run cp hash_prod/hash_blog.ml hash_host.ml)))
+
(library
(name blog)
(libraries
brr
brr.note
- color
elements
)
+ (preprocess (pps ppx_hash))
+
+
)
diff --git a/blog/hash_prod/hash_blog.ml b/blog/hash_prod/hash_blog.ml
new file mode 100755
index 0000000..f5e172e
--- /dev/null
+++ b/blog/hash_prod/hash_blog.ml
@@ -0,0 +1 @@
+let expected_host = [%static_hash "blog.chimrod.com"]
diff --git a/blog/hash_prod/hash_localhost.ml b/blog/hash_prod/hash_localhost.ml
new file mode 100755
index 0000000..c652b6a
--- /dev/null
+++ b/blog/hash_prod/hash_localhost.ml
@@ -0,0 +1 @@
+let expected_host = [%static_hash ""]
diff --git a/blog/nord.ml b/blog/nord.ml
index 78c4c61..f0f2772 100755
--- a/blog/nord.ml
+++ b/blog/nord.ml
@@ -1 +1,2 @@
let nord0 = Jstr.v "#2e3440"
+let nord8 = Jstr.v "#81a1c1"
diff --git a/blog/sidebar.ml b/blog/sidebar.ml
index a1293de..1df0f1a 100755
--- a/blog/sidebar.ml
+++ b/blog/sidebar.ml
@@ -21,4 +21,3 @@ let rec clean
else
clean el
)
-
diff --git a/elements/input.ml b/elements/input.ml
index 935f34a..6ae9aa8 100755
--- a/elements/input.ml
+++ b/elements/input.ml
@@ -21,5 +21,3 @@ let slider
|> S.hold init_value
in
slider, event
-
-
diff --git a/path/builder.ml b/path/builder.ml
index 3ccad9c..39ff75e 100755
--- a/path/builder.ml
+++ b/path/builder.ml
@@ -337,14 +337,15 @@ module Make(Point:P) = struct
|> (fun b -> Gg.Box2.add_pt b bezier.ctrl0)
|> (fun b -> Gg.Box2.add_pt b bezier.ctrl1)
+ (** 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 -> fixedPath -> float option =
fun point beziers ->
Array.fold_left beziers.path
~init:None
- ~f:(fun res path ->
- match path with
+ ~f:(fun res -> function
| Empty -> None
| Line (p0, p1) ->
let box = Gg.Box2.of_pts (Point.get_coord p0) (Point.get_coord p1) in
@@ -377,4 +378,16 @@ module Make(Point:P) = struct
let id
: fixedPath -> int
= fun {id; _} -> id
+
+ let map_point
+ : fixedPath -> (Point.t -> Point.t) -> fixedPath
+ = fun {id; path} f ->
+ let path = Array.map path
+ ~f:(function
+ | Empty -> Empty
+ | Line (p1, p2) -> Line (f p1, f p2)
+ | Curve bezier -> Curve {bezier with p0 = f bezier.p0 ; p1 = f bezier.p1}
+ ) in
+ {id; path}
+
end
diff --git a/path/builder.mli b/path/builder.mli
index 557cdfa..ca496f7 100755
--- a/path/builder.mli
+++ b/path/builder.mli
@@ -74,4 +74,7 @@ module Make(P:P) : sig
val id
: fixedPath -> int
+
+ val map_point
+ : fixedPath -> (P.t -> P.t) -> fixedPath
end
diff --git a/path/point.ml b/path/point.ml
index abb9515..06eb635 100755
--- a/path/point.ml
+++ b/path/point.ml
@@ -19,6 +19,12 @@ let create ~angle ~width ~x ~y =
let copy point p =
{ point with p }
+let set_angle p angle =
+ { p with angle = Gg.Float.rad_of_deg (180. -. angle) }
+
+let set_width p size =
+ { p with size }
+
let (+) p1 p2 =
{ p1 with p = Gg.V2.(+) p1.p p2 }
diff --git a/path/point.mli b/path/point.mli
index 2c687ab..649a3be 100755
--- a/path/point.mli
+++ b/path/point.mli
@@ -10,5 +10,9 @@ val create: angle:float -> width:float -> x:float -> y:float -> t
val copy : t -> Gg.v2 -> t
+val set_angle : t -> float -> t
+
+val set_width: t -> float -> t
+
val get_coord'
: t -> Gg.v2
diff --git a/paths.ml b/paths.ml
index 2db8ab0..82eca48 100755
--- a/paths.ml
+++ b/paths.ml
@@ -1,2 +1,4 @@
+(** Common module for ensuring that the function is evaluated only once *)
+
module Path_Builder = Path.Builder.Make(Path.Point)
diff --git a/script.ml b/script.ml
index 5d011d9..a250c7f 100755
--- a/script.ml
+++ b/script.ml
@@ -3,7 +3,6 @@ open Note
open Brr
open Brr_note
-
module CanvaRepr = Path.FillPrinter.Make(Layer.CanvaPrinter)
module Path_Printer = Paths.Path_Builder.Draw(CanvaRepr)
@@ -13,6 +12,12 @@ type canva_signal = Path.Point.t
module Mouse = Brr_note_kit.Mouse
+let get_height el =
+ match El.at (Jstr.v "height") el with
+ | None -> 0
+ | Some att ->
+ Option.value ~default:0 (Jstr.to_int att)
+
(** Create the element in the page, and the event handler *)
let canva
: Brr.El.t -> [> State.canva_events] Note.E.t * (float * float) option Note.S.t * Brr_canvas.Canvas.t
@@ -128,7 +133,7 @@ let set_sidebar
let input_angle, angle_event =
Elements.Input.slider
~at:At.[ type' (Jstr.v "range")
- ; v (Jstr.v "min") (Jstr.v "1")
+ ; v (Jstr.v "min") (Jstr.v "0")
; v (Jstr.v "max") (Jstr.v "90")
; At.value (Jstr.of_float state.angle)
] in
@@ -143,9 +148,6 @@ let set_sidebar
)
);
- let click = Evr.on_el Ev.click Evr.unit delete in
- let _ = click in
-
let () =
El.append_children element
[ hr ()
@@ -155,7 +157,6 @@ let set_sidebar
; width
; nib_size
- ; El.br ()
; angle
; input_angle
@@ -167,8 +168,8 @@ let set_sidebar
let backgroundColor = Blog.Nord.nord0
let white = Jstr.v "#eceff4"
let green = Jstr.v "#a3be8c"
-let nord8 = Jstr.v "#81a1c1"
+(** Redraw the canva on update *)
let on_change canva mouse_position state =
let module Path' = Path in
let open Brr_canvas.C2d in
@@ -215,25 +216,26 @@ let on_change canva mouse_position state =
List.iter paths
~f:(fun path ->
+
+ let () = match state.mode with
+ | Selection s ->
+ begin match (Paths.Path_Builder.id s) = (Paths.Path_Builder.id path) with
+ | true ->
+ set_fill_style context (color Blog.Nord.nord8);
+ set_stroke_style context (color Blog.Nord.nord8)
+ | false ->
+ set_stroke_style context (color white);
+ set_fill_style context (color white);
+ end
+ | _ -> ()
+ in
+
let path = CanvaRepr.get
@@ Fixed_Printer.draw
path
(CanvaRepr.create_path (fun p -> fill context p)) in
stroke context path;
);
-
-
- (* If there is a selection draw it *)
- let () = match state.mode with
- | Selection path ->
- set_fill_style context (color nord8);
- set_stroke_style context (color nord8);
- let path = CanvaRepr.get
- @@ Fixed_Printer.draw
- path
- (CanvaRepr.create_path (fun p -> fill context p)) in
- stroke context path;
- | _ -> () in
()
@@ -258,7 +260,6 @@ let page_main id =
in
-
(*begin match Document.find_el_by_id G.document id with*)
begin match (Jv.is_none id) with
| true -> Console.(error [str "No element with id '%s' found"; id])
@@ -297,6 +298,8 @@ let page_main id =
let _ =
E.select
[ E.map (fun _ -> ()) (S.changes mouse_position)
+ ; E.map (fun _ -> ()) (S.changes angle_signal')
+ ; E.map (fun _ -> ()) (S.changes width_signal')
; delete_event' ]
|> fun ev -> E.log ev (fun _ -> on_change canva mouse_position (S.value state) )
|> Option.iter Logr.hold in
diff --git a/state.ml b/state.ml
index 60796c8..e41c328 100755
--- a/state.ml
+++ b/state.ml
@@ -5,8 +5,7 @@ module Path_Builder = Paths.Path_Builder
module SVGRepr = Path.WireFramePrinter.Make(Layer.Svg)
module SVG_Fixed_Printer = Path_Builder.DrawFixed(SVGRepr)
-
-let expected_host = [%static_hash ""]
+let expected_host = Blog.Hash_host.expected_host
let backgroundColor = Blog.Nord.nord0
@@ -40,7 +39,7 @@ type events =
]
(*
- The state cannt hold functionnal values, and thus cannot be used to store
+ The state cant hold functionnal values, and thus cannot be used to store
elements like timer
*)
type state =
@@ -94,6 +93,20 @@ let check_selection
end
)
+(** Update the path in the selection with the given function applied to
+ every point *)
+let update_selection s state f =
+ let s = Path_Builder.map_point s f
+ and id = Path_Builder.id s in
+
+ let paths = List.map state.paths
+ ~f:(fun path ->
+ let id' = Path_Builder.id path in
+ match id = id' with
+ | false -> path
+ | true -> s
+ ) in
+ { state with mode = Selection s ; paths}
let do_action
: events -> state -> state
@@ -205,12 +218,30 @@ let do_action
);
state
+ (* Change the select curve with the appropriate setting *)
+ | `Angle angle, Selection s ->
+ let state = { state with angle } in
+ update_selection s state (fun p -> Path.Point.set_angle p angle)
+ | `Width width, Selection s ->
+ let state = { state with width } in
+ update_selection s state (fun p -> Path.Point.set_width p width)
+
| `Angle angle, _ ->
{ state with angle}
| `Width width, _ ->
{ state with width}
- | _ -> state
+ | `Delete, Out
+ -> state
+
+ (* Some non possible cases *)
+ | `Out _, Out
+ | `Point _, Out
+ | `Point _, Selection _
+ | `Out _, Selection _
+ | `Click _, Edit
+ | `Delete, Edit
+ -> state
let init =
{ paths = []