l4/pkg/ocaml/contrib/otherlibs/labltk/examples_camltk/eyes.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                 MLTk, Tcl/Tk interface of Objective Caml            *)
   4 (*                                                                     *)
   5 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
   6 (*               projet Cristal, INRIA Rocquencourt                    *)
   7 (*            Jacques Garrigue, Kyoto University RIMS                  *)
   8 (*                                                                     *)
   9 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
  10 (*  en Automatique and Kyoto University.  All rights reserved.         *)
  11 (*  This file is distributed under the terms of the GNU Library        *)
  12 (*  General Public License, with the special exception on linking      *)
  13 (*  described in file LICENSE found in the Objective Caml source tree. *)
  14 (*                                                                     *)
  15 (***********************************************************************)
  16
  17 (* The eyes of Caml (CamlTk) *)
  18
  19 open Camltk;;
  20
  21 let _ =
  22   let top = opentk () in
  23
  24   let fw = Frame.create top [] in
  25   pack [fw] [];
  26   let c = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in
  27   let create_eye cx cy wx wy ewx ewy bnd =
  28     let o2 =
  29        Canvas.create_oval c
  30         (Pixels (cx - wx)) (Pixels (cy - wy))
  31         (Pixels (cx + wx)) (Pixels (cy + wy))
  32         [Outline (NamedColor "black"); Width (Pixels 7);
  33          FillColor (NamedColor "white")]
  34     and o =
  35       Canvas.create_oval c
  36        (Pixels (cx - ewx)) (Pixels (cy - ewy))
  37        (Pixels (cx + ewx)) (Pixels (cy + ewy))
  38        [FillColor (NamedColor "black")] in
  39     let curx = ref cx
  40     and cury = ref cy in
  41     bind c [[], Motion]
  42       (BindExtend ([Ev_MouseX; Ev_MouseY],
  43         (fun e ->
  44           let nx, ny =
  45             let xdiff = e.ev_MouseX - cx
  46             and ydiff = e.ev_MouseY - cy in
  47             let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +.
  48                                (float ydiff /. (float wy *. bnd)) ** 2.0) in
  49             if diff > 1.0 then
  50               truncate ((float xdiff) *. (1.0 /. diff)) + cx,
  51               truncate ((float ydiff) *. (1.0 /. diff)) + cy
  52             else
  53               e.ev_MouseX, e.ev_MouseY
  54           in
  55           Canvas.move c o (Pixels (nx - !curx)) (Pixels (ny - !cury));
  56           curx := nx;
  57           cury := ny)))
  58   in
  59   create_eye 60 100 30 40 5 6 0.6;
  60   create_eye 140 100 30 40 5 6 0.6;
  61   pack [c] []
  62
  63 let _ = Printexc.print mainLoop ()
  64
  65
  66
  67