summaryrefslogtreecommitdiff
path: root/otherlibs/labltk/example/clock.ml
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs/labltk/example/clock.ml')
-rw-r--r--otherlibs/labltk/example/clock.ml115
1 files changed, 115 insertions, 0 deletions
diff --git a/otherlibs/labltk/example/clock.ml b/otherlibs/labltk/example/clock.ml
new file mode 100644
index 0000000000..0aa0ab74d7
--- /dev/null
+++ b/otherlibs/labltk/example/clock.ml
@@ -0,0 +1,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 ()