(************************************************************
   graph_drawer.ml	Created      : Sat Feb 22 13:04:27 2003
  			Last modified: Thu Feb 27 11:09:38 2003
  Compile: ocamlfind ocamlc -I +labltk unix.cma str.cma labltk.cma jpflib.cma graph_drawer.ml -o graph_drawer #
  FTP Directory: sources/ocaml #
************************************************************)
(**
   ハンドラのつけはずし
   ドラッグの処理 スムーズな図形移動
   typeof を使用して図形の種類を判別する
   枝という意味のあるようなものの描画
   ノードの移動とともに枝も動く。mutable を使用した破壊的代入操作
   ボタン3ののダブルクリックでノードの削除

BUG
   ノードをダブルクリックすると変な動きをする
   move が悪い???
   fixed: ノード位置の破壊的代入の忘れ
   
TODO
   カスタマイズできるように? 色、キーバンド、キャンバスの大きさ
   重複する枝の削除。相互な枝を `Both で描画!?
   レイアウトエンジン
   ノードの形の多様化
   メニュー

  @author Takashi Masuyama <mamewo@dk9.so-net.ne.jp>
*)
open Tk
module Unix = UnixLabels

let wx = 50
let wy = 50
let hwx = wx/2
let hwy = wy/2
let oval_color = `Green
let changed_color = `Yellow
let selected_oval_color = `Yellow

type oval_info = { mutable cx: int; mutable cy: int; r: int; oval_tag: tagOrId }
type edge_info = { source: oval_info; target: oval_info; mutable edge_tag: tagOrId }
type im_which_t = IM_Source | IM_Target

let ovals = ref ([] : oval_info list)
let edges = ref ([] : edge_info list)    

let moving_color = `Color("#ffaacc")

let dump_ovals canvas e =
  List.iter 
    (fun x -> List.iter (fun x -> Printf.printf "%f " x) 
	(Canvas.coords_get canvas x.oval_tag); print_newline ())
    !ovals;
  flush stdout
;;

let draw_arrow canvas sx sy tx ty =
  let line = 
    Canvas.create_line ~xys:[(sx, sy); (tx, ty)] ~width:3 canvas in
  Canvas.configure_line ~arrow:`Last canvas line; line
;;
      
let is_inside_of_oval x y oval_info =
  let dx = x - oval_info.cx in
  let dy = y - oval_info.cy in
  let r = oval_info.r in
  dx*dx + dy*dy <= r*r
;;

let get_connected_edges oval_tag =
  let rec iter = function
      [] -> ([], [])
    | ({ source = { oval_tag = source_oval };
	 target = { oval_tag = target_oval };
	 edge_tag = edge_tag } as edge_info) :: tl ->
	  let (matched, not_matched)
	      = iter tl in
	  if oval_tag = source_oval then
	    ((IM_Source, edge_info)::matched, not_matched)
	  else if oval_tag = target_oval then
	    ((IM_Target, edge_info)::matched, not_matched)
	  else 
	    (matched, edge_info::not_matched) in
  let (matched, not_matched) = iter !edges in
  edges := not_matched;
  matched
;;

let add_edge edge = 
  edges := edge :: !edges
;;
	    
let rec get_clicked_oval x y =
  let rec iter = function
    [] -> (None, [])
  | hd::tl ->
      if is_inside_of_oval x y hd then
	(Some hd, tl)
      else
	let (o, tl) = iter tl in
	(o, hd::tl) in
  let (result, next_ovals) = iter !ovals in
  ovals := next_ovals; result
;;

let add_oval oval =
  ovals := oval::!ovals
;;

let draw_moving_oval ?(color = moving_color) canvas oval x y =
  let oval_tag = oval.oval_tag in
  let dx = x - oval.cx in
  let dy = y - oval.cy in
  Canvas.configure_oval ~fill:color canvas oval.oval_tag;
  Canvas.move canvas oval_tag dx dy;
;;

let draw_moving_edge canvas x y (t, edge_info) = 
  match t with
    IM_Source ->
      draw_arrow canvas x y edge_info.target.cx edge_info.target.cy;
  | IM_Target ->
      draw_arrow canvas edge_info.source.cx edge_info.source.cy x y;
;;

let erase_and_draw_edge canvas x y ((tag, edge_info) as p) =
  let new_edge = draw_moving_edge canvas x y p in
  Canvas.delete canvas [edge_info.edge_tag];
  edge_info.edge_tag <- new_edge
;;

let on_dragging_oval canvas oval moving_edges e =
  let oval_tag = oval.oval_tag in
  let x = e.ev_MouseX in
  let y = e.ev_MouseY in
  draw_moving_oval canvas oval x y;
  List.iter (erase_and_draw_edge canvas x y) moving_edges;
  oval.cx <- x;
  oval.cy <- y;
;;

let on_released canvas oval moving_edges e =
  let x = e.ev_MouseX in
  let y = e.ev_MouseY in
  begin
    draw_moving_oval canvas oval ~color:oval_color x y;
    List.iter (erase_and_draw_edge canvas x y) moving_edges;
    oval.cx <- x;
    oval.cy <- y;
    add_oval oval;
    List.iter (fun (_,x) -> add_edge x) moving_edges;
    bind ~events:[`ButtonReleaseDetail(1)] ~action:(fun e -> ()) canvas;
    bind ~events:[`Motion] ~action:(fun e -> ()) canvas;
  end
;;

let rec on_click_target_node canvas source_oval e =
  let x = e.ev_MouseX in
  let y = e.ev_MouseY in
  let sx = source_oval.cx in
  let sy = source_oval.cy in
  match get_clicked_oval x y with
    Some oval ->
      let tx = oval.cx in
      let ty = oval.cy in
      let line = 
	draw_arrow canvas sx sy tx ty in
      let edge =
	{ source = source_oval; target = oval; edge_tag = line } in
      List.iter add_oval [source_oval; oval];
      add_edge edge;
      Canvas.configure_oval ~fill:oval_color canvas source_oval.oval_tag;
      bind ~events:[`ButtonPressDetail(2)] ~action:(on_click_source_node canvas)
	~fields:[`MouseX; `MouseY] canvas;
  | None -> ()

and on_click_source_node canvas e =
  let x = e.ev_MouseX in
  let y = e.ev_MouseY in
  match get_clicked_oval x y with
    Some oval ->
      Canvas.configure_oval ~fill:selected_oval_color canvas oval.oval_tag;
      bind ~events:[`ButtonPressDetail(2)] ~action:(on_click_target_node canvas oval)
	~fields:[`MouseX; `MouseY] canvas;
  | None -> ()
;;

let on_clicked_oval canvas e =
  let x = e.ev_MouseX in
  let y = e.ev_MouseY in
  let r = hwx in
  match get_clicked_oval x y with
    Some oval ->
      let oval_tag = oval.oval_tag in
      let connected_edges = get_connected_edges oval_tag in
      begin
	Canvas.configure_oval ~fill:moving_color canvas oval_tag;
	bind ~events:[`ButtonReleaseDetail(1)] ~fields:[`MouseX; `MouseY] 
	  ~action:(on_released canvas oval connected_edges) canvas;
	bind ~events:[`Motion] ~fields:[`MouseX; `MouseY] 
	  ~action:(on_dragging_oval canvas oval connected_edges) canvas;
      end
  | None -> ()
(*  | None ->*)
(*      let oval =*)
(*	Canvas.create_oval ~x1:(x-hwx) ~y1:(y-hwy) ~x2:(x+hwx) ~y2:(y+hwy)*)
(*	  ~fill:oval_color canvas in*)
(*      add_oval { cx = x; cy = y; r = r; oval_tag = oval }*)
;;

let on_create_oval canvas e =
  let x = e.ev_MouseX in
  let y = e.ev_MouseY in
  let r = hwx in
  let oval =
	Canvas.create_oval ~x1:(x-hwx) ~y1:(y-hwy) ~x2:(x+hwx) ~y2:(y+hwy)
	  ~fill:oval_color canvas in
      add_oval { cx = x; cy = y; r = r; oval_tag = oval }
;;
let on_change_color_of_closest_object canvas e =
  let x = e.ev_MouseX in
  let y = e.ev_MouseY in
  let lst = Canvas.find canvas ~specs:[`Closest(x, y)] in
  let change_color_function tag =
    match Canvas.typeof canvas tag with
      `Oval ->
	Canvas.configure_oval ~fill:changed_color canvas tag
    | _ -> () in
  List.iter change_color_function lst
;;

let remove_connected_edges canvas oval_tag =
  let matched = get_connected_edges oval_tag in
  Canvas.delete canvas (List.map (fun (_, x) -> x.edge_tag) matched)
;;

let on_remove_clicked_node canvas e =
  let x = e.ev_MouseX in
  let y = e.ev_MouseY in
  match get_clicked_oval x y with
    Some oval ->
      let oval_tag = oval.oval_tag in
      Canvas.delete canvas [oval_tag];
      remove_connected_edges canvas oval_tag
  | None -> ()
;;

let _ =
  let canvas_width = ref 500 in
  let canvas_height = ref 500 in
  let specs = 
    [ ("-height", Arg.Int(fun i -> canvas_height := i), "configure canvas height");
      ("-width", Arg.Int(fun i -> canvas_width := i), "configure canvas width")] in
  let usage_line = Sys.argv.(0) ^ " [options]" in
  let _= Arg.parse specs ignore usage_line in
  let appname = "Interactive Graphic Sample" in
  let window = openTk() in
  let canvas = 
    Canvas.create ~background:`White ~name:"canvas"
      ~height:!canvas_height ~width:!canvas_width
      window in
(*  let menubar = Frame.create window in*)
  let menubar = Menubutton.create window ~text:"File" ~underline:0 in
  let filemenu = Menu.create menubar in
  let save_command filename = ignore (Canvas.postscript canvas ~file:filename) in
  let filesel () = 
    Fileselect.f ~title:"Save as PostScript" ~action:(List.iter save_command)
      ~filter:"*" ~multi:false ~file:"" ~sync:true in
  let _ =
    Menubutton.configure menubar ~menu:filemenu;
    Menu.add_command filemenu ~label:"Save" ~command:filesel in
  begin
    appname_set appname;
(*    マウスのどのボタンにバインドするかは `ButtonPressDetail の引数で決まる*)
    bind ~events:[`ButtonPressDetail(1)] ~extend:false
      ~fields:[`MouseX; `MouseY] 
      ~action:(on_clicked_oval canvas) canvas;
    bind ~events:[`Modified([`Double],`ButtonPressDetail(1))] ~extend:false 
      ~fields:[`MouseX; `MouseY] 
      ~action:(on_create_oval canvas) canvas;
    bind ~events:[`ButtonPressDetail(2)] ~extend:false
      ~fields:[`MouseX; `MouseY] 
      ~action:(on_click_source_node canvas) canvas;
    bind ~events:[`Modified([`Double], `ButtonPressDetail(3))]
      ~extend:false ~fields:[`MouseX; `MouseY] 
      ~action:(on_remove_clicked_node canvas) canvas;
    pack [menubar] ~side:`Top;
    pack [canvas];
    mainLoop ()
  end