(***********************************************************************)
(* *)
(* 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 ();;