simpleclock.fs -- F# version of the C# SimpleClock

gistfile1.ml

(*
 Compile by doing
  fscp10.exe -r Mono.Cairo.dll -I /usr/lib/mono/gtk-sharp-2.0/ -r gtk-sharp.dll \
             -r gdk-sharp.dll -r glib-sharp.dll simpleclock.fs
*)
open System
open Gtk
open Cairo

let withDo g f v cr = f v cr; g cr

let curry f x y = f (x,y)
let curry3 f x y z = f (x,y,z)
let curry4 f x y z w = f (x,y,z,w)
let curry5 f x y z w v = f (x,y,z,w,v)
let uncurry f (x,y) = f x y

let translate (cr:Cairo.Context) = curry cr.Translate
let rotate (cr:Cairo.Context) = cr.Rotate
let scale (cr:Cairo.Context) = curry cr.Scale

let stroke (cr:Cairo.Context) = cr.Stroke ()
let fill (cr:Cairo.Context) = cr.Fill ()
let arc (cr:Cairo.Context) = curry5 cr.Arc
let rectangle (cr:Cairo.Context) = curry4 cr.Rectangle

let save (cr:Cairo.Context) = cr.Save ()
let restore (cr:Cairo.Context) = cr.Restore ()

let push cr f =
  save cr;
  let rv = f cr in
  restore cr;
  rv

let withStroke = withDo stroke
let withFill = withDo fill

let drawCircle x y r cr = arc cr x y r 0.0 (Math.PI * 2.0)
let strokeCircle x y = withStroke (drawCircle x y)
let fillCircle x y = withFill (drawCircle x y)

let drawRectangle x y w h cr = rectangle cr x y w h
let fillRectangle x y w = withFill (drawRectangle x y w)
let strokeRectangle x y w = withStroke (drawRectangle x y w)

let color (cr:Cairo.Context) c = cr.Color <- c

let newRGB r g b = new Color (r,g,b)
let newRGBA r g b a = new Color (r,g,b,a)

let rgb cr r g b = color cr <| newRGB r g b
let rgba cr r g b a = color cr <| newRGBA r g b a
let lineWidth (cr:Cairo.Context) w = cr.LineWidth <- w

let drawClockFace cr = push cr <| fun cr ->
  rgb cr 0.188 0.855 1.0;
  lineWidth cr 0.01;
  strokeCircle 0.0 0.0 0.95 cr

let drawHand c length thickness base cr value =
  let rot = (float (value % base)) / (float base) in
  push cr <| fun cr ->
    rotate cr <| rot * Math.PI * 2.0;
    color cr c;
    fillRectangle 0.0 (-thickness/2.0) length thickness cr

let fgColor = newRGB 0.188 0.855 1.0
let drawHourHand = drawHand fgColor 0.6 0.15 12
let drawMinuteHand = drawHand fgColor 0.8 0.1 60
let drawSecondHand = drawHand fgColor 0.9 0.05 60

let drawPin cr = push cr <| fun cr ->
  color cr fgColor;
  fillCircle 0.0 0.0 0.075 cr

let drawClock (cr:Context) w h =
  let boxSize = min w h in
  let date = DateTime.Now in
  push cr <| fun cr ->
    rgb cr 0.2 0.2 0.2;
    fillRectangle 0.0 0.0 w h cr;
    translate cr ((w - boxSize) / 2.0) ((h - boxSize) / 2.0);
    scale cr (boxSize / 2.0) (boxSize / 2.0);
    translate cr 1.0 1.0;
    rotate cr (-Math.PI / 2.0);
    drawClockFace cr;
    drawHourHand cr date.Hour;
    drawMinuteHand cr date.Minute;
    drawSecondHand cr date.Second;
    drawPin cr

let simpleClock (da:Gtk.DrawingArea) _ =
  use drawable = da.GdkWindow in
    let w,h = da.Allocation.Width, da.Allocation.Height in
    use cr = Gdk.CairoHelper.Create (drawable) in
      drawClock cr (float w) (float h)

let updateClock (win:Gtk.Window) _ =
  win.QueueDraw ();
  true

let () =
  Application.Init ();
  let win = new Window "Simpleclock" in
  let drawingArea = new Gtk.DrawingArea () in
  win.SetDefaultSize (256, 256);
  let t = GLib.Timeout.Add (500u, new GLib.TimeoutHandler(updateClock win)) in
  drawingArea.ExposeEvent.Add (simpleClock drawingArea);
  win.Destroyed.Add(fun _ -> Application.Quit() );
  win.Add drawingArea;
  win.ShowAll ();
  Application.Run ()