#!/bin/sh
#| -*- scheme -*-
exec racket "$0" "$@"
|#
#lang racket/base
(require racket/gui/base racket/class racket/promise racket/string)
(define help-text "\
* Entry format:
`NN:NN' -- set an alarm to given time
`Nm' -- set an N minute timer (`s/h/d' for
seconds, hours, days)
`Nh Mm' -- timer for N hours and M minutes
`.' -- stopwatch
`!...' -- use a `!' prefix with the above to
avoid showing the current time
* Enter: use for setting one of the above, and
if the entry is not changed, will do something
that depends on the mode:
- alarm/timer: switch between showing the
alarm time and time left until the alarm
- stopwatch: start/stop
- when an alarm is active, will stop it
- two quick enters will force the string to be
re-entered (eg, resetting a timer)
* Escape: hit three times quickly to quit")
;; ============================================================================
;; Customization
(define init-width 150)
(define init-height 40)
(define window-style '(no-caption #|float|#))
(define face (case (system-type)
[(windows) "Arial Black"]
[(unix) " Arial Black"]
[else (error 'alarm "no default font for this system")]))
(define sounds-dir (build-path (getenv "HOME") "stuff" "sounds"))
(define alarm-sounds #("Drip" "Switch" "Doink" "Hold" "Eeeooop"))
#|
(cond [(get-font-from-user) => (λ (f) (printf "~a\n" (send f get-face)))])
(exit)
|#
;; ============================================================================
;; Initialization stuff
(define threads '())
(define (thread* thunk) (set! threads (cons (thread thunk) threads)))
(uncaught-exception-handler
(λ (e) (for-each kill-thread threads)
(message-box "Alarm Error!" (exn-message e)) (exit 1)))
(define commandline-args
(string-join (vector->list (current-command-line-arguments)) " "))
;; ============================================================================
;; Sounds
(define play
(if (or (getenv "VNCDESKTOP") (not (directory-exists? sounds-dir)))
void
(λ (wav)
(play-sound (build-path sounds-dir (string-append wav ".wav")) #t))))
;; ============================================================================
;; GUI
;; A smooth+no-flicker text widget
(define lines%
(class canvas%
(define bm #f)
(define width 1)
(define height 1)
(define 1height 1)
(define *dc #f)
(define dc (make-object bitmap-dc%))
(define font #f)
(init-field [lines #()])
(define/public (set-line i new)
(unless (< i (vector-length lines))
(define new-lines (make-vector (add1 i) ""))
(let loop ([j (sub1 (vector-length lines))])
(when (<= 0 j)
(vector-set! new-lines j (vector-ref lines j))
(loop (sub1 j))))
(set! lines new-lines)
(do-resize))
(unless (equal? (vector-ref lines i) new)
(vector-set! lines i new)
(draw-lines)))
(define/public (set-lines new)
(unless (equal? new lines)
(define same-length? (= (vector-length lines) (vector-length new)))
(set! lines new)
(unless same-length? (do-resize))
(draw-lines)))
(define alarm #f)
(define plain-bg (make-object color% "white"))
(define alarm-bgs
(list->vector (map (λ (rgb) (apply make-object color% rgb))
'((#xFF #x40 #x40) (#xFF #xFF #x40)))))
(define next-sound #f)
(define next-sound-delta #f)
(define/public (do-alarm n)
(unless (equal? n alarm)
(when n
(unless alarm (set! next-sound n) (set! next-sound-delta 16))
(when (and next-sound (<= next-sound n))
(play (vector-ref alarm-sounds
(random (min (vector-length alarm-sounds)
(add1 (quotient n 120))))))
(set! next-sound (+ next-sound next-sound-delta))
(set! next-sound-delta (max 1 (- next-sound-delta 1/4)))))
(set! alarm n)
(send dc set-background
(if alarm
(vector-ref alarm-bgs (modulo alarm (vector-length alarm-bgs)))
plain-bg))
(draw-lines)))
(define/override (on-size w h)
(set! width w)
(set! height h)
(do-resize)
(draw-lines))
(define (do-resize)
(when (or (not bm)
(< (send bm get-width) width)
(< (send bm get-height) height))
(set! bm (make-object bitmap%
(max width (if bm (send bm get-width) 0))
(max height (if bm (send bm get-height) 0))))
(send dc set-bitmap bm))
(set! 1height (round (/ height (max 1 (vector-length lines)))))
(send dc set-font (get-font 1height))
(unless *dc (set! *dc (send this get-dc))))
(define get-font
(let ([fonts (make-vector 256 #f)])
(λ (size)
(let ([size (max (min size 255) 1)])
(or (vector-ref fonts size)
(let ([font (make-object font% size face 'default 'normal
'bold #f 'smoothed #t)])
(vector-set! fonts size font)
font))))))
(define (find-font-for-width hi txt)
(let loop ([lo 1] [hi hi])
(if (<= (- hi lo) 1)
(send dc set-font (get-font lo))
(let ([mid (round (/ (+ lo hi) 2))])
(send dc set-font (get-font mid))
(let-values ([(w h d s) (send dc get-text-extent txt)])
(if (< w width) (loop mid hi) (loop lo mid)))))))
(define (draw-lines)
(when bm
(send dc clear)
(let loop ([i (sub1 (vector-length lines))])
(when (<= 0 i)
(let*-values ([(line) (vector-ref lines i)]
[(w h d e) (send dc get-text-extent line)])
(if (or (<= w width)
(<= width 5)) ; sometimes width is 1 when initializing
(begin (send dc draw-text line
(round (/ (- width w) 2))
(+ (* 1height i) (round (/ (- 1height h) 2))))
(loop (sub1 i)))
(begin (find-font-for-width 1height line)
(loop (sub1 (vector-length lines))))))))
(on-paint)))
(define/override (on-paint)
(when *dc (send *dc draw-bitmap bm 0 0)))
(super-new [min-width init-width] [stretchable-width #t]
[min-height init-height] [stretchable-height #t]
[style '(no-autoclear)])))
(define frame
(new
(class frame%
(define escapes #f)
(define last-time 0)
(define/override (on-subwindow-char w e)
(define key (send e get-key-code))
(cond [(eq? 'release key) #f]
[(eq? 'escape key)
(define now (current-inexact-milliseconds))
(set! escapes (if (and escapes (< (- now last-time) 1000))
(add1 escapes) 1))
(set! last-time now)
(when (integer? alarm-mode) (set! alarm-mode 'stopped))
(when (<= 3 escapes) (send this show #f))
#t]
[(eq? 'f1 key) (message-box "Help" help-text this)]
[else (set! escapes #f) #f]))
(super-new [label "Alarm"] [style window-style]))))
(define 2lines
(new lines% [lines #("" "")] [parent frame]))
(define input
(new text-field% [label ""] [parent frame] [init-value commandline-args]
[horiz-margin 1] [vert-margin 1]
[callback (λ (t ev)
(let ([typ (send ev get-event-type)])
(when (eq? typ 'text-field-enter)
(set-mode (send t get-value))
(send (send t get-editor) select-all))))]))
(define (warn fmt . args)
(message-box "Warning" (apply format fmt args) frame))
;; ============================================================================
;; Time code
(define (->regexp . strs)
(regexp (string-append*
(map (λ (x) (if (regexp? x) (object-name x) x)) strs))))
(define re:num #rx"(?:[+-]?(?:[0-9]+|[0-9]+[.][0-9]*|[0-9]*[.][0-9]+))")
(define re:alarm (->regexp "^ *("re:num"):("re:num")(?::("re:num"))? *$"))
(define re:interval-indicator #rx"[smhdSMHD]")
(define re:interval-item (->regexp "("re:num") *("re:interval-indicator")"))
(define re:interval? (->regexp "^( *"re:interval-item")+ *$"))
(define re:interval-item+rest (->regexp "^ *"re:interval-item" *(.*)$"))
(define (string->number* str)
(parameterize ([read-decimal-as-inexact #f])
(string->number str)))
(define (hms->secs h m s) (round (+ s (* 60 (+ m (* 60 h))))))
(define (alarm:string->time str)
(cond [(regexp-match re:alarm str)
=> (λ (m)
(define cur (current-seconds))
(define alarm (hms->secs (string->number* (cadr m))
(string->number* (caddr m))
(string->number* (or (cadddr m) "0"))))
(define now (let ([cur (seconds->date cur)])
(hms->secs (date-hour cur)
(date-minute cur)
(date-second cur))))
(+ cur (- alarm now) (if (<= alarm now) (* 24 60 60) 0)))]
[else #f]))
(define (interval:string->time str)
(and (regexp-match? re:interval? str)
(let loop ([str str] [secs 0])
(cond [(regexp-match re:interval-item+rest str)
=> (λ (m)
(loop (cadddr m)
(+ secs
(* (string->number* (cadr m))
(case (string->symbol
(string-downcase (caddr m)))
[(s) 1]
[(m) 60]
[(h) (* 60 60)]
[(d) (* 60 60 24)])))))]
[(regexp-match #rx"^ *$" str)
(+ (current-seconds) (round secs))]
[else #f]))))
(define display-clock? #t)
(define display-mode #f)
(define alarm-time #f)
(define alarm-mode #f)
(define last-mode #f)
(define mode-repeated 0)
(define last-set-mode-time +inf.0)
(define (set-mode mode)
(define different-display-clock?
(let ([new (cond [(regexp-match-positions #rx"^ *! *" mode)
=> (λ (m) (set! mode (substring mode (cdar m))) #f)]
[else #t])])
(begin0 (not (equal? display-clock? new))
(set! display-clock? new))))
(define new? (begin0 (not (equal? mode last-mode)) (set! last-mode mode)))
(define fast-again? (let ([now (current-inexact-milliseconds)])
(begin0 (< (- now last-set-mode-time) 200.0)
(set! last-set-mode-time now))))
(unless (integer? alarm-mode)
(set! mode-repeated (if (or new? different-display-clock? fast-again?)
0 (add1 mode-repeated))))
(when (integer? alarm-mode) (set! alarm-mode 'stopped))
(define t-int (interval:string->time mode))
(define t-alm (alarm:string->time mode))
(define t-up (regexp-match? #rx"^ *[+.^]+ *$" mode))
(define t-non (regexp-match? #rx"^ *$" mode))
(define cnt? (if (even? mode-repeated) t-int (not t-int)))
(when (or fast-again? new? t-non)
(set! alarm-mode #f)
(cond [t-non (set! alarm-time #f)]
[t-up (set! alarm-time 0.0) (set! display-mode 'countup-paused)]
[(or t-int t-alm) => (λ (t) (set! alarm-time t))]
[else (set! last-mode #f) (warn "bad mode: ~s" mode)]))
(set! display-mode
(cond [t-non 'none]
[t-up ; pause/resume
(let ([now (/ (current-inexact-milliseconds) 1000.0)])
;; switch between start-time (running) and elapsed (paused)
(set! alarm-time (- now alarm-time))
(case display-mode
[(countup-paused) 'countup]
[(countup) 'countup-paused]
[else (error 'set-mode "internal error")]))]
[cnt? 'countdown]
[else 'show]))
(tick #t))
(define time-string
(case-lambda
[(h m s neg?)
(define (pad n) (if (< n 10) (format "0~a" n) n))
(define sign (if neg? "-" ""))
(define (hms s) (format "~a~a:~a:~a" sign (pad h) (pad m) (pad s)))
(cond [(exact? s) (hms s)]
[(< 0 h) (hms (inexact->exact (round s)))]
[else (let ([s00 (inexact->exact (round (* s 100.0)))])
(format "~a~a:~a.~a" sign (pad m)
(pad (quotient s00 100))
(pad (modulo s00 100))))])]
[(h m s) (time-string h m s #f)]
[(x) (if (date? x)
(time-string (date-hour x) (date-minute x) (date-second x))
(let* ([neg? (< x 0)]
[s (abs x)]
[m (floor (/ (inexact->exact (floor s)) 60))]
[s (- s (* 60 m))]
[h (floor (/ m 60))]
[m (- m (* 60 h))])
(time-string h m s neg?)))]))
(define tick
(let ([last #f] [last-alarm #f] [last-alarm-string #f] [last-alarm-mode #f])
(λ ([force? #f])
(define sec (if (and alarm-time (inexact? alarm-time))
(/ (current-inexact-milliseconds) 1000.0)
(current-seconds)))
(unless (and (equal? sec last) (not force?))
(set! last sec)
(define date (seconds->date (if (inexact? sec) (current-seconds) sec)))
(define 2nd
(and alarm-time
(case display-mode
[(none) #f]
[(countup) (time-string (- sec alarm-time))]
[(countup-paused) (time-string alarm-time)]
[(countdown) (time-string (- alarm-time sec))]
[(show) (unless (equal? last-alarm alarm-time)
(define date (seconds->date alarm-time))
(set! last-alarm alarm-time)
(set! last-alarm-string (time-string date)))
last-alarm-string]
[else (error 'tick "bad display-mode: ~e" display-mode)])))
;; at least one should be shown
(define 1st (and (or display-clock? (not 2nd)) (time-string date)))
(send 2lines set-lines
(cond [(not 2nd) (vector 1st)]
[(not 1st) (vector 2nd)]
[else (vector 1st 2nd)]))
(cond [(memq display-mode '(countup countup-paused))
(set! alarm-mode #f)]
[(integer? alarm-mode)
(set! alarm-mode (add1 alarm-mode))]
[(and alarm-time (not alarm-mode) (< alarm-time sec))
(set! alarm-mode 0)])
(unless (equal? alarm-mode last-alarm-mode)
(set! last-alarm-mode alarm-mode)
(send 2lines do-alarm (and (integer? alarm-mode) alarm-mode)))))))
;; ============================================================================
;; Start up
(send (send input get-editor) select-all)
(send input focus)
(define sema (make-semaphore 1))
(send frame center)
(send frame show #t)
(thread* (λ ()
(queue-callback (λ () (set-mode commandline-args)))
(let loop ()
(sleep (if (eq? 'countup display-mode) 0.03 0.2))
(semaphore-wait sema)
(queue-callback (λ () (tick) (semaphore-post sema)))
(loop))))