sql/time.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; $Id$
   5 ;;;;
   6 ;;;; A variety of structures and function for creating and
   7 ;;;; manipulating dates, times, durations and intervals for
   8 ;;;; CLSQL.
   9 ;;;;
  10 ;;;; This file was originally part of ODCL and is Copyright (c) 2002 -
  11 ;;;; 2003 onShore Development, Inc.
  12 ;;;;
  13 ;;;; CLSQL users are granted the rights to distribute and use this software
  14 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  15 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  16 ;;;; *************************************************************************
  17
  18 (in-package #:clsql-sys)
  19
  20 ;; ------------------------------------------------------------
  21 ;; Months
  22
  23 (defvar *month-keywords*
  24   '(:january :february :march :april :may :june :july :august :september
  25     :october :november :december))
  26
  27 (defvar *month-names*
  28   '("" "January" "February" "March" "April" "May" "June" "July" "August"
  29     "September" "October" "November" "December"))
  30
  31 (defun month-name (month-index)
  32   (nth month-index *month-names*))
  33
  34 (defun ordinal-month (month-keyword)
  35   "Return the zero-based month number for the given MONTH keyword."
  36   (position month-keyword *month-keywords*))
  37
  38
  39 ;; ------------------------------------------------------------
  40 ;; Days
  41
  42 (defvar *day-keywords*
  43   '(:sunday :monday :tuesday :wednesday :thursday :friday :saturday))
  44
  45 (defvar *day-names*
  46   '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
  47
  48 (defun day-name (day-index)
  49   (nth day-index *day-names*))
  50
  51 (defun ordinal-day (day-keyword)
  52   "Return the zero-based day number for the given DAY keyword."
  53   (position day-keyword *day-keywords*))
  54
  55
  56 ;; ------------------------------------------------------------
  57 ;; time classes: wall-time, duration
  58
  59 (eval-when (:compile-toplevel :load-toplevel)
  60
  61 (defstruct (wall-time (:conc-name time-)
  62                       (:constructor %make-wall-time)
  63                       (:print-function %print-wall-time))
  64   (mjd 0 :type fixnum)
  65   (second 0 :type fixnum)
  66   (usec 0 :type fixnum))
  67
  68 (defun %print-wall-time (time stream depth)
  69   (declare (ignore depth))
  70   (format stream "#<WALL-TIME: ~a>" (format-time nil time)))
  71
  72 (defstruct (duration (:constructor %make-duration)
  73                      (:print-function %print-duration))
  74   (year 0 :type fixnum)
  75   (month 0 :type fixnum)
  76   (day 0 :type fixnum)
  77   (hour 0 :type fixnum)
  78   (second 0 :type fixnum)
  79   (minute 0 :type fixnum)
  80   (usec 0 :type fixnum))
  81
  82 (defun %print-duration (duration stream depth)
  83   (declare (ignore depth))
  84   (format stream "#<DURATION: ~a>"
  85           (format-duration nil duration :precision :second)))
  86
  87 );eval-when
  88
  89 (defun duration-timestring (duration)
  90   (let ((second (duration-second duration))
  91         (minute (duration-minute duration))
  92         (hour (duration-hour duration))
  93         (day (duration-day duration)))
  94     (format nil "P~dD~dH~dM~dS" day hour minute second)))
  95
  96
  97 ;; ------------------------------------------------------------
  98 ;; Constructors
  99
 100 (defun make-time (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)
 101                        (second 0) (usec 0) (offset 0))
 102   (let ((mjd (gregorian-to-mjd month day year))
 103         (sec (+ (* hour 60 60)
 104                 (* minute 60)
 105                 second (- offset))))
 106     (multiple-value-bind (day-add raw-sec)
 107         (floor sec (* 60 60 24))
 108       (%make-wall-time :mjd (+ mjd day-add) :second raw-sec :usec usec))))
 109
 110 (defun copy-time (time)
 111   (%make-wall-time :mjd (time-mjd time)
 112                    :second (time-second time)))
 113
 114 (defun utime->time (utime)
 115   "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
 116   (multiple-value-bind (second minute hour day mon year)
 117       (decode-universal-time utime)
 118     (make-time :year year :month mon :day day :hour hour :minute minute
 119                :second second)))
 120
 121 (defun get-time ()
 122   "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
 123   (utime->time (get-universal-time)))
 124
 125 (defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0)
 126                       (second 0) (usec 0))
 127   (multiple-value-bind (second-add usec-1000000)
 128       (floor usec 1000000)
 129     (multiple-value-bind (minute-add second-60)
 130         (floor (+ second second-add) 60)
 131       (multiple-value-bind (hour-add minute-60)
 132           (floor (+ minute minute-add) 60)
 133         (multiple-value-bind (day-add hour-24)
 134             (floor (+ hour hour-add) 24)
 135           (%make-duration :year year :month month :day (+ day day-add)
 136                           :hour hour-24
 137                           :minute minute-60
 138                           :second second-60
 139                           :usec usec-1000000))))))
 140
 141
 142 ;; ------------------------------------------------------------
 143 ;; Accessors
 144
 145 (defun time-hms (time)
 146   (multiple-value-bind (hourminute second)
 147       (floor (time-second time) 60)
 148     (multiple-value-bind (hour minute)
 149         (floor hourminute 60)
 150       (values hour minute second))))
 151
 152 (defun time-ymd (time)
 153   (destructuring-bind (month day year)
 154       (mjd-to-gregorian (time-mjd time))
 155     (values year month day)))
 156
 157 (defun time-dow (time)
 158   "Return the 0 indexed Day of the week starting with Sunday"
 159   (mod (+ 3 (time-mjd time)) 7))
 160
 161 (defun decode-time (time)
 162   "returns the decoded time as multiple values: usec, second, minute, hour,
 163   day, month, year, integer day-of-week"
 164   (multiple-value-bind (year month day)
 165       (time-ymd time)
 166     (multiple-value-bind (hour minute second)
 167         (time-hms time)
 168       (values (time-usec time) second minute hour day month year (mod (+ (time-mjd time) 3) 7)))))
 169
 170 ;; duration specific
 171 (defun duration-reduce (duration precision &optional round)
 172   (ecase precision
 173     (:usec
 174      (+ (duration-usec duration)
 175         (* (duration-reduce duration :second) 1000000)))
 176     (:second
 177      (+ (if round
 178             (floor (duration-usec duration) 500000)
 179             0)
 180         (duration-second duration)
 181         (* (duration-reduce duration :minute) 60)))
 182     (:minute
 183      (+ (if round
 184             (floor (duration-second duration) 30)
 185             0)
 186         (duration-minute duration)
 187         (* (duration-reduce duration :hour) 60)))
 188     (:hour
 189      (+ (if round
 190             (floor (duration-minute duration) 30)
 191             0)
 192         (duration-hour duration)
 193         (* (duration-reduce duration :day) 24)))
 194     (:day
 195      (+ (if round
 196             (floor (duration-hour duration) 12)
 197             0)
 198         (duration-day duration)))))
 199
 200
 201 ;; ------------------------------------------------------------
 202 ;; Arithemetic and comparators
 203
 204 (defun duration= (duration-a duration-b)
 205   (= (duration-reduce duration-a :usec)
 206      (duration-reduce duration-b :usec)))
 207
 208 (defun duration< (duration-a duration-b)
 209   (< (duration-reduce duration-a :usec)
 210      (duration-reduce duration-b :usec)))
 211
 212 (defun duration<= (duration-a duration-b)
 213   (<= (duration-reduce duration-a :usec)
 214       (duration-reduce duration-b :usec)))
 215
 216 (defun duration>= (x y)
 217   (duration<= y x))
 218
 219 (defun duration> (x y)
 220   (duration< y x))
 221
 222 (defun %time< (x y)
 223   (let ((mjd-x (time-mjd x))
 224         (mjd-y (time-mjd y)))
 225     (if (/= mjd-x mjd-y)
 226         (< mjd-x mjd-y)
 227         (if (/= (time-second x) (time-second y))
 228             (< (time-second x) (time-second y))
 229             (< (time-usec x) (time-usec y))))))
 230
 231 (defun %time>= (x y)
 232   (if (/= (time-mjd x) (time-mjd y))
 233       (>= (time-mjd x) (time-mjd y))
 234       (if (/= (time-second x) (time-second y))
 235           (>= (time-second x) (time-second y))
 236           (>= (time-usec x) (time-usec y)))))
 237
 238 (defun %time<= (x y)
 239   (if (/= (time-mjd x) (time-mjd y))
 240       (<= (time-mjd x) (time-mjd y))
 241       (if (/= (time-second x) (time-second y))
 242           (<= (time-second x) (time-second y))
 243           (<= (time-usec x) (time-usec y)))))
 244
 245 (defun %time> (x y)
 246   (if (/= (time-mjd x) (time-mjd y))
 247       (> (time-mjd x) (time-mjd y))
 248       (if (/= (time-second x) (time-second y))
 249           (> (time-second x) (time-second y))
 250           (> (time-usec x) (time-usec y)))))
 251
 252 (defun %time= (x y)
 253   (and (= (time-mjd x) (time-mjd y))
 254        (= (time-second x) (time-second y))
 255        (= (time-usec x) (time-usec y))))
 256
 257 (defun time= (number &rest more-numbers)
 258   "Returns T if all of its arguments are numerically equal, NIL otherwise."
 259   (do ((nlist more-numbers (cdr nlist)))
 260       ((atom nlist) t)
 261      (declare (list nlist))
 262      (if (not (%time= (car nlist) number)) (return nil))))
 263
 264 (defun time/= (number &rest more-numbers)
 265   "Returns T if no two of its arguments are numerically equal, NIL otherwise."
 266   (do* ((head number (car nlist))
 267         (nlist more-numbers (cdr nlist)))
 268        ((atom nlist) t)
 269      (declare (list nlist))
 270      (unless (do* ((nl nlist (cdr nl)))
 271                   ((atom nl) t)
 272                (declare (list nl))
 273                (if (%time= head (car nl)) (return nil)))
 274        (return nil))))
 275
 276 (defun time< (number &rest more-numbers)
 277   "Returns T if its arguments are in strictly increasing order, NIL otherwise."
 278   (do* ((n number (car nlist))
 279         (nlist more-numbers (cdr nlist)))
 280        ((atom nlist) t)
 281      (declare (list nlist))
 282      (if (not (%time< n (car nlist))) (return nil))))
 283
 284 (defun time> (number &rest more-numbers)
 285   "Returns T if its arguments are in strictly decreasing order, NIL otherwise."
 286   (do* ((n number (car nlist))
 287         (nlist more-numbers (cdr nlist)))
 288        ((atom nlist) t)
 289      (declare (list nlist))
 290      (if (not (%time> n (car nlist))) (return nil))))
 291
 292 (defun time<= (number &rest more-numbers)
 293   "Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
 294   (do* ((n number (car nlist))
 295         (nlist more-numbers (cdr nlist)))
 296        ((atom nlist) t)
 297      (declare (list nlist))
 298      (if (not (%time<= n (car nlist))) (return nil))))
 299
 300 (defun time>= (number &rest more-numbers)
 301   "Returns T if arguments are in strictly non-increasing order, NIL otherwise."
 302   (do* ((n number (car nlist))
 303         (nlist more-numbers (cdr nlist)))
 304        ((atom nlist) t)
 305      (declare (list nlist))
 306      (if (not (%time>= n (car nlist))) (return nil))))
 307
 308 (defun time-max (number &rest more-numbers)
 309   "Returns the greatest of its arguments."
 310   (do ((nlist more-numbers (cdr nlist))
 311        (result number))
 312       ((null nlist) (return result))
 313      (declare (list nlist))
 314      (if (%time> (car nlist) result) (setf result (car nlist)))))
 315
 316 (defun time-min (number &rest more-numbers)
 317   "Returns the least of its arguments."
 318   (do ((nlist more-numbers (cdr nlist))
 319        (result number))
 320       ((null nlist) (return result))
 321      (declare (list nlist))
 322      (if (%time< (car nlist) result) (setf result (car nlist)))))
 323
 324 (defun time-compare (time-a time-b)
 325   (let ((mjd-a (time-mjd time-a))
 326         (mjd-b (time-mjd time-b))
 327         (sec-a (time-second time-a))
 328         (sec-b (time-second time-b))
 329         (usec-a (time-usec time-a))
 330         (usec-b (time-usec time-b)))
 331     (if (= mjd-a mjd-b)
 332         (if (= sec-a sec-b)
 333             (if (= usec-a usec-b)
 334                 :equal
 335                 (if (< usec-a usec-b)
 336                     :less-than
 337                     :greater-than))
 338             (if (< sec-a sec-b)
 339                 :less-than
 340                 :greater-than))
 341         (if (< mjd-a mjd-b)
 342             :less-than
 343             :greater-than))))
 344
 345
 346 ;; ------------------------------------------------------------
 347 ;; Formatting and output
 348
 349 (defvar +decimal-printer+ #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
 350
 351 (defun db-timestring (time)
 352   "return the string to store the given time in the database"
 353   (declare (optimize (speed 3)))
 354   (let ((output (copy-seq "'XXXX-XX-XX XX:XX:XX.")))
 355     (flet ((inscribe-base-10 (output offset size decimal)
 356              (declare (type fixnum offset size decimal)
 357                       (type (simple-vector 10) +decimal-printer+))
 358              (dotimes (x size)
 359                (declare (type fixnum x)
 360                         (optimize (safety 0)))
 361                (multiple-value-bind (next this)
 362                    (floor decimal 10)
 363                  (setf (aref output (+ (- size x 1) offset))
 364                        (aref +decimal-printer+ this))
 365                  (setf decimal next)))))
 366       (multiple-value-bind (usec second minute hour day month year)
 367           (decode-time time)
 368         (inscribe-base-10 output 1 4 year)
 369         (inscribe-base-10 output 6 2 month)
 370         (inscribe-base-10 output 9 2 day)
 371         (inscribe-base-10 output 12 2 hour)
 372         (inscribe-base-10 output 15 2 minute)
 373         (inscribe-base-10 output 18 2 second)
 374         (format nil "~a~d'" output usec)))))
 375
 376 (defun iso-timestring (time)
 377   "return the string to store the given time in the database"
 378   (declare (optimize (speed 3)))
 379   (let ((output (copy-seq "XXXX-XX-XX XX:XX:XX,")))
 380     (flet ((inscribe-base-10 (output offset size decimal)
 381              (declare (type fixnum offset size decimal)
 382                       (type (simple-vector 10) +decimal-printer+))
 383              (dotimes (x size)
 384                (declare (type fixnum x)
 385                         (optimize (safety 0)))
 386                (multiple-value-bind (next this)
 387                    (floor decimal 10)
 388                  (setf (aref output (+ (- size x 1) offset))
 389                        (aref +decimal-printer+ this))
 390                  (setf decimal next)))))
 391       (multiple-value-bind (usec second minute hour day month year)
 392           (decode-time time)
 393         (inscribe-base-10 output 0 4 year)
 394         (inscribe-base-10 output 5 2 month)
 395         (inscribe-base-10 output 8 2 day)
 396         (inscribe-base-10 output 11 2 hour)
 397         (inscribe-base-10 output 14 2 minute)
 398         (inscribe-base-10 output 17 2 second)
 399         (format nil "~a,~d" output usec)))))
 400
 401
 402 ;; ------------------------------------------------------------
 403 ;; Intervals
 404
 405 (defstruct interval
 406   (start nil)
 407   (end nil)
 408   (name nil)
 409   (contained nil)
 410   (type nil)
 411   (data nil))
 412
 413 ;; fix : should also return :contains / :contained
 414
 415 (defun interval-relation (x y)
 416   "Compare the relationship of node x to node y. Returns either
 417 :contained :contains :follows :overlaps or :precedes."
 418   (let ((xst  (interval-start x))
 419         (xend (interval-end x))
 420         (yst  (interval-start y))
 421         (yend (interval-end y)))
 422     (case (time-compare xst yst)
 423       (:equal
 424        (case (time-compare xend yend)
 425          (:less-than
 426           :contained)
 427          ((:equal :greater-than)
 428           :contains)))
 429       (:greater-than
 430        (case (time-compare xst yend)
 431          ((:equal :greater-than)
 432           :follows)
 433          (:less-than
 434           (case (time-compare xend yend)
 435             ((:less-than :equal)
 436              :contained)
 437             ((:greater-than)
 438              :overlaps)))))
 439       (:less-than
 440        (case (time-compare xend yst)
 441          ((:equal :less-than)
 442           :precedes)
 443          (:greater-than
 444           (case (time-compare xend yend)
 445             (:less-than
 446              :overlaps)
 447             ((:equal :greater-than)
 448              :contains))))))))
 449
 450 ;; ------------------------------------------------------------
 451 ;; interval lists
 452
 453 (defun sort-interval-list (list)
 454   (sort list (lambda (x y)
 455                (case (interval-relation x y)
 456                  ((:precedes :contains) t)
 457                  ((:follows :overlaps :contained) nil)))))
 458
 459 ;; interval push will return its list of intervals in strict order.
 460 (defun interval-push (interval-list interval &optional container-rule)
 461   (declare (ignore container-rule))
 462   (let ((sorted-list (sort-interval-list interval-list)))
 463     (dotimes (x (length sorted-list))
 464       (let ((elt (nth x sorted-list)))
 465         (case (interval-relation elt interval)
 466           (:follows
 467            (return-from interval-push (insert-at-index x sorted-list interval)))
 468           (:contains
 469            (return-from interval-push
 470              (replace-at-index x sorted-list
 471                                (make-interval :start (interval-start elt)
 472                                               :end (interval-end elt)
 473                                               :type (interval-type elt)
 474                                               :contained (interval-push (interval-contained elt) interval)
 475                                               :data (interval-data elt)))))
 476           ((:overlaps :contained)
 477            (error "Overlap")))))
 478     (append sorted-list (list interval))))
 479
 480 ;; interval lists
 481
 482 (defun interval-match (list time)
 483   "Return the index of the first interval in list containing time"
 484   ;; this depends on ordering of intervals!
 485   (let ((list (sort-interval-list list)))
 486     (dotimes (x (length list))
 487       (let ((elt (nth x list)))
 488         (when (and (time<= (interval-start elt) time)
 489                    (time< time (interval-end elt)))
 490           (return-from interval-match x))))))
 491
 492 (defun interval-clear (list time)
 493   (dotimes (x (length list))
 494     (let ((elt (nth x list)))
 495       (when (and (time<= (interval-start elt) time)
 496                  (time< time (interval-end elt)))
 497         (if (interval-match (interval-contained elt) time)
 498             (return-from interval-clear
 499               (replace-at-index x list
 500                                 (make-interval :start (interval-start elt)
 501                                                :end (interval-end elt)
 502                                                :type (interval-type elt)
 503                                                :contained (interval-clear (interval-contained elt) time)
 504                                                :data (interval-data elt))))
 505             (return-from interval-clear
 506               (delete-at-index x list)))))))
 507
 508 (defun interval-edit (list time start end &optional tag)
 509   "Attempts to modify the most deeply nested interval in list which
 510 begins at time.  If no changes are made, returns nil."
 511   ;; function required sorted interval list
 512   (let ((list (sort-interval-list list)))
 513     (if (null list) nil
 514       (dotimes (x (length list))
 515         (let ((elt (nth x list)))
 516           (when (and (time<= (interval-start elt) time)
 517                      (time< time (interval-end elt)))
 518             (or (interval-edit (interval-contained elt) time start end tag)
 519                 (cond ((and (< 0 x)
 520                             (time< start (interval-end (nth (1- x) list))))
 521                        (error "Overlap of previous interval"))
 522                       ((and (< x (1- (length list)))
 523                             (time< (interval-start (nth (1+ x) list)) end))
 524                        (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end ))
 525                       ((time= (interval-start elt) time)
 526                        (return-from interval-edit
 527                          (replace-at-index x list
 528                                            (make-interval :start start
 529                                                           :end end
 530                                                           :type (interval-type elt)
 531                                                           :contained (restrict-intervals (interval-contained elt) start end)
 532                                                           :data (or tag (interval-data elt))))))))))))))
 533
 534 (defun restrict-intervals (list start end &aux newlist)
 535   (let ((test-interval (make-interval :start start :end end)))
 536     (dolist (elt list)
 537       (when (equal :contained
 538                    (interval-relation elt test-interval))
 539         (push elt newlist)))
 540     (nreverse newlist)))
 541
 542 ;;; utils from odcl/list.lisp
 543
 544 (defun replace-at-index (idx list elt)
 545   (cond ((= idx 0)
 546          (cons elt (cdr list)))
 547         ((= idx (1- (length list)))
 548          (append (butlast list) (list elt)))
 549         (t
 550          (append (subseq list 0 idx)
 551                  (list elt)
 552                  (subseq list (1+ idx))))))
 553
 554 (defun insert-at-index (idx list elt)
 555   (cond ((= idx 0)
 556          (cons elt list))
 557         ((= idx (1- (length list)))
 558          (append list (list elt)))
 559         (t
 560          (append (subseq list 0 idx)
 561                  (list elt)
 562                  (subseq list idx)))))
 563
 564 (defun delete-at-index (idx list)
 565   (cond ((= idx 0)
 566          (cdr list))
 567         ((= idx (1- (length list)))
 568          (butlast list))
 569         (t
 570          (append (subseq list 0 idx)
 571                  (subseq list (1+ idx))))))
 572
 573
 574 ;; ------------------------------------------------------------
 575 ;; return MJD for Gregorian date
 576
 577 (defun gregorian-to-mjd (month day year)
 578   (let ((b 0)
 579         (month-adj month)
 580         (year-adj (if (< year 0)
 581                       (+ year 1)
 582                       year))
 583         d
 584         c)
 585     (when (< month 3)
 586       (incf month-adj 12)
 587       (decf year-adj))
 588     (unless (or (< year 1582)
 589                 (and (= year 1582)
 590                      (or (< month 10)
 591                          (and (= month 10)
 592                               (< day 15)))))
 593       (let ((a (floor (/ year-adj 100))))
 594         (setf b (+ (- 2 a) (floor (/ a 4))))))
 595     (if (< year-adj 0)
 596         (setf c (floor (- (* 365.25d0 year-adj) 679006.75d0)))
 597         (setf c (floor (- (* 365.25d0 year-adj) 679006d0))))
 598     (setf d (floor (* 30.6001 (+ 1 month-adj))))
 599     ;; (cmsg "b ~s c ~s d ~s day ~s" b c d day)
 600     (+ b c d day)))
 601
 602 ;; convert MJD to Gregorian date
 603
 604 (defun mjd-to-gregorian (mjd)
 605   (let (z r g a b c year month day)
 606     (setf z (floor (+ mjd 678882)))
 607     (setf r (- (+ mjd 678882) z))
 608     (setf g (- z .25))
 609     (setf a (floor (/ g 36524.25)))
 610     (setf b (- a (floor (/ a 4))))
 611     (setf year (floor (/ (+ b g) 365.25)))
 612     (setf c (- (+ b z) (floor (* 365.25 year))))
 613     (setf month (truncate (/ (+ (* 5 c) 456) 153)))
 614     (setf day (+ (- c (truncate (/ (- (* 153 month) 457) 5))) r))
 615     (when (> month 12)
 616       (incf year)
 617       (decf month 12))
 618     (list month day year)))
 619
 620 (defun duration+ (time &rest durations)
 621   "Add each DURATION to TIME, returning a new wall-time value."
 622   (let ((year   (duration-year time))
 623         (month  (duration-month time))
 624         (day    (duration-day time))
 625         (hour   (duration-hour time))
 626         (minute (duration-minute time))
 627         (second (duration-second time))
 628         (usec   (duration-usec time)))
 629     (dolist (duration durations)
 630       (incf year    (duration-year duration))
 631       (incf month   (duration-month duration))
 632       (incf day     (duration-day duration))
 633       (incf hour    (duration-hour duration))
 634       (incf minute  (duration-minute duration))
 635       (incf second  (duration-second duration))
 636       (incf usec    (duration-usec duration)))
 637     (make-duration :year year :month month :day day :hour hour :minute minute
 638                    :second second :usec usec)))
 639
 640 (defun duration- (duration &rest durations)
 641     "Subtract each DURATION from TIME, returning a new duration value."
 642   (let ((year   (duration-year duration))
 643         (month  (duration-month duration))
 644         (day    (duration-day duration))
 645         (hour   (duration-hour duration))
 646         (minute (duration-minute duration))
 647         (second (duration-second duration))
 648         (usec   (duration-usec duration)))
 649     (dolist (duration durations)
 650       (decf year    (duration-year duration))
 651       (decf month   (duration-month duration))
 652       (decf day     (duration-day duration))
 653       (decf hour    (duration-hour duration))
 654       (decf minute  (duration-minute duration))
 655       (decf second  (duration-second duration))
 656       (decf usec    (duration-usec duration)))
 657     (make-duration :year year :month month :day day :hour hour :minute minute
 658                    :second second :usec usec)))
 659
 660 ;; Date + Duration
 661
 662 (defun time+ (time &rest durations)
 663   "Add each DURATION to TIME, returning a new wall-time value."
 664   (let ((new-time (copy-time time)))
 665     (dolist (duration durations)
 666       (roll new-time
 667             :year (duration-year duration)
 668             :month (duration-month duration)
 669             :day (duration-day duration)
 670             :hour (duration-hour duration)
 671             :minute (duration-minute duration)
 672             :second (duration-second duration)
 673             :usec (duration-usec duration)
 674             :destructive t))
 675     new-time))
 676
 677 (defun time- (time &rest durations)
 678   "Subtract each DURATION from TIME, returning a new wall-time value."
 679   (let ((new-time (copy-time time)))
 680     (dolist (duration durations)
 681       (roll new-time
 682             :year (- (duration-year duration))
 683             :month (- (duration-month duration))
 684             :day (- (duration-day duration))
 685             :hour (- (duration-hour duration))
 686             :minute (- (duration-minute duration))
 687             :second (- (duration-second duration))
 688             :usec (- (duration-usec duration))
 689             :destructive t))
 690     new-time))
 691
 692 (defun time-difference (time1 time2)
 693   "Returns a DURATION representing the difference between TIME1 and
 694 TIME2."
 695   (flet ((do-diff (time1 time2)
 696
 697   (let (day-diff sec-diff)
 698     (setf day-diff (- (time-mjd time2)
 699                       (time-mjd time1)))
 700     (if (> day-diff 0)
 701         (progn (decf day-diff)
 702                (setf sec-diff (+ (time-second time2)
 703                                  (- (* 60 60 24)
 704                                     (time-second time1)))))
 705       (setf sec-diff (- (time-second time2)
 706                         (time-second time1))))
 707      (make-duration :day day-diff
 708                    :second sec-diff))))
 709     (if (time< time1 time2)
 710         (do-diff time1 time2)
 711       (do-diff time2 time1))))
 712
 713 (defun format-time (stream time &key format
 714                     (date-separator "-")
 715                     (time-separator ":")
 716                     (internal-separator " "))
 717   "produces on stream the timestring corresponding to the wall-time
 718 with the given options"
 719   (let ((*print-circle* nil))
 720     (multiple-value-bind (usec second minute hour day month year dow)
 721         (decode-time time)
 722       (case format
 723         (:pretty
 724          (format stream "~A ~A, ~A ~D, ~D"
 725                  (pretty-time hour minute)
 726                  (day-name dow)
 727                  (month-name month)
 728                  day
 729                  year))
 730         (:short-pretty
 731          (format stream "~A, ~D/~D/~D"
 732                  (pretty-time hour minute)
 733                  month day year))
 734         (:iso
 735          (let ((string (iso-timestring time)))
 736            (if stream
 737                (write-string string stream)
 738              string)))
 739         (t
 740          (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D.~6,'0D"
 741                  year date-separator month date-separator day
 742                  internal-separator hour time-separator minute time-separator
 743                  second usec))))))
 744
 745 (defun pretty-time (hour minute)
 746   (cond
 747    ((eq hour 0)
 748     (format nil "12:~2,'0D AM" minute))
 749    ((eq hour 12)
 750     (format nil "12:~2,'0D PM" minute))
 751    ((< hour 12)
 752     (format nil "~D:~2,'0D AM" hour minute))
 753    ((and (> hour 12) (< hour 24))
 754     (format nil "~D:~2,'0D PM" (- hour 12) minute))
 755    (t
 756     (error "pretty-time got bad hour"))))
 757
 758 (defun leap-days-in-days (days)
 759   ;; return the number of leap days between Mar 1 2000 and
 760   ;; (Mar 1 2000) + days, where days can be negative
 761   (if (< days 0)
 762       (ceiling (/ (- days) (* 365 4)))
 763       (floor (/ days (* 365 4)))))
 764
 765 (defun current-year ()
 766   (third (mjd-to-gregorian (time-mjd (get-time)))))
 767
 768 (defun current-month ()
 769   (second (mjd-to-gregorian (time-mjd (get-time)))))
 770
 771 (defun current-day ()
 772   (first (mjd-to-gregorian (time-mjd (get-time)))))
 773
 774 (defun parse-date-time (string)
 775   "parses date like 08/08/01, 8.8.2001, eg"
 776   (when (> (length string) 1)
 777     (let ((m (current-month))
 778           (d (current-day))
 779           (y (current-year)))
 780       (let ((integers (mapcar #'parse-integer (hork-integers string))))
 781         (case (length integers)
 782           (1
 783            (setf y (car integers)))
 784           (2
 785            (setf m (car integers))
 786            (setf y (cadr integers)))
 787           (3
 788            (setf m (car integers))
 789            (setf d (cadr integers))
 790            (setf y (caddr integers)))
 791           (t
 792            (return-from parse-date-time))))
 793       (when (< y 100)
 794         (incf y 2000))
 795       (make-time :year y :month m :day d))))
 796
 797 (defun hork-integers (input)
 798   (let ((output '())
 799         (start 0))
 800     (dotimes (x (length input))
 801       (unless (<= 48 (char-code (aref input x)) 57)
 802         (push (subseq input start x) output)
 803         (setf start (1+ x))))
 804     (nreverse (push (subseq input start) output))))
 805
 806 (defun merged-time (day time-of-day)
 807   (%make-wall-time :mjd (time-mjd day)
 808                    :second (time-second time-of-day)))
 809
 810 (defun time-meridian (hours)
 811   (cond ((= hours 0)
 812          (values 12 "AM"))
 813         ((= hours 12)
 814          (values 12 "PM"))
 815         ((< 12 hours)
 816          (values (- hours 12) "PM"))
 817         (t
 818          (values hours "AM"))))
 819
 820 (defgeneric to-string (val &rest keys)
 821   )
 822
 823 (defmethod to-string ((time wall-time) &rest keys)
 824   (destructuring-bind (&key (style :daytime) &allow-other-keys)
 825       keys
 826     (print-date time style)))
 827
 828 (defun print-date (time &optional (style :daytime))
 829   (multiple-value-bind (second minute hour day month year dow)
 830       (decode-time time)
 831     (declare (ignore second))
 832     (multiple-value-bind (hours meridian)
 833         (time-meridian hour)
 834       (ecase style
 835         (:time-of-day
 836          ;; 2:00 PM
 837          (format nil "~d:~2,'0d ~a" hours minute meridian))
 838         (:long-day
 839          ;; October 11th, 2000
 840          (format nil "~a ~d, ~d" (month-name month) day year))
 841         (:month
 842          ;; October
 843          (month-name month))
 844         (:month-year
 845          ;; October 2000
 846          (format nil "~a ~d" (month-name month) year))
 847         (:full
 848          ;; 11:08 AM, November 22, 2002
 849          (format nil "~d:~2,'0d ~a, ~a ~d, ~d"
 850                  hours minute meridian (month-name month) day year))
 851         (:full+weekday
 852          ;; 11:09 AM Friday, November 22, 2002
 853          (format nil "~d:~2,'0d ~a ~a, ~a ~d, ~d"
 854                  hours minute meridian (nth dow *day-names*)
 855                  (month-name month) day year))
 856         (:daytime
 857          ;; 11:09 AM, 11/22/2002
 858          (format-time nil time :format :short-pretty))
 859         (:day
 860          ;; 11/22/2002
 861          (format nil "~d/~d/~d" month day year))))))
 862
 863 (defun time-element (time element)
 864   (multiple-value-bind (second minute hour day month year dow)
 865       (decode-time time)
 866     (ecase element
 867       (:seconds
 868        second)
 869       (:minutes
 870        minute)
 871       (:hours
 872        hour)
 873       (:day-of-month
 874        day)
 875       (:integer-day-of-week
 876        dow)
 877       (:day-of-week
 878        (nth dow *day-keywords*))
 879       (:month
 880        month)
 881       (:year
 882        year))))
 883
 884 (defun format-duration (stream duration &key (precision :minute))
 885   (let ((second (duration-second duration))
 886         (minute (duration-minute duration))
 887         (hour (duration-hour duration))
 888         (day (duration-day duration))
 889         (return (null stream))
 890         (stream (or stream (make-string-output-stream))))
 891     (ecase precision
 892       (:day
 893        (setf hour 0 second 0 minute 0))
 894       (:hour
 895        (setf second 0 minute 0))
 896       (:minute
 897        (setf second 0))
 898       (:second
 899        t))
 900     (if (= 0 day hour minute)
 901         (format stream "0 minutes")
 902         (let ((sent? nil))
 903           (when (< 0 day)
 904             (format stream "~d day~p" day day)
 905             (setf sent? t))
 906           (when (< 0 hour)
 907             (when sent?
 908               (write-char #\Space stream))
 909             (format stream "~d hour~p" hour hour)
 910             (setf sent? t))
 911           (when (< 0 minute)
 912             (when sent?
 913               (write-char #\Space stream))
 914             (format stream "~d min~p" minute minute)
 915             (setf sent? t))
 916           (when (< 0 second)
 917             (when sent?
 918               (write-char #\Space stream))
 919             (format stream "~d sec~p" second second))))
 920     (when return
 921       (get-output-stream-string stream))))
 922
 923 (defgeneric midnight (self))
 924 (defmethod midnight ((self wall-time))
 925   "truncate hours, minutes and seconds"
 926   (%make-wall-time :mjd (time-mjd self)))
 927
 928 (defun roll (date &key (year 0) (month 0) (day 0) (second 0) (hour 0)
 929              (minute 0) (usec 0) (destructive nil))
 930   (unless (= 0 year month)
 931     (multiple-value-bind (year-orig month-orig day-orig)
 932         (time-ymd date)
 933       (setf date (make-time :year (+ year year-orig)
 934                             :month (+ month month-orig)
 935                             :day day-orig
 936                             :second (time-second date)
 937                             :usec usec))))
 938   (let ((mjd (time-mjd date))
 939         (sec (time-second date))
 940         (usec (time-usec date)))
 941     (multiple-value-bind (sec-new usec-new)
 942         (floor (+ usec
 943                   (* 1000000
 944                      (+ sec second
 945                         (* 60 minute)
 946                         (* 60 60 hour))))
 947                1000000)
 948       (declare (ignore sec-new))
 949       (multiple-value-bind (mjd-new sec-new)
 950           (floor sec (* 60 60 24))
 951         (if destructive
 952             (progn
 953               (setf (time-mjd date) (+ mjd mjd-new day)
 954                     (time-second date) sec-new
 955                     (time-usec date) usec-new)
 956               date)
 957             (%make-wall-time :mjd (+ mjd mjd-new day)
 958                              :second sec-new
 959                              :usec usec-new))))))
 960
 961 (defun roll-to (date size position)
 962   (ecase size
 963     (:month
 964      (ecase position
 965        (:beginning
 966         (roll date :day (+ 1
 967                            (- (time-element date :day-of-month)))))
 968        (:end
 969         (roll date :day (+ (days-in-month (time-element date :month)
 970                                           (time-element date :year))
 971                            (- (time-element date :day-of-month)))))))))
 972
 973 (defun week-containing (time)
 974   (let* ((midn (midnight time))
 975          (dow (time-element midn :integer-day-of-week)))
 976     (list (roll midn :day (- dow))
 977           (roll midn :day (- 7 dow)))))
 978
 979 (defun leap-year? (year)
 980   "t if YEAR is a leap yeap in the Gregorian calendar"
 981   (and (= 0 (mod year 4))
 982        (or (not (= 0 (mod year 100)))
 983            (= 0 (mod year 400)))))
 984
 985 (defun valid-month-p (month)
 986   "t if MONTH exists in the Gregorian calendar"
 987   (<= 1 month 12))
 988
 989 (defun valid-gregorian-date-p (date)
 990   "t if DATE (year month day) exists in the Gregorian calendar"
 991   (let ((max-day (days-in-month (nth 1 date) (nth 0 date))))
 992     (<= 1 (nth 2 date) max-day)))
 993
 994 (defun days-in-month (month year &key (careful t))
 995   "the number of days in MONTH of YEAR, observing Gregorian leap year
 996 rules"
 997   (declare (type fixnum month year))
 998   (when careful
 999     (check-type month (satisfies valid-month-p)
1000                 "between 1 (January) and 12 (December)"))
1001   (if (eql month 2)                     ; feb
1002       (if (leap-year? year)
1003           29 28)
1004       (let ((even (mod (1- month) 2)))
1005         (if (< month 8)                 ; aug
1006             (- 31 even)
1007             (+ 30 even)))))
1008
1009 (defun day-of-year (year month day &key (careful t))
1010   "the day number within the year of the date DATE.  For example,
1011 1987 1 1 returns 1"
1012   (declare (type fixnum year month day))
1013   (when careful
1014     (let ((date (list year month day)))
1015     (check-type date (satisfies valid-gregorian-date-p)
1016                 "a valid Gregorian date")))
1017   (let ((doy (+ day (* 31 (1- month)))))
1018     (declare (type fixnum doy))
1019     (when (< 2 month)
1020       (setf doy (- doy (floor (+ 23 (* 4 month)) 10)))
1021       (when (leap-year? year)
1022         (incf doy)))
1023     doy))
1024
1025 (defun parse-yearstring (string)
1026   (let ((year (or (parse-integer-insensitively string)
1027                   (extract-roman string))))
1028     (when (and year (< 1500 year 2500))
1029       (make-time :year year))))
1030
1031 (defun parse-integer-insensitively (string)
1032   (let ((start (position-if #'digit-char-p string))
1033         (end   (position-if #'digit-char-p string :from-end t)))
1034     (when (and start end)
1035       (parse-integer (subseq string start (1+ end)) :junk-allowed t))))
1036
1037 (defvar *roman-digits*
1038   '((#\M . 1000)
1039     (#\D . 500)
1040     (#\C . 100)
1041     (#\L . 50)
1042     (#\X . 10)
1043     (#\V . 5)
1044     (#\I . 1)))
1045
1046 (defun extract-roman (string &aux parse)
1047   (dotimes (x (length string))
1048     (let ((val (cdr (assoc (aref string x) *roman-digits*))))
1049       (when (and val parse (< (car parse) val))
1050         (push (- (pop parse)) parse))
1051       (push val parse)))
1052   (apply #'+ parse))
1053
1054
1055 ;; ------------------------------------------------------------
1056 ;; Parsing iso-8601 timestrings
1057
1058 (define-condition iso-8601-syntax-error (sql-user-error)
1059   ((bad-component;; year, month whatever
1060     :initarg :bad-component
1061     :reader bad-component))
1062   (:report (lambda (c stream)
1063              (format stream "Bad component: ~A " (bad-component c)))))
1064
1065 (defun parse-timestring (timestring &key (start 0) end junk-allowed)
1066   "parse a timestring and return the corresponding wall-time.  If the
1067 timestring starts with P, read a duration; otherwise read an ISO 8601
1068 formatted date string."
1069   (declare (ignore junk-allowed))
1070   (let ((string (subseq timestring start end)))
1071     (if (char= (aref string 0) #\P)
1072         (parse-iso-8601-duration string)
1073       (parse-iso-8601-time string))))
1074
1075 (defvar *iso-8601-duration-delimiters*
1076   '((#\D . :days)
1077     (#\H . :hours)
1078     (#\M . :minutes)
1079     (#\S . :seconds)))
1080
1081 (defun iso-8601-delimiter (elt)
1082   (cdr (assoc elt *iso-8601-duration-delimiters*)))
1083
1084 (defun iso-8601-duration-subseq (string start)
1085   (let* ((pos (position-if #'iso-8601-delimiter string :start start))
1086          (number (when pos (parse-integer (subseq string start pos)
1087                                           :junk-allowed t))))
1088     (when number
1089       (values number
1090               (1+ pos)
1091               (iso-8601-delimiter (aref string pos))))))
1092
1093 (defun parse-iso-8601-duration (string)
1094   "return a wall-time from a duration string"
1095   (block parse
1096     (let ((days 0) (secs 0) (hours 0) (minutes 0) (index 1))
1097       (loop
1098        (multiple-value-bind (duration next-index duration-type)
1099            (iso-8601-duration-subseq string index)
1100          (case duration-type
1101            (:hours
1102             (incf hours duration))
1103            (:minutes
1104             (incf minutes duration))
1105            (:seconds
1106             (incf secs duration))
1107            (:days
1108             (incf days duration))
1109            (t
1110             (return-from parse (make-duration :day days :hour hours
1111                                               :minute minutes :second secs))))
1112          (setf index next-index))))))
1113
1114 ;; e.g. 2000-11-11 00:00:00-06
1115
1116 (defun parse-iso-8601-time (string)
1117   "return the wall-time corresponding to the given ISO 8601 datestring"
1118   (multiple-value-bind (year month day hour minute second usec offset)
1119       (syntax-parse-iso-8601 string)
1120     (make-time :year year
1121                :month month
1122                :day day
1123                :hour hour
1124                :minute minute
1125                :second second
1126                :usec usec
1127                :offset offset)))
1128
1129
1130 (defun syntax-parse-iso-8601 (string)
1131   ;; use strlen to determine if fractional seconds are present in timestamp
1132   (let ((strlen (length string))
1133         year month day hour minute second usec gmt-sec-offset)
1134     (handler-case
1135         (progn
1136           (setf year           (parse-integer string :start 0 :end 4)
1137                 month          (parse-integer string :start 5 :end 7)
1138                 day            (parse-integer string :start 8 :end 10)
1139                 hour           (if (<= 13 strlen)
1140                                    (parse-integer string :start 11 :end 13)
1141                                    0)
1142                 minute         (if (<= 16 strlen)
1143                                    (parse-integer string :start 14 :end 16)
1144                                    0)
1145                 second         (if (<= 19 strlen)
1146                                    (parse-integer string :start 17 :end 19)
1147                                    0))
1148           (cond
1149             ((and (> strlen 19)
1150                   (or (char= #\, (char string 19))
1151                       (char= #\. (char string 19))))
1152              (multiple-value-bind (parsed-usec usec-end)
1153                  (parse-integer string :start 20 :junk-allowed t)
1154                (setf usec          parsed-usec
1155                      gmt-sec-offset (if (<= (+ 3 usec-end)  strlen)
1156                                         (let ((skip-to (or (position #\+ string :start 19)
1157                                                            (position #\- string :start 19))))
1158                                           (if skip-to
1159                                               (* 60 60
1160                                                  (parse-integer string :start skip-to
1161                                                                 :end (+ skip-to 3)))
1162                                               0))
1163                                         0))))
1164             (t
1165              (setf usec           0
1166                    gmt-sec-offset (if (<= 22  strlen)
1167                                       (let ((skip-to (or (position #\+ string :start 19)
1168                                                          (position #\- string :start 19))))
1169                                         (if skip-to
1170                                             (* 60 60
1171                                                (parse-integer string :start skip-to
1172                                                               :end (+ skip-to 3)))
1173                                             0))
1174                                       0))))
1175           (unless (< 0 year)
1176             (error 'iso-8601-syntax-error
1177                    :bad-component '(year . 0)))
1178           (unless (< 0 month)
1179             (error 'iso-8601-syntax-error
1180                    :bad-component '(month . 0)))
1181           (unless (< 0 day)
1182             (error 'iso-8601-syntax-error
1183                    :bad-component '(month . 0)))
1184           (values year month day hour minute second usec gmt-sec-offset))
1185       (simple-error ()
1186         (error 'iso-8601-syntax-error
1187                :bad-component
1188                (car (find-if (lambda (pair) (null (cdr pair)))
1189                              `((year . ,year) (month . ,month)
1190                                (day . ,day) (hour . ,hour)
1191                                (minute . ,minute) (second . ,second)
1192                                (usec . ,usec)
1193                                (timezone . ,gmt-sec-offset)))))))))