134 lines
4.7 KiB
OCaml
134 lines
4.7 KiB
OCaml
(*************************************************************************)
|
|
(* *)
|
|
(* Objective Caml LablTk library *)
|
|
(* *)
|
|
(* Jun Furuse, projet Cristal, INRIA Rocquencourt *)
|
|
(* Jacques Garrigue, Kyoto University RIMS *)
|
|
(* *)
|
|
(* Copyright 1999 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. *)
|
|
(* *)
|
|
(*************************************************************************)
|
|
|
|
(* $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 ~x1:1 ~y1:1 ~x2:(width - 2) ~y2:(height - 2)
|
|
~tags:["cadran"] ~width:3 ~outline:`Yellow ~fill:`White
|
|
canvas;
|
|
(* Draw the figures *)
|
|
self#draw_figures;
|
|
(* Create the arrows with dummy position *)
|
|
Canvas.create_line ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
|
|
~tags:["hours"] ~fill:`Red
|
|
canvas;
|
|
Canvas.create_line ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
|
|
~tags:["minutes"] ~fill:`Blue
|
|
canvas;
|
|
Canvas.create_line ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
|
|
~tags:["seconds"] ~fill:`Black
|
|
canvas;
|
|
(* 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 ~events:[`Configure]
|
|
~action:(fun _ ->
|
|
width <- Winfo.width canvas;
|
|
height <- Winfo.height canvas;
|
|
self#redraw)
|
|
canvas;
|
|
(* Change direction with right button *)
|
|
bind ~events:[`ButtonPressDetail 3]
|
|
~action:(fun _ -> rflag <- -rflag; self#redraw)
|
|
canvas;
|
|
(* 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
|
|
~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
|
|
canvas
|
|
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 ()
|