From 77544bdfad2af41514ec1435f706fee87ea2969e Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Mon, 7 Feb 2022 15:38:37 +0100 Subject: Added viz.js code --- viz.js/canvasTool.ml | 39 +++++++++++ viz.js/convert.ml | 155 +++++++++++++++++++++++++++++++++++++++++++ viz.js/dispatch.ml | 30 +++++++++ viz.js/dispatch.mli | 12 ++++ viz.js/dune | 37 +++++++++++ viz.js/index.html | 110 ++++++++++++++++++++++++++++++ viz.js/process/dune | 10 +++ viz.js/process/formatter.ml | 100 ++++++++++++++++++++++++++++ viz.js/process/process.ml | 29 ++++++++ viz.js/process/tab_Lexer.mll | 65 ++++++++++++++++++ viz.js/process/tools.ml | 26 ++++++++ viz.js/promise/dune | 7 ++ viz.js/promise/promise.ml | 66 ++++++++++++++++++ viz.js/promise/promise.mli | 56 ++++++++++++++++ viz.js/worker.ml | 18 +++++ 15 files changed, 760 insertions(+) create mode 100755 viz.js/canvasTool.ml create mode 100755 viz.js/convert.ml create mode 100755 viz.js/dispatch.ml create mode 100755 viz.js/dispatch.mli create mode 100755 viz.js/dune create mode 100755 viz.js/index.html create mode 100755 viz.js/process/dune create mode 100755 viz.js/process/formatter.ml create mode 100755 viz.js/process/process.ml create mode 100755 viz.js/process/tab_Lexer.mll create mode 100755 viz.js/process/tools.ml create mode 100755 viz.js/promise/dune create mode 100755 viz.js/promise/promise.ml create mode 100755 viz.js/promise/promise.mli create mode 100755 viz.js/worker.ml (limited to 'viz.js') diff --git a/viz.js/canvasTool.ml b/viz.js/canvasTool.ml new file mode 100755 index 0000000..1b21143 --- /dev/null +++ b/viz.js/canvasTool.ml @@ -0,0 +1,39 @@ +open Js_of_ocaml + +let (pixelRatio: int) = 2 * Js.Unsafe.get Dom_html.window (Js.string "devicePixelRatio") + +class type xmlSerializer = object + method serializeToString: Dom.element Js.t -> Js.js_string Js.t Js.meth +end + +let (xmlSerializer: xmlSerializer Js.t Js.constr) = Js.Unsafe.global##._XMLSerializer + +(* Extract an image from a svg element *) +let generate_png (svg_image : Dom_svg.svgElement Js.t) callback = begin + let image = Dom_html.createImg Dom_html.document in + + image##.onload := Dom_html.handler (fun _ev -> + + let canvas = Dom_html.createCanvas Dom_html.document in + let context = canvas##getContext Dom_html._2d_ in + let width = svg_image##.width##.baseVal##.value + and height = svg_image##.height##.baseVal##.value in + + image##.width := pixelRatio * (int_of_float width); + image##.height := pixelRatio * (int_of_float height); + + canvas##.width := pixelRatio * (int_of_float width); + canvas##.height := pixelRatio * (int_of_float height); + + context##drawImage_withSize image 0.0 0.0 ((float_of_int pixelRatio) *. width) ((float_of_int pixelRatio) *. height); + + callback @@ canvas##toDataURL_type (Js.string "image/png"); + Js._false + ); + + let xml = new%js xmlSerializer in + let svg_xml = xml##serializeToString (svg_image :> Dom.element Js.t) in + let svg_src = (Js.string "data:image/svg+xml;base64,")##concat (Dom_html.window##btoa (Js.unescape (Js.encodeURIComponent svg_xml))) in + image##.src := svg_src; + +end diff --git a/viz.js/convert.ml b/viz.js/convert.ml new file mode 100755 index 0000000..75c4fcd --- /dev/null +++ b/viz.js/convert.ml @@ -0,0 +1,155 @@ +open Js_of_ocaml +open Js_of_ocaml_lwt + +(** Event generated once the library has created the svg image *) +let (generated_svg_event:(Dom_svg.svgElement Js.t * Js.js_string Js.t) Dom.Event.typ) + = Dom_html.Event.make "generated_svg" + +(* Save the generated image *) +let on_result_png image = begin + let a = Dom_html.createA Dom_html.document in + a##.href := image##.src; + Js.Unsafe.set a (Js.string "download") (Js.string "output.png"); + Dom.appendChild Dom_html.document##.body a; + a##click; + Dom.removeChild Dom_html.document##.body a +end + +let on_result_svg + : Dom_html.element Js.t -> (Dom.node Js.t) -> unit + = fun svg_display image -> begin + let childNodes = svg_display##.childNodes in + for i = 0 to childNodes##.length do + Js.Opt.iter (childNodes##item i) (fun elem -> ignore @@ svg_display##removeChild elem) + done; + Dom.appendChild svg_display image; + () + end + +let download data (filename : Js.js_string Js.t) (mime: Js.js_string Js.t) + = Js.Unsafe.( + fun_call (js_expr "download") + [| inject data + ; inject filename + ; inject mime |]) + +(** Message send by the worker *) +type message = Process.t +type worker = (Js.js_string Js.t, message) Worker.worker Js.t + +let change_event (worker:worker) input _ev _ = begin + let text: Js.js_string Js.t = input##.value in + + (* Send the content to the worker *) + let () = worker##postMessage text in + Lwt.return_unit +end + +class type _Dom_parser = object + method parseFromString: Js.js_string Js.t -> Js.js_string Js.t -> Dom_html.document Js.t Js.meth +end + +let dom_parser = (Js.Unsafe.global##._DOMParser) +let dom_parser = new%js dom_parser + +let load () = + + (* The URL is be relative with the page location. If the worker is called + from diffenent location, it becomes mandatory to declare the URL as + absolute. *) + let (worker:worker) = Worker.create "/resources/viz.js/worker.js" in + + worker##.onmessage := Dom.handler (fun (event: message Worker.messageEvent Js.t) -> + let gv, image = event##.data in + let image = dom_parser##parseFromString image "image/svg+xml" in + let image = image##.documentElement in + + let _ = Dispatch.call generated_svg_event (image, gv) in + Js._true); + + let svg_display = Dom_html.getElementById_exn "svg" + and output_button = Dom_html.getElementById_exn "png_output" + and dot_button = Dom_html.getElementById_exn "dot_output" + and editor = Dom_html.getElementById_exn "editor" in + + ignore @@ Dispatch.register generated_svg_event (fun (image, input) -> + + on_result_svg svg_display (image :> Dom.node Js.t); + + (* Download the dot file *) + dot_button##.onclick := Dom_html.handler (fun _ev -> + let _ = download input (Js.string "output.dot") (Js.string "text/plain") in + Js._false + ); + + (* Convert the svg in png *) + output_button##.onclick := Dom_html.handler (fun _-> + (*download image*) + CanvasTool.generate_png image (fun image -> + let _ = download image (Js.string "output.png") (Js.string "text/plain") in + () + ); + Js._false + ); + ); + + Js.Opt.iter (Dom_html.CoerceTo.textarea editor) (fun input -> + Lwt_js_events.async (fun () -> (Lwt_js_events.limited_loop Lwt_js_events.change ~elapsed_time:0.1 editor (change_event worker input) )); + Lwt_js_events.async (fun () -> (Lwt_js_events.limited_loop Lwt_js_events.input ~elapsed_time:0.1 editor (change_event worker input) )); + (* Run the first generation *) + Lwt.ignore_result (change_event worker input () ()); + ); + + (** Handle the separation window *) + Option.iter + (fun button -> + let _ = Dom_events.listen button Dom_html.Event.click (fun _ _ -> + + let opt_window2 = Dom_html.window##open_ + (Js.string "") + (Js.string "_image") + Js.Opt.empty in + + Js.Opt.iter opt_window2 (fun window2 -> + + let callback + : Dom_svg.svgElement Js.t * Js.js_string Js.t -> unit + = fun (image, _gv) -> begin + let node2 = image##cloneNode Js._true in + let () = on_result_svg window2##.document##.body + (node2 :> Dom.node Js.t) in + () + end in + let handler = Dispatch.register generated_svg_event callback in + + (* Remove the update event when the window is closed *) + window2##.onunload := Dom_html.handler (fun _ev -> + Dispatch.remove generated_svg_event handler; + Js._false + ); + + (* Copy the current display to the new window *) + let childNodes = svg_display##.childNodes in + for i = 0 to childNodes##.length do + Js.Opt.iter + (childNodes##item i) + (fun elem -> + Dom.appendChild window2##.document##.body (elem##cloneNode Js._true) + ) + done; + ); + + false + ) in + () + ) + (Dom_html.getElementById_opt "btn_window"); + Lwt.return Js._false + +let _ = Lwt.bind (Lwt_js_events.onload ()) (fun _ -> load()) + +let _ = + Js.export "generator" + (object%js + method load = load () + end) diff --git a/viz.js/dispatch.ml b/viz.js/dispatch.ml new file mode 100755 index 0000000..42f7dc8 --- /dev/null +++ b/viz.js/dispatch.ml @@ -0,0 +1,30 @@ +open Js_of_ocaml + +type event_container = + E : 'a Dom.Event.typ * ('a -> unit) -> event_container + +type event_key = K : 'a Dom.Event.typ -> event_key + +type t = event_container + +let (catalog:event_container list ref) = ref [] + +let register: type a. a Dom.Event.typ -> (a -> unit) -> t = + begin fun event callback -> + let handler = E (event, callback) in + catalog := handler::!catalog; + handler + end + +let remove: type a. a Dom.Event.typ -> t -> unit = + begin fun _event callback -> + catalog := List.filter (fun reg -> reg != callback) !catalog; + end + +let call: type a. a Dom.Event.typ -> a -> unit = + begin fun event value -> + List.iter (fun (E (registered_event, callback)) -> + if K event = K registered_event then + callback (Obj.magic value) + ) !catalog + end diff --git a/viz.js/dispatch.mli b/viz.js/dispatch.mli new file mode 100755 index 0000000..8d8999b --- /dev/null +++ b/viz.js/dispatch.mli @@ -0,0 +1,12 @@ +open Js_of_ocaml + +type t + +(** Register a new function with the given event *) +val register: 'a Dom.Event.typ -> ('a -> unit) -> t + +(* Remove the handler for the event *) +val remove: 'a Dom.Event.typ -> t -> unit + +(* Call the event *) +val call: 'a Dom.Event.typ -> 'a -> unit diff --git a/viz.js/dune b/viz.js/dune new file mode 100755 index 0000000..d6eba67 --- /dev/null +++ b/viz.js/dune @@ -0,0 +1,37 @@ +(executable + (name convert) + (libraries + js_of_ocaml + js_of_ocaml-lwt + promise + process + ) + (modes js) + (preprocess (pps js_of_ocaml-ppx)) + (link_flags (:standard -no-check-prims)) + (modules convert dispatch CanvasTool) + ) + +(rule + (targets convert.js) + (deps convert.bc.js) + (action (copy %{deps} %{targets}))) + +(executable + (name worker) + (libraries + js_of_ocaml + js_of_ocaml-lwt + promise + process + ) + (modes js) + (preprocess (pps js_of_ocaml-ppx)) + (link_flags (:standard -no-check-prims)) + (modules worker) + ) + +(rule + (targets worker.js) + (deps worker.bc.js) + (action (copy %{deps} %{targets}))) diff --git a/viz.js/index.html b/viz.js/index.html new file mode 100755 index 0000000..abb158c --- /dev/null +++ b/viz.js/index.html @@ -0,0 +1,110 @@ + + + + + Graph editor + + + + +
+
+ +
+
+ + + +
+
+
+
+
+ + + + + + diff --git a/viz.js/process/dune b/viz.js/process/dune new file mode 100755 index 0000000..fba62e8 --- /dev/null +++ b/viz.js/process/dune @@ -0,0 +1,10 @@ +(ocamllex tab_Lexer) + +(library + (name process) + (libraries + js_of_ocaml + promise + ) + (preprocess (pps js_of_ocaml-ppx)) + ) diff --git a/viz.js/process/formatter.ml b/viz.js/process/formatter.ml new file mode 100755 index 0000000..e6a8a0e --- /dev/null +++ b/viz.js/process/formatter.ml @@ -0,0 +1,100 @@ +open Js_of_ocaml + +module T = Tools + +let leftright = false + +module Printer = struct + + type t = Js.js_string Js.t + + let inject = Js.string + + let print2 t t1 t2 = t##concat_2 t1 t2 + let print4 t t1 t2 t3 t4 = t##concat_4 t1 t2 t3 t4 + let print5 t t1 t2 t3 t4 t5 = (t##concat t1)##concat_4 t2 t3 t4 t5 + let print10 t t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 = + ((t##concat_4 t1 t2 t3 t4)##concat_3 t5 t6 t7)##concat_3 t8 t9 t10 + +end + +let print_arrow = begin function + | Tab_Lexer.Backward -> Printer.inject "back" + | Tab_Lexer.Both -> Printer.inject "both" + | Tab_Lexer.None -> Printer.inject "none" + | Tab_Lexer.Forward -> Printer.inject "forward" +end + +let rec print_links (acc:Js.js_string Js.t) = begin function + | [] -> acc + | (current_name, level, target, comment, arrow)::tl -> + let acc' = Printer.print10 acc + (current_name) + (Printer.inject ":") + (Printer.inject @@ string_of_int level) + (Printer.inject " -> ") + target + (Printer.inject "[label=\"") + comment + (Printer.inject "\" dir=\"") + (print_arrow arrow) + (Printer.inject "\" ]\n") in + print_links acc' tl +end + +let shape = (Printer.inject "[label=<") + +let rec parse lexbuf acc current_name level links = begin + try + begin match Tab_Lexer.parse_line lexbuf with + | Root content -> + let acc' = Printer.print2 acc + content + shape + in + parse lexbuf acc' content 0 links + | Entry (content, target) -> + let level' = level + 1 in + let acc' = (acc##concat_4 + (Js.string "") + in + let links' = begin match target with + | None -> links + | Some (target, comment, arrow) -> (current_name, level', target, comment, arrow)::links + end in + parse lexbuf acc' current_name level' links' + | Redirection (target, comment, arrow) -> + let links' = (current_name, level, target, comment, arrow)::links in + parse lexbuf acc current_name level links' + | NewLine -> + let acc' = + if (level >= 0) then ( + print_links (acc##concat (Js.string "
") + content + )##concat + (Js.string "
>];\n")) links; + ) else ( + acc + ) in + parse lexbuf acc' (Js.string "") (-1) [] + | Separator -> + let text = "" in + parse lexbuf (acc##concat (Js.string text)) current_name level links + end + with Tab_Lexer.Eof -> + if (level >= 0) then ( + let text = Js.string ">];\n" in + print_links (acc##concat text) links; + ) else + acc +end + +let convert source = begin + + let text = (Js.string "digraph G {rankdir=LR;node [shape=plaintext];") in + (* Content *) + let lexbuf = Lexing.from_string (Js.to_string (source##concat (Js.string "\r\n"))) in + (parse lexbuf text (Js.string "") 0 [])##concat (Js.string "}") +end diff --git a/viz.js/process/process.ml b/viz.js/process/process.ml new file mode 100755 index 0000000..ef23b78 --- /dev/null +++ b/viz.js/process/process.ml @@ -0,0 +1,29 @@ +open Js_of_ocaml + +class type viz = object + (* PNG output *) + method renderImageElement: Js.js_string Js.t -> (Dom_html.imageElement Js.t, unit) Promise.promise Js.meth + (* SVG output *) + method renderSVGElement: Js.js_string Js.t -> (Dom_svg.svgElement Js.t, unit) Promise.promise Js.meth + + method renderString: Js.js_string Js.t -> (Js.js_string Js.t, unit) Promise.promise Js.meth +end + +type t = Js.js_string Js.t * Js.js_string Js.t + +let do_action + : viz Js.t -> Js.js_string Js.t -> (unit, unit) Promise.promise + = fun v text -> + + if text##.length != 0 then ( + let gv = Formatter.convert text in + let promise = + (try v##renderString gv + with _ -> Promise.reject () + ) in + Promise.then_map + ~on_fulfilled:(fun svg -> Worker.post_message ((gv, svg):t)) + ~on_rejected:(fun _ -> ()) + promise + ) else + Promise.reject () diff --git a/viz.js/process/tab_Lexer.mll b/viz.js/process/tab_Lexer.mll new file mode 100755 index 0000000..67793e4 --- /dev/null +++ b/viz.js/process/tab_Lexer.mll @@ -0,0 +1,65 @@ +{ + open Js_of_ocaml + exception SyntaxError of string * Lexing.lexbuf + exception Eof + + type arrow = + | Forward + | Backward + | Both + | None + + type jstring = Js.js_string Js.t + + type res = + | NewLine + | Root of jstring + | Entry of jstring * (jstring * jstring * arrow) option + | Redirection of jstring * jstring * arrow + | Separator + + let get_arrow = begin function + | "<-" -> Backward + | "<->" -> Both + | "--" -> None + | _ -> Forward + end + +} + +let space = ['\000' '\t' '\x0C' ' '] +let spaces = space* +let newline = spaces ("\r\n" | '\n' | '\r')+ + +(* Any character except the delimiters and spaces *) +let regular = [^ '\n' '\x0C' '\r' ] +let target_id = ['A'-'Z' 'a'-'z' '0'-'9']+ (':' ['0'-'9']+)? + +let arrow = "->" | "--" | "<-" | "<->" + +rule parse_line = shortest + | eof { raise Eof } + + | newline {NewLine} + + | space+ '-'+ newline {Separator} + + | (target_id as _1) newline { Root (Js.string _1) } + + | (spaces as _1) + (arrow as _arrow) space+ + (target_id as _target) spaces + (regular* as comment) newline + { Redirection ( Js.string _target, Js.string comment, (get_arrow _arrow))} + + | spaces + (regular+ as _2) space+ + (arrow as _arrow) space+ + (target_id as _target) spaces + (regular* as comment) newline + { Entry (Js.string _2, Some (Js.string _target, Js.string comment, (get_arrow _arrow)))} + + | (space+ as _1) + (regular+ as _2) newline + { Entry (Js.string _2, None) } + diff --git a/viz.js/process/tools.ml b/viz.js/process/tools.ml new file mode 100755 index 0000000..c5e39b1 --- /dev/null +++ b/viz.js/process/tools.ml @@ -0,0 +1,26 @@ +let drop_while predicate = + let rec _drop = function + | [] -> [] + | (hd::tl) as l -> + if predicate hd then + _drop tl + else + l + in _drop + +(* Split a text and and new line before it goes to long *) +let split limit = + let rec _split elms text = + let length = (String.length text) -1 in + if (length < limit) then + List.rev (text::elms) + |> String.concat "\\n" + else + try + let pos = String.rindex_from text limit ' ' in + let hd = String.sub text 0 pos + and tl = String.sub text (pos +1) (length - pos) in + _split (hd::elms) tl + with Not_found -> text + in _split [] + diff --git a/viz.js/promise/dune b/viz.js/promise/dune new file mode 100755 index 0000000..e1ae25f --- /dev/null +++ b/viz.js/promise/dune @@ -0,0 +1,7 @@ +(library + (name promise) + (libraries + js_of_ocaml + ) + (preprocess (pps js_of_ocaml-ppx)) + ) diff --git a/viz.js/promise/promise.ml b/viz.js/promise/promise.ml new file mode 100755 index 0000000..f9f7e53 --- /dev/null +++ b/viz.js/promise/promise.ml @@ -0,0 +1,66 @@ +open Js_of_ocaml + +type ('a, 'b) promise + +type 'a resolve = 'a -> unit + +type 'a reject = 'a -> unit + +let promise_global = Js.Unsafe.global##._Promise + +let is_supported () = Js.Optdef.test promise_global + +let make f = + Js.Unsafe.new_obj promise_global [|Js.Unsafe.inject f|] + +let resolve value = + Js.Unsafe.fun_call promise_global##.resolve [|Js.Unsafe.inject value|] + +let reject value = + Js.Unsafe.fun_call promise_global##.reject [|Js.Unsafe.inject value|] + +let js_of_opt = function + | Some value -> Js.Unsafe.inject value + | None -> Js.Unsafe.inject Js.undefined + +let then_bind ~on_fulfilled ?on_rejected promise = + Js.Unsafe.meth_call promise "then" + [|Js.Unsafe.inject on_fulfilled; js_of_opt on_rejected|] + +let then_map ~on_fulfilled ?on_rejected promise = + Js.Unsafe.meth_call promise "then" + [|Js.Unsafe.inject on_fulfilled; js_of_opt on_rejected|] + +let catch_bind ~on_rejected promise = + Js.Unsafe.meth_call promise "catch" [|Js.Unsafe.inject on_rejected|] + +let catch_map ~on_rejected promise = + Js.Unsafe.meth_call promise "catch" [|Js.Unsafe.inject on_rejected|] + +let then_final ~on_fulfilled ~on_rejected promise = + Js.Unsafe.meth_call promise "then" + [|Js.Unsafe.inject on_fulfilled; Js.Unsafe.inject on_rejected|] + +let all promises = + let intermediate_promise = + Js.Unsafe.fun_call promise_global##.all + [|Js.Unsafe.inject (Js.array promises)|] + in + then_map + ~on_fulfilled:(fun js_array -> Js.to_array js_array) intermediate_promise + +let race promises = + Js.Unsafe.fun_call promise_global##.race + [|Js.Unsafe.inject (Js.array promises)|] + +module Infix = struct + let (>>=) promise on_fulfilled = then_bind ~on_fulfilled promise + let (>|=) promise on_fulfilled = then_map ~on_fulfilled promise + + let (>>~) promise on_rejected = catch_bind ~on_rejected promise + let (>|~) promise on_rejected = catch_map ~on_rejected promise + + let (>||) promise (on_fulfilled, on_rejected) = + then_final ~on_fulfilled ~on_rejected promise +end + diff --git a/viz.js/promise/promise.mli b/viz.js/promise/promise.mli new file mode 100755 index 0000000..26831c4 --- /dev/null +++ b/viz.js/promise/promise.mli @@ -0,0 +1,56 @@ +type ('a, 'b) promise + +type 'a resolve = 'a -> unit + +type 'a reject = 'a -> unit + +val is_supported : unit -> bool + +val make : ('a resolve -> 'b reject -> unit) -> ('a, 'b) promise + +val resolve : 'a -> ('a, 'b) promise + +val reject : 'b -> ('a, 'b) promise + +val then_bind : + on_fulfilled:('a -> ('c ,'b) promise) -> + ?on_rejected:('b -> ('c, 'b) promise) -> + ('a, 'b) promise -> + ('c, 'b) promise + +val then_map : + on_fulfilled:('a -> 'c) -> + ?on_rejected:('b -> 'd) -> + ('a, 'b) promise -> + ('c, 'd) promise + +val catch_bind : + on_rejected:('b -> ('a, 'b) promise) -> + ('a, 'b) promise -> + ('a, 'b) promise + +val catch_map : + on_rejected:('b -> 'a) -> + ('a, 'b) promise -> + ('a, 'b) promise + +val then_final : + on_fulfilled:('a -> unit) -> + on_rejected:('b -> unit) -> + ('a, 'b) promise -> + unit + +val all : (('a, 'b) promise) array -> ('a array, 'b) promise + +val race : (('a, 'b) promise) array -> ('a, 'b) promise + +module Infix : sig + val (>>=) : ('a, 'b) promise -> ('a -> ('c ,'b) promise) -> ('c, 'b) promise + val (>|=) : ('a, 'b) promise -> ('a -> 'c) -> ('c, 'b) promise + + val (>>~) : ('a, 'b) promise -> ('b -> ('a, 'b) promise) -> ('a, 'b) promise + val (>|~) : ('a, 'b) promise -> ('b -> 'a) -> ('a, 'b) promise + + val (>||) : ('a, 'b) promise -> ('a -> unit) * ('b -> unit) -> unit +end + diff --git a/viz.js/worker.ml b/viz.js/worker.ml new file mode 100755 index 0000000..c6ed6f5 --- /dev/null +++ b/viz.js/worker.ml @@ -0,0 +1,18 @@ +open Js_of_ocaml + +let () = + Worker.import_scripts + [ "viz.js" + ; "full.render.js" + ] + +let () = Worker.set_onmessage (fun content -> + let (viz: Process.viz Js.t Js.constr) + = Js.Unsafe.global##._Viz in + + let _ = Process.do_action (new%js viz) content in + () + + + ) + -- cgit v1.2.3