(let ((second (duration-second duration))
(minute (duration-minute duration))
(hour (duration-hour duration))
(let ((second (duration-second duration))
(minute (duration-minute duration))
(hour (duration-hour duration))
- (day (duration-day duration)))
- (format nil "P~dD~dH~dM~dS" day hour minute second)))
+ (day (duration-day duration))
+ (month (duration-month duration))
+ (year (duration-year duration)))
+ (format nil "P~dY~dM~dD~dH~dM~dS" year month day hour minute second)))
(defun make-date (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)
(second 0) (usec 0) (offset 0))
(time->date (make-time :year year :month month :day day :hour hour
(defun make-date (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)
(second 0) (usec 0) (offset 0))
(time->date (make-time :year year :month month :day day :hour hour
- (floor (duration-minute duration) 30)
- 0)
- (duration-hour duration)
- (* (duration-reduce duration :day) 24)))
+ (floor (duration-minute duration) 30)
+ 0)
+ (duration-hour duration)
+ (* (duration-reduce duration :day) 24)))
(defun time/= (number &rest more-numbers)
"Returns T if no two of its arguments are numerically equal, NIL otherwise."
(do* ((head number (car nlist))
(defun time/= (number &rest more-numbers)
"Returns T if no two of its arguments are numerically equal, NIL otherwise."
(do* ((head number (car nlist))
(return nil))))
(defun time< (number &rest more-numbers)
"Returns T if its arguments are in strictly increasing order, NIL otherwise."
(do* ((n number (car nlist))
(return nil))))
(defun time< (number &rest more-numbers)
"Returns T if its arguments are in strictly increasing order, NIL otherwise."
(do* ((n number (car nlist))
(defun time> (number &rest more-numbers)
"Returns T if its arguments are in strictly decreasing order, NIL otherwise."
(do* ((n number (car nlist))
(defun time> (number &rest more-numbers)
"Returns T if its arguments are in strictly decreasing order, NIL otherwise."
(do* ((n number (car nlist))
(defun time<= (number &rest more-numbers)
"Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
(do* ((n number (car nlist))
(defun time<= (number &rest more-numbers)
"Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
(do* ((n number (car nlist))
(defun time>= (number &rest more-numbers)
"Returns T if arguments are in strictly non-increasing order, NIL otherwise."
(do* ((n number (car nlist))
(defun time>= (number &rest more-numbers)
"Returns T if arguments are in strictly non-increasing order, NIL otherwise."
(do* ((n number (car nlist))
(defun replace-string (string1 search-string replace-string &key (test #'string=))
"Search within string1 for search-string, replace with replace-string, non-destructively."
(let ((replace-string-length (length replace-string))
(defun replace-string (string1 search-string replace-string &key (test #'string=))
"Search within string1 for search-string, replace with replace-string, non-destructively."
(let ((replace-string-length (length replace-string))
- (let ((found-position (search search-string current-string :test test :start2 position)))
- (if (null found-position)
- current-string
- (sub-replace-string (concatenate 'string
- (subseq current-string 0 found-position)
- replace-string
- (subseq current-string (+ found-position search-string-length)))
- (+ position replace-string-length))))))
+ (let ((found-position (search search-string current-string :test test :start2 position)))
+ (if (null found-position)
+ current-string
+ (sub-replace-string (concatenate 'string
+ (subseq current-string 0 found-position)
+ replace-string
+ (subseq current-string (+ found-position search-string-length)))
+ (+ position replace-string-length))))))
- (let ((date-func (intern (replace-string (symbol-name time-func) "TIME" "DATE"))))
+ (let ((date-func (intern (replace-string (symbol-name time-func)
+ (symbol-name-default-case "TIME")
+ (symbol-name-default-case "DATE")))))
`(defun ,date-func (number &rest more-numbers)
(let ((result (apply #',time-func (mapcar #'date->time (cons number more-numbers)))))
`(defun ,date-func (number &rest more-numbers)
(let ((result (apply #',time-func (mapcar #'date->time (cons number more-numbers)))))
- (case (interval-relation x y)
- ((:precedes :contains) t)
- ((:follows :overlaps :contained) nil)))))
+ (case (interval-relation x y)
+ ((:precedes :contains) t)
+ ((:follows :overlaps :contained) nil)))))
;; interval push will return its list of intervals in strict order.
(defun interval-push (interval-list interval &optional container-rule)
;; interval push will return its list of intervals in strict order.
(defun interval-push (interval-list interval &optional container-rule)
(let ((sorted-list (sort-interval-list interval-list)))
(dotimes (x (length sorted-list))
(let ((elt (nth x sorted-list)))
(let ((sorted-list (sort-interval-list interval-list)))
(dotimes (x (length sorted-list))
(let ((elt (nth x sorted-list)))
- (case (interval-relation elt interval)
- (:follows
- (return-from interval-push (insert-at-index x sorted-list interval)))
- (:contains
- (return-from interval-push
- (replace-at-index x sorted-list
- (make-interval :start (interval-start elt)
- :end (interval-end elt)
- :type (interval-type elt)
- :contained (interval-push (interval-contained elt) interval)
- :data (interval-data elt)))))
- ((:overlaps :contained)
- (error "Overlap")))))
+ (case (interval-relation elt interval)
+ (:follows
+ (return-from interval-push (insert-at-index x sorted-list interval)))
+ (:contains
+ (return-from interval-push
+ (replace-at-index x sorted-list
+ (make-interval :start (interval-start elt)
+ :end (interval-end elt)
+ :type (interval-type elt)
+ :contained (interval-push (interval-contained elt) interval)
+ :data (interval-data elt)))))
+ ((:overlaps :contained)
+ (error "Overlap")))))
(let ((list (sort-interval-list list)))
(dotimes (x (length list))
(let ((elt (nth x list)))
(let ((list (sort-interval-list list)))
(dotimes (x (length list))
(let ((elt (nth x list)))
- (when (and (time<= (interval-start elt) time)
- (time< time (interval-end elt)))
- (return-from interval-match x))))))
+ (when (and (time<= (interval-start elt) time)
+ (time< time (interval-end elt)))
+ (return-from interval-match x))))))
- (let ((elt (nth x list)))
- (when (and (time<= (interval-start elt) time)
- (time< time (interval-end elt)))
- (or (interval-edit (interval-contained elt) time start end tag)
- (cond ((and (< 0 x)
- (time< start (interval-end (nth (1- x) list))))
- (error "Overlap of previous interval"))
- ((and (< x (1- (length list)))
- (time< (interval-start (nth (1+ x) list)) end))
- (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end ))
- ((time= (interval-start elt) time)
- (return-from interval-edit
- (replace-at-index x list
- (make-interval :start start
- :end end
- :type (interval-type elt)
- :contained (restrict-intervals (interval-contained elt) start end)
- :data (or tag (interval-data elt))))))))))))))
+ (let ((elt (nth x list)))
+ (when (and (time<= (interval-start elt) time)
+ (time< time (interval-end elt)))
+ (or (interval-edit (interval-contained elt) time start end tag)
+ (cond ((and (< 0 x)
+ (time< start (interval-end (nth (1- x) list))))
+ (error "Overlap of previous interval"))
+ ((and (< x (1- (length list)))
+ (time< (interval-start (nth (1+ x) list)) end))
+ (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end ))
+ ((time= (interval-start elt) time)
+ (return-from interval-edit
+ (replace-at-index x list
+ (make-interval :start start
+ :end end
+ :type (interval-type elt)
+ :contained (restrict-intervals (interval-contained elt) start end)
+ :data (or tag (interval-data elt))))))))))))))
(defun restrict-intervals (list start end &aux newlist)
(let ((test-interval (make-interval :start start :end end)))
(defun restrict-intervals (list start end &aux newlist)
(let ((test-interval (make-interval :start start :end end)))
- (:pretty
- (format stream "~A ~A, ~A ~D, ~D"
- (pretty-time hour minute)
- (day-name dow)
- (month-name month)
- day
- year))
- (:short-pretty
- (format stream "~A, ~D/~D/~D"
- (pretty-time hour minute)
- month day year))
- (:iso
- (let ((string (iso-timestring time)))
- (if stream
- (write-string string stream)
+ (:pretty
+ (format stream "~A ~A, ~A ~D, ~D"
+ (pretty-time hour minute)
+ (day-name dow)
+ (month-name month)
+ day
+ year))
+ (:short-pretty
+ (format stream "~A, ~D/~D/~D"
+ (pretty-time hour minute)
+ month day year))
+ (:iso
+ (let ((string (iso-timestring time)))
+ (if stream
+ (write-string string stream)
- (t
- (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D.~6,'0D"
- year date-separator month date-separator day
- internal-separator hour time-separator minute time-separator
- second usec))))))
+ (t
+ (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D.~6,'0D"
+ year date-separator month date-separator day
+ internal-separator hour time-separator minute time-separator
+ second usec))))))
(defun parse-date-time (string)
"parses date like 08/08/01, 8.8.2001, eg"
(defun parse-date-time (string)
"parses date like 08/08/01, 8.8.2001, eg"
(minute (duration-minute duration))
(hour (duration-hour duration))
(day (duration-day duration))
(minute (duration-minute duration))
(hour (duration-hour duration))
(day (duration-day duration))
(defun parse-timestring (timestring &key (start 0) end junk-allowed)
"parse a timestring and return the corresponding wall-time. If the
(defun parse-timestring (timestring &key (start 0) end junk-allowed)
"parse a timestring and return the corresponding wall-time. If the
(declare (ignore junk-allowed))
(let ((string (subseq timestring start end)))
(if (char= (aref string 0) #\P)
(declare (ignore junk-allowed))
(let ((string (subseq timestring start end)))
(if (char= (aref string 0) #\P)
-(defun iso-8601-duration-subseq (string start)
- (let* ((pos (position-if #'iso-8601-delimiter string :start start))
- (number (when pos (parse-integer (subseq string start pos)
- :junk-allowed t))))
+(defun iso-8601-duration-subseq (string end)
+ (let* ((pos (position-if #'iso-8601-delimiter string :end end :from-end t))
+ (pos2 (when pos
+ (position-if-not #'digit-char-p string :end pos :from-end t)))
+ (number (when pos2
+ (parse-integer
+ (subseq string (1+ pos2) pos) :junk-allowed t))))
- (or (char= #\, (char string 19))
- (char= #\. (char string 19))))
+ (or (char= #\, (char string 19))
+ (char= #\. (char string 19))))
(multiple-value-bind (parsed-usec usec-end)
(parse-integer string :start 20 :junk-allowed t)
(setf usec (or parsed-usec 0)
(multiple-value-bind (parsed-usec usec-end)
(parse-integer string :start 20 :junk-allowed t)
(setf usec (or parsed-usec 0)
`((year . ,year) (month . ,month)
(day . ,day) (hour . ,hour)
(minute . ,minute) (second . ,second)
`((year . ,year) (month . ,month)
(day . ,day) (hour . ,hour)
(minute . ,minute) (second . ,second)