Commit e1bd38bd authored by Bruno Guillaume's avatar Bruno Guillaume Committed by Bruno Guillaume

on-going new version of rew_display

parent fe182a1d
......@@ -9,7 +9,7 @@ VERSION = `cat VERSION`
all: native
native: src/grew_glade.ml datadir
native: src/grew_glade.ml src/new_glade.ml datadir
$(OCB) -tag-line "true: package(libgrew)" grew_main.native
datadir:
......@@ -18,7 +18,7 @@ datadir:
install:
cp grew_main.native $(BINDIR)/grew
mkdir -p $(DATA_DIR)
cp src/grew.glade $(DATA_DIR)
cp src/*.glade $(DATA_DIR)
uninstall:
rm -f $(BINDIR)/grew
......@@ -29,7 +29,7 @@ uninstall:
clean:
$(OCB) -clean
rm -f DATA_DIR
rm -f src/grew_glade.ml
rm -f src/*_glade.ml
info:
@echo "BINDIR = $(BINDIR)"
......@@ -40,3 +40,10 @@ src/grew_glade.ml : src/grew.glade
lablgladecc2 $< > $@
sed -iback 's|src/grew.glade|$(DATA_DIR)grew.glade|g' src/grew_glade.ml
rm -f src/grew_glade.mlback
# glade file are not handle by ocamlbuild
src/new_glade.ml : src/new.glade
lablgladecc2 $< > $@
sed -iback 's|src/new.glade|$(DATA_DIR)new.glade|g' src/new_glade.ml
rm -f src/new_glade.mlback
......@@ -14,7 +14,7 @@ open Libgrew
module Grew_args = struct
type mode = Gui | Corpus | Filter | Det | Full | Grep
type mode = Gui | Corpus | Filter | Det | Full | Grep | Test
let mode = ref Gui
type html_mode =
......@@ -60,6 +60,7 @@ module Grew_args = struct
"-det", Unit (fun () -> mode := Det), " enable det mode: rewrite a corpus with a deterministric grs";
"-full", Unit (fun () -> mode := Full), " enable full mode: rewrite a corpus (conll output)";
"-filter", Unit (fun () -> mode := Filter), " enable filter mode";
"-test", Unit (fun () -> mode := Test), " Undocumented";
"-grep", Unit (fun () -> mode := Grep), " enable grep mode\n\nOptions for all modes";
"-grs", String (fun s -> grs := absolute s), "<grs_file> chose the grs file to load";
......
......@@ -645,14 +645,20 @@ let init () =
grew_window#vpane_right#set_position 30;
true
| ["showOnBottom2"; graph] ->
printf "...> 1\n%!";
(try
let svg_file =
if grew_window#btn_gr_bottom_dot#active
then (Grew_rew_display.get_dot_graph_with_background ?domain
~main_feat:(!Grew_config.current_config.Grew_config.main_feat) ~botop:(true,false) graph)
else (Grew_rew_display.get_dep_graph_with_background ?domain ~filter:(get_current_filter ())
~main_feat:(!Grew_config.current_config.Grew_config.main_feat) ~botop:(true,false) graph) in
printf "...> 2\n%!";
graph_bottom_webkit#load_uri ("file://"^svg_file);
printf "...> 3\n%!";
Grew_rew_display.current_bottom_graph := graph;
printf "...> 4\n%!";
with exc -> printf "--->%s<----\n%!" (Printexc.to_string exc); show_error "XXX");
true
| ["showOnTop2"; graph] ->
let svg_file = if grew_window#btn_gr_top_dot#active
......
......@@ -30,3 +30,5 @@ let _ =
| Grew_args.Full -> Grew_corpus.full ()
| Grew_args.Filter -> Grew_corpus.multi_conll ()
| Grew_args.Grep -> Grew_corpus.grep ()
| Grew_args.Test -> Grew_test.init ()
This diff is collapsed.
open Printf
open GMain
open New_glade
(* ==================================================================================================== *)
module Svg = struct
type t = Buffer.t
let init ~width ~height =
let t = Buffer.create 32 in
bprintf t "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>\n";
bprintf t "<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\" \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">\n";
bprintf t
"<svg width=\"%d\" height=\"%d\" xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\">\n"
width height;
bprintf t "<style type=\"text/css\">\n";
bprintf t "<![CDATA[\n";
bprintf t ".graph {\n";
bprintf t " stroke: #000;\n";
bprintf t " fill: #fff;\n";
bprintf t " stroke-width: 1.5;\n";
bprintf t "}\n";
bprintf t ".graph:hover {\n";
bprintf t " fill: #fc0;\n";
bprintf t "}\n";
bprintf t "path {\n";
bprintf t " fill: none;\n";
bprintf t " stroke: #000;\n";
bprintf t " stroke-width: 1;\n";
bprintf t "}\n";
bprintf t ".rule {\n";
bprintf t " stroke: #000000;\n";
bprintf t " fill: #b8d7ef;\n";
bprintf t " stroke-width: 1.5;\n";
bprintf t "}\n";
bprintf t ".g-rule {\n";
bprintf t " opacity: 0.55;\n";
bprintf t "}\n";
bprintf t ".g-rule:hover {\n";
bprintf t " opacity: 1;\n";
bprintf t "}\n";
bprintf t "]]>\n";
bprintf t "</style>\n";
t
let close t =
bprintf t "</svg>\n";
Buffer.contents t
let path d t =
bprintf t "<path d=\"%s\"/>\n" d;
t
let graph ~x ~y t =
bprintf t "<circle cx=\"%d\" cy=\"%d\" r=\"6\" class=\"graph\" cursor=\"pointer\"/>\n" x y;
t
let rule_height = 20
let rule ~alert ~text ~x ~y ~w t =
bprintf t "<g class=\"g-rule\" onclick=\"alert('%s')\" cursor=\"pointer\">\n" alert;
bprintf t " <rect class=\"rule\" x=\"%d\" y=\"%d\" rx=\"%d\" width=\"%d\" height=\"%d\" />\n" x (y-(rule_height/2)) (rule_height/2) w rule_height;
bprintf t " <text text-anchor=\"middle\" font-size=\"14px\" x=\"%d\" y=\"%d\">%s</text>\n" (x + w/2) (y+rule_height/2-5) text;
bprintf t "</g>\n";
t
end
(* ==================================================================================================== *)
let left_delta = 30
let right_delta = 30
let margin = 10
let v_delta = 30
type t = T of (int * t) list;;
let rec maxlist = function
| [], l | l, [] -> l
| (x::t, y::u) -> (max x y)::(maxlist (t,u))
let rec tree_width = function
| T [] -> 1
| T sons -> List.fold_left (fun acc (_,son) -> acc + (tree_width son)) 0 sons
let rec get_depths = function
| T [] -> []
| T ((i,t) :: tail) -> maxlist ((i::get_depths t),(get_depths (T tail)))
let x_pos_right_most depths =
let right_most = ref 0 in
let rec loop pos = function
| [] -> right_most := pos; [pos]
| w::t -> pos :: loop (pos + w + left_delta + right_delta) t in
let res = loop margin depths in
(res, !right_most)
let build_svg t =
let depths = get_depths t in
let (x_pos, right_most) = x_pos_right_most depths in
let width = right_most + margin in
let height = v_delta * ((tree_width t) - 1) + Svg.rule_height + margin*2 in
let rec loop (svg, y) = function
| (T [], x::_) -> (Svg.graph ~x ~y:y svg, y, y + v_delta)
| (T sons, x :: x' :: tail_x_pos) ->
(* draw sons *)
let (new_svg, y_list, new_y) =
List.fold_left
(fun (svg, y_tail, y) (_,son) ->
let (svg', y_son, next_y) = loop (svg, y) (son, x' :: tail_x_pos) in
(svg', y_son::y_tail, next_y)
)
(svg, [], y) sons in
(* compute the current y position *)
let y_middle = (y + new_y - v_delta) / 2 in
let svg2 =
List.fold_left2
(fun acc_svg (w,_) y ->
let delta = (x' - x - left_delta - right_delta - w) / 2 in
acc_svg
|> (Svg.path (sprintf "M%d,%d L%d,%d L%d,%d" x y_middle (x+left_delta/2) y (x+left_delta+delta) y))
|> (Svg.path (sprintf "M%d,%d L%d,%d" (x'-right_delta-delta) y x' y))
|> (Svg.rule ~alert:"A" ~text:"Rule" ~x:(x+left_delta+delta) ~y ~w)
|> (Svg.graph ~x:x' ~y)
)
new_svg sons (List.rev y_list) in
(svg2, y_middle, new_y)
| _ -> failwith "Bug in build_svg" in
let (final_svg,y,_) = loop (Svg.init ~width ~height, margin + Svg.rule_height/2) (t, x_pos) in
final_svg
|> (Svg.graph ~x:margin ~y)
|> Svg.close
let u = T [ (50, T [ (150, T []); (500, T []);(150, T []); (200, T []);(150, T [ (50, T [ (150, T []); (500, T []);(150, T []); (200, T []);(150, T []); (200, T []) ]); (100,T [ (250,T []); (150,T [(100,T [])]) ]) ]); (200, T []) ]); (100,T [ (250,T []); (150,T [(100,T [])]) ]) ]
let depths = get_depths u
let (x_pos, right_most) = x_pos_right_most depths
;;
let svg = build_svg u
(* let svg =
(Svg.init ~width: 400 ~height: 200)
|> (Svg.path "M50,90 L65,60 L80,60")
|> (Svg.path "M50,90 L65,90 L80,90")
|> (Svg.path "M50,90 L65,120 L80,120")
|> (Svg.graph ~x:50 ~y:90)
|> (Svg.rule ~alert:"A" ~text:"Rule_A" ~x:80 ~y:50 ~w:100)
|> (Svg.rule ~alert:"B" ~text:"Rule_B" ~x:80 ~y:80 ~w:100)
|> (Svg.rule ~alert:"C" ~text:"Rule_C" ~x:80 ~y:110 ~w:100)
|> (Svg.path "M180,60 l30,0")
|> (Svg.graph ~x:210 ~y:60)
|> (Svg.path "M180,90 l30,0")
|> (Svg.graph ~x:210 ~y:90)
|> (Svg.path "M180,120 l30,0")
|> (Svg.graph ~x:210 ~y:120)
|> Svg.close
*)
let html_msg msg = sprintf "<html><body><font color=blue fontname=Arial>%s</font></body></html>\n" msg
let init () =
let _ = GMain.Main.init () in
let window = new window1 () in
let top_webkit = GWebView.web_view ~packing:window#vbox11#add () in
top_webkit#set_full_content_zoom true;
top_webkit#set_custom_encoding "UTF-8";
let bottom_webkit = GWebView.web_view ~packing:window#vbox11#add () in
bottom_webkit#set_full_content_zoom true;
bottom_webkit#set_custom_encoding "UTF-8";
(* let svg = load "/Users/guillaum/code/svg/s1.svg" in
*) let _ = top_webkit#load_html_string svg "" in
let empty_html = "<html><body><font color=red fontname=Arial>Nothing to display</font></body></html>" in
let _ = bottom_webkit#load_html_string empty_html "" in
let _ = top_webkit#connect#script_alert
~callback:
(fun _ msg ->
bottom_webkit#load_html_string (html_msg msg) "";
true
) in
let _ = window#toplevel#connect#destroy ~callback:(GMain.quit) in
(* Really start the gui *)
window#check_widgets ();
window#toplevel#show ();
GMain.Main.main ()
......@@ -65,6 +65,18 @@ module File = struct
done; assert false
with End_of_file -> close_in in_ch; List.rev !res
let load file =
let ch = open_in file in
let buff = Buffer.create 32 in
try
while true do
let next = input_line ch in
Printf.bprintf buff "%s\n" next
done; assert false
with End_of_file ->
close_in ch;
Buffer.contents buff
exception Found of int
let get_suffix file_name =
let len = String.length file_name in
......
<?xml version="1.0" encoding="UTF-8"?>
<glade-interface>
<!-- interface-requires gtk+ 2.16 -->
<!-- interface-naming-policy project-wide -->
<widget class="GtkWindow" id="window1">
<property name="can_focus">False</property>
<child>
<widget class="GtkVBox" id="vbox11">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<widget class="GtkHBox" id="hbox1">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<widget class="GtkButton" id="button1">
<property name="label" translatable="yes">button</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<placeholder/>
</child>
<child>
<placeholder/>
</child>
</widget>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<placeholder/>
</child>
<child>
<placeholder/>
</child>
</widget>
</child>
</widget>
</glade-interface>
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment