diff options
Diffstat (limited to 'script.it')
-rwxr-xr-x | script.it/drawer.html | 135 | ||||
-rwxr-xr-x | script.it/dune | 35 | ||||
-rwxr-xr-x | script.it/script.ml | 196 | ||||
-rwxr-xr-x | script.it/state.ml | 69 | ||||
-rwxr-xr-x | script.it/worker.ml | 64 |
5 files changed, 400 insertions, 99 deletions
diff --git a/script.it/drawer.html b/script.it/drawer.html new file mode 100755 index 0000000..c55a849 --- /dev/null +++ b/script.it/drawer.html @@ -0,0 +1,135 @@ + +<!DOCTYPE html> +<html lang="fr_fr"> +<head> + <meta charset="utf-8" /> + <meta http-equiv="X-UA-Compatible" content="IE=edge" /> + <meta name="HandheldFriendly" content="True" /> + <meta name="viewport" content="width=device-width, initial-scale=1.0" /> + <meta name="robots" content="noindex, nofollow" /> + + <link href="https://fonts.googleapis.com/css2?family=Source+Code+Pro:ital,wght@0,400;0,700;1,400&family=Source+Sans+Pro:ital,wght@0,300;0,400;0,700;1,400&display=swap" rel="stylesheet"> + + <link rel="stylesheet" type="text/css" href="/theme/stylesheet/style.min.css"> + + + <link id="pygments-light-theme" rel="stylesheet" type="text/css" + href="//localhost:8000/theme/pygments/monokai.min.css"> + + + <link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/fontawesome.css"> + <link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/brands.css"> + <link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/solid.css"> + + <link href="//localhost:8000/custom.css" rel="stylesheet"> + + <link href="//localhost:8000/feeds/all.atom.xml" type="application/atom+xml" rel="alternate" title="Chimrod Atom"> + + + + + + <meta name="author" content="Chimrod" /> + <meta name="description" content="" /> +<meta property="og:site_name" content="Chimrod"/> +<meta property="og:type" content="blog"/> +<meta property="og:title" content="Chimrod"/> +<meta property="og:description" content=""/> +<meta property="og:locale" content="en_US"/> +<meta property="og:url" content="//localhost:8000"/> +<meta property="og:image" content="/images/profile.png"> + + + + <title>Chimrod – Drawer</title> + +</head> +<body class="light-theme"> + <aside> + <div> + <a href="//localhost:8000"> + <img src="/profile.png" alt="Chimrod" title="Chimrod"> + </a> + + <h1> + <a href="//localhost:8000">Chimrod</a> + </h1> + + + + <nav> + <ul class="list"> + + + + <li> + <a target="_self" href="http://git.chimrod.com" >git</a> + </li> + </ul> + </nav> + + <ul class="social"> + </ul> + </div> + + </aside> + <main> + + <nav> + <a href="//localhost:8000">Accueil</a> + + + <a href="//localhost:8000/feeds/all.atom.xml">Atom</a> + + </nav> + +<article class="single"> + <header> + + <h1 id="drawer">Drawer</h1> + </header> + <div> + + <noscript>Sorry, you need to enable JavaScript to see this page.</noscript> + <script id="drawer_js" type="text/javascript" defer="defer" src="script.js"></script> + <script> + var script = document.getElementById('drawer_js'); + script.addEventListener('load', function() { + var app = document.getElementById('slate'); + drawer.run(app); + }); + </script> + <section class="todoapp" id="app"> + <canvas id="slate" class="drawing-zone" width="800" height="800"> + </section> + + Cliquez dans l’ardoise pour commencer à dessiner<span style="white-space:nowrap"> </span>! + + <footer class="info"> </footer> + </div> +</article> + + <footer> +<p>© </p> +<p> +Construit avec <a href="http://getpelican.com" target="_blank">Pelican</a> utilisant le thème <a href="http://bit.ly/flex-pelican" target="_blank">Flex</a> +</p> </footer> + </main> + + + + +<script type="application/ld+json"> +{ + "@context" : "http://schema.org", + "@type" : "Blog", + "name": " Chimrod ", + "url" : "//localhost:8000", + "image": "./profile.png", + "description": "" +} +</script> + + +</body> +</html> diff --git a/script.it/dune b/script.it/dune index 1536f2b..e7ca0dc 100755 --- a/script.it/dune +++ b/script.it/dune @@ -1,26 +1,39 @@ -(executables - (names script) +(executable + (name script) (libraries - js_of_ocaml brr brr.note - vg - vg.htmlc - messages - messages_json - worker shapes - tools elements blog - path + layer ) (modes js) - (preprocess (pps ppx_hash)) + (modules script state) + (preprocess (pps ppx_hash js_of_ocaml-ppx)) (link_flags (:standard -no-check-prims)) ) + (rule (targets script.js) (deps script.bc.js) (action (run cp %{deps} %{targets}))) + +(executable + (name worker) + (modules worker) + (libraries + js_of_ocaml + shapes + path + ) + (modes js) + (preprocess (pps ppx_hash js_of_ocaml-ppx)) + (link_flags (:standard -no-check-prims)) + ) + +(rule + (targets worker.js) + (deps worker.bc.js) + (action (run cp %{deps} %{targets}))) diff --git a/script.it/script.ml b/script.it/script.ml index 3e52f5c..131ea39 100755 --- a/script.it/script.ml +++ b/script.it/script.ml @@ -80,8 +80,16 @@ let click_event el = let show_value input = El.txt (Jstr.of_float input) +type 'a param_events = + { width : float S.t + ; angle : float S.t + ; export : unit E.t + ; delete : unit E.t + ; rendering : ([> State.render_event] as 'a) E.t + } + let set_sidebar - : El.t -> State.state -> unit E.t * float S.t * float S.t *unit E.t + : El.t -> State.state -> _ param_events = fun element state -> let open El in @@ -130,6 +138,7 @@ let set_sidebar ; v (Jstr.v "max") (Jstr.v "90") ; At.value (Jstr.of_float state.angle) ] in + let angle = El.div [] in Elr.def_children angle @@ -143,17 +152,32 @@ let set_sidebar let render = El.select - [ El.option ~at:At.[value (Jstr.v "Fill")] + [ El.option ~at:At.[value (Jstr.v "1")] [ txt' "Fill"] - ; El.option ~at:At.[value (Jstr.v "Wireframe")] - [ txt' "Wireframe"] - ; El.option ~at:At.[value (Jstr.v "Ductus")] + ; 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 [ txt' "Rendering : " ; render ] in + let render_event = + Evr.on_el + Ev.change (fun _ -> + let raw_value = El.prop El.Prop.value render + |> Jstr.to_int in + match raw_value with + | Some 1 -> `Rendering `Fill + | Some 2 -> `Rendering `Line + | Some 3 -> `Rendering `Ductus + | _ -> `Rendering `Fill + ) rendering' in + let () = El.append_children element [ hr () @@ -172,14 +196,19 @@ let set_sidebar ] in - delete_event, angle_event, nib_size_event, export_event + { delete = delete_event + ; angle = angle_event + ; width = nib_size_event + ; export = export_event + ; rendering = render_event + } let backgroundColor = Blog.Nord.nord0 let white = Jstr.v "#eceff4" let green = Jstr.v "#a3be8c" (** Redraw the canva on update *) -let on_change canva mouse_position state = +let on_change canva mouse_position timer state = let module Cd2d = Brr_canvas.C2d in let w, h = Brr_canvas.Canvas.(float_of_int @@ w canva, float_of_int @@ h canva) in @@ -206,15 +235,14 @@ let on_change canva mouse_position state = let current = begin match state.State.mode, pos with | Edit, Some point -> - State.insert_or_replace state point state.current + let stamp = Elements.Timer.delay timer in + State.insert_or_replace state point stamp state.current | _ -> state.current end in - let repr = `Fill in - - Path.to_canva (module Path.Path_Builder) current context repr; + Layer.Paths.to_canva (module Path.Path_Builder) current context state.rendering; List.iter state.paths ~f:(fun path -> @@ -233,14 +261,21 @@ let on_change canva mouse_position state = | _ -> () in - Path.to_canva (module Path.Fixed) path context repr + Layer.Paths.to_canva (module Path.Fixed) path context state.rendering ); () +let spawn_worker () = + try + Ok (Brr_webworkers.Worker.create (Jstr.v "worker.js")) + with + | Jv.Error e -> Error e let page_main id = - let delete_event', angle_signal', width_signal', export_event' = + let timer, tick = Elements.Timer.create () in + + let parameters = begin match Blog.Sidebar.get () with | None -> Jv.throw (Jstr.v "No sidebar") @@ -249,11 +284,11 @@ let page_main id = Blog.Sidebar.clean el; set_sidebar el State.init end in - let delete_event = E.map (fun () -> `Delete) delete_event' - and export_event = E.map (fun () -> `Export) export_event' - and angle_event = S.changes angle_signal' + 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 |> E.map (fun value -> `Angle value) - and width_event = S.changes width_signal' + and width_event = S.changes parameters.width |> E.map (fun value -> `Width value) in @@ -263,64 +298,81 @@ let page_main id = | true -> Console.(error [str "No element with id '%s' found"; id]) | false -> - (* 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 tick_event = - S.sample_filter mouse_position - ~on:State.tick - (fun pos f -> Option.map (fun p -> `Point (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 = - E.select - [ canva_events - ; tick_event - ; angle_event - ; width_event - ; delete_event - ; export_event ] - |> E.map State.do_action - |> Note.S.accum State.init 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 _ -> ()) (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 - - - (* Draw the canva for first time *) - on_change canva mouse_position State.init; - - (* Hold the state *) - let _ = Logr.hold (S.log state (fun _ -> ())) in - () + 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 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 tick_event = + S.sample_filter mouse_position + ~on:tick + (fun pos f -> Option.map (fun p -> `Point (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 = + E.select + [ worker_event + ; canva_events + ; tick_event + ; angle_event + ; width_event + ; delete_event + ; export_event + ; parameters.rendering + ] + |> E.map (State.do_action worker timer) + |> Note.S.accum State.init 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 _ -> ()) (S.changes parameters.angle) + ; E.map (fun _ -> ()) (S.changes parameters.width) + ; 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 + + + (* 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 + () end let () = - if Brr_webworkers.Worker.ami () then - () - else ( - let open Jv in - let drawer = obj - [| "run", (repr page_main) - |] in + let open Jv in + let drawer = obj + [| "run", (repr page_main) + |] in - set global "drawer" drawer - ) + set global "drawer" drawer diff --git a/script.it/state.ml b/script.it/state.ml index 5a1ef8f..cfde0b0 100755 --- a/script.it/state.ml +++ b/script.it/state.ml @@ -1,12 +1,8 @@ open StdLabels open Brr -let expected_host = Blog.Hash_host.expected_host - let backgroundColor = Blog.Nord.nord0 -let timer, tick = Elements.Timer.create () - type mode = | Edit | Selection of int @@ -22,10 +18,21 @@ type button_events = [ `Delete | `Export ] +type render_event = + [ + `Rendering of Layer.Paths.printer + ] + +type worker_event = + [ `Basic of Jv.t + | `Complete of (int * (Path.Fixed.path array)) + ] type events = [ canva_events | button_events + | render_event + | worker_event | `Point of float * (float * float) | `Width of float | `Angle of float @@ -41,12 +48,13 @@ type state = ; current : Path.Path_Builder.t ; width : float ; angle : float + ; rendering : Layer.Paths.printer } -let insert_or_replace state ((x, y) as p) path = +let insert_or_replace state ((x, y) as p) stamp path = let width = state.width and angle = state.angle in - let point = Path.Point.create ~x ~y ~angle ~width in + let point = Path.Point.create ~x ~y ~angle ~width ~stamp in match Path.Path_Builder.peek path with | None -> Path.Path_Builder.add_point @@ -97,14 +105,15 @@ let update_selection id state f = { state with paths } let do_action - : events -> state -> state - = fun event state -> + : Brr_webworkers.Worker.t -> Elements.Timer.t -> events -> state -> state + = fun worker timer event state -> match event, state.mode with - | `Point (_delay, point), Edit -> + | `Point (delay, point), Edit -> (* Add the point in the list *) let current = insert_or_replace state point + delay state.current in { state with current } @@ -115,16 +124,17 @@ let do_action let width = state.width and angle = state.angle in + let stamp = 0. in let point = match check_selection p state.paths with | None -> (* Start a new path with the point clicked *) - Path.Point.create ~x ~y ~angle ~width + Path.Point.create ~x ~y ~angle ~width ~stamp | 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 - Path.Point.create ~x ~y ~angle ~width + Path.Point.create ~x ~y ~angle ~width ~stamp in let current = Path.Path_Builder.add_point @@ -150,6 +160,7 @@ let do_action end | `Out point, Edit -> + let stamp = Elements.Timer.delay timer in Elements.Timer.stop timer; begin match Path.Path_Builder.peek2 state.current with (* If there is at last two points selected, handle this as a curve @@ -162,14 +173,20 @@ let do_action | Some (p, _) -> Gg.V2.to_tuple p in *) - let current = insert_or_replace state point state.current in + let current = insert_or_replace state point stamp state.current in let paths = let last = Path.Fixed.to_fixed (module Path.Path_Builder) current in + + let id = Path.Fixed.id last + and path = Path.Fixed.path last in + let () = Brr_webworkers.Worker.post worker (`Complete (id, path)) in last::state.paths and current = Path.Path_Builder.empty in + + { state with mode = Out ; paths; current } @@ -198,8 +215,7 @@ let do_action | `Export, _ -> let my_host = Uri.host @@ Window.location @@ G.window in - - if (Hashtbl.hash my_host) = expected_host then ( + if (Hashtbl.hash my_host) = Blog.Hash_host.expected_host then ( (* Convert the path into an sVG element *) let svg = Layer.Svg.svg ~at:Brr.At.[ @@ -208,11 +224,11 @@ let do_action (List.map state.paths ~f:(fun path -> - Path.to_svg + Layer.Paths.to_svg ~color:backgroundColor (module Path.Fixed) path - `Fill + state.rendering )) in let content = El.prop Elements.Prop.outerHTML svg in @@ -248,6 +264,26 @@ let do_action | `Delete, Out -> state + | `Rendering rendering, _ -> + { state with rendering} + + + | `Basic t, _ -> + Console.(log [t]); + state + + | `Complete (id, paths), _ -> + let paths = List.map state.paths + ~f:(fun path -> + let id' = Path.Fixed.id path in + match id = id' with + | false -> path + | true -> + Path.Fixed.update path paths + ) in + { state with paths } + + (* Some non possible cases *) | `Out _, Out | `Point _, Out @@ -263,4 +299,5 @@ let init = ; mode = Out ; angle = 30. ; width = 10. + ; rendering = `Fill } diff --git a/script.it/worker.ml b/script.it/worker.ml new file mode 100755 index 0000000..3150869 --- /dev/null +++ b/script.it/worker.ml @@ -0,0 +1,64 @@ +open StdLabels +open Js_of_ocaml + +type message = [ + | `Complete of (int * (Path.Fixed.path array)) +] + +exception Empty_Element + +let get_point + : Path.Fixed.path -> Gg.v2 + = function + | Empty -> raise Empty_Element + | Line (_, p1) -> Path.Point.get_coord p1 + | Curve bezier -> Path.Point.get_coord bezier.Path.Fixed.p1 + +let first_point + : Path.Fixed.path -> Gg.v2 + = function + | Empty -> raise Empty_Element + | Line (p0, _) -> Path.Point.get_coord p0 + | Curve bezier -> Path.Point.get_coord bezier.Path.Fixed.p0 + +let assoc_point + : Shapes.Bezier.t -> Path.Fixed.path -> Path.Fixed.path + = fun bezier -> function + | Empty -> raise Empty_Element + | Line (p0, p1) + | Curve {p0; p1; _} -> + let p0' = Path.Point.copy p0 bezier.Shapes.Bezier.p0 + and p1' = Path.Point.copy p1 bezier.Shapes.Bezier.p1 in + Curve + { Path.Fixed.p0 = p0' + ; Path.Fixed.p1 = p1' + ; Path.Fixed.ctrl0 = bezier.Shapes.Bezier.ctrl0 + ; Path.Fixed.ctrl1 = bezier.Shapes.Bezier.ctrl1 + } + +let execute (command: [> message]) = + match command with + | `Complete (id, paths) -> + (* Convert all the points in list *) + let points = List.init + ~len:((Array.length paths) ) + ~f:(fun i -> get_point (Array.get paths i)) in + let p0 = first_point (Array.get paths 0)in + + let points = p0::points in + + (* We process the whole curve in a single block *) + begin match Shapes.Bspline.to_bezier points with + | Error `InvalidPath -> () + | Ok beziers -> + + (* Now for each point, reassociate the same point information, + We should have as many points as before *) + let rebuilded = Array.map2 beziers paths ~f:assoc_point in + Worker.post_message (`Complete (id, rebuilded)) + end + | any -> + Worker.post_message (`Other any) + +let () = + Worker.set_onmessage execute |