base/time.lisp

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