/spelled-out-time.rkt

  1#! /bin/sh
  2#| Hey Emacs, this is -*-scheme-*- code!
  3exec  racket -l errortrace --require $0 --main -- ${1+"$@"}
  4|#
  5
  6#lang racket
  7
  8(require (planet neil/numspell/numspell)
  9         (planet schematics/schemeunit:3)
 10         (planet schematics/schemeunit:3/text-ui))
 11
 12(define (seconds->english secs)
 13  (let loop ([units secs]
 14             [divisors '((second . 60)
 15                         (minute . 60)
 16                         (hour   . 24)
 17                         (day    .  7)
 18                         (week   . 52)
 19                         (year   . 100))]
 20             [accum '()])
 21
 22    (cond
 23     [(zero? units)
 24      (if (null? accum)
 25          '((second . 0))
 26          accum)]
 27     [(null? divisors)
 28      (cons `(century . ,units) accum)]
 29     [else
 30      (let ([d (car divisors)])
 31        (let-values ([(q r) (quotient/remainder units (cdr d))])
 32          (loop
 33           q
 34           (cdr divisors)
 35           (cons (cons (car d) r) accum))))])))
 36
 37(define (number->english/plural n unit-name)
 38
 39  (define (y->ie n unit-name)
 40    (cond
 41     [(equal? 1 n)
 42      unit-name]
 43     [(equal? unit-name "century")
 44      "centurie"]
 45     [else unit-name]))
 46
 47  (string-append (number->english n)
 48                 " "
 49                 (y->ie n unit-name)
 50                 (if (equal? 1 n)
 51                     ""
 52                     "s")))
 53
 54(define (safe-take lst pos)
 55  (let ([pos (min pos (length lst))])
 56    (take lst pos)))
 57
 58(define (spelled-out-time secs)
 59  (let* ([result (safe-take (seconds->english secs) 1)]
 60         [final (list (car result))]
 61         [final (if (and (< 1 (length result))
 62                         (zero? (cdr (second result))))
 63                     final
 64                     (append final (cdr result)))])
 65    (string-join
 66     (map (lambda (p)
 67            (number->english/plural
 68              (cdr p)
 69              (symbol->string (car p))))
 70          final)
 71     ", ")))
 72
 73
 74(define-binary-check (check-spelled-out-time input-seconds expected-string)
 75  (equal? (spelled-out-time input-seconds)
 76          expected-string))
 77
 78(define spelled-out-time-tests
 79
 80  (test-suite
 81   "spelled-out-time"
 82   (check-spelled-out-time 0 "zero seconds")
 83   (check-spelled-out-time 1 "one second")
 84   (check-spelled-out-time 2 "two seconds")
 85   (check-spelled-out-time 25 "twenty-five seconds")
 86   (check-spelled-out-time 123 "two minutes")
 87   (check-spelled-out-time 3611 "one hour")
 88   (check-spelled-out-time 75532 "twenty hours")
 89   (check-spelled-out-time 7229 "two hours")
 90   (check-spelled-out-time (+ 17 (* 24 3600)) "one day")
 91   (check-spelled-out-time (* 2 24 3600) "two days")
 92   (check-spelled-out-time (* 1 60 60 24 7 52 100)   "one century")
 93   (check-spelled-out-time (* 1 60 60 24 7 52 100 10)"ten centuries")))
 94
 95(define (main . args)
 96  (exit (run-tests spelled-out-time-tests 'verbose)))
 97
 98(provide/contract
 99 [seconds->english (-> natural-number/c (listof (cons/c symbol? natural-number/c)))]
100 [spelled-out-time  (-> natural-number/c string?)])
101(provide main)