+let assigner_of =
+ function
+ "ge_closure" -> (fun e u->{e with ge_closure=SOF.add u e.ge_closure})
+ | "gt_closure" -> (fun e u->{e with gt_closure=SOF.add u e.gt_closure})
+ | "eq_closure" -> (fun e u->{e with eq_closure=SOF.add u e.eq_closure})
+ | "in_gegt_of" -> (fun e u->{e with in_gegt_of =SOF.add u e.in_gegt_of})
+ | "one_s_ge" -> (fun e u->{e with one_s_ge =SOF.add u e.one_s_ge})
+ | "one_s_gt" -> (fun e u->{e with one_s_gt =SOF.add u e.one_s_gt})
+ | "one_s_eq" -> (fun e u->{e with one_s_eq =SOF.add u e.one_s_eq})
+ | s -> raise (Failure ("unsupported tag " ^ s))
+;;
+
+let cb_factory m =
+ let current_node = ref (0,None) in
+ let current_entry = ref empty_entry in
+ let current_assign = ref (assigner_of "in_ge_of") in
+ function
+ | E_error exn -> raise (Failure (Pxp_types.string_of_exn exn))
+ | E_start_tag ("entry",attlist,_,_) ->
+ let id = List.assoc "id" attlist in
+ let uri = List.assoc "uri" attlist in
+ current_node := (int_of_string id,Some (UriManager.uri_of_string uri))
+ | E_start_tag ("node",attlist,_,_) ->
+ let id = int_of_string (List.assoc "id" attlist) in
+ let uri = List.assoc "uri" attlist in
+ current_entry := !current_assign !current_entry
+ (id,Some (UriManager.uri_of_string uri))
+ | E_start_tag (s,_,_,_) ->
+ current_assign := assigner_of s
+ | E_end_tag ("entry",_) ->
+ m := MAL.add !current_node !current_entry !m;
+ current_entry := empty_entry
+ | _ -> ()
+;;
+
+(* alternative implementation *)
+let mapl = [
+ ("ge_closure",0);("gt_closure",1);("eq_closure",2);
+ ("in_gegt_of", 3);
+ ("one_s_ge", 4);("one_s_gt", 5);("one_s_eq", 6)]
+;;
+
+let assigner_of' s = List.assoc s mapl ;;
+
+let entry_of_array a = {
+ ge_closure = a.(0); gt_closure = a.(1); eq_closure = a.(2);
+ in_gegt_of = a.(3);
+ one_s_ge = a.(4); one_s_gt = a.(5); one_s_eq = a.(6)}
+;;
+
+let cb_factory' m =
+ let current_node = ref (0,None) in
+ let current_entry = Array.create 7 SOF.empty in
+ let current_assign = ref 0 in
+ function
+ | E_error exn -> raise (Failure (Pxp_types.string_of_exn exn))
+ | E_start_tag ("entry",attlist,_,_) ->
+ let id = List.assoc "id" attlist in
+ let uri = List.assoc "uri" attlist in
+ current_node := (int_of_string id,Some (UriManager.uri_of_string uri))
+ | E_start_tag ("node",attlist,_,_) ->
+ let id = int_of_string (List.assoc "id" attlist) in
+ let uri = List.assoc "uri" attlist in
+ current_entry.(!current_assign) <-
+ SOF.add (id,Some (UriManager.uri_of_string uri))
+ current_entry.(!current_assign)
+ | E_start_tag (s,_,_,_) ->
+ current_assign := assigner_of' s
+ | E_end_tag ("entry",_) ->
+ m := MAL.add !current_node (entry_of_array current_entry) !m;
+ Array.fill current_entry 0 7 SOF.empty
+ | _ -> ()
+;;
+
+
+let ugraph_of_xml filename =
+ let module PX = Pxp_ev_parser in
+ let module NE = Netconversion in
+ let config = default_config in
+ let entry = `Entry_document [] in
+ let encoding = `Enc_iso88591 in
+ let source = from_file ~system_encoding:encoding filename in
+ let entity_manager =
+ PX.create_entity_manager ~is_document:true config source in
+ let result = ref MAL.empty in
+ let cb = cb_factory result in
+(*let cb = cb_factory' result in*)
+ PX.process_entity config entry entity_manager cb;
+ !result
+
+\f
+(*****************************************************************************)
+(** the main, only for testing **)
+(*****************************************************************************)
+
+(*
+
+type arc = Ge | Gt | Eq ;;
+
+let randomize_actionlist n m =
+ let ge_percent = 0.7 in
+ let gt_percent = 0.15 in
+ let random_step () =
+ let node1 = Random.int m in
+ let node2 = Random.int m in
+ let op =
+ let r = Random.float 1.0 in
+ if r < ge_percent then
+ Ge
+ else (if r < (ge_percent +. gt_percent) then
+ Gt
+ else
+ Eq)
+ in
+ op,node1,node2