summaryrefslogtreecommitdiff
path: root/sql/time.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'sql/time.lisp')
-rw-r--r--sql/time.lisp1359
1 files changed, 1359 insertions, 0 deletions
diff --git a/sql/time.lisp b/sql/time.lisp
new file mode 100644
index 0000000..0bb18c3
--- /dev/null
+++ b/sql/time.lisp
@@ -0,0 +1,1359 @@
+;;;; -*- 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
+(defun db-timestring (time &key stream)
+ "return the string to store the given time in the database"
+ (if stream
+ (progn (write-char #\' stream) (iso-timestring time :stream stream) (write-char #\' stream))
+ (concatenate 'string "'" (iso-timestring time) "'")))
+
+(defun iso-timestring (time &key stream)
+ (multiple-value-bind (usec sec min hour day month year dow)
+ (decode-time time)
+ (declare (ignore dow))
+ (flet ((fmt (stream)
+ (when (< year 1000) (princ #\0 stream))
+ (when (< year 100) (princ #\0 stream))
+ (when (< year 10) (princ #\0 stream))
+ (princ year stream)
+ (princ #\- stream)
+ (when (< month 10) (princ #\0 stream))
+ (princ month stream)
+ (princ #\- stream)
+ (when (< day 10) (princ #\0 stream))
+ (princ day stream)
+ (princ #\T stream) ;strict ISO says T here isn't optional.
+ (when (< hour 10) (princ #\0 stream))
+ (princ hour stream)
+ (princ #\: stream)
+ (when (< min 10) (princ #\0 stream))
+ (princ min stream)
+ (princ #\: stream)
+ (when (< sec 10) (princ #\0 stream))
+ (princ sec stream)
+ (when (and usec (plusp usec))
+ ;; we dont do this because different dbs support differnt precision levels
+ (princ #\. stream)
+ (loop for i from 5 downto 0
+ for x10 = (expt 10 i)
+ do (multiple-value-bind (quo rem)
+ (floor (/ usec x10))
+ (setf usec (- usec (* quo x10)))
+ (princ quo stream)
+ (when (= rem 0) (return)))))
+ nil))
+ (if stream
+ (fmt stream)
+ (with-output-to-string (stream)
+ (fmt stream))))))
+
+(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 :iso8601) (iso-timestring time :stream 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)
+ )))))
+
+(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))
+
+(defun format-duration (stream duration &key (precision :minute))
+ (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))
+ (return (null stream))
+ (stream (or stream (make-string-output-stream))))
+ (ecase precision
+ (:day
+ (setf hour 0 second 0 minute 0))
+ (:hour
+ (setf second 0 minute 0))
+ (:minute
+ (setf second 0))
+ (:second
+ t))
+ (if (= 0 year month day hour minute)
+ (format stream "0 minutes")
+ (let ((sent? nil))
+ (when (< 0 year)
+ (format stream "~d year~p" year year)
+ (setf sent? t))
+ (when (< 0 month)
+ (when sent?
+ (write-char #\Space stream))
+ (format stream "~d month~p" month month)
+ (setf sent? t))
+ (when (< 0 day)
+ (when sent?
+ (write-char #\Space stream))
+ (format stream "~d day~p" day day)
+ (setf sent? t))
+ (when (< 0 hour)
+ (when sent?
+ (write-char #\Space stream))
+ (format stream "~d hour~p" hour hour)
+ (setf sent? t))
+ (when (< 0 minute)
+ (when sent?
+ (write-char #\Space stream))
+ (format stream "~d min~p" minute minute)
+ (setf sent? t))
+ (when (< 0 second)
+ (when sent?
+ (write-char #\Space stream))
+ (format stream "~d sec~p" second second))))
+ (when return
+ (get-output-stream-string stream))))
+
+(defgeneric midnight (self))
+(defmethod midnight ((self wall-time))
+ "truncate hours, minutes and seconds"
+ (%make-wall-time :mjd (time-mjd self)))
+
+(defun roll (date &key (year 0) (month 0) (day 0) (second 0) (hour 0)
+ (minute 0) (usec 0) (destructive nil))
+ (unless (= 0 year month)
+ (multiple-value-bind (year-orig month-orig day-orig)
+ (time-ymd date)
+ (multiple-value-bind (new-year new-month)
+ (floor (+ month month-orig (* 12 (+ year year-orig))) 12)
+ (let ((new-date (make-time :year new-year
+ :month new-month
+ :day day-orig
+ :second (time-second date)
+ :usec usec)))
+ (if destructive
+ (setf (time-mjd date) (time-mjd new-date))
+ (setq date new-date))))))
+ (let ((mjd (time-mjd date))
+ (sec (time-second date)))
+ (multiple-value-bind (sec-new usec-new)
+ (floor (+ usec (time-usec date)
+ (* 1000000
+ (+ sec second
+ (* 60 minute)
+ (* 60 60 hour))))
+ 1000000)
+ (multiple-value-bind (mjd-new sec-new)
+ (floor sec-new (* 60 60 24))
+ (if destructive
+ (progn
+ (setf (time-mjd date) (+ mjd mjd-new day)
+ (time-second date) sec-new
+ (time-usec date) usec-new)
+ date)
+ (%make-wall-time :mjd (+ mjd mjd-new day)
+ :second sec-new
+ :usec usec-new))))))
+
+(defun roll-to (date size position)
+ (ecase size
+ (:month
+ (ecase position
+ (:beginning
+ (roll date :day (+ 1
+ (- (time-element date :day-of-month)))))
+ (:end
+ (roll date :day (+ (days-in-month (time-element date :month)
+ (time-element date :year))
+ (- (time-element date :day-of-month)))))))))
+
+(defun week-containing (time)
+ (let* ((midn (midnight time))
+ (dow (time-element midn :integer-day-of-week)))
+ (list (roll midn :day (- dow))
+ (roll midn :day (- 7 dow)))))
+
+(defun leap-year? (year)
+ "t if YEAR is a leap yeap in the Gregorian calendar"
+ (and (= 0 (mod year 4))
+ (or (not (= 0 (mod year 100)))
+ (= 0 (mod year 400)))))
+
+(defun valid-month-p (month)
+ "t if MONTH exists in the Gregorian calendar"
+ (<= 1 month 12))
+
+(defun valid-gregorian-date-p (date)
+ "t if DATE (year month day) exists in the Gregorian calendar"
+ (let ((max-day (days-in-month (nth 1 date) (nth 0 date))))
+ (<= 1 (nth 2 date) max-day)))
+
+(defun days-in-month (month year &key (careful t))
+ "the number of days in MONTH of YEAR, observing Gregorian leap year
+rules"
+ (declare (type fixnum month year))
+ (when careful
+ (check-type month (satisfies valid-month-p)
+ "between 1 (January) and 12 (December)"))
+ (if (eql month 2) ; feb
+ (if (leap-year? year)
+ 29 28)
+ (let ((even (mod (1- month) 2)))
+ (if (< month 8) ; aug
+ (- 31 even)
+ (+ 30 even)))))
+
+(defun day-of-year (year month day &key (careful t))
+ "the day number within the year of the date DATE. For example,
+1987 1 1 returns 1"
+ (declare (type fixnum year month day))
+ (when careful
+ (let ((date (list year month day)))
+ (check-type date (satisfies valid-gregorian-date-p)
+ "a valid Gregorian date")))
+ (let ((doy (+ day (* 31 (1- month)))))
+ (declare (type fixnum doy))
+ (when (< 2 month)
+ (setf doy (- doy (floor (+ 23 (* 4 month)) 10)))
+ (when (leap-year? year)
+ (incf doy)))
+ doy))
+
+(defun parse-yearstring (string)
+ (let ((year (or (parse-integer-insensitively string)
+ (extract-roman string))))
+ (when (and year (< 1500 year 2500))
+ (make-time :year year))))
+
+(defun parse-integer-insensitively (string)
+ (let ((start (position-if #'digit-char-p string))
+ (end (position-if #'digit-char-p string :from-end t)))
+ (when (and start end)
+ (parse-integer (subseq string start (1+ end)) :junk-allowed t))))
+
+(defvar *roman-digits*
+ '((#\M . 1000)
+ (#\D . 500)
+ (#\C . 100)
+ (#\L . 50)
+ (#\X . 10)
+ (#\V . 5)
+ (#\I . 1)))
+
+(defun extract-roman (string &aux parse)
+ (dotimes (x (length string))
+ (let ((val (cdr (assoc (aref string x) *roman-digits*))))
+ (when (and val parse (< (car parse) val))
+ (push (- (pop parse)) parse))
+ (push val parse)))
+ (apply #'+ parse))
+
+
+;; ------------------------------------------------------------
+;; Parsing iso-8601 timestrings
+
+(define-condition iso-8601-syntax-error (sql-user-error)
+ ((bad-component;; year, month whatever
+ :initarg :bad-component
+ :reader bad-component))
+ (:report (lambda (c stream)
+ (format stream "Bad component: ~A " (bad-component c)))))
+
+(defun parse-timestring (timestring &key (start 0) end junk-allowed)
+ "parse a timestring and return the corresponding wall-time. If the
+timestring starts with P, read a duration; otherwise read an ISO 8601
+formatted date string."
+ (declare (ignore junk-allowed))
+ (etypecase timestring
+ (wall-time timestring)
+ (date (date->time timestring))
+ (string
+ (let ((string (subseq timestring start end)))
+ (if (char= (aref string 0) #\P)
+ (parse-iso-8601-duration string)
+ (parse-iso-8601-time string))))))
+
+(defun parse-datestring (datestring &key (start 0) end junk-allowed)
+ "parse a ISO 8601 timestring and return the corresponding date.
+Will throw a hissy fit if the date string is a duration. Will ignore any precision beyond day (hour/min/sec/usec)."
+ (etypecase datestring
+ (date datestring)
+ (wall-time (time->date datestring))
+ (string
+ (let ((parsed-value
+ (parse-timestring
+ datestring :start start :end end :junk-allowed junk-allowed)))
+ (etypecase parsed-value
+ (date parsed-value)
+ (wall-time (time->date parsed-value)))))))
+
+
+(defvar *iso-8601-duration-delimiters*
+ '((#\Y . :years)
+ (#\D . :days)
+ (#\H . :hours)
+ (#\M . :months/minutes)
+ (#\S . :seconds)))
+
+(defun iso-8601-delimiter (elt)
+ (cdr (assoc elt *iso-8601-duration-delimiters*)))
+
+(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))))
+ (when number
+ (values number
+ (1+ pos)
+ (1+ pos2)
+ (iso-8601-delimiter (aref string pos))))))
+
+(defun parse-iso-8601-duration (string)
+ "return a wall-time from a duration string"
+ (block parse
+ (let ((years 0)
+ (months 0)
+ (days 0)
+ (secs 0)
+ (hours 0)
+ (minutes 0)
+ (index (length string))
+ (months/minutes nil))
+ (loop
+ (multiple-value-bind (duration end next-index duration-type)
+ (iso-8601-duration-subseq string index)
+ (declare (ignore end))
+ (case duration-type
+ (:years
+ (incf years duration))
+ (:months/minutes
+ (if months/minutes
+ (incf months duration)
+ (progn
+ (setq months/minutes t)
+ (incf minutes duration))))
+ (:days
+ (setq months/minutes t)
+ (incf days duration))
+ (:hours
+ (setq months/minutes t)
+ (incf hours duration))
+ (:seconds
+ (incf secs duration))
+ (t
+ (return-from parse
+ (make-duration
+ :year years :month months :day days :hour hours
+ :minute minutes :second secs))))
+ (setf index next-index))))))
+
+;; e.g. 2000-11-11 00:00:00-06
+
+(defun parse-iso-8601-time (string)
+ "return the wall-time corresponding to the given ISO 8601 datestring"
+ (multiple-value-bind (year month day hour minute second usec offset)
+ (syntax-parse-iso-8601 string)
+ (make-time :year year
+ :month month
+ :day day
+ :hour hour
+ :minute minute
+ :second second
+ :usec usec
+ :offset offset)))
+
+
+(defun syntax-parse-iso-8601 (string)
+ ;; use strlen to determine if fractional seconds are present in timestamp
+ (let ((strlen (length string))
+ year month day hour minute second usec gmt-sec-offset)
+ (handler-case
+ (progn
+ (setf year (parse-integer string :start 0 :end 4)
+ month (parse-integer string :start 5 :end 7)
+ day (parse-integer string :start 8 :end 10)
+ hour (if (<= 13 strlen)
+ (parse-integer string :start 11 :end 13)
+ 0)
+ minute (if (<= 16 strlen)
+ (parse-integer string :start 14 :end 16)
+ 0)
+ second (if (<= 19 strlen)
+ (parse-integer string :start 17 :end 19)
+ 0))
+ (cond
+ ((and (> strlen 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)
+ (let ((parsed-usec (and parsed-usec
+ (floor (* parsed-usec (expt 10 (+ 6 (- usec-end) 20)))))))
+ (setf usec (or parsed-usec 0)
+ gmt-sec-offset (if (<= (+ 3 usec-end) strlen)
+ (let ((skip-to (or (position #\+ string :start 19)
+ (position #\- string :start 19))))
+ (if skip-to
+ (* 60 60
+ (parse-integer string :start skip-to
+ :end (+ skip-to 3)))
+ 0))
+ 0)))))
+ (t
+ (setf usec 0
+ gmt-sec-offset (if (<= 22 strlen)
+ (let ((skip-to (or (position #\+ string :start 19)
+ (position #\- string :start 19))))
+ (if skip-to
+ (* 60 60
+ (parse-integer string :start skip-to
+ :end (+ skip-to 3)))
+ 0))
+ 0))))
+ (unless (< 0 year)
+ (error 'iso-8601-syntax-error
+ :bad-component '(year . 0)))
+ (unless (< 0 month)
+ (error 'iso-8601-syntax-error
+ :bad-component '(month . 0)))
+ (unless (< 0 day)
+ (error 'iso-8601-syntax-error
+ :bad-component '(month . 0)))
+ (values year month day hour minute second usec gmt-sec-offset))
+ (simple-error ()
+ (error 'iso-8601-syntax-error
+ :bad-component
+ (car (find-if (lambda (pair) (null (cdr pair)))
+ `((year . ,year) (month . ,month)
+ (day . ,day) (hour . ,hour)
+ (minute . ,minute) (second . ,second)
+ (usec . ,usec)
+ (timezone . ,gmt-sec-offset)))))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-11 09:07:38 +0000