Commit 4f48bb2c authored by Benoit Barbot's avatar Benoit Barbot
Browse files

working exchange string

parent b0b2e720
Pipeline #885 failed with stage
in 14 seconds
......@@ -104,9 +104,9 @@ module S (P:PREGRAPH) =
let _,(n1,_) = Data.acca graph.state n1i
and _,(n2,_) = Data.acca graph.state n2i in
match P.init_arc !n1 !n2 with
Some a -> Data.add ((),(ref a,n1i,n2i)) graph.arc; true
| None -> false end
| _ -> false
Some a -> Some (`Arc (Data.addk ((),(ref a,n1i,n2i)) graph.arc))
| None -> None end
| _ -> None
let nodes_of_arc graph = function
`Empty -> (`Empty,`Empty)
| `Arc (k) ->
......
......@@ -23,7 +23,7 @@ module type GRAPH = sig
val iter_arc : graph -> (arc -> unit) -> unit
val shapes_of_arc : graph -> DrawingGeom.shape -> DrawingGeom.shape -> arc ->
(DrawingGeom.shape list)
val new_arc : graph -> node -> node -> bool
val new_arc : graph -> node -> node -> arc option
val update_arc_attribute : graph -> arc -> attribute_id -> attribute option -> bool
val get_new_arc_attribute : graph -> arc -> (string * (unit -> attribute_id)) list
val get_arc_attribute : graph -> arc -> string*( (attribute_id*string *attribute) list)
......@@ -211,9 +211,17 @@ module GraphEditor (G: GRAPH ) = struct
Buffer.add_char buff 'A';
buff_int buff (Hashtbl.find map n1);
buff_int buff (Hashtbl.find map n2);
let attr = snd @@ G.get_arc_attribute graph arc in
buff_list buff write_attribute attr
);
Bytes.to_string @@ Buffer.to_bytes buff
let rec find_and_remove x = function
[] -> None,[]
| (tx,ty)::q when tx=x -> (Some ty),q
| t::q -> let v,q2 = find_and_remove x q in
v,t::q2
let parse_exchange_string str =
let open GenericSerializer in
......@@ -231,32 +239,76 @@ module GraphEditor (G: GRAPH ) = struct
Hashtbl.add map !i node;
incr i;
pos := !pos+8;
let npos,attr = list_buff str read_attribute !pos in
let npos,attrl = list_buff str read_attribute !pos in
let _,cattr = G.get_node_attribute graph node in
let nattrl = G.get_new_node_attribute graph node in
let attrl2 = List.fold_left (fun l (id,name,_) ->
let found,nl = find_and_remove name attrl in
begin match found with
Some v -> if not (G.update_node_attribute graph node id (Some v)) then
print_endline ("Fail to update default attribute:"^str)
| None -> ()
end;
nl) attrl cattr in
List.iter (fun (str,attr) ->
match List.assoc_opt str nattrl with
None -> print_endline ("Fail to create attribute:"^str)
| Some f -> let nat = f () in
if not (G.update_node_attribute graph node nat (Some attr)) then
print_endline ("Fail to update attribute:"^str)
) attrl2;
pos := npos
done;
while !pos+7 <= length && str.[!pos] = 'A' do
let n1 = Hashtbl.find map (int_buff str (!pos+1)) in
let n2 = Hashtbl.find map (int_buff str (!pos+4)) in
let arc = G.new_arc graph n1 n2 in
pos := !pos+7;
let npos,attrl = list_buff str read_attribute !pos in
pos := npos;
match G.new_arc graph n1 n2 with
None -> print_endline "Fail to add arc"
| Some arc -> begin
let _,cattr = G.get_arc_attribute graph arc in
let nattrl = G.get_new_arc_attribute graph arc in
let attrl2 = List.fold_left (fun l (id,name,_) ->
let found,nl = find_and_remove name attrl in
begin match found with
Some v -> if not (G.update_arc_attribute graph arc id (Some v)) then
print_endline ("Fail to update default attribute:"^str)
| None -> ()
end;
nl) attrl cattr in
List.iter (fun (str,attr) ->
match List.assoc_opt str nattrl with
None -> print_endline ("Fail to create attribute:"^str)
| Some f -> let nat = f () in
if not (G.update_arc_attribute graph arc nat (Some attr)) then
print_endline ("Fail to update attribute:"^str)
) attrl2;
end
done;
graph
let save_load_html s =
let loadfile st =
(*s.graph <- G.read_graph st;*)
s.graph <- parse_exchange_string st;
s.graph <- if String.sub st 0 3 = "GEX" then parse_exchange_string st
else G.read_graph st;
draw s (0.0,0.0) in
div [p [pcdata "Load file: ";
input ~a:[a_id "filein"; a_input_type `File; a_onchange (change_file loadfile)] ();
button ~a:[a_onclick (fun _ ->
(*let string_value = Format.asprintf "%a" G.print_graph s.graph in*)
let string_value = get_exchange_string s.graph in
download string_value (G.download_file_name s.graph) "data:application/xml") ]
let string_value = Format.asprintf "%a" G.print_graph s.graph in download string_value (G.download_file_name s.graph) "data:application/xml") ]
[pcdata "Download"];
button ~a:[a_onclick (fun _ ->
let string_value = get_exchange_string s.graph in
download string_value "graph.gex" "data:application/xml") ]
[pcdata "Get GEX"];
button ~a:[a_onclick (fun _ -> layout_graph s; draw s (0.0,0.0))] [pcdata "Layout Graph"];
]]
......
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