/usr/share/doc/ocaml/examples/labltk/clock.ml is in ocaml 4.01.0-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 | (***********************************************************************)
(* *)
(* 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. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Clock/V, a simple clock.
Reverts every time you push the right button.
Adapted from ASCII/V May 1997
Uses Tk and Unix, so you must link with
labltklink unix.cma clock.ml -o clock -cclib -lunix
*)
open Tk
(* pi is not a constant! *)
let pi = acos (-1.)
(* The main class:
* create it with a parent: [new clock parent:top]
* initialize with [#init]
*)
class clock ~parent = object (self)
(* Instance variables *)
val canvas = Canvas.create ~width:100 ~height:100 parent
val mutable height = 100
val mutable width = 100
val mutable rflag = -1
(* Convert from -1.0 .. 1.0 to actual positions on the canvas *)
method x x0 = truncate (float width *. (x0 +. 1.) /. 2.)
method y y0 = truncate (float height *. (y0 +. 1.) /. 2.)
initializer
(* Create the oval border *)
Canvas.create_oval canvas ~tags:["cadran"]
~x1:1 ~y1:1 ~x2:(width - 2) ~y2:(height - 2)
~width:3 ~outline:`Yellow ~fill:`White;
(* Draw the figures *)
self#draw_figures;
(* Create the arrows with dummy position *)
Canvas.create_line canvas
~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
~tags:["hours"] ~fill:`Red;
Canvas.create_line canvas
~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
~tags:["minutes"] ~fill:`Blue;
Canvas.create_line canvas
~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
~tags:["seconds"] ~fill:`Black;
(* Setup a timer every second *)
let rec timer () =
self#draw_arrows (Unix.localtime (Unix.time ()));
Timer.add ~ms:1000 ~callback:timer; ()
in timer ();
(* Redraw when configured (changes size) *)
bind canvas ~events:[`Configure] ~action:
begin fun _ ->
width <- Winfo.width canvas;
height <- Winfo.height canvas;
self#redraw
end;
(* Change direction with right button *)
bind canvas ~events:[`ButtonPressDetail 3]
~action:(fun _ -> rflag <- -rflag; self#redraw);
(* Pack, expanding in both directions *)
pack ~fill:`Both ~expand:true [canvas]
(* Redraw everything *)
method redraw =
Canvas.coords_set canvas (`Tag "cadran")
~xys:[ 1, 1; width - 2, height - 2 ];
self#draw_figures;
self#draw_arrows (Unix.localtime (Unix.time ()))
(* Delete and redraw the figures *)
method draw_figures =
Canvas.delete canvas [`Tag "figures"];
for i = 1 to 12 do
let angle = float (rflag * i - 3) *. pi /. 6. in
Canvas.create_text canvas
~x:(self#x (0.8 *. cos angle)) ~y:(self#y (0.8 *. sin angle))
~tags:["figures"]
~text:(string_of_int i) ~font:"variable"
~anchor:`Center
done
(* Resize and reposition the arrows *)
method draw_arrows tm =
Canvas.configure_line ~width:(min width height / 40)
canvas (`Tag "hours");
let hangle =
float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180)
*. pi /. 360. in
Canvas.coords_set canvas (`Tag "hours")
~xys:[ self#x 0., self#y 0.;
self#x (cos hangle /. 2.), self#y (sin hangle /. 2.) ];
Canvas.configure_line ~width:(min width height / 50)
canvas (`Tag "minutes");
let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in
Canvas.coords_set canvas (`Tag "minutes")
~xys:[ self#x 0., self#y 0.;
self#x (cos mangle /. 1.5), self#y (sin mangle /. 1.5) ];
let sangle = float (rflag * tm.Unix.tm_sec - 15) *. pi /. 30. in
Canvas.coords_set canvas (`Tag "seconds")
~xys:[ self#x 0., self#y 0.;
self#x (cos sangle /. 1.25), self#y (sin sangle /. 1.25) ]
end
(* Initialize the Tcl interpreter *)
let top = openTk ()
(* Create a clock on the main window *)
let clock =
new clock ~parent:top
(* Wait for events *)
let _ = mainLoop ()
|