;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-

;;;; *************************************************************************

;;;;

;;;; A variety of structures and function for creating and

;;;; manipulating dates, times, durations and intervals for

;;;; CLSQL.

;;;;

;;;; This file was originally part of ODCL and is Copyright (c) 2002 -

;;;; 2003 onShore Development, Inc.

;;;;

;;;; CLSQL users are granted the rights to distribute and use this software

;;;; as governed by the terms of the Lisp Lesser GNU Public License

;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.

;;;; *************************************************************************

(in-package #:clsql-sys)

;; ------------------------------------------------------------

;; Months

(defvar *month-keywords*

'(:january :february :march :april :may :june :july :august :september

:october :november :december))

(defvar *month-names*

'("" "January" "February" "March" "April" "May" "June" "July" "August"

"September" "October" "November" "December"))

(defun month-name (month-index)

(nth month-index *month-names*))

(defun ordinal-month (month-keyword)

"Return the zero-based month number for the given MONTH keyword."

(position month-keyword *month-keywords*))

;; ------------------------------------------------------------

;; Days

(defvar *day-keywords*

'(:sunday :monday :tuesday :wednesday :thursday :friday :saturday))

(defvar *day-names*

'("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))

(defun day-name (day-index)

(nth day-index *day-names*))

(defun ordinal-day (day-keyword)

"Return the zero-based day number for the given DAY keyword."

(position day-keyword *day-keywords*))

;; ------------------------------------------------------------

;; time classes: wall-time, duration

(eval-when (:compile-toplevel :load-toplevel)

(defstruct (wall-time (:conc-name time-)

(:constructor %make-wall-time)

(:print-function %print-wall-time))

(mjd 0 :type fixnum)

(second 0 :type fixnum)

(usec 0 :type fixnum))

(defun %print-wall-time (time stream depth)

(declare (ignore depth))

(if *print-escape*

(format stream "#<WALL-TIME: ~a>" (format-time nil time))

(format-time stream time :format :pretty)))

(defstruct (duration (:constructor %make-duration)

(:print-function %print-duration))

(year 0 :type fixnum)

(month 0 :type fixnum)

(day 0 :type fixnum)

(hour 0 :type fixnum)

(second 0 :type fixnum)

(minute 0 :type fixnum)

(usec 0 :type fixnum))

(defun %print-duration (duration stream depth)

(declare (ignore depth))

(if *print-escape*

(format stream "#<DURATION: ~a>"

(format-duration nil duration :precision :second))

(format-duration stream duration :precision :second)))

(defstruct (date (:constructor %make-date)

(:print-function %print-date))

(mjd 0 :type fixnum))

(defun %print-date (date stream depth)

(declare (ignore depth))

(if *print-escape*

(format stream "#<DATE: ~a>" (format-date nil date))

(format-date stream date :format :pretty)))

);eval-when

(defun duration-timestring (duration)

(let ((second (duration-second duration))

(minute (duration-minute duration))

(hour (duration-hour duration))

(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)))

;; ------------------------------------------------------------

;; Constructors

(defun make-time (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)

(second 0) (usec 0) (offset 0))

(let ((mjd (gregorian-to-mjd month day year))

(sec (+ (* hour 60 60)

(* minute 60)

second (- offset))))

(multiple-value-bind (day-add raw-sec)

(floor sec (* 60 60 24))

(%make-wall-time :mjd (+ mjd day-add) :second raw-sec :usec usec))))

(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

:minute minute :second second :usec usec :offset offset)))

(defun copy-time (time)

(%make-wall-time :mjd (time-mjd time)

:second (time-second time)))

(defun utime->time (utime)

"Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"

(multiple-value-bind (second minute hour day mon year)

(decode-universal-time utime)

(make-time :year year :month mon :day day :hour hour :minute minute

:second second)))

(defun date->time (date)

"Returns a walltime for the given date"

(%make-wall-time :mjd (date-mjd date)))

