l4/pkg/ocaml/contrib/otherlibs/labltk/examples_labltk/clock.ml

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