(************************************************************
   move_dragged_oval.ml	Created      : Sat Feb 22 13:04:27 2003
  			Last modified: Sat Feb 22 23:47:48 2003
  Compile: ocamlc.opt -I +labltk labltk.cma move_dragged_oval.ml -o move_dragged_oval #
  FTP Directory: sources/ocaml #
************************************************************)
(**
   ハンドラのつけはずし
   ドラッグの処理の方法
   typeof を使用して図形の種類を判別する
  @author Takashi Masuyama <mamewo@dk9.so-net.ne.jp>
*)

open Tk

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

type oval_info = { cx: int; cy: int; r: int; oval: tagOrId }

let ovals = ref ([] : oval_info list)
    
let moving_oval = ref None
let line_init_position = ref None

let dump_ovals canvas e =
  List.iter 
    (fun x -> List.iter (fun x -> Printf.printf "%f " x) 
	(Canvas.coords_get canvas x.oval); print_newline ())
    !ovals;
  flush stdout
      
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 rec get_clicked_oval x y = function
    [] -> (None, [])
  | hd::tl ->
      if is_inside_of_oval x y hd then
	(Some hd, tl)
      else
	let (o, tl) = get_clicked_oval x y tl in
	(o, hd::tl)

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

let dragged = ref false

let move_to_abs_pos canvas oval x y =
  let dx = x - oval.cx in
  let dy = y - oval.cy in
  let new_oval = 
    { oval with cx = x; cy = y } in
  let oval_tag = new_oval.oval in
  Canvas.configure_oval ~fill:(color) canvas oval_tag;
  Canvas.move canvas oval_tag dx dy
;;

let draw_moving_oval canvas e =
  let x = e.ev_MouseX in
  let y = e.ev_MouseY in
  match !moving_oval with
    Some oval ->
      let oval_tag = oval.oval in
      move_to_abs_pos canvas oval x y
  | None ->
      print_endline "draw_moving_oval:SomeError occurd in release (no oval)";
      flush stdout
;;

let released canvas e =
  let x = e.ev_MouseX in
  let y = e.ev_MouseY in
  match !moving_oval with
    Some oval ->
      let dx = x - oval.cx in
      let dy = y - oval.cy in
      let new_oval = 
	{ oval with cx = x; cy = y } in
      let oval_tag = new_oval.oval in
      Canvas.configure_oval ~fill:(color) canvas oval_tag;
      Canvas.move canvas oval_tag dx dy;
      ovals := new_oval::!ovals;
      moving_oval := None;
      bind ~events:[`ButtonReleaseDetail(1)] ~action:(fun e -> ()) canvas;
  | None ->
      print_endline "SomeError occurd in release (no oval)";
      flush stdout
;;

let on_end_line canvas e =
  match !line_init_position with
    Some(x, y) ->
      let tx = e.ev_MouseX in
      let ty = e.ev_MouseY in
      ignore (Canvas.create_line ~xys:[(x, y); (tx, ty)] ~width:2 canvas);
      line_init_position := None;
      bind ~events:[`ButtonReleaseDetail(2)] ~action:(fun e -> ()) canvas
  | None ->
      print_endline "on_end_line:Error occured (no init position)"; flush stdout
;;

let on_start_line canvas e =
  let x = e.ev_MouseX in
  let y = e.ev_MouseY in
  begin
    line_init_position := Some(x,y);
    bind ~events:[`ButtonReleaseDetail(2)] ~action:(on_end_line canvas)
      ~fields:[`MouseX; `MouseY] canvas;
  end
;;

let draw_oval_on_clicked canvas e =
  let x = e.ev_MouseX in
  let y = e.ev_MouseY in
  let r = hwx in
  let (oval_opt, next) = get_clicked_oval x y !ovals in
  let _ = ovals := next in
  match oval_opt with
    Some oval ->
      let oval_tag = oval.oval in
      Canvas.configure_oval ~fill:(`Color("#ffaacc")) canvas oval_tag;
      moving_oval := Some oval; 
      bind ~events:[`ButtonReleaseDetail(1)] ~fields:[`MouseX; `MouseY] 
	~action:(released canvas) canvas;
      (* timer!? *)
      (* unsafe とかいてあったが、postscriptを出力できる *)
(*      print_endline (Canvas.postscript ~file:"hoge.ps" canvas); flush stdout*)
  | None ->
      let oval =
	Canvas.create_oval ~x1:(x-hwx) ~y1:(y-hwy) ~x2:(x+hwx) ~y2:(y+hwy)
	  ~fill:color canvas in
      add_oval { cx = x; cy = y; r = r; oval = 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 _ =
  let appname = "Interactive Graphic Sample" in
  let window = openTk() in
  let canvas = Canvas.create ~background:`White ~name:"canvas" ~height:500 ~width:500 
      window in
  begin
    appname_set appname;
(*    マウスのどのボタンにバインドするかは `ButtonPressDetail の引数で決まる*)
    bind ~events:[`ButtonPressDetail(1)] ~extend:false ~fields:[`MouseX; `MouseY] 
      ~action:(draw_oval_on_clicked canvas) canvas;
    bind ~events:[`ButtonPressDetail(3)] ~extend:false 
      ~action:(dump_ovals canvas) canvas;
    bind ~events:[`ButtonPressDetail(2)] ~extend:false ~fields:[`MouseX; `MouseY] 
      ~action:(on_start_line canvas) canvas;
    bind ~events:[`Modified([`Shift], `ButtonPressDetail(1))]
      ~extend:false ~fields:[`MouseX; `MouseY] 
      ~action:(on_change_color_of_closest_object canvas) canvas;
    pack [canvas];
    mainLoop ()
  end