(defun time->date (time)

"Returns a date for the given wall time (obvious loss in resolution)"

(%make-date :mjd (time-mjd time)))

(defun get-time ()

"Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"

(utime->time (get-universal-time)))

(defun get-date ()

"Returns a date for today"

(time->date (get-time)))

(defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0)

(second 0) (usec 0))

(multiple-value-bind (second-add usec-1000000)

(floor usec 1000000)

(multiple-value-bind (minute-add second-60)

(floor (+ second second-add) 60)

(multiple-value-bind (hour-add minute-60)

(floor (+ minute minute-add) 60)

(multiple-value-bind (day-add hour-24)

(floor (+ hour hour-add) 24)

(%make-duration :year year :month month :day (+ day day-add)

:hour hour-24

:minute minute-60

:second second-60

:usec usec-1000000))))))

;; ------------------------------------------------------------

;; Accessors

(defun time-hms (time)

(multiple-value-bind (hourminute second)

(floor (time-second time) 60)

(multiple-value-bind (hour minute)

(floor hourminute 60)

(values hour minute second))))

(defun time-ymd (time)

(destructuring-bind (month day year)

(mjd-to-gregorian (time-mjd time))

(values year month day)))

(defun time-dow (time)

"Return the 0 indexed Day of the week starting with Sunday"

(mod (+ 3 (time-mjd time)) 7))

(defun decode-time (time)

"returns the decoded time as multiple values: usec, second, minute, hour,

day, month, year, integer day-of-week"

(multiple-value-bind (year month day)

(time-ymd time)

(multiple-value-bind (hour minute second)

(time-hms time)

(values (time-usec time) second minute hour day month year (mod (+ (time-mjd time) 3) 7)))))

(defun date-ymd (date)

(time-ymd (date->time date)))

(defun date-dow (date)

(time-dow (date->time date)))

(defun decode-date (date)

"returns the decoded date as multiple values: day month year integer day-of-week"

(multiple-value-bind (year month day)

(time-ymd (date->time date))

(values day month year (date-dow date))))

;; duration specific

(defun duration-reduce (duration precision &optional round)

(ecase precision

(:usec

(+ (duration-usec duration)

(* (duration-reduce duration :second) 1000000)))

(:second

(+ (if round

(floor (duration-usec duration) 500000)

0)

(duration-second duration)

(* (duration-reduce duration :minute) 60)))

(:minute

(+ (if round

(floor (duration-second duration) 30)

0)

(duration-minute duration)

(* (duration-reduce duration :hour) 60)))

(:hour

(+ (if round

(floor (duration-minute duration) 30)

0)

(duration-hour duration)

(* (duration-reduce duration :day) 24)))

(:day

(+ (if round

(floor (duration-hour duration) 12)

0)

(duration-day duration)))))

;; ------------------------------------------------------------

;; Arithemetic and comparators

(defun duration= (duration-a duration-b)

(= (duration-reduce duration-a :usec)

(duration-reduce duration-b :usec)))

(defun duration< (duration-a duration-b)

(< (duration-reduce duration-a :usec)

(duration-reduce duration-b :usec)))

(defun duration<= (duration-a duration-b)

(<= (duration-reduce duration-a :usec)

(duration-reduce duration-b :usec)))

(defun duration>= (x y)

(duration<= y x))

(defun duration> (x y)

(duration< y x))

(defun %time< (x y)

(let ((mjd-x (time-mjd x))

(mjd-y (time-mjd y)))

(if (/= mjd-x mjd-y)

(< mjd-x mjd-y)

(if (/= (time-second x) (time-second y))

(< (time-second x) (time-second y))

(< (time-usec x) (time-usec y))))))

(defun %time>= (x y)

(if (/= (time-mjd x) (time-mjd y))

(>= (time-mjd x) (time-mjd y))

(if (/= (time-second x) (time-second y))

(>= (time-second x) (time-second y))

(>= (time-usec x) (time-usec y)))))

