(************************************************************
   graph.ml		Created      : Fri Oct 18 10:30:15 2002
  			Last modified: Mon Nov 04 19:46:23 2002
  Compile: ocamlfind ocamlc -g -I /home/tak/lib/ocaml str.cma mylib.cma graph.ml -o graph.bc #
  Execute: ./graph.bc -n dep parse.cmo #
  Compile: ocamlfind ocamlc -package getopt -linkpkg -g -I /home/tak/lib/ocaml str.cma mylib.cma graph.ml -o graph.bc #
  FTP Directory: sources/ocaml #
  Compile: ocamlopt.opt -I /home/tak/lib/ocaml str.cmxa mylib.cmxa graph.ml -o graph #
  Compile: ocamlc.opt -g -I /home/tak/lib/ocaml str.cma mylib.cma graph.ml -o graph #
  Compile: ocamldoc -d doc -html
************************************************************)
(**
   graph作成
   @author Takashi Masuyama <mamewo@dk9.so-net.ne.jp>
   @see <http://www002.upp.so-net.ne.jp/mamewo/ml.html> 作者のホームページ
   @version $Id: graph.ml,v 1.3 2002/11/02 18:07:30 tak Exp $

   topological sortをする。
   で、実際に使用するには何を提供する?
   
   {u 問題}
   ファイル名のリストと dependency file が与えられる。そのファイル名リストを
   dependency list にしたがって topological sort して出力せよ。

   {ol 
   {- dependency file からグラフを切り出すが、それは依存する側からされる
   側にエッジをはる (よって普通にグラフをdfsして逆順を出力)}
   }
   
   {u Todos}
   {ol
   {- prefix をまとめて集合をノードとしてあつかう!?}
   {- dfs でたどった過程を元に木をつくってみよう }
   {- 仮想の根を入れたりするのに0番を開けるのはどうだろう? }
   {- subgraphで必要点を張るのはよいがゴミが残っている。収集したい}
   }

   {u メモ}
   グラフのエッジを逆向きにする操作をするのはInvというコンストラクタを掛ける
   ことにしてアルゴリズム側で配列の添字をひっくりかえすのがよいかと思ったが、
   もうちょっとコードを整備しなければならない。

   {u ChangeLog}
   $Log: graph.ml,v $
   Revision 1.3  2002/11/02 18:07:30  tak
   prefixでまとめる機能をつけてみた

   Revision 1.2  2002/11/02 17:43:36  tak
   *** empty log message ***

   Revision 1.1.1.1  2002/11/02 12:47:53  tak
   graph

   Revision 1.7  2002/10/25 07:18:29  tak
   0番を特別な目的のために開けてみる
*)

type node = string
type edge = node * node
let init_size = 103

let root_node = "#root#"
(* manifestだからいいのかな? *)
let is_grouping = ref true
(** filenameをあつかっているから

   {u 仕様}
   
   与えられる入力はファイル名。これはidである。入力文字列と完全一致か、正規
   表現でマッチするかはまだ決めていない。!is_grouping が true ならば id を
   id_to_group に通してノードを group に写像し、枝は移し先同士で張る。

   n → id_to_group n

   if (n,m) ∈ edge && id_to_group n <> id_to_group m then
   Set.add edge' (id_to_group n, id_to_group m)

   つまり自分へのエッジは加えたくないなぁってこと (loopなしにしたい)
 *)

let id_to_group id = Filename.chop_extension id
let node_function is_grouping = if is_grouping then id_to_group else (fun x -> x) 

(**
   ハッシュとmapとどっちがいいかな?
*)
module NodeHash =
  Hashtbl.Make(struct type t = string
    let equal = (=)
    let hash = Hashtbl.hash end)

(* depend on the fact that "elt = string" *)
module NodeMap = Map.Make(String)
module NodeSet = Set.Make(String)

module Edge =
  struct
    type t = node * node
	  (** defaultのものがあるらしい *)
    let compare = compare
