sql/time.lisp

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