diff options
| author | Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> | 1999-11-16 10:22:42 +0000 |
|---|---|---|
| committer | Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> | 1999-11-16 10:22:42 +0000 |
| commit | df8e31a8ae8fda0499f209ebd6efadbe544d4549 (patch) | |
| tree | 6ad5d6bd60a5126b08d77b8c6c60671cba022ab1 /otherlibs/labltk/example/eyes.ml | |
| parent | fce433fa4ddf1ce57a29a00cf7d6c6c62ba85bff (diff) | |
This commit was generated by cvs2svn to compensate for changes in r2531,
which included commits to RCS files with non-trunk default branches.
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2532 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat (limited to 'otherlibs/labltk/example/eyes.ml')
| -rw-r--r-- | otherlibs/labltk/example/eyes.ml | 43 |
1 files changed, 43 insertions, 0 deletions
diff --git a/otherlibs/labltk/example/eyes.ml b/otherlibs/labltk/example/eyes.ml new file mode 100644 index 000000000..1f281d66c --- /dev/null +++ b/otherlibs/labltk/example/eyes.ml @@ -0,0 +1,43 @@ +open Tk + +let _ = + let top = openTk () in + let fw = Frame.create parent: top () in + pack [fw]; + let c = Canvas.create parent: fw width: (`Pix 200) height: (`Pix 200) () in + let create_eye cx cy wx wy ewx ewy bnd = + let o2 = Canvas.create_oval c + x1:(`Pix (cx - wx)) y1:(`Pix (cy - wy)) + x2:(`Pix (cx + wx)) y2:(`Pix (cy + wy)) + outline: (`Color "black") width: (`Pix 7) + fill: (`Color "white") + and o = Canvas.create_oval c + x1:(`Pix (cx - ewx)) y1:(`Pix (cy - ewy)) + x2:(`Pix (cx + ewx)) y2:(`Pix (cy + ewy)) + fill: (`Color "black") in + let curx = ref cx + and cury = ref cy in + bind c events:[[], `Motion] + action: (`Extend ([`MouseX; `MouseY], (fun e -> + let nx, ny = + 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 + if diff > 1.0 then + truncate ((float xdiff) *. (1.0 /. diff)) + cx, + truncate ((float ydiff) *. (1.0 /. diff)) + cy + else + e.ev_MouseX, e.ev_MouseY + in + Canvas.move c tag: o + x: (`Pix (nx - !curx)) y: (`Pix (ny - !cury)); + curx := nx; + cury := ny))) + in + create_eye 60 100 30 40 5 6 0.6; + create_eye 140 100 30 40 5 6 0.6; + pack [c] + +let _ = Printexc.print mainLoop () + |