(***********************************************************************)
(*                                                                     *)
(*                 MLTk, Tcl/Tk interface of OCaml                     *)
(*                                                                     *)
(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
(*               projet Cristal, INRIA Rocquencourt                    *)
(*            Jacques Garrigue, Kyoto University RIMS                  *)
(*                                                                     *)
(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
(*  en Automatique and Kyoto University.  All rights reserved.         *)
(*  This file is distributed under the terms of the GNU Library        *)
(*  General Public License, with the special exception on linking      *)
(*  described in file LICENSE found in the OCaml source tree.          *)
(*                                                                     *)
(***********************************************************************)

(* The eyes of OCaml (CamlTk) *)

open Camltk;;

let create_eye canvas cx cy wx wy ewx ewy bnd =
  let _oval2 =
    Canvas.create_oval canvas
     (Pixels (cx - wx)) (Pixels (cy - wy))
     (Pixels (cx + wx)) (Pixels (cy + wy))
     [Outline (NamedColor "black"); Width (Pixels 7);
      FillColor (NamedColor "white"); ]
  and oval =
    Canvas.create_oval canvas
     (Pixels (cx - ewx)) (Pixels (cy - ewy))
     (Pixels (cx + ewx)) (Pixels (cy + ewy))
     [FillColor (NamedColor "black")] in
  let curx = ref cx
  and cury = ref cy in

  let treat_event e =

    let xdiff = e.ev_MouseX - cx
    and ydiff = e.ev_MouseY - cy in

    let diff =
      sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +.
            (float ydiff /. (float wy *. bnd)) ** 2.0) in

    let nx, ny =
      if diff <= 1.0 then e.ev_MouseX, e.ev_MouseY else
        truncate ((float xdiff) *. (1.0 /. diff)) + cx,
        truncate ((float ydiff) *. (1.0 /. diff)) + cy in

    Canvas.move canvas oval (Pixels (nx - !curx)) (Pixels (ny - !cury));
    curx := nx;
    cury := ny; in

  bind canvas [[], Motion] (
    BindExtend ([Ev_MouseX; Ev_MouseY], treat_event)
  )
;;

let main () =
  let top = opentk () in
  let fw = Frame.create top [] in
  pack [fw] [];

  let canvas = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in

  create_eye canvas 60 100 30 40 5 6 0.6;
  create_eye canvas 140 100 30 40 5 6 0.6;
  pack [canvas] [];

  mainLoop ();
;;

Printexc.print main ();;