[plt-scheme] scheduling scheme into my life

With a project winding down, I'm getting out of Java mode and trying  
more Scheme, something I've been meaning to do.  The opportunity came  
when my church needed a new usher schedule, and DrScheme was a great  
help.  (Thank you!)  What I came up with is shown below.  It worked,  
and a technically minded usher said "Cool," but I know you know  
better.  Given that this was a relatively quick hack, I'm curious if,  
after looking at this for half a minute, anything stands out, such as  
"you should done this" or "never do that."  I'm guessing I could have  
organized the code better, simplified things, learned about contracts...

Geoffrey
--
Geoffrey S. Knauth | http://knauth.org/gsk


;;; ushers.scm -- Generate Usher Schedule
;;;
;;; geoff at knauth.org 2006-02-26 (PLT DrScheme)

(require (lib "time.ss" "srfi" "19"))
(require (lib "class.ss"))
(require (lib "misc.ss" "swindle"))

(define (ymd2d ymd)
   (let ((year (car ymd))
         (month (cadr ymd))
         (day (caddr ymd)))
   (make-srfi:date 0 0 30 10 day month year (* -5 3600))))

;; list of sundays to list of dates
(define (los->lod list-of-sundays)
   (map ymd2d list-of-sundays))

(define qtr-months '(4 5 6))
(define first-sunday '(2006 4 2))
(define youth-sundays
   (los->lod (list '(2006 4 2) '(2006 5 7))))

(define seven-days (* 7 24 3600))

(define qtr-sundays
   (let ((sundays '()))
     (let loop ((sunday (ymd2d first-sunday)))
       (when (member (srfi:date-month sunday) qtr-months)
         (set! sundays (cons sunday sundays))
         (loop (time-utc->date (add-duration (date->time-utc sunday)  
(make-time time-duration 0 seven-days))))))
     (reverse sundays)))

(define usher-day%
   (class object%

     (public youth-sunday summer-sunday ushers-found ushers-needed?  
assign print-ushers-scheduled)

     (init-field
      (day #f)
      (ushers-needed-start 4)
      (ushers-scheduled '()))

     (define (youth-sunday)
       (set! ushers-needed-start 1))

     (define (summer-sunday)
       (set! ushers-needed-start 2))

     (define (ushers-needed)
       (- ushers-needed-start (ushers-found)))

     (define (ushers-needed?)
       (> (ushers-needed) 0))

     (define (ushers-found) (length ushers-scheduled))

     ; should only be called by usher-day instance
     (define (assign usher)
       (when (not (member usher ushers-scheduled))
         (set! ushers-scheduled (cons usher ushers-scheduled))))

     (define (print-ushers-scheduled)
       (printf "Ushers scheduled:")
         (for-each
          (lambda (u)
            (printf " ~a" (get-field name u)))
          ushers-scheduled)
         (printf "\n"))

     (super-new)))

(define (day-to-usher-day d)
   (let ((usher-day (new usher-day% (day d))))
     (if (member d youth-sundays)
       (send usher-day youth-sunday)
       (when (and (= (srfi:date-month d) 6)
                  (>= (srfi:date-day d) 11))
         (send usher-day summer-sunday)))
     usher-day))

(define usher-days
   (map day-to-usher-day qtr-sundays))

(define usher%
   (class object%

     (public assign)

     (define schedule '())

     (init-field
      (name #f)
      (avoid-dates '())
      (prefer-dates '())
      (partner #f)
      (most-recent (ymd2d '(1900 1 1))))

     (define (assign usher-day)
       (if (member usher-day schedule)
           #f
           (begin
             (printf "assign ~a\n" name)
             (send usher-day assign this)
             (set! schedule (cons usher-day schedule))
             (set! most-recent (get-field day usher-day))
             this)))

   (super-new)))

(define all-ushers
   (list

    (new usher%
         (name "Andy Lafft")
         (most-recent (ymd2d '(2006 3 26))))

    (new usher%
         (name "Arnie Adoll")
         (most-recent (ymd2d '(2006 3 26))))

    (new usher%
         (name "Barbara Pirate")
         (avoid-dates (los->lod (list '(2006 4 16))))
         (partner "Frank Pirate")
         (most-recent (ymd2d '(2006 3 19))))

    (new usher%
         (name "Bob Zioronkel")
         (most-recent (ymd2d '(2006 3 12))))

    (new usher%
         (name "Don Juan")
         (most-recent (ymd2d '(2006 3 12))))

    (new usher%
         (name "Frank Pirate")
         (avoid-dates (los->lod (list '(2006 4 16))))
         (partner "Barbara Pirate")
         (most-recent (ymd2d '(2006 3 19))))

    (new usher%
         (name "Georg Reorg")
         (avoid-dates (los->lod (list '(2006 4 2) '(2006 4 16) '(2006  
6 25))))
         (most-recent (ymd2d '(2006 3 19))))

    (new usher%
         (name "Greg Eggspression")
         (avoid-dates (los->lod (list '(2006 4 16) '(2006 4 23)  
'(2006 5 7) '(2006 5 21) '(2006 6 4))))
         (most-recent (ymd2d '(2006 3 19))))

    (new usher%
         (name "Jim Meanit")
         (most-recent (ymd2d '(2006 3 12))))

    (new usher%
         (name "Mike Lima")
         (most-recent (ymd2d '(2006 3 12))))

    (new usher%
         (name "Per Chants")
         (most-recent (ymd2d '(2006 3 26))))

    (new usher%
         (name "Rob Paul")
         (avoid-dates (los->lod (list '(2006 4 2) '(2006 4 23) '(2006  
5 28) '(2006 6 4))))
         (most-recent (ymd2d '(2006 3 26))))

    (new usher%
         (name "Tom Agranite")
         (avoid-dates (los->lod (list '(2006 4 16) '(2006 5 7) '(2006  
5 21) '(2006 5 28) '(2006 6 25))))
         (prefer-dates (los->lod (list '(2006 4 2))))
         (most-recent (ymd2d '(2006 3 5))))

    ))

(define (usher-available? usher usher-day)
   (and (not (member (get-field day usher-day) (get-field avoid-dates  
usher)))
        (not (member usher (get-field ushers-scheduled usher-day)))))

(define (usher-volunteers? usher usher-day)
   (member (get-field day usher-day) (get-field prefer-dates usher)))

(define (available-ushers ushers usher-day)
   (filter
    (lambda (usher)
      (usher-available? usher usher-day))
    ushers))

(define (available-volunteers ushers usher-day)
   (filter
    (lambda (usher)
      (usher-volunteers? usher usher-day))
    (available-ushers ushers usher-day)))

(define (sort-least-recent ushers usher-day)
   (let ((day (date->time-utc (get-field day usher-day))))
     (quicksort ushers
                (lambda (u1 u2)
                  (time>? (time-difference day (date->time-utc (get- 
field most-recent u1)))
                          (time-difference day (date->time-utc (get- 
field most-recent u2))))))))

(define (assign-ushers day-list)
   (when (not (null? day-list))
     (let* ((usher-day (car day-list))
            (day-call-list (sort-least-recent (available-ushers all- 
ushers usher-day) usher-day)))
       ;(printf "\n")
       ;(for-each (lambda (u) (printf "PREV ~a ~a\n" (date->string  
(get-field most-recent u) "~Y-~m-~d") (get-field name u))) day-call- 
list)
       (printf "\n~a\n" (date->string (get-field day usher-day)))
       (pick-ushers usher-day day-call-list)
       (assign-ushers (cdr day-list)))))

(define (pick-ushers usher-day some-ushers)
   (let loop ((ushers some-ushers))
     (when (and (not (null? ushers))
                (send usher-day ushers-needed?))
       (if (not (or (pick-volunteer usher-day ushers)
                    (pick-partner usher-day)
                    (pick-usher usher-day ushers)))
         (error "could not find an usher")
         (loop (cdr ushers))))))

(define (pick-volunteer usher-day some-ushers)
   (let loop ((volunteers (available-volunteers some-ushers usher-day)))
     (cond ((null? volunteers) #f)
           (else
            (if (send (car volunteers) assign usher-day)
                (car volunteers)
                (loop (cdr volunteers)))))))

(define (pick-usher usher-day some-ushers)
   (let loop ((ushers some-ushers))
     (cond ((null? ushers) #f)
           (else
            (if (send (car ushers) assign usher-day)
                (car ushers)
                (loop (cdr ushers)))))))

(define (pick-partner usher-day)
   (let loop ((ushers (get-field ushers-scheduled usher-day)))
     (cond ((null? ushers) #f)
           (else
            (let ((partner (find-partner usher-day (car ushers))))
              (if (and partner (send partner assign usher-day))
                  partner
                  (loop (cdr ushers))))))))

(define (usher-by-name name)
   (define (ubn name ul)
     (cond ((null? ul) #f)
           ((equal? name (get-field name (car ul))) (car ul))
           (else (ubn name (cdr ul)))))
   (ubn name all-ushers))

(define (find-partner usher-day usher)
   (let ((partner (usher-by-name (get-field partner usher))))
     (if (or (not partner)
             (not (usher-available? partner usher-day)))
         #f
         partner)))

(assign-ushers usher-days)