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