Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
simpleclock.fs -- F# version of the C# SimpleClock
(*
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 ()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment