56 lines
1.8 KiB
Racket
56 lines
1.8 KiB
Racket
#lang racket/gui
|
|
|
|
(require racket/date slideshow/pict)
|
|
|
|
(define (clock h m s [r 100])
|
|
(define (draw-hand length angle
|
|
#:width [width 1]
|
|
#:color [color "black"])
|
|
(dc (λ (dc dx dy)
|
|
(define old-pen (send dc get-pen))
|
|
(send dc set-pen (new pen% [width width] [color color]))
|
|
(send dc draw-line
|
|
(+ dx r) (+ dy r)
|
|
(+ dx r (* length (sin angle)))
|
|
(+ dy r (* length (cos angle))))
|
|
(send dc set-pen old-pen))
|
|
(* 2 r) (* 2 r)))
|
|
(cc-superimpose
|
|
(for/fold ([pict (circle (* 2 r))])
|
|
([angle (in-range 0 (* 2 pi) (/ pi 6))]
|
|
[hour (cons 12 (range 1 12))])
|
|
(define angle* angle)
|
|
(define r* (* r 0.8))
|
|
(define txt (text (number->string hour) '(bold . "Helvetica")))
|
|
(define x (- (* r* (sin angle*)) (/ (pict-width txt) 2)))
|
|
(define y (+ (* r* (cos angle*)) (/ (pict-height txt) 2)))
|
|
(pin-over pict (+ r x) (- r y) txt))
|
|
(draw-hand (* r 0.7) (+ pi (* (modulo h 12) (- (/ pi 6))))
|
|
#:width 3)
|
|
(draw-hand (* r 0.5) (+ pi (* m (- (/ pi 30))))
|
|
#:width 2)
|
|
(draw-hand (* r 0.7) (+ pi (* s (- (/ pi 30))))
|
|
#:color "red")
|
|
(disk (* r 0.1))))
|
|
|
|
(define f (new frame% [label "Clock"] [width 300] [height 300]))
|
|
|
|
(define c
|
|
(new canvas%
|
|
[parent f]
|
|
[paint-callback
|
|
(λ (c dc)
|
|
(define date (current-date))
|
|
(draw-pict (clock (date-hour date)
|
|
(date-minute date)
|
|
(date-second date)
|
|
(/ (send c get-width) 2))
|
|
dc 0 0))]))
|
|
|
|
(define t
|
|
(new timer%
|
|
[notify-callback (λ () (send c refresh-now))]
|
|
[interval 1000]))
|
|
|
|
(send f show #t)
|