Ruby Quiz 144 (in CL)

There was a small posting on c.l.l asking if anyone felt like completing Ruby quiz 144 in CL and after eric's solution I thought I'd give it a go.

This needs :cl-ppcre and :alexandria (and :lisp-unit to run the tests)
Apologies for formatting screwiness.

(defpackage :time-window (:use :cl :cl-ppcre :alexandria)
  (:export #:in-window-p))

(in-package :time-window)

;(defparameter *window* "Sat-Mon; Mon Wed 0700-0900; Thu 0700-0900 1000-1200")

;; This works by converting a spec (like the one above) into it's seperate components (split by ;)
;; and converting each spec into distinct time and day parts (expanding day ranges as we go)
;; so the above would be converted into the following
;; ((nil                       ("Sat" "Sun" "Mon"))
;;  (("0700-0900")             ("Mon" "Wed"))
;;  (("0700-0900" "1000-1200") ("Thu")))
;; We can then walk through each converted spec ensuring that the time specified falls into
;; the time/day specified.

(defun in-window-p (time window)
  (some (lambda (spec)
          (every (lambda (part)
                   (if (null part)
                       t ;; since (some (constantly t) ()) is nil
                       (some (curry 'time-within time) part)))
                 spec))
        (mapcar (lambda (split)
                  (group-by-type (split " " (string-trim " " split))))
                (split ";" window))))

(defun group-by-type (list)
  (loop for spec in list
        :when (time-range-p spec) :collect spec :into times
        :when (single-day-p spec) :collect spec :into days
        :when (day-range-p spec) :append (days-of spec) :into days
        :finally (return (list times days))))

(defparameter *days*
  '(("Mon" . 0) ("Tue" . 1) ("Wed" . 2) ("Thu" . 3) ("Fri" . 4) ("Sat" . 5) ("Sun" . 6)))

(defparameter *day-ring* (let ((list (copy-list *days*)))
                           (setf (cdr (last list)) list)
                           list))

(defun single-day-p (spec)
  (assoc spec *days* :test 'string=))

(defun day<-spec (spec)
  (cdr (single-day-p spec)))

(defun day-range-p (spec)
  (and (= (count #\- spec) 1)
       (every 'single-day-p (split "-" spec))))

(defun days-of (spec)
  (assert (day-range-p spec))
  (destructuring-bind (start stop) (split "-" spec)
    (loop :for (day . nil) :in (member start *day-ring* :key 'first :test 'string=)
          :collect day
          :until (string= day stop))))

(defun single-time-p (spec)
  (every 'digit-char-p spec))

(defun time-range-p (spec)
  (and (= 1 (count #\- spec))
       (every 'single-time-p (split "-" spec))))

(defun time-in-range (hour minute start stop)
  (flet ((to-mins (x) (+ (* 60 (parse-integer (subseq x 0 2)))
                         (parse-integer (subseq x 2 4)))))
    (<= (to-mins start) (+ (* 60 hour) minute) (1- (to-mins stop)))))

(defun time-within (time spec)
  (multiple-value-bind (sec minute hour date month year day)
      (decode-universal-time time 0)
    (declare (ignore sec date month year))
    (cond ((single-day-p spec) (= day (day<-spec spec)))
          ((time-range-p spec)
           (apply #'time-in-range hour minute (split "-" spec))))))


;;; and a small test package
(defpackage :time-window.tests (:use :time-window :lisp-unit :cl))
(in-package :time-window.tests)

;; Tests
(define-test window-tests
  (let ((window "Sat-Sun; Mon Wed 0700-0900; Thu 0700-0900 1000-1200"))
    (flet ((in (sec hour date month year)
             (in-window-p (encode-universal-time 0 sec hour date month year 0) window)))
    (assert-false (in 0 8 25 9 2007))
    (assert-true  (in 0 8 26 9 2007))
    (assert-false (in 0 11 26 9 2007))
    (assert-false (in 59 6 27 9 2007))
    (assert-true (in 0 7 27 9 2007))
    (assert-true (in 59 8 27 9 2007))
    (assert-false (in 0 9 27 9 2007))
    (assert-true (in 0 11 27 9 2007))
    (assert-true (in 0 11 29 9 2007))
    (assert-true (in 0 0 29 9 2007))
    (assert-true (in 59 23 29 9 2007))
    )))

(define-test window-tests2
  (let ((window "Fri-Mon"))
    (flet ((in (date month year)
             (in-window-p (encode-universal-time 0 0 0 date month year 0) window)))
      (assert-false (in 27 9 2007))
      (assert-true (in 28 9 2007))
      (assert-true (in 29 9 2007))
      (assert-true (in 30 9 2007))
      (assert-true (in 1 10 2007))
      (assert-false (in 2 10 2007)))))

(run-tests)

Nothing flashy but it does remind me how useful circular lists can be.
Comments, as always, are welcomed.

---
This post brought to you by Lispworks 5.0.2