Skip to content
GitLab
Commit 2612be73 authored by Benoit Barbot's avatar Benoit Barbot
Browse files

progress

parent a289ffab
Hide whitespace changes
Inline Side-by-side
editor/DrawingGeom.ml
View file @ 2612be73
......@@ -79,6 +79,11 @@ module Circle =
let (dmx,dmy) = rot (-.angle) (mouse_pos -.. (x,y)) in
(abs_float dmx) <= width && (abs_float dmy) <= height
let contain ((x,y),asym,radius,angle) (x2,y2) =
let w,h = (radius/.asym,radius) in
x2 >= x-.w && x2 <= x +.w
&& y2 >= y-.h && y2 <= y+.h
let contains ((x,y),asym,radius,angle) ptlist =
let w,h = (radius/.asym,radius) in
List.filter (fun ((x2,y2),_) ->
......
editor/graphDrawing.ml
View file @ 2612be73
......@@ -44,7 +44,11 @@ module GraphEditor (G: GRAPH ) = struct
let height = 2048
let increment = 5
type selectable_type = Node of G.node | Arc of G.arc | Area of G.node list
type selectable_type =
| Empty
| Node of G.node
| Arc of G.arc
| Area of DrawingGeom.Rectangle.t
type editor_state =
{ mutable zoom: float;
......@@ -60,7 +64,15 @@ module GraphEditor (G: GRAPH ) = struct
match G.shapes_of_node s.graph node with
t::_ -> center_shape t
| [] -> 0.0, 0.0
let node_in_rect s rect =
let nlist = ref [] in
G.iter_node s.graph (fun node -> nlist := node:: !nlist);
!nlist
|> List.map (fun node -> (center_of_node s node),node)
|> Rectangle.contains rect
let change_file (cb: string->unit) _ =
let id2 = Js.string "filein" in
let f s = cb (Js.to_string s) in
......@@ -148,7 +160,7 @@ module GraphEditor (G: GRAPH ) = struct
let draw s mouse_pos =
clean s;
clean s;
let found_node = ref false in
G.iter_node s.graph (fun obj ->
let shapes = G.shapes_of_node s.graph obj in
......@@ -156,7 +168,8 @@ module GraphEditor (G: GRAPH ) = struct
found_node := !found_node || over_node;
let node_selected = match s.selected_obj with
Node obj2 when obj=obj2 -> true
| Area l -> List.mem obj l
| Area r -> [] <> (DrawingGeom.Rectangle.contains r
[center_of_node s obj,()])
| _ -> false in
set_style s.ctx node_selected over_node;
List.iter (fun sh -> draw_shape (to_screen s) s.ctx sh) shapes);
......@@ -175,6 +188,8 @@ module GraphEditor (G: GRAPH ) = struct
| _ -> ())
)
let save_load_html s =
let loadfile st =
s.graph <- G.read_graph st;
......@@ -201,7 +216,7 @@ module GraphEditor (G: GRAPH ) = struct
ctx##.font := Js.string "15px Arial";
let s = {zoom=1.5;
origin= -50.0, -50.0;
selected_obj = Area [];
selected_obj = Empty;
graph=G.new_graph ();
canvas;
ctx;
......@@ -248,12 +263,12 @@ module GraphEditor (G: GRAPH ) = struct
stick_coord s ~exact (float (ev##.clientX - x0), float (ev##.clientY - y0))
let is_over_object s mouse_pos =
let obj = ref (Area []) in
let obj = ref Empty in
G.iter_node s.graph (fun o ->
let shapes = G.shapes_of_node s.graph o in
if is_over_shapes (to_screen s) mouse_pos shapes then obj:= Node o );
if !obj = (Area []) then
if !obj = Empty then
G.iter_arc s.graph (fun o ->
let shapes = shapes_of_arc s o in
if is_over_shapes (to_screen s) mouse_pos shapes then obj:= Arc o);
......@@ -270,22 +285,22 @@ let rec html_of_attr s attr nattr cb =
Node node -> let v2= G.update_node_attribute s.graph node id (Some nva) in
if v2 then
begin try ignore @@ G.get_node_attribute s.graph node with
_ -> s.selected_obj <- Area [];
_ -> s.selected_obj <- Empty;
update_attr s; end; v2
| Arc arc -> let v2= G.update_arc_attribute s.graph arc id (Some nva) in
if v2 then
begin try ignore @@ G.get_arc_attribute s.graph arc with
_ -> s.selected_obj <- Area [];
_ -> s.selected_obj <- Empty;
update_attr s;end; v2
| Area [] -> G.update_arc_attribute s.graph `Empty id (Some nva)
| Empty -> G.update_arc_attribute s.graph `Empty id (Some nva)
| Area _ -> false in
draw s (0.0,0.0); v in
let callback_supr id _ =
let _ = match s.selected_obj with
Node node -> G.update_node_attribute s.graph node id None
| Arc arc -> G.update_arc_attribute s.graph arc id None
| Area [] -> G.update_arc_attribute s.graph `Empty id None
| Empty -> G.update_arc_attribute s.graph `Empty id None
| Area _ -> false in
draw s (0.0,0.0); update_attr s; in
let attr_tr =
......@@ -329,7 +344,7 @@ let rec html_of_attr s attr nattr cb =
match s.selected_obj with
Node node -> G.get_node_attribute s.graph node
| Arc arc -> G.get_arc_attribute s.graph arc
| Area [] -> G.get_arc_attribute s.graph `Empty
| Empty -> G.get_arc_attribute s.graph `Empty
| Area _ -> "Selection",[]
in
......@@ -343,7 +358,7 @@ let rec html_of_attr s attr nattr cb =
let nattr = match s.selected_obj with
Node node -> G.get_new_node_attribute s.graph node
| Arc arc -> G.get_new_arc_attribute s.graph arc
| Area [] -> G.get_new_arc_attribute s.graph `Empty
| Empty -> G.get_new_arc_attribute s.graph `Empty
| Area _ -> [] in
let nsattr,_ = List.split nattr in
......@@ -362,14 +377,16 @@ let rec html_of_attr s attr nattr cb =
s.attribute_list
(Eliom_content.Html.To_dom.of_br (br ()));
if (match s.selected_obj with Area [] -> false | _ -> true ) then
if (match s.selected_obj with Empty -> false | _ -> true ) then
let suprcb _ =
begin match s.selected_obj with
Node node -> G.remove_node s.graph node
| Empty -> ()
| Node node -> G.remove_node s.graph node
| Arc arc -> G.remove_arc s.graph arc;
| Area l -> List.iter (fun node -> G.remove_node s.graph node) l
| Area r -> let l = node_in_rect s r in
List.iter (fun node -> G.remove_node s.graph node) l
end;
set_selected s (Area []) (0.0,0.0) in
set_selected s Empty (0.0,0.0) in
Dom.appendChild
s.attribute_list
(Eliom_content.Html.To_dom.of_button (button ~a:[a_style "float:right"; a_onclick suprcb] [pcdata "Delete"]))
......@@ -382,7 +399,7 @@ let rec html_of_attr s attr nattr cb =
let open Eliom_lib in
let open Lwt_js_events in
let osobj = ref (Area []) in
let osobj = ref Empty in
Lwt.async (fun () ->
Lwt.pick [
(* highlight element *)
......@@ -411,13 +428,13 @@ let rec html_of_attr s attr nattr cb =
| _ -> [] in
begin match s.selected_obj,sobj with
(Area (_::_ as l),Node n) when List.mem n l && ev##.shiftKey = Js._false -> ()
(Area r,Node n) when List.mem n (node_in_rect s r) && ev##.shiftKey = Js._false -> ()
| Arc a,_ when cp <>[] -> ()
| _ -> set_selected s sobj mouse_pos
end;
match s.selected_obj, ev##.shiftKey with
(* New node *)
| Area [] ,b when b=Js._true ->
| Empty ,b when b=Js._true ->
let nchoice = draw_choice s mouse_pos in
mouseup s.canvas >>= (
fun ev2 -> (
......@@ -428,8 +445,7 @@ let rec html_of_attr s attr nattr cb =
Lwt.return ()
))
(* Select area *)
| Area [] ,_ ->
let nlist = ref [] in
| Empty ,_ ->
Lwt.pick [
mouseup s.canvas >>= (fun ev ->
let mouse_pos = get_coord ~exact:true s ev in
......@@ -440,12 +456,7 @@ let rec html_of_attr s attr nattr cb =
let pos1 = from_screen s mouse_pos in
let pos2 = from_screen s mouse_pos2 in
let rect = Rectangle.of_border pos1 pos2 in
nlist := [];
G.iter_node s.graph (fun node -> nlist := node:: !nlist);
let nlist = !nlist
|> List.map (fun node -> (center_of_node s node),node)
|> Rectangle.contains rect in
s.selected_obj <- Area nlist;
s.selected_obj <- Area rect;
draw s mouse_pos2;
set_style s.ctx false true;
s.ctx##.fillStyle := Js.string "rgba(0, 0, 255, 0.3)";
......@@ -508,9 +519,22 @@ let rec html_of_attr s attr nattr cb =
end
(* Move several node*)
| Area ls, _ ->
| Area r, _ ->
let ls = node_in_rect s r in
let base_node = match sobj with
Node n -> n | _ ->List.hd ls in
let cpointlistref = ref [] in
let init_mouse = from_screen s mouse_pos in
G.iter_arc s.graph (fun arc ->
G.get_arc_attribute s.graph arc
|> snd
|> List.iter (function
(id,_,`ControlPoint p) when
DrawingGeom.Rectangle.contain r p ->
cpointlistref := (id,p-..init_mouse,arc):: !cpointlistref
| _ -> ())
);
Lwt.pick [
mouseup s.canvas >>= (fun ev ->
Lwt.return ());
......@@ -521,6 +545,8 @@ let rec html_of_attr s attr nattr cb =
List.iter (fun node ->
let pos2 = center_of_node s node in
G.move_node s.graph (pos2 +.. vect) node) ls;
List.iter (fun (id,p,arc) ->
ignore @@ G.update_arc_attribute s.graph arc id (Some (`ControlPoint (p+..pos1)))) !cpointlistref;
draw s mouse_pos;
Lwt.return ())
]
......
Supports Markdown
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