diff options
| -rwxr-xr-x | blog/dune | 14 | ||||
| -rwxr-xr-x | blog/hash_prod/hash_blog.ml | 1 | ||||
| -rwxr-xr-x | blog/hash_prod/hash_localhost.ml | 1 | ||||
| -rwxr-xr-x | blog/nord.ml | 1 | ||||
| -rwxr-xr-x | blog/sidebar.ml | 1 | ||||
| -rwxr-xr-x | elements/input.ml | 2 | ||||
| -rwxr-xr-x | path/builder.ml | 17 | ||||
| -rwxr-xr-x | path/builder.mli | 3 | ||||
| -rwxr-xr-x | path/point.ml | 6 | ||||
| -rwxr-xr-x | path/point.mli | 4 | ||||
| -rwxr-xr-x | paths.ml | 2 | ||||
| -rwxr-xr-x | script.ml | 45 | ||||
| -rwxr-xr-x | state.ml | 39 |
13 files changed, 105 insertions, 31 deletions
@@ -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 @@ -1,2 +1,4 @@ +(** Common module for ensuring that the function is evaluated only once *) + module Path_Builder = Path.Builder.Make(Path.Point) @@ -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 @@ -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 = [] |