(defun %time<= (x y)

(if (/= (time-mjd x) (time-mjd y))

(<= (time-mjd x) (time-mjd y))

(if (/= (time-second x) (time-second y))

(<= (time-second x) (time-second y))

(<= (time-usec x) (time-usec y)))))

(defun %time> (x y)

(if (/= (time-mjd x) (time-mjd y))

(> (time-mjd x) (time-mjd y))

(if (/= (time-second x) (time-second y))

(> (time-second x) (time-second y))

(> (time-usec x) (time-usec y)))))

(defun %time= (x y)

(and (= (time-mjd x) (time-mjd y))

(= (time-second x) (time-second y))

(= (time-usec x) (time-usec y))))

(defun time= (number &rest more-numbers)

"Returns T if all of its arguments are numerically equal, NIL otherwise."

(do ((nlist more-numbers (cdr nlist)))

((atom nlist) t)

(declare (list nlist))

(if (not (%time= (car nlist) number)) (return nil))))

(defun time/= (number &rest more-numbers)

"Returns T if no two of its arguments are numerically equal, NIL otherwise."

(do* ((head number (car nlist))

(nlist more-numbers (cdr nlist)))

((atom nlist) t)

(declare (list nlist))

(unless (do* ((nl nlist (cdr nl)))

((atom nl) t)

(declare (list nl))

(if (%time= head (car nl)) (return nil)))

(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))

(nlist more-numbers (cdr nlist)))

((atom nlist) t)

(declare (list nlist))

(if (not (%time< n (car nlist))) (return nil))))

(defun time> (number &rest more-numbers)

"Returns T if its arguments are in strictly decreasing order, NIL otherwise."

(do* ((n number (car nlist))

(nlist more-numbers (cdr nlist)))

((atom nlist) t)

(declare (list nlist))

(if (not (%time> n (car nlist))) (return nil))))

(defun time<= (number &rest more-numbers)

"Returns T if arguments are in strictly non-decreasing order, NIL otherwise."

(do* ((n number (car nlist))

(nlist more-numbers (cdr nlist)))

((atom nlist) t)

(declare (list nlist))

(if (not (%time<= n (car nlist))) (return nil))))

(defun time>= (number &rest more-numbers)

"Returns T if arguments are in strictly non-increasing order, NIL otherwise."

(do* ((n number (car nlist))

(nlist more-numbers (cdr nlist)))

((atom nlist) t)

(declare (list nlist))

(if (not (%time>= n (car nlist))) (return nil))))

(defun time-max (number &rest more-numbers)

"Returns the greatest of its arguments."

(do ((nlist more-numbers (cdr nlist))

(result number))

((null nlist) (return result))

(declare (list nlist))

(if (%time> (car nlist) result) (setf result (car nlist)))))

(defun time-min (number &rest more-numbers)

"Returns the least of its arguments."

(do ((nlist more-numbers (cdr nlist))

(result number))

((null nlist) (return result))

(declare (list nlist))

(if (%time< (car nlist) result) (setf result (car nlist)))))

(defun time-compare (time-a time-b)

(let ((mjd-a (time-mjd time-a))

(mjd-b (time-mjd time-b))

(sec-a (time-second time-a))

(sec-b (time-second time-b))

(usec-a (time-usec time-a))

(usec-b (time-usec time-b)))

(if (= mjd-a mjd-b)

(if (= sec-a sec-b)

(if (= usec-a usec-b)

:equal

(if (< usec-a usec-b)

:less-than

:greater-than))

(if (< sec-a sec-b)

:less-than

:greater-than))

(if (< mjd-a mjd-b)

:less-than

:greater-than))))

; now the same for dates

(eval-when (:compile-toplevel :load-toplevel)

(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))

(search-string-length (length search-string)))

(labels ((sub-replace-string (current-string position)

(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))))))

(sub-replace-string string1 0))))

);eval-when

(defmacro wrap-time-for-date (time-func &key (result-func))

(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)))))

