Do the scientific 7 minute workout... with Racket!

exercise7.rkt

#lang racket
(provide main)
(require (planet clements/rsound) 2htdp/universe 2htdp/image)

;; Helpful app to implement the exercise plan in
;; http://well.blogs.nytimes.com/2013/05/09/the-scientific-7-minute-workout/

(define exercises '("Jumping jacks"
                    "Wall sit"
                    "Push ups"
                    "Abdominal crunch"
                    "Step-up onto chair"
                    "Squats"
                    "Tricep dip on chair"
                    "Plank"
                    "High knee running in place"
                    "Lunges"
                    "Push-up and rotation"
                    "Side plank"))
(define exercise-time 30) ;; seconds
(define rest-time 10) ;; seconds
(define width 500) ;; pixels
(define height 400) ;; pixels
(define font-size 36) ;; point
(define text-color "black")
(define background-color "white")

;; A Pre-Status is one of
;; - 'Rest
;; - 'Exercise

;; A Status is one of
;; - Pre-Status
;; - `(Paused ,Pre-Status)
;; - `(Unpause ,Pre-Status)

;; A World one of
;; - (list Status (list string) count-down)
;; - 'Done

(define (draw w)
  (if (eq? w 'Done)
      empty-image
      (overlay
       (if (match w [(list (list 'Paused _) _ _) #t] [_ #f])
           (text "Paused" font-size text-color)
           (above (text (match w
                          [(list (or 'Rest (list 'Unpause 'Rest)) (cons next _) count-down)
                           (format "~a (next: ~a)"
                                   (if (< count-down 3)
                                       "Get ready"
                                       "Rest")
                                   next)]
                          [(list (or 'Exercise (list 'Unpause 'Exercise)) (cons current _) _) current]
                          [_ (error 'bad-draw)])
                        font-size text-color)
                  (text (number->string (third w)) font-size text-color)))
       (rectangle width height "solid" background-color))))

(define (notice) (play/s ding))

(define (tick w)
  (match w
    [(list (list 'Paused status) exercise count-down) w]
    [(list (list 'Unpause status) exercise count-down)
     (list status exercise (sub1 count-down))]
    [(list 'Exercise (and exercise (cons current rest)) count-down)
     (cond
      [(= 1 count-down)
       (notice)
       (if (null? rest)
           'Done
           (list 'Rest rest rest-time))]
      [else (list 'Exercise exercise (sub1 count-down))])]
    [(list 'Rest exercise count-down)
     (cond
      [(= 1 count-down)
       (notice)
       (list 'Exercise exercise exercise-time)]
      [else (list 'Rest exercise (sub1 count-down))])]
    [_ (error 'bad-tick "~a" w)]))

(define (key w ke)
  (match ke
    ["right" (match w
               [(list 'Rest exercise count-down)
                (list 'Exercise exercise exercise-time)]
               [(list 'Exercise (list current) count-down)
                'Done]
               [(list 'Exercise (cons current rest) count-down)
                (list 'Rest rest rest-time)]
               [_ (error 'bad-key)])]
    [" "
     (match w
       [(list (list _ status) exercise count-down)
        (list (list 'Unpause status) exercise count-down)]
       [(list status exercise count-down)
        (list (list 'Paused status) exercise count-down)])]
    ["escape" 'Done]
    [_ w]))

(define (main)
  (big-bang (list 'Exercise exercises exercise-time)
            (on-tick tick 1)
            (on-key key)
            (stop-when (λ (w) (eq? w 'Done)))
            (to-draw draw)))

(main)