working exchange string

editor/SimpleGraph.ml

@@ -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) ->

editor/graphDrawing.ml

@@ -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"];
             
         ]]