(*    let compare (x1,y1) (x2,y2) =*)
(*      if x1 < x2 then -1*)
(*      else if x1 = x2 then *)
(*	if y1 < y2 then -1*)
(*	else if y1 = y2 then 0*)
(*	else 1*)
(*      else 1*)
  end

module EdgeSet = Set.Make(Edge)

(** 0番のidは空けておく *)
type graph = Graph of node array * int NodeMap.t * bool array array
(*type inv_graph = NormalGraph of graph | Inv of graph*)

(* エッジリスト表現のグラフにおいて *)
type lgraph = LGraph of node list * edge list 

(** ノードの数 *)
let get_graph_size (Graph(_, _, edge_table)) = (Array.length edge_table)-1

let is_base_node ((Graph(elements, node_to_id, edge_table)) as g) id =
  (* n^2の馬鹿な方法 *)
  let size = get_graph_size g in
  let rec iter source =
    if source = size then
      true
    else if edge_table.(source).(id) then
      false
    else
      iter (source+1)
  in iter 0
(*    (source > size) || ((not edge_table.(source).(id)) && (iter (source+1)))*)

(* つかbaseをすべて求める必要あり? *)
let find_all_base_node ((Graph(elements, node_to_id, edge_table)) as g) =
  List.fold_right (fun x lst -> (if is_base_node g x then x::lst else lst)) 
    (Mylib.make_interval_list 1 (get_graph_size g)) []

let find_all_to_node ((Graph(_, _, edge_table)) as g) node_id =
  let size = get_graph_size g in
  List.fold_right (fun x l -> if edge_table.(node_id).(x) then x::l else l) (Mylib.make_interval_list 0 (size-1)) []

let print_adjacency_matrix (Graph(_,_,m)) =
  let size_x = Array.length m in
  let size_y = Array.length m.(0) in
  print_string "  |";
  for j = 0 to size_y-1 do
    Printf.printf " %2d" j;
  done;
  print_endline "";
  for j = 0 to size_y do
    print_string "---";
  done;
  print_endline "";
  for i = 0 to size_x-1 do
    Printf.printf "%2d|" i;
    for j = 0 to size_y-1 do 
      print_string (if m.(i).(j) then "  o" else "  x");
    done;
    print_endline "";
  done

let print_HTML_adjacency_matrix (Graph(_,_,m)) =
  let size_x = Array.length m in
  let size_y = Array.length m.(0) in
  begin
    print_endline "<html><head><title>Graph</title></head><body><pre>";
    print_string "  |";
    for j = 0 to size_y-1 do
      Printf.printf " %2d" j;
    done;
    print_endline "";
    for j = 0 to size_y do
      print_string "---";
    done;
    print_endline "";
    for i = 0 to size_x-1 do
      Printf.printf "%2d|" i;
      for j = 0 to size_y-1 do 
	print_string (if m.(i).(j) then "  <font color=\"#880000\"><b>o</b></font>" else "  -");
      done;
      print_endline "";
    done;
    print_endline "</pre></body></html>";
  end
  
(**
  dependency ファイルを読む hashは集合演算(重複のない追加)のために使用。
   結果は lgraph vcgに落す場合などはlgraphの方が都合が良い。
   Mylib.read_dependency_file
*)
let read_graph in_channel =
  (* オラクル的な存在 *)
  (* ん、setでよいではないか、よいではないか? *)
(*  let node_hash = NodeHash.create init_size in*)
  let node_f = node_function !is_grouping in
  let rec iter node_set edge_set = 
    try 
      let (head, tail) = Mylib.read_dependency_file in_channel in
      (* headからtailへの枝を張る *)    
      let new_edge_set = 
	List.fold_right
	  (fun x s -> 
	    let s' = node_f head in
	    let d' = node_f x in
	    if s' <> d' then EdgeSet.add (s', d') s
	    else s) tail edge_set in
      (** side effect *)
      let new_node_set = List.fold_right
	  (fun x s -> NodeSet.add (node_f x) s) (head::tail) node_set in
      iter new_node_set new_edge_set
    with
      End_of_file ->
	(* set を list 化 *)
	let node_list = NodeSet.elements node_set in
	let edge_list = EdgeSet.elements edge_set in
	LGraph(node_list, edge_list) in
  iter NodeSet.empty EdgeSet.empty

