blob: 0aa0ab74d713ca482244fa41270efb64193f5145 (
plain)
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
|
(* $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 :parent width:(`Pix 100) height:(`Pix 100) ()
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 = `Pix (truncate (float width *. (x0 +. 1.) /. 2.))
method y y0 = `Pix (truncate (float height *. (y0 +. 1.) /. 2.))
initializer
(* Create the oval border *)
Canvas.create_oval canvas tags:[`Tag "cadran"]
x1:(`Pix 1) y1:(`Pix 1)
x2:(`Pix (width - 2)) y2:(`Pix (height - 2))
width:(`Pix 3) outline:(`Yellow) fill:`White;
(* Draw the figures *)
self#draw_figures;
(* Create the arrows with dummy position *)
Canvas.create_line canvas tags:[`Tag "hours"] fill:`Red
xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.];
Canvas.create_line canvas tags:[`Tag "minutes"] fill:`Blue
xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.];
Canvas.create_line canvas tags:[`Tag "seconds"] fill:`Black
xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.];
(* 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:(`Set ([], fun _ ->
width <- Winfo.width canvas;
height <- Winfo.height canvas;
self#redraw));
(* Change direction with right button *)
bind canvas events:[[],`ButtonPressDetail 3]
action:(`Set ([], fun _ -> rflag <- -rflag; self#redraw));
(* Pack, expanding in both directions *)
pack [canvas] fill:`Both expand:true
(* Redraw everything *)
method redraw =
Canvas.coords_set canvas tag:(`Tag "cadran")
coords:[ `Pix 1; `Pix 1;
`Pix (width - 2); `Pix (height - 2) ];
self#draw_figures;
self#draw_arrows (Unix.localtime (Unix.time ()))
(* Delete and redraw the figures *)
method draw_figures =
Canvas.delete canvas tags:[`Tag "figures"];
for i = 1 to 12 do
let angle = float (rflag * i - 3) *. pi /. 6. in
Canvas.create_text canvas tags:[`Tag "figures"]
text:(string_of_int i) font:"variable"
x:(self#x (0.8 *. cos angle))
y:(self#y (0.8 *. sin angle))
anchor:`Center
done
(* Resize and reposition the arrows *)
method draw_arrows tm =
Canvas.configure_line canvas tag:(`Tag "hours")
width:(`Pix (min width height / 40));
let hangle =
float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180)
*. pi /. 360. in
Canvas.coords_set canvas tag:(`Tag "hours")
coords:[ self#x 0.; self#y 0.;
self#x (cos hangle /. 2.); self#y (sin hangle /. 2.) ];
Canvas.configure_line canvas tag:(`Tag "minutes")
width:(`Pix (min width height / 50));
let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in
Canvas.coords_set canvas tag:(`Tag "minutes")
coords:[ 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:(`Tag "seconds")
coords:[ 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 ()
|
