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