,(if result-func

`(funcall #',result-func result)

'result)))))

(wrap-time-for-date time=)

(wrap-time-for-date time/=)

(wrap-time-for-date time<)

(wrap-time-for-date time>)

(wrap-time-for-date time<=)

(wrap-time-for-date time>=)

(wrap-time-for-date time-max :result-func time->date)

(wrap-time-for-date time-min :result-func time->date)

(defun date-compare (date-a date-b)

(time-compare (date->time date-a) (date->time date-b)))

;; ------------------------------------------------------------

;; Formatting and output

(defvar +decimal-printer+ #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))

(defun db-timestring (time)

"return the string to store the given time in the database"

(declare (optimize (speed 3)))

(let ((output (copy-seq "'XXXX-XX-XX XX:XX:XX.")))

(flet ((inscribe-base-10 (output offset size decimal)

(declare (type fixnum offset size decimal)

(type (simple-vector 10) +decimal-printer+))

(dotimes (x size)

(declare (type fixnum x)

(optimize (safety 0)))

(multiple-value-bind (next this)

(floor decimal 10)

(setf (aref output (+ (- size x 1) offset))

(aref +decimal-printer+ this))

(setf decimal next)))))

(multiple-value-bind (usec second minute hour day month year)

(decode-time time)

(inscribe-base-10 output 1 4 year)

(inscribe-base-10 output 6 2 month)

(inscribe-base-10 output 9 2 day)

(inscribe-base-10 output 12 2 hour)

(inscribe-base-10 output 15 2 minute)

(inscribe-base-10 output 18 2 second)

(format nil "~a~d'" output usec)))))

(defun iso-timestring (time)

"return the string to store the given time in the database"

(declare (optimize (speed 3)))

(let ((output (copy-seq "XXXX-XX-XX XX:XX:XX,")))

(flet ((inscribe-base-10 (output offset size decimal)

(declare (type fixnum offset size decimal)

(type (simple-vector 10) +decimal-printer+))

(dotimes (x size)

(declare (type fixnum x)

(optimize (safety 0)))

(multiple-value-bind (next this)

(floor decimal 10)

(setf (aref output (+ (- size x 1) offset))

(aref +decimal-printer+ this))

(setf decimal next)))))

(multiple-value-bind (usec second minute hour day month year)

(decode-time time)

(inscribe-base-10 output 0 4 year)

(inscribe-base-10 output 5 2 month)

(inscribe-base-10 output 8 2 day)

(inscribe-base-10 output 11 2 hour)

(inscribe-base-10 output 14 2 minute)

(inscribe-base-10 output 17 2 second)

(format nil "~a,~d" output usec)))))

(defun db-datestring (date)

(db-timestring (date->time date)))

(defun iso-datestring (date)

(iso-timestring (date->time date)))

;; ------------------------------------------------------------

;; Intervals

(defstruct interval

(start nil)

(end nil)

(name nil)

(contained nil)

(type nil)

(data nil))

;; fix : should also return :contains / :contained

(defun interval-relation (x y)

"Compare the relationship of node x to node y. Returns either

:contained :contains :follows :overlaps or :precedes."

(let ((xst (interval-start x))

(xend (interval-end x))

(yst (interval-start y))

(yend (interval-end y)))

(case (time-compare xst yst)

(:equal

(case (time-compare xend yend)

(:less-than

:contained)

((:equal :greater-than)

:contains)))

(:greater-than

(case (time-compare xst yend)

((:equal :greater-than)

:follows)

(:less-than

(case (time-compare xend yend)

((:less-than :equal)

:contained)

((:greater-than)

:overlaps)))))

(:less-than

(case (time-compare xend yst)

((:equal :less-than)

:precedes)

(:greater-than

(case (time-compare xend yend)

(:less-than

:overlaps)

((:equal :greater-than)

:contains))))))))

;; ------------------------------------------------------------

;; interval lists

(defun sort-interval-list (list)

(sort list (lambda (x y)

(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)

(declare (ignore container-rule))

(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")))))

(append sorted-list (list interval))))

;; interval lists

(defun interval-match (list time)

"Return the index of the first interval in list containing time"

;; this depends on ordering of intervals!

(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))))))

(defun interval-clear (list time)

(dotimes (x (length list))

(let ((elt (nth x list)))

(when (and (time<= (interval-start elt) time)

(time< time (interval-end elt)))

(if (interval-match (interval-contained elt) time)

(return-from interval-clear

(replace-at-index x list

(make-interval :start (interval-start elt)

:end (interval-end elt)

:type (interval-type elt)

:contained (interval-clear (interval-contained elt) time)

:data (interval-data elt))))

(return-from interval-clear

(delete-at-index x list)))))))

(defun interval-edit (list time start end &optional tag)

"Attempts to modify the most deeply nested interval in list which

begins at time. If no changes are made, returns nil."

;; function required sorted interval list

(let ((list (sort-interval-list list)))

(if (null list) nil

(dotimes (x (length list))

(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)))

(dolist (elt list)

(when (equal :contained

(interval-relation elt test-interval))

(push elt newlist)))

(nreverse newlist)))

;;; utils from odcl/list.lisp

(defun replace-at-index (idx list elt)

(cond ((= idx 0)

(cons elt (cdr list)))

((= idx (1- (length list)))

(append (butlast list) (list elt)))

(t

(append (subseq list 0 idx)

(list elt)

(subseq list (1+ idx))))))

(defun insert-at-index (idx list elt)

(cond ((= idx 0)

(cons elt list))

((= idx (1- (length list)))

(append list (list elt)))

(t

(append (subseq list 0 idx)

(list elt)

(subseq list idx)))))

(defun delete-at-index (idx list)

(cond ((= idx 0)

(cdr list))

((= idx (1- (length list)))

(butlast list))

(t

(append (subseq list 0 idx)

(subseq list (1+ idx))))))

;; ------------------------------------------------------------

;; return MJD for Gregorian date

(defun gregorian-to-mjd (month day year)

(let ((b 0)

(month-adj month)

(year-adj (if (< year 0)

(+ year 1)

year))

d

c)

(when (< month 3)

(incf month-adj 12)

(decf year-adj))

(unless (or (< year 1582)

(and (= year 1582)

(or (< month 10)

(and (= month 10)

(< day 15)))))

(let ((a (floor (/ year-adj 100))))

(setf b (+ (- 2 a) (floor (/ a 4))))))

(if (< year-adj 0)

(setf c (floor (- (* 365.25d0 year-adj) 679006.75d0)))

(setf c (floor (- (* 365.25d0 year-adj) 679006d0))))

(setf d (floor (* 30.6001 (+ 1 month-adj))))

;; (cmsg "b ~s c ~s d ~s day ~s" b c d day)

(+ b c d day)))

;; convert MJD to Gregorian date

(defun mjd-to-gregorian (mjd)

(let (z r g a b c year month day)

(setf z (floor (+ mjd 678882)))

(setf r (- (+ mjd 678882) z))

(setf g (- z .25))

(setf a (floor (/ g 36524.25)))

(setf b (- a (floor (/ a 4))))

(setf year (floor (/ (+ b g) 365.25)))

(setf c (- (+ b z) (floor (* 365.25 year))))

(setf month (truncate (/ (+ (* 5 c) 456) 153)))

(setf day (+ (- c (truncate (/ (- (* 153 month) 457) 5))) r))

(when (> month 12)

(incf year)

(decf month 12))

(list month day year)))

(defun duration+ (time &rest durations)

"Add each DURATION to TIME, returning a new wall-time value."

(let ((year (duration-year time))

(month (duration-month time))

(day (duration-day time))

(hour (duration-hour time))

(minute (duration-minute time))

(second (duration-second time))

(usec (duration-usec time)))

(dolist (duration durations)

(incf year (duration-year duration))

(incf month (duration-month duration))

(incf day (duration-day duration))

(incf hour (duration-hour duration))

(incf minute (duration-minute duration))

(incf second (duration-second duration))

(incf usec (duration-usec duration)))

(make-duration :year year :month month :day day :hour hour :minute minute

:second second :usec usec)))

(defun duration- (duration &rest durations)

"Subtract each DURATION from TIME, returning a new duration value."

(let ((year (duration-year duration))

(month (duration-month duration))

(day (duration-day duration))

(hour (duration-hour duration))

(minute (duration-minute duration))

(second (duration-second duration))

(usec (duration-usec duration)))

(dolist (duration durations)

(decf year (duration-year duration))

(decf month (duration-month duration))

(decf day (duration-day duration))

(decf hour (duration-hour duration))

(decf minute (duration-minute duration))

(decf second (duration-second duration))

(decf usec (duration-usec duration)))

(make-duration :year year :month month :day day :hour hour :minute minute

:second second :usec usec)))

;; Date + Duration

(defun time+ (time &rest durations)

"Add each DURATION to TIME, returning a new wall-time value."

(let ((new-time (copy-time time)))

(dolist (duration durations)

(roll new-time

:year (duration-year duration)

:month (duration-month duration)

:day (duration-day duration)

:hour (duration-hour duration)

:minute (duration-minute duration)

:second (duration-second duration)

:usec (duration-usec duration)

:destructive t))

new-time))

(defun date+ (date &rest durations)

"Add each DURATION to DATE, returning a new date value.

Note that (barring daylight saving time) 12h + 12h will result in a new day, but doing

it as separate calculations will not, as the time is chopped to a date before being returned."

(time->date (apply #'time+ (cons (date->time date) durations))))

(defun time- (time &rest durations)

"Subtract each DURATION from TIME, returning a new wall-time value."

(let ((new-time (copy-time time)))

(dolist (duration durations)

(roll new-time

:year (- (duration-year duration))

:month (- (duration-month duration))

:day (- (duration-day duration))

:hour (- (duration-hour duration))

:minute (- (duration-minute duration))

:second (- (duration-second duration))

:usec (- (duration-usec duration))

:destructive t))

new-time))

(defun date- (date &rest durations)

"Subtract each DURATION to DATE, returning a new date value.

Note that (barring daylight saving time) 12h + 12h will result in a new day, but doing

it as separate calculations will not, as the time is chopped to a date before being returned."

(time->date (apply #'time- (cons (date->time date) durations))))

(defun time-difference (time1 time2)

"Returns a DURATION representing the difference between TIME1 and

TIME2."

(flet ((do-diff (time1 time2)

(let (day-diff sec-diff)

(setf day-diff (- (time-mjd time2)

(time-mjd time1)))

(if (> day-diff 0)

(progn (decf day-diff)

(setf sec-diff (+ (time-second time2)

(- (* 60 60 24)

(time-second time1)))))

(setf sec-diff (- (time-second time2)

(time-second time1))))

(make-duration :day day-diff

:second sec-diff))))

(if (time< time1 time2)

(do-diff time1 time2)

(do-diff time2 time1))))

(defun date-difference (date1 date2)

"Returns a DURATION representing the difference between TIME1 and

TIME2."

(time-difference (date->time date1) (date->time date2)))

(defun format-date (stream date &key format

(date-separator "-")

(internal-separator " "))

"produces on stream the datestring corresponding to the date

with the given options"

(format-time stream (date->time date)

:format format

:date-separator date-separator

:internal-separator internal-separator))

(defun format-time (stream time &key format

(date-separator "-")

(time-separator ":")

(internal-separator " "))

"produces on stream the timestring corresponding to the wall-time

with the given options"

(let ((*print-circle* nil))

(multiple-value-bind (usec second minute hour day month year dow)

(decode-time time)

(case format

(: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)

string)))

(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 pretty-time (hour minute)

(cond

((eq hour 0)

(format nil "12:~2,'0D AM" minute))

((eq hour 12)

(format nil "12:~2,'0D PM" minute))

((< hour 12)

(format nil "~D:~2,'0D AM" hour minute))

((and (> hour 12) (< hour 24))

(format nil "~D:~2,'0D PM" (- hour 12) minute))

(t

(error "pretty-time got bad hour"))))

(defun leap-days-in-days (days)

;; return the number of leap days between Mar 1 2000 and

;; (Mar 1 2000) + days, where days can be negative

(if (< days 0)

(ceiling (/ (- days) (* 365 4)))

(floor (/ days (* 365 4)))))

(defun current-year ()

(third (mjd-to-gregorian (time-mjd (get-time)))))

(defun current-month ()

(first (mjd-to-gregorian (time-mjd (get-time)))))

(defun current-day ()

(second (mjd-to-gregorian (time-mjd (get-time)))))

(defun parse-date-time (string)

"parses date like 08/08/01, 8.8.2001, eg"

(when (> (length string) 1)

(let ((m (current-month))

(d (current-day))

(y (current-year)))

(let ((integers (mapcar #'parse-integer (hork-integers string))))

(case (length integers)

(1

(setf y (car integers)))

(2

(setf m (car integers))

(setf y (cadr integers)))

(3

(setf m (car integers))

(setf d (cadr integers))

(setf y (caddr integers)))

(t

(return-from parse-date-time))))

(when (< y 100)

(incf y 2000))

(make-time :year y :month m :day d))))

(defun hork-integers (input)

(let ((output '())

(start 0))

(dotimes (x (length input))

(unless (<= 48 (char-code (aref input x)) 57)

(push (subseq input start x) output)

(setf start (1+ x))))

(nreverse (push (subseq input start) output))))

(defun merged-time (day time-of-day)

(%make-wall-time :mjd (time-mjd day)

:second (time-second time-of-day)))

(defun time-meridian (hours)

(cond ((= hours 0)

(values 12 "AM"))

((= hours 12)

(values 12 "PM"))

((< 12 hours)

(values (- hours 12) "PM"))

(t

(values hours "AM"))))

(defgeneric to-string (val &rest keys)

)

(defmethod to-string ((time wall-time) &rest keys)

(destructuring-bind (&key (style :daytime) &allow-other-keys)

keys

(print-date time style)))

(defun print-date (time &optional (style :daytime))

(multiple-value-bind (usec second minute hour day month year dow)

(decode-time time)

(declare (ignore usec second))

(multiple-value-bind (hours meridian)

(time-meridian hour)

(ecase style

(:time-of-day

;; 2:00 PM

(format nil "~d:~2,'0d ~a" hours minute meridian))

(:long-day

;; October 11th, 2000

(format nil "~a ~d, ~d" (month-name month) day year))

(:month

;; October

(month-name month))

(:month-year

;; October 2000

(format nil "~a ~d" (month-name month) year))

(:full

;; 11:08 AM, November 22, 2002

(format nil "~d:~2,'0d ~a, ~a ~d, ~d"

hours minute meridian (month-name month) day year))

(:full+weekday

;; 11:09 AM Friday, November 22, 2002

(format nil "~d:~2,'0d ~a ~a, ~a ~d, ~d"

hours minute meridian (nth dow *day-names*)

(month-name month) day year))

(:daytime

;; 11:09 AM, 11/22/2002

(format-time nil time :format :short-pretty))

(:day

;; 11/22/2002

(format nil "~d/~d/~d" month day year))))))

(defun time-element (time element)

(multiple-value-bind (usec second minute hour day month year dow)

(decode-time time)

(declare (ignore usec))

(ecase element

(:seconds

second)

(:minutes

minute)

(:hours

hour)

(:day-of-month

day)

(:integer-day-of-week

dow)

(:day-of-week

(nth dow *day-keywords*))

(:month

month)

(:year

year))))

(defun date-element (date element)

(time-element (date->time date) element))