(**
   エッジを隣接行列で表現。ノード名からidへのハッシュを作成
*)
let lgraph_to_agraph (LGraph(node_list,edge_list)) =
  let size = List.length node_list in
  let adjacency_matrix = Array.make_matrix (size+1) (size+1) false in
  let nodes = Array.of_list (root_node :: node_list) in
  (* 逆びき表 *)
  let node_to_id = 
(*    let node_to_id_ref = ref NodeMap.empty in*)
(*    begin*)
      (* Map.Make の add : key -> 'a -> 'a t -> 'a t *)
    snd (Array.fold_left (fun (c,m) n -> (c+1, NodeMap.add n c m)) (0,NodeMap.empty) nodes) in
  begin
    (* 枝を登録 *)
    List.iter (fun (source,target) -> 
      let sid = NodeMap.find source node_to_id in
      let tid = NodeMap.find target node_to_id in
(*      let _ = Printf.printf "(%2d, %2d) %s - %s\n" sid tid source target; flush stdout in*)
      adjacency_matrix.(sid).(tid) <- true) edge_list;
    Graph(nodes, node_to_id, adjacency_matrix)
  end

let agraph_to_lgraph ((Graph(nodes, node_to_id, adjacency_matrix)) as g) =
  let node_list = match Array.to_list nodes with [] -> [] | _::tl -> tl in
  let size = get_graph_size g in
  (* 単純にいうと二重のfor loop *)
  let rec iter_out i result =
    let rec iter_in j result =
      if j > size then
	result
      else
	iter_in (j+1) (if adjacency_matrix.(i).(j) then
	  let source_name = nodes.(i) in
	  let target_name = nodes.(j) in
	  (source_name, target_name)::result
	else
	  result) in
    if i > size then
      result
    else
      iter_out (i+1) (iter_in 1 result) in
  let edge_list = iter_out 1 [] in
  LGraph(node_list, edge_list)
  
(* 走らせる *)

let output_vcg out_channel (LGraph(node_list, edge_list)) =
  begin
    output_string out_channel "graph: { title: \"test\"\n";
    List.iter
      (fun x -> 
	Printf.fprintf out_channel "  node: { title: \"%s\" label: \"%s\"}\n" x x)
      node_list;
    output_string out_channel "\n";
    List.iter 
      (fun (s,t) ->
	Printf.fprintf out_channel 
	  "  edge: { sourcename: \"%s\" targetname: \"%s\" }\n" s t)
      edge_list;
    output_string out_channel "}\n";
  end
(************************************************************
   invあり
 **)
(*module InvGraph =*)
(*  struct *)
(*    let inv = function*)
(*	NormalGraph g -> Inv g*)
(*      | Inv g -> NormalGraph g*)
(*    let is_base_node n =*)
(*      let g*)

(************************************************************
   ばかな反転
************************************************************)
let inverse_graph ((Graph(node_list, node_to_id, edge_table)) as g) =
  let size = get_graph_size g in
  let new_edge_table = Array.make_matrix size size false in
  begin
    for i = 0 to size do
      for j = 0 to size do
	new_edge_table.(i).(j) <- edge_table.(j).(i)
      done
    done;
    Graph(node_list, node_to_id, edge_table)
  end
(* ... んんん *)

let is_all_visited g visited_table =
  let size = get_graph_size g in
  let rec iter c = 
    if c = 0 then true
    else
      visited_table.(c) && iter (c-1) in
  iter size

(* start は任意 *)
let topological_sort g =
  let size = get_graph_size g in
  let base_list = find_all_base_node g in
  let visited_table = Array.make (size+1) false in
  let rec visit current result =
    (* 現在の枝から出ていてしかも訪問してないのをとってきないなぁ *)
    (* 訪問してないチェックをどこでやろうか? *)
    if visited_table.(current) then
      result
    else
      begin
	visited_table.(current) <- true;
	let new_edge =
	  List.fold_right (fun x lst -> (if visited_table.(x) then lst else x::lst))
	    (find_all_to_node g current) [] in
	let to_node_list = find_all_to_node g current in
	List.fold_right (fun x lst -> visit x lst) new_edge (current::result)
      end in
  List.fold_right visit base_list []

let id_to_name (Graph(nodes, _, _)) id = nodes.(id)


(* たどった枝のリストを表示する 最近たどった枝が先頭に来る *)
let dfs_with_record_edge ((Graph(nodes, _ ,adjacency_matrix)) as g) start_id = 
  let size = get_graph_size g in
  let visited_table = Array.create (size+1) false in
  let rec visit (parent,current) result =
    (* 現在の枝から出ていてしかも訪問してないのをとってきないなぁ *)
    (* 訪問してないチェックをどこでやろうか? *)
    if visited_table.(current) then
      result
    else
      begin
	visited_table.(current) <- true;
	let new_edge =
	  List.fold_right
	    (fun x lst -> (if visited_table.(x) then lst else (current,x)::lst))
	    (find_all_to_node g current) [] in
	let to_node_list = find_all_to_node g current in
	List.fold_right visit new_edge ((parent,current)::result)
      end in
  let dummy_result = visit (0,start_id) [] in
  let rec chop = function
      [elt] -> []
    | hd::tl -> hd::(chop tl)
    | [] -> assert false
  in chop dummy_result;;

(* たどった枝のリストを表示する 最近たどった枝が先頭に来る *)
(* dfsってグラフだけもらう!? *)
let make_dfs_tree ((Graph(nodes, node_to_id, adjacency_matrix)) as g) = 
  (* rootから伸びるノードのリストとともに返す ってか、base nodeをまた求めたらわかる*)
  (* すべてのbase treeからたどる *) 
  (* 一つのrootにまとめる *)
  let size = get_graph_size g in
  let visited_table = Array.create (size+1) false in
  let result_adjacency_matrix = Array.make_matrix (size+1) (size+1) false in
  let rec visit (parent,current)  =
    (* 現在の枝から出ていてしかも訪問してないのをとってきないなぁ *)
    (* 訪問してないチェックをどこでやろうか? *)
    if visited_table.(current) then
      ()
    else
      begin
	visited_table.(current) <- true;
	result_adjacency_matrix.(parent).(current) <- true;
	let new_edge_list =
	  List.fold_right
	    (fun x lst -> (if visited_table.(x) then lst else (current,x)::lst))
	  (find_all_to_node g current) [] in
(*	let to_node_list = find_all_to_node g current in*)
	visit_all_edges new_edge_list
      end
  and visit_all_edges edge_list = List.iter visit edge_list in
  begin
    (* body *)
    visit_all_edges (List.map (fun x -> (0,x)) (find_all_base_node g));
    Graph(nodes, node_to_id, result_adjacency_matrix)
  end
  
let dfs ((Graph(nodes,nodes_to_id,adjacency_matrix)) as g) start_id = 
  let size = get_graph_size g in
  let visited_table = Array.create (size+1) false in
  let rec visit current result =
    (* 現在の枝から出ていてしかも訪問してないのをとってきないなぁ *)
    (* 訪問してないチェックをどこでやろうか? *)
    if visited_table.(current) then
      result
    else
      begin
	visited_table.(current) <- true;
	let new_edge =
	  List.fold_right 
	    (fun x lst -> (if visited_table.(x) then lst else x::lst))
	    (find_all_to_node g current) [] in
	let to_node_list = find_all_to_node g current in
	List.fold_right visit new_edge (current::result)
      end in
  visit start_id [] 

let span_nodes_by_sub_graph ((Graph(nodes, node_to_id, adjacency_matrix)) as g)
    node_list = 
  (* rootから伸びるノードのリストとともに返す ってか、base nodeをまた求めたらわかる*)
  (* すべてのbase treeからたどる *) 
  (* 一つのrootにまとめる *)
  (* 前提 depend graph は依存する側 -> される側であるが、ここに渡されるグラフは
    エッジを逆にしたもの *)
  let size = get_graph_size g in
  let visited_table = Array.create (size+1) false in
  let result_adjacency_matrix = Array.make_matrix (size+1) (size+1) false in
  let rec visit (parent,current)  =
    (* 現在の枝から出ていてしかも訪問してないのをとってきないなぁ *)
    (* 訪問してないチェックをどこでやろうか? *)
    (* ループがないは大前提 *)
    begin
      result_adjacency_matrix.(parent).(current) <- true;
      if visited_table.(current) then
	(* DAGっているところ。 dfsで枝を選ぶ順が決定的ならばいらないとおもわれ *)
	()
      else
	begin
	  visited_table.(current) <- true;
	  result_adjacency_matrix.(parent).(current) <- true;
	  let new_edge_list =
	    List.fold_right
	      (fun x lst -> (current,x)::lst)
	      (find_all_to_node g current) [] in
	  visit_all_edges new_edge_list
	end
    end
  and visit_all_edges edge_list = List.iter visit edge_list in
  begin
    (* body *)
    visit_all_edges (List.map (fun x -> (0,x)) node_list);
    Graph(nodes, node_to_id, result_adjacency_matrix)
  end

let span_nodes_by_sub_graph_and_gc
    ((Graph(nodes, node_to_id, adjacency_matrix)) as g)
    node_list = 
  (* rootから伸びるノードのリストとともに返す ってか、base nodeをまた求めたらわかる*)
  (* すべてのbase treeからたどる *) 
  (* 一つのrootにまとめる *)
  (* 前提 depend graph は依存する側 -> される側であるが、ここに渡されるグラフは
    エッジを逆にしたもの *)
  let size = get_graph_size g in
  let visited_table = Array.create (size+1) false in
  let result_adjacency_matrix = Array.make_matrix (size+1) (size+1) false in
  let rec visit (parent,current)  =
    (* 現在の枝から出ていてしかも訪問してないのをとってきないなぁ *)
    (* 訪問してないチェックをどこでやろうか? *)
    (* ループがないは大前提 *)
    begin
      result_adjacency_matrix.(parent).(current) <- true;
      if visited_table.(current) then
	(* DAGっているところ。 dfsで枝を選ぶ順が決定的ならばいらないとおもわれ *)
	()
      else
	begin
	  visited_table.(current) <- true;
	  result_adjacency_matrix.(parent).(current) <- true;
	  let new_edge_list =
	    List.fold_right
	      (fun x lst -> (current,x)::lst)
	      (find_all_to_node g current) [] in
	  visit_all_edges new_edge_list
	end
    end
  and visit_all_edges edge_list = List.iter visit edge_list in
(*  let new_size =*)
(*    Array.fold_left (fun x c -> if x then c+1 else c) visited_table in*)
  let translation_table = Array.make (size+1) 0 in
  let counter = ref 0 in
  begin
    (* body *)
    visit_all_edges (List.map (fun x -> (0,x)) node_list);      
    for i = 1 to size do
      if visited_table.(i) then
	begin
	  incr counter;	    
	  translation_table.(i) <- !counter
	end
      else ()
    done;
    (* Functional ぢゃないんですけど... *)
    let final_node_table = Array.make (!counter+1) "" in
    let final_adjacency_matrix =
      Array.make_matrix (!counter+1) (!counter+1) false in
    begin
      for i = 1 to size do 
	if visited_table.(i) then
	  let i' = translation_table.(i) in
	  begin
	    final_node_table.(i') <- nodes.(i);
	    for j = 1 to size do 
	      if visited_table.(j) then
		let j' = translation_table.(j) in
		final_adjacency_matrix.(i').(j') <- result_adjacency_matrix.(i).(j)
	      else ()
	    done
	  end
	else ()
      done;
      let final_node_to_id = 
	snd (Array.fold_left (fun (c,m) n -> (c+1, NodeMap.add n c m))
	       (0, NodeMap.empty) nodes) in
      begin
(*	Array.iteri (fun i n -> if i > 0 then Printf.printf "%2d: %s\n" i n else ()) final_node_table;*)
	Graph(final_node_table, final_node_to_id, final_adjacency_matrix)
      end
    end
  end
(* ..... nnnnn *)
(*    end in*)
(*    Graph(nodes, node_to_id, result_adjacency_matrix)*)
(*  end*)


(*let group_flag = ref false*)
(*let print_usage () =*)
(*  print_string *)
(*"usage: graph [dependency_file] [filename(s)...]*)
(*  option: -n  do not group nodes by drop extensions*)
(*"*)

(* getoptに関するメモ
  長いオプションのみの時はどうすればよいのじゃ?
  parse_cmdline は Sys.argv に副作用を残さない。(オプションを取り除いたりはしない)
*)
(*let specs = [ ('n', "", Some(fun () -> is_grouping := false), None);*)
(*	      ('u', "", Some(print_usage), None) ]*)

(* Getopt のかわりに Arg を使う *)
let specs = [ ("-n", Arg.Clear(is_grouping),
   "  option: -n  do not group nodes by drop extensions") ]
let _ =
   let dependency_filename_ref = ref "" in
   let init_node_name_list_ref = ref [] in
   let is_first = ref true in
   let _ = Arg.parse specs (fun x -> if !is_first then
   begin dependency_filename_ref := x; is_first := false end
   else init_node_name_list_ref := x :: !init_node_name_list_ref)
   "usage: graph.ml [options] [dependfile] [filename(s) ...]" in
    let dependency_filename = !dependency_filename_ref in
    let init_node_name_list = !init_node_name_list_ref in
    let all_graph_name = "all.vcg" in
    let sub_graph_name = "sub.vcg" in
    let in_channel = open_in dependency_filename in
    let lg = read_graph in_channel in
    (* debug *)
    let all_output = open_out all_graph_name in
    let _ = begin output_vcg all_output lg; close_out all_output end in
    (* end *)
    let ((Graph(nodes, node_to_id, edge_table)) as g) = lgraph_to_agraph lg in
    let node_f = node_function !is_grouping in
    let init_node_list =
      List.map (fun x -> NodeMap.find (node_f x) node_to_id) init_node_name_list in
    let sub_graph = span_nodes_by_sub_graph_and_gc g init_node_list in
    (* debug *)
    let sub_lgraph = agraph_to_lgraph sub_graph in
    let sub_output = open_out sub_graph_name in
    let _ = begin output_vcg sub_output sub_lgraph; close_out sub_output end in
    (* end *)

    let sorted_list = topological_sort sub_graph in
    (* for debug *) 
    (*let filter_regexp = Str.regexp "cm" in*)
    begin
      List.iter 
	(fun x -> let name = nodes.(x) in Printf.printf "%s.cmo " name) sorted_list;
	print_endline "";
    end

(************************************************************)
(* Depth First Search *)
(*    let dfs (Graph(nodes,nodes_to_id,adjacency_matrix)) start_id = *)
(*      let size = get_graph_size g in*)
(*      let visited_table = Array.create size false in*)
(*      let rec visit current result =*)
(*	  (* 現在の枝から出ていてしかも訪問してないのをとってきないなぁ *)*)
(*          (* 訪問してないチェックをどこでやろうか? *)*)
(*	if visited_table.(current) then*)
(*	  result*)
(*	else*)
(*	  begin*)
(*	    visited_table.(current) <- true;*)
(*	    let new_edge =*)
(*	      List.fold_right *)
(*		(fun x lst -> (if visited_table.(x) then lst else x::lst))*)
(*		(find_all_to_node g current) [] in*)
(*	    let to_node_list = find_all_to_node g current in*)
(*	    List.fold_right (fun x lst -> visit x lst) new_edge (current::result)*)
(*	  end in*)
(*      visit start_id [] in*)