~npalix/coccinelle/upstream

open Oassocb

open Osetb

 

 *  -  node: index -> nodevalue

 *  -  arc: (index * index) * edgevalue

 * either assoc is a key also.

 * How ? matrix ? but no growing array :(

 * When need index ? Must have an index when can't just use nodevalue

 * as a key, cos sometimes may have 2 times the same key, but it must

 * be 2 different nodes. For instance in program f(); f(); we want 2

 * nodes, one per f(); hence the index. If each node is different,

 * then no problem, can omit index.

 * todo?: prend en parametre le type de finitemap et set a prendre

 * have a ref to a set.

 * visited_counter.  check(that node is in, ...), display.

 * free_index are used,  or do some defrag-like-move/renaming).

 *)

 

type nodei = int

 

  object(o)

    (* inherit ['a] ograph *)

    val free_index = 0

 

    val succ = build_assoc()

    val pred = build_assoc()

    val nods = build_assoc()

 

      let i = free_index in

        pred = pred#add (i, build_set() );

        succ = succ#add (i, build_set() );

        free_index = i + 1;

       >}, i)

 

        pred = pred#add (i, build_set() );

        succ = succ#add (i, build_set() );

        free_index = (max free_index i) + 1;

       >}, i)

 

 

      {<

           and check that already in *)

 

        (* todo: assert that have no pred and succ, otherwise

         *)

        pred = pred#delkey i;

        succ = succ#delkey i;

        >}

 

      assert (nods#haskey i);

      {<

        nods = nods#replkey (i, e);

       >}

 

        succ = succ#replkey (a, (succ#find a)#add (b, v));

        pred = pred#replkey (b, (pred#find b)#add (a, v));

        >}

    method del_arc ((a,b),v) =

        succ = succ#replkey (a, (succ#find a)#del (b,v));

        pred = pred#replkey (b, (pred#find b)#del (a,v));

        >}

    method allsuccessors = succ

 

(*

        match xs#view with (* could be done with an iter *)

        | Empty -> acc

              +> (fun newacc -> aux (o#predecessors x) newacc)

              +> (fun newacc -> aux xs newacc)

      in aux xs (f2()) (* (new osetb []) *)

 

        match xs#view with (* could be done with an iter *)

        | Empty -> acc

              +> (fun newacc -> aux (o#successors x) newacc)

              +> (fun newacc -> aux xs newacc)

      in aux xs (f2()) (* (new osetb []) *)

 

      let parents = o#predecessors x in

      (parents#fold (fun acc e -> acc $++$ o#successors e) (f2()))#del x

 

*)

 

 

 

 

  let build_set ()   = new osetb Setb.empty in

 

  object(o)

    val mutable free_index = 0

 

    val mutable succ = build_assoc()

    val mutable pred = build_assoc()

    val mutable nods = build_assoc()

 

      let i = free_index in

      pred <- pred#add (i, build_set() );

      succ <- succ#add (i, build_set() );

      free_index <- i + 1;

      i

 

      pred <- pred#add (i, build_set() );

      succ <- succ#add (i, build_set() );

      free_index <- (max free_index i) + 1;

 

 

           and check that already in *)

 

        (* todo: assert that have no pred and succ, otherwise

         *)

        pred <- pred#delkey i;

        succ <- succ#delkey i;

 

      assert (nods#haskey i);

      nods <- nods#replkey (i, e);

      succ <- succ#replkey (a, (succ#find a)#add (b, v));

      pred <- pred#replkey (b, (pred#find b)#add (a, v));

    method del_arc ((a,b),v) =

    method nodes = nods

    method allsuccessors = succ

 

 

 

(* depth first search *)

let dfs_iter xi f g =

  let already = Hashtbl.create 101 in

      if Hashtbl.mem already xi then ()

      else begin

        Hashtbl.add already xi true;

  aux_dfs [xi]

 

 

  let already = Hashtbl.create 101 in

    if Hashtbl.mem already xi then ()

    else begin

      Hashtbl.add already xi true;

      f xi path;

      let succ = g#successors xi in

      let succ' = succ#tolist +> List.map fst in

          aux_dfs (xi::path) yi

      );

      end

  in

  aux_dfs [] xi

 

let generate_ograph_generic g label fnode filename =

  Common.with_open_outfile filename (fun (pr,_) ->

    | Some x -> pr (Printf.sprintf "label = \"%s\";\n" x));

 

    let nodes = g#nodes in

      let (str,border_color,inner_color) = fnode (k, node) in

      let color =

        match inner_color with

            | Some x -> Printf.sprintf ", style=\"setlinewidth(3)\", color = %s" x)

        | Some x ->

            (match border_color with

            | Some x' -> Printf.sprintf ", style=\"setlinewidth(3),filled\", fillcolor = %s, color = %s" x x') in

      pr (sprintf "%d [label=\"%s   [%d]\"%s];\n" k str k color)

    );

 

      let succ = g#successors k in

      succ#iter (fun (j,edge) ->

        pr (sprintf "%d -> %d;\n" k j);

    pr "size = \"10,10\";\n" ;

 

    let nodes = g#nodes in

      pr (sprintf "%d [label=\"%s   [%d]\"];\n" k s k)

    );

 

      let succ = g#successors k in

      succ#iter (fun (j,edge) ->

        pr (sprintf "%d -> %d;\n" k j);

 

 

let launch_gv_cmd filename =

    Unix.system ("dot " ^ filename ^ " -Tps  -o " ^ filename ^ ".ps;") in

  let _status = Unix.system ("gv " ^ filename ^ ".ps &")

  in

  (* zarb: I need this when I launch the program via eshell, otherwise gv

     do not get the chance to be launched *)

  ()

 

  generate_ograph_generic g label fnode output_file;

  if launch_gv then launch_gv_cmd output_file