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