simple-date/simple-date.lisp

   1 (defpackage :simple-date
   2   (:use :common-lisp)
   3   (:export #:date #:encode-date #:decode-date #:day-of-week
   4            #:timestamp #:encode-timestamp #:decode-timestamp
   5            #:timestamp-to-universal-time #:universal-time-to-timestamp
   6            #:interval #:encode-interval #:decode-interval
   7            #:time-add #:time-subtract
   8            #:time= #:time> #:time< #:time<= #:time>=))
   9
  10 (in-package :simple-date)
  11
  12 (defun to-external-date (year month day)
  13   "Convert a internal date representation to an external one.
  14 Internally, months and days start at 0 and the 1st of March 2000 is
  15 the year 0."
  16   (let ((day (1+ day))
  17         (month (+ month 3))
  18         (year (+ year 2000)))
  19     (if (> month 12)
  20         (values (1+ year) (- month 12) day)
  21         (values year month day))))
  22
  23 (defun to-internal-date (year month day)
  24   "Convert an external date representation to an internal one."
  25   (declare (type integer year)
  26            (type (integer 1 12) month)
  27            (type (integer 1 31) day))
  28   (let ((day (1- day))
  29         (month (- month 3))
  30         (year (- year 2000)))
  31     (if (< month 0)
  32         (values (1- year) (+ month 12) day)
  33         (values year month day))))
  34
  35 (let ((lookup #(0 31 61 92 122 153 184 214 245 275 306 337)))
  36   (defun days-before-month (month)
  37     "Find the amount of days in a year before the start of a given
  38 month. \(This works because in the internal representation march is
  39 the first month, so leap days only happen at the end of the year.)"
  40     (aref lookup month)))
  41
  42 (defun month-at-day (days)
  43   "Find the month in which a given day of the year falls. It's a
  44 manually constructed binary search. Which is pretty ugly."
  45   (if (< days 184)
  46       (if (< days 61)
  47           (if (< days 31) 0 1)
  48           (if (< days 122)
  49               (if (< days 92) 2 3)
  50               (if (< days 153) 4 5)))
  51       (if (< days 245)
  52           (if (< days 214) 6 7)
  53           (if (< days 306)
  54               (if (< days 275) 8 9)
  55               (if (< days 337) 10 11)))))
  56
  57 ;; These assume a typical set of years, they are used by first taking
  58 ;; care of the 4-century periods, then the centuries, etc. That way,
  59 ;; the centuries will never have to deal with a year divisible by 400,
  60 ;; the 4-year periods will never contain century-years, and the
  61 ;; one-year periods are never leap years.
  62 (defconstant +days-in-400-years+ (+ (* 400 365) 97))
  63 (defconstant +days-in-100-years+ (+ (* 100 365) 24))
  64 (defconstant +days-in-4-years+ (+ (* 4 365) 1))
  65 (defconstant +days-in-year+ 365)
  66
  67 (defconstant +millisecs-in-day+ (* 1000 3600 24))
  68
  69 (defun encode-days (year month day)
  70   "Get the number of days since March 1st 2000 for a given date \(in
  71 internal format.)"
  72   (incf day (days-before-month month))
  73   (flet ((adjust (factor days)
  74            (multiple-value-bind (parts remainder) (floor year factor)
  75              (incf day (* parts days))
  76              (setf year remainder))))
  77     (adjust 400 +days-in-400-years+)
  78     (adjust 100 +days-in-100-years+)
  79     (adjust 4 +days-in-4-years+)
  80     (adjust 1 +days-in-year+)
  81     day))
  82
  83 (defun decode-days (days)
  84   "Transform a number of days since March 1st 2000 to a date \(in
  85 internal format.)"
  86   (let ((year 0)
  87         (month 0))
  88     (flet ((adjust (factor factor-days prev)
  89              (multiple-value-bind (parts remainder) (floor days factor-days)
  90                (when (and prev (= parts prev))
  91                  (decf parts)
  92                  (incf remainder factor-days))
  93                (incf year (* factor parts))
  94                (setf days remainder))))
  95       (adjust 400 +days-in-400-years+ nil)
  96       (adjust 100 +days-in-100-years+ 4)
  97       (adjust 4 +days-in-4-years+ 25)
  98       (adjust 1 +days-in-year+ 4)
  99       (setf month (month-at-day days))
 100       (values year month (- days (days-before-month month))))))
 101
 102 (defun encode-millisecs (hour minute second millisecond)
 103   "Get the amount of milliseconds from a number of bigger units."
 104   (+ millisecond (* 1000 (+ second (* 60 (+ minute (* 60 hour)))))))
 105
 106 (defun decode-millisecs (millisecs)
 107   "Decompose a number of milliseconds into hours, minutes, seconds and
 108 milliseconds."
 109   (multiple-value-bind (seconds millisecs) (floor millisecs 1000)
 110     (multiple-value-bind (minutes seconds) (floor seconds 60)
 111       (multiple-value-bind (hours minutes) (floor minutes 60)
 112         (values hours minutes seconds millisecs)))))
 113
 114 (defun leap-year-p (year)
 115   "Is this year a leap year?"
 116   (and (zerop (mod year 4))
 117        (or (not (zerop (mod year 100)))
 118            (zerop (mod year 400)))))
 119
 120 (defun days-in-month (month year)
 121   "Days in a certain month -- note that these months use internal
 122 encoding."
 123   (case month
 124     (11 (if (leap-year-p (1+ year)) 29 28))
 125     ((1 3 6 8) 30)
 126     (t 31)))
 127
 128 (defun normalize-timestamp (days millisecs)
 129   "Make sure that a number of milliseconds falls within a day, correct
 130 the amount of days if necessary."
 131   (multiple-value-bind (extra-days millisecs) (floor millisecs +millisecs-in-day+)
 132     (values (+ days extra-days) millisecs)))
 133
 134 (defun date-add (base-days months)
 135   "Add a number of months to a date \(expressed in days)."
 136   (multiple-value-bind (year month day) (decode-days base-days)
 137     (multiple-value-bind (extra-years month) (floor (+ month months) 12)
 138       (incf year extra-years)
 139       (encode-days year month (min day (1- (days-in-month month year)))))))
 140
 141 (defun invert-interval (interval)
 142   "Invert the components of an interval."
 143   (make-instance 'interval :ms (- (millisecs interval))
 144                  :months (- (months interval))))
 145
 146 (defclass date ()
 147   ((days :initarg :days :accessor days))
 148   (:documentation "This class is used to represent dates where the
 149 time of day is not important."))
 150
 151 (defmethod print-object ((date date) stream)
 152   (print-unreadable-object (date stream :type t)
 153     (multiple-value-bind (year month day) (decode-date date)
 154       (format stream "~2,'0d-~2,'0d-~4,'0d" day month year))))
 155
 156 (defun encode-date (year month day)
 157   "Create a date object."
 158   (multiple-value-bind (year month day) (to-internal-date year month day)
 159     (make-instance 'date :days (encode-days year month day))))
 160
 161 (defun decode-date (date)
 162   "Get the date elements from a date object."
 163   (multiple-value-bind (year month day) (decode-days (days date))
 164     (to-external-date year month day)))
 165
 166 (defun day-of-week (date)
 167   "Returns the weekday of the given date as a number between 0 and 6,
 168 0 being Sunday and 6 being Saturday."
 169   (+ (mod (+ (days date) 3) 7)))
 170
 171 (defclass timestamp (date)
 172   ((millisecs :initarg :ms :accessor millisecs))
 173   (:documentation "A timestamp specifies a time with a precision up to
 174 milliseconds."))
 175
 176 (defmethod print-object ((stamp timestamp) stream)
 177   (print-unreadable-object (stamp stream :type t)
 178     (multiple-value-bind (year month day hour min sec ms) (decode-timestamp stamp)
 179       (format stream "~2,'0d-~2,'0d-~4,'0dT~2,'0d:~2,'0d:~2,'0d~@[,~3,'0d~]"
 180               day month year hour min sec (if (zerop ms) nil ms)))))
 181
 182 (defun encode-timestamp (year month day &optional (hour 0) (minute 0) (second 0) (millisecond 0))
 183   "Create a timestamp object."
 184   (multiple-value-bind (year month day) (to-internal-date year month day)
 185     (make-instance 'timestamp :days (encode-days year month day)
 186                    :ms (encode-millisecs hour minute second millisecond))))
 187
 188 (defun decode-timestamp (timestamp)
 189   "Extract the date and time from a timestamp object."
 190   (multiple-value-bind (year month day) (decode-days (days timestamp))
 191     (multiple-value-bind (year month day) (to-external-date year month day)
 192       (multiple-value-bind (hour minute second millisec) (decode-millisecs (millisecs timestamp))
 193         (values year month day hour minute second millisec)))))
 194
 195 (defconstant +universal-time-offset+ (encode-universal-time 0 0 0 1 3 2000 0))
 196
 197 (defun timestamp-to-universal-time (timestamp)
 198   "Convert a timestamp to a Lisp universal time."
 199   (+ +universal-time-offset+ (round (+ (* +millisecs-in-day+ (days timestamp))
 200                                        (millisecs timestamp)) 1000)))
 201
 202 (defun universal-time-to-timestamp (utime)
 203   "Convert a Lisp universal time to a timestamp."
 204   (multiple-value-bind (days millisecs) (floor (* 1000 (- utime +universal-time-offset+))
 205                                                +millisecs-in-day+)
 206     (make-instance 'timestamp :days days :ms millisecs)))
 207
 208 (defclass interval ()
 209   ((millisecs :initarg :ms :accessor millisecs)
 210    (months :initform 0 :initarg :months :accessor months))
 211   (:documentation "Intervals can be added to date and timestamp units
 212 to get relative times. The amount of time added for the month part of
 213 a timestamp depends on the time it is being added to."))
 214
 215 (defmethod print-object ((interval interval) stream)
 216   (print-unreadable-object (interval stream :type t)
 217     (multiple-value-bind (year month day hour min sec ms) (decode-interval interval)
 218       (flet ((not-zero (x) (if (zerop x) nil x)))
 219         (format stream "P~@[~dY~]~@[~dM~]~@[~dD~]~@[~dH~]~@[~dm~]~@[~d~@[,~3,'0d~]S~]"
 220                 (not-zero year) (not-zero month) (not-zero day)
 221                 (not-zero hour) (not-zero min)
 222                 (if (and (zerop sec) (zerop ms)) nil sec) (not-zero ms))))))
 223
 224 (defun encode-interval (&key (year 0) (month 0) (week 0) (day 0)
 225                         (hour 0) (minute 0) (second 0) (millisecond 0))
 226   "Create an interval object. Parameters may be negative."
 227   (make-instance 'interval
 228                  :ms (+ (* +millisecs-in-day+ (+ day (* 7 week)))
 229                         (encode-millisecs hour minute second millisecond))
 230                  :months (+ month (* 12 year))))
 231
 232 (defun decode-interval (interval)
 233   (multiple-value-bind (day millisecs) (floor (millisecs interval) +millisecs-in-day+)
 234     (multiple-value-bind (hour min sec ms) (decode-millisecs millisecs)
 235       (multiple-value-bind (year month) (floor (months interval) 12)
 236         (values year month day hour min sec ms)))))
 237
 238 (defgeneric time-add (a b)
 239   (:documentation "Generic function for combining datetime objects.
 240 Adding an interval to a date or timestamp will return a new date or
 241 timestamp, increased by the value of the interval. Adding two
 242 intervals returns a new interval with the sum of the two arguments.
 243 Integers can be used in place of intervals, and will be interpreted as
 244 an amount of milliseconds."))
 245
 246 (defmethod time-add ((stamp timestamp) (interval interval))
 247   (multiple-value-bind (days millisecs)
 248       (normalize-timestamp (days stamp) (+ (millisecs stamp) (millisecs interval)))
 249     (unless (zerop (months interval))
 250       (setf days (date-add days (months interval))))
 251     (make-instance 'timestamp :ms millisecs :days days)))
 252
 253 (defmethod time-add ((interval interval) (stamp timestamp))
 254   (time-add stamp interval))
 255
 256 (defmethod time-add ((date date) (interval interval))
 257   (multiple-value-bind (days remainder) (floor (millisecs interval) +millisecs-in-day+)
 258     (unless (zerop remainder)
 259       (error "Can not add an interval spanning a fractional number of days to a date."))
 260     (make-instance 'date :days (date-add (+ (days date) days) (months interval)))))
 261
 262 (defmethod time-add ((interval interval) (date date))
 263   (time-add date interval))
 264
 265 (defmethod time-add ((a interval) (b interval))
 266   (make-instance 'interval :ms (+ (millisecs a) (millisecs b))
 267                  :months (+ (months a) (months b))))
 268
 269 (defmethod time-add ((interval interval) (millisecs integer))
 270   (make-instance 'interval :ms (+ (millisecs interval) millisecs)
 271                  :months (months interval)))
 272
 273 (defmethod time-add ((millisecs integer) (interval interval))
 274   (time-add interval millisecs))
 275
 276 (defmethod time-add ((stamp timestamp) (millisecs integer))
 277   (multiple-value-bind (days millisecs)
 278       (normalize-timestamp (days stamp) (+ (millisecs stamp) millisecs))
 279     (make-instance 'timestamp :ms millisecs :days days)))
 280
 281 (defmethod time-add ((millisecs integer) (stamp timestamp))
 282   (time-add stamp millisecs))
 283
 284 (defmethod time-add ((a integer) (b integer))
 285   (+ a b))
 286
 287 (defgeneric time-subtract (a b)
 288   (:documentation "Subtracts datetime objects from each other.
 289 Subtracting two dates or timestamps results in an interval that
 290 represents the difference between them. Similarly subtracting two
 291 intervals gives their difference."))
 292
 293 (defmethod time-subtract ((a date) (b date))
 294   (make-instance 'interval :ms (* +millisecs-in-day+ (- (days a) (days b)))))
 295
 296 (defmethod time-subtract ((a timestamp) (b date))
 297   (make-instance 'interval :ms (+ (* +millisecs-in-day+ (- (days a) (days b)))
 298                                   (millisecs a))))
 299
 300 (defmethod time-subtract ((a timestamp) (b timestamp))
 301   (make-instance 'interval :ms (+ (* +millisecs-in-day+ (- (days a) (days b)))
 302                                   (- (millisecs a) (millisecs b)))))
 303
 304 (defmethod time-subtract ((date date) (interval interval))
 305   (time-add date (invert-interval interval)))
 306
 307 (defmethod time-subtract ((stamp timestamp) (millisecs integer))
 308   (time-add stamp (- millisecs)))
 309
 310 (defmethod time-subtract ((a interval) (b interval))
 311   (time-add a (invert-interval b)))
 312
 313 (defmethod time-subtract ((interval interval) (millisecs integer))
 314   (time-add interval (- millisecs)))
 315
 316 (defmethod time-subtract ((millisecs integer) (interval interval))
 317   (time-add millisecs (invert-interval interval)))
 318
 319 (defgeneric time= (a b)
 320   (:documentation "Compare two time-related values, returns a boolean
 321 indicating whether they denote the same time or period."))
 322
 323 (defmethod time= ((a date) (b date))
 324   (= (days a) (days b)))
 325
 326 (defmethod time= ((a date) (b timestamp))
 327   (and (= (days a) (days b))
 328        (= (millisecs b) 0)))
 329
 330 (defmethod time= ((a timestamp) (b date))
 331   (time= b a))
 332
 333 (defmethod time= ((a timestamp) (b timestamp))
 334   (and (= (days a) (days b))
 335        (= (millisecs a) (millisecs b))))
 336
 337 (defmethod time= ((a interval) (b interval))
 338   (and (= (millisecs a) (millisecs b))
 339        (= (months a) (months b))))
 340
 341 (defgeneric time< (a b)
 342   (:documentation "Compare two time-related values, returns a boolean
 343 indicating whether the first is less than the second."))
 344
 345 (defmethod time< ((a date) (b date))
 346   (< (days a) (days b)))
 347
 348 (defmethod time< ((a date) (b timestamp))
 349   (or (< (days a) (days b))
 350       (and (= (days a) (days b))
 351            (> (millisecs b) 0))))
 352
 353 (defmethod time< ((a timestamp) (b date))
 354   (time> b a))
 355
 356 (defmethod time< ((a timestamp) (b timestamp))
 357   (or (< (days a) (days b))
 358       (and (= (days a) (days b))
 359            (< (millisecs a) (millisecs b)))))
 360
 361 (defmethod time< ((a interval) (b interval))
 362   (or (< (months a) (months b))
 363       (and (= (months a) (months b))
 364            (< (millisecs a) (millisecs b)))))
 365
 366 (defgeneric time> (a b)
 367   (:documentation "Compare two time-related values, returns a boolean
 368 indicating whether the first is greater than the second."))
 369
 370 (defmethod time> ((a date) (b date))
 371   (> (days a) (days b)))
 372
 373 (defmethod time> ((a date) (b timestamp))
 374   (> (days a) (days b)))
 375
 376 (defmethod time> ((a timestamp) (b date))
 377   (time< b a))
 378
 379 (defmethod time> ((a timestamp) (b timestamp))
 380   (or (> (days a) (days b))
 381       (and (= (days a) (days b))
 382            (> (millisecs a) (millisecs b)))))
 383
 384 (defmethod time> ((a interval) (b interval))
 385   (or (> (months a) (months b))
 386       (and (= (months a) (months b))
 387            (> (millisecs a) (millisecs b)))))
 388
 389 (defun time<= (a b)
 390   "Compare two time-related values, returns a boolean indicating
 391 whether the first is less or equal than the second."
 392   (not (time> a b)))
 393
 394 (defun time>= (a b)
 395   "Compare two time-related values, returns a boolean indicating
 396 whether the first is greater or equal than the second."
 397   (not (time< a b)))