/spelled-out-time.rkt

http://github.com/elibarzilay/rudybot · Shell · 101 lines · 93 code · 5 blank · 3 comment · 0 complexity · 34584f3159a79e5ba5edb41da4723219 MD5 · raw file

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