#!/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))))