l4/pkg/ocaml/ocaml/contrib/otherlibs/labltk/examples_labltk/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 (* $Id: eyes.ml 4745 2002-04-26 12:16:26Z furuse $ *)
  18
  19 open Tk
  20
  21 let _ =
  22   let top = openTk () in
  23   let fw = Frame.create top in
  24   pack [fw];
  25   let c = Canvas.create ~width: 200 ~height: 200 fw in
  26   let create_eye cx cy wx wy ewx ewy bnd =
  27     let o2 = Canvas.create_oval
  28         ~x1:(cx - wx) ~y1:(cy - wy)
  29         ~x2:(cx + wx) ~y2:(cy + wy)
  30         ~outline: `Black ~width: 7
  31         ~fill: `White
  32         c
  33     and o = Canvas.create_oval
  34         ~x1:(cx - ewx) ~y1:(cy - ewy)
  35         ~x2:(cx + ewx) ~y2:(cy + ewy)
  36         ~fill:`Black
  37         c in
  38     let curx = ref cx
  39     and cury = ref cy in
  40     bind ~events:[`Motion] ~extend:true ~fields:[`MouseX; `MouseY]
  41       ~action:(fun e ->
  42         let nx, ny =
  43           let xdiff = e.ev_MouseX - cx
  44           and ydiff = e.ev_MouseY - cy in
  45           let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +.
  46                              (float ydiff /. (float wy *. bnd)) ** 2.0) in
  47           if diff > 1.0 then
  48             truncate ((float xdiff) *. (1.0 /. diff)) + cx,
  49             truncate ((float ydiff) *. (1.0 /. diff)) + cy
  50           else
  51             e.ev_MouseX, e.ev_MouseY
  52         in
  53         Canvas.move c o ~x: (nx - !curx) ~y: (ny - !cury);
  54         curx := nx;
  55         cury := ny)
  56       c
  57   in
  58   create_eye 60 100 30 40 5 6 0.6;
  59   create_eye 140 100 30 40 5 6 0.6;
  60   pack [c]
  61
  62 let _ = Printexc.print mainLoop ()
  63
  64
  65