aland/cl-dates
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial upload version 0.7

Browse source
This commit is contained in:
Sudhir Shenoy 2017-07-06 23:27:04 +09:00
parent d25c3d51ae
commit c306e8a033
11 changed files with 2015 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

60
cl-dates.asd Normal file
View file

@ -0,0 +1,60 @@
;;; Copyright (c) 2017, Sudhir Shenoy. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-user)
(defpackage :cl-dates
(:use :cl :asdf))
(in-package :cl-dates)
(defsystem :cl-dates
:version "0.7"
:description "Date-time library for Common Lisp"
:author "Sudhir Shenoy"
:license "BSD"
:serial t
:components ((:file "packages")
(:file "util")
(:file "timezones")
(:file "dates")
(:file "parse-date")
(:file "print-date")
(:file "date-arith")))
(defsystem :cl-dates-test
:description "Date-time library tests"
:author "Sudhir Shenoy"
:license "BSD"
:depends-on (:cl-dates)
:serial t
:components ((:file "test-main")
(:file "test-dates")
(:file "test-parse-date")))
(defmethod perform ((o test-op) (c (eql (find-system :cl-dates))))
(operate 'load-op :cl-dates-test)
(funcall (intern (symbol-name :run-all-tests) (find-package :cl-dates-test))))

97
date-arith.lisp Normal file
View file

@ -0,0 +1,97 @@
;;; Copyright (c) 2017, Sudhir Shenoy. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-dates)
;; Date comparisons - strip off time component
(defun date= (&rest dates)
(every (lambda (a b) (= (jday-number a) (jday-number b))) dates (cdr dates)))
(defun date/= (&rest dates)
(notevery (lambda (a b) (= (jday-number a) (jday-number b))) dates (cdr dates)))
(defun date> (&rest dates)
(every (lambda (a b) (> (jday-number a) (jday-number b))) dates (cdr dates)))
(defun date< (&rest dates)
(every (lambda (a b) (< (jday-number a) (jday-number b))) dates (cdr dates)))
(defun date>= (&rest dates)
(every (lambda (a b) (>= (jday-number a) (jday-number b))) dates (cdr dates)))
(defun date<= (&rest dates)
(every (lambda (a b) (<= (jday-number a) (jday-number b))) dates (cdr dates)))
;; Date arithmetic
(defun date+ (date days)
"Advance date by given number of days"
(+ date days))
(defun date- (date days)
"Retreat date by given number of days"
(- date days))
(defun date-diff (dt1 dt2)
"Return (positive) number of days between two dates"
(abs (- (jday-number dt1) (jday-number dt2))))
(defun nth-day-of-week (date dow n)
"Returns the nth day of the week e.g., second Saturday of the month in which date falls.
If n is large enough to make the date fall in a future month, the last valid day in
the month is returned."
(multiple-value-bind (yy mm dd h m s) (date->ymd date)
(declare (ignore dd))
(let ((dt (loop for dd = (ymd->date yy mm 1 h m s) then (1+ dd)
until (eq dow (day-of-week dd))
finally (return dd))))
(if (< n 2)
dt
(dotimes (i (1- n) dt)
(let ((next-dt (+ 7 dt)))
(multiple-value-bind (yy1 mm1 dd1 h1 m1 s1) (date->ymd next-dt)
(declare (ignore yy1 dd1 h1 m1 s1))
(if (/= mm1 mm)
(return dt)
(setf dt next-dt)))))))))
(defun first-of-next-month (date)
"Returns date for 1st of the following month"
(multiple-value-bind (yy mm dd h m s) (date->ymd date)
(declare (ignore dd))
(if (= mm 12)
(ymd->date (1+ yy) 1 1 h m s)
(ymd->date yy (1+ m) 1 h m s))))
(defun last-day-of-month (date)
"Returns last day in curent month"
(1- (first-of-next-month date)))
(defun last-day-of-prev-month (date)
"Returns last day of previous month"
(multiple-value-bind (yy mm dd h m s) (date->ymd date)
(declare (ignore dd))
(1- (ymd->date yy mm 1 h m s))))

283
dates.lisp Normal file
View file

@ -0,0 +1,283 @@
;;; Copyright (c) 2017, Sudhir Shenoy. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-dates)
(defun jday-number (date)
"Returns the Julian day number for the given Julian date"
(floor (+ date 1/2)))
(defparameter +days-of-week+ #(:monday :tuesday :wednesday :thursday :friday :saturday :sunday))
(defun day-of-week (date)
"Returns the day of week on which the given Julian date falls"
(aref +days-of-week+ (mod (jday-number date) 7)))
(defun ymd->date (yy mm dd &optional (hour 0) (min 0) (sec 0) zone)
"Return the Julian date corresponding to the given date and time. No
compensation is made for the Gregorian Calendar introduction.
Note that the Julian date is an integer when the time is noon so a
date without time (midnight) will have a fractional part of 0.5.
If timezone is specified, it should be either an alphabetic code e.g., \"IST\"
or a numeric offset in fractions of an hour e.g., +5.5"
(let* ((a (floor (* 1/12 (- 14 mm))))
(b (- yy a))
(c (floor (/ b 100)))
(day-frac (hms->day-fraction hour min sec))
(jdate (+ (floor (* 30.6001d0 (+ (* a 12) mm 1)))
(- (floor (* 365.25d0 (+ b 4716))) 1524)
(floor (/ c 4))
(- c)
2
dd
(- day-frac 0.5d0)))
(offset (zone-to-offset zone)))
(- jdate (/ offset 24))))
(defun date->ymd (date)
"Returns 6 values corresponding to the given datetime-
year, month, day, hour, minute, second. Second may be a floating
point value but the first five are aways integers"
(let* ((jd (jday-number date))
(e (floor (/ (- jd 1867216.25d0) 36524.25d0)))
(f (+ 1 jd e (- (floor (/ e 4)))))
(g (+ f 1524))
(h (floor (/ (- g 122.1d0) 365.25d0)))
(i (floor (* 365.25d0 h)))
(j (floor (/ (- g i) 30.6001d0)))
(dd (- g i (floor (* j 30.6001d0))))
(mm (- j (* 12 (floor (/ j 14))) 1))
(yy (+ h (floor (* 1/12 (- 14 mm))) -4716))
(day-frac (multiple-value-bind (day frac) (truncate date)
(declare (ignore day))
(if (>= frac 0.5d0)
;; midnight to noon
(- frac 0.5d0)
(+ frac 0.5d0)))))
(multiple-value-bind (h m s) (day-fraction->hms day-frac)
(values yy mm dd h m s))))
(defun valid-date-p (yy mm dd)
"Check that year, month and day form a valid calendar date"
(multiple-value-bind (y m d hr mn sc) (date->ymd (ymd->date yy mm dd))
(declare (ignore hr mn sc))
(and (= yy y) (= mm m) (= dd d))))
(defun valid-time-p (h m s)
"Check that hour, minute and second are valid numbers"
(and (<= 0 h 23) (<= 0 m 59) (>= s 0) (< s 60)))
(defun todays-date ()
"Return current date-time (UTC)"
(multiple-value-bind (s m h dd mm yy dw dst zone)
(decode-universal-time (get-universal-time) 0)
(declare (ignore h m s dw dst zone))
(ymd->date yy mm dd)))
(defun todays-datetime (&optional zone)
"Return current date-time (UTC)"
(let ((offset (zone-to-offset zone)))
(multiple-value-bind (s m h dd mm yy dw dst zone)
(decode-universal-time (get-universal-time) 0)
(declare (ignore dw dst zone))
(- (ymd->date yy mm dd h m s) (/ offset 24)))))
(defun date->javascript-time (date)
"Convert a datetime to the corresponding time value in Javascript"
(let ((days (- date 2440587.5d0))) ; days since 1-Jan-1970
(truncate (* days 86400 1000)))) ; number of milliseconds
(defun easter-day (yy &optional (want-gregorian-date nil))
"Returns the date for Easter Sunday in the given year.
Accurate until approx. 4000 CE
Returns a Julian date if want-gregorian-date is NIL. Otherwise,
it returns year, month, day, hour, minute and second as 6 values"
(let* ((century (floor (/ yy 100)))
(remain-19 (mod yy 19))
(temp (+ (floor (* 1/2 (- century 15)))
202
(* -11 remain-19))))
;; calculate date of Paschal moon
(cond ((member century '(21 24 25 27 28 29 30 31 32 34 35 38))
(decf temp))
((member century '(33 36 37 39 40))
(decf temp 2)))
(setf temp (mod temp 30))
(let ((temp-a (+ temp 21)))
(when (or (= 29 temp)
(and (= 28 temp) (> remain-19 10)))
(decf temp-a))
;; find next Sunday
(let* ((temp-b (mod (- temp-a 19) 7))
(temp-c (mod (- 40 century) 4)))
(when (= temp-c 3)
(incf temp-c))
(when (> temp-c 1)
(incf temp-c))
(setf temp (mod yy 100))
(let* ((temp-d (mod (+ temp (floor (/ temp 4))) 7))
(temp-e (1+ (mod (- 20 temp-b temp-c temp-d) 7)))
(dd (+ temp-a temp-e))
(mm 3))
(when (> dd 31)
(setf dd (- dd 31)
mm 4))
(if want-gregorian-date
(values yy mm dd)
(ymd->date yy mm dd)))))))
(defun vernal-equinox (yy &optional (want-gregorian-date nil))
"Return UTC date-time of the vernal (spring) equinox for the given year.
Returns a Julian date if want-gregorian-date is NIL. Otherwise,
it returns year, month, day, hour, minute and second as 6 values"
(calc-equinox-or-solstice-date 1 yy want-gregorian-date))
(defun summer-solstice (yy &optional (want-gregorian-date nil))
"Return UTC date-time of the summer solstice for the given year.
Returns a Julian date if want-gregorian-date is NIL. Otherwise,
it returns year, month, day, hour, minute and second as 6 values"
(calc-equinox-or-solstice-date 2 yy want-gregorian-date))
(defun autumnal-equinox (yy &optional (want-gregorian-date nil))
"Return UTC date-time of the autumnal equinox for the given year.
Returns a Julian date if want-gregorian-date is NIL. Otherwise,
it returns year, month, day, hour, minute and second as 6 values"
(calc-equinox-or-solstice-date 3 yy want-gregorian-date))
(defun winter-solstice (yy &optional (want-gregorian-date nil))
"Return UTC date-time of the winter solstice for the given year.
Returns a Julian date if want-gregorian-date is NIL. Otherwise,
it returns year, month, day, hour, minute and second as 6 values"
(calc-equinox-or-solstice-date 4 yy want-gregorian-date))
;; Formulae are from Chapter 27 of Jan Meeus' Astronomical Algorithms
;; Valid for years between 1000-3000
;; Accurate to within a minute from 1950-2050
(defun calc-equinox-or-solstice-date (which yy want-gregorian-date)
(let* ((mf (/ (- yy 2000) 1000))
(date (cond ((= which 1) (+ 2451623.80984d0
(* mf 365242.37404d0)
(* mf mf 0.05169d0)
(* mf mf mf -0.00411d0)
(* mf mf mf mf -0.00057d0)))
((= which 2) (+ 2451716.56767d0
(* mf 365241.62603d0)
(* mf mf 0.00325d0)
(* mf mf mf 0.00888d0)
(* mf mf mf mf -0.00030d0)))
((= which 3) (+ 2451810.21715d0
(* mf 365242.01767d0)
(* mf mf -0.11575d0)
(* mf mf mf -0.00337d0)
(* mf mf mf mf 0.00078d0)))
((= which 4) (+ 2451900.05952d0
(* mf 365242.74049d0)
(* mf mf -0.06223d0)
(* mf mf mf -0.00823d0)
(* mf mf mf mf 0.00032d0)))
(t (error "Invalid param which: ~a" which)))))
(setf date (apply-correction-factors yy date))
(if want-gregorian-date
(date->ymd date)
date)))
(defun cos-degrees (deg)
(cos (/ (* deg pi) 180d0)))
;; Jan Meeus' Astronomical Algorithms, Chapter 27
(defun apply-correction-factors (yy jd)
(let* ((t0 (/ (- jd 2451545d0) 36525d0))
(w (- (* 35999.373d0 t0) 2.47d0))
(dl (+ 1.0 (* 0.0334d0 (cos-degrees w))
(* 0.0007d0 (cos-degrees (* 2.0d0 w)))))
(s (periodic-24 t0)))
;; get correct time in TDT (terrestrial dynamic time)
(incf jd (/ (* 0.00001d0 s) dl))
;; apply correction TDT -> UTC
(tdt-to-utc yy jd)))
;; Jan Meeus' Astronomical Algorithms, Chapter 27
(defparameter +periodic-24-a+ #(485d0 203d0 199d0 182d0 156d0 136d0 77d0 74d0 70d0
58d0 52d0 50d0 45d0 44d0 29d0 18d0 17d0 16d0 14d0
12d0 12d0 12d0 9d0 8d0))
(defparameter +periodic-24-b+ #(324.96d0 337.23d0 342.08d0 27.85d0 73.14d0 171.52d0
222.54d0 296.72d0 243.58d0 119.81d0 297.17d0 21.02d0
247.54d0 325.15d0 60.93d0 155.12d0 288.79d0 198.04d0
199.76d0 95.39d0 287.11d0 320.81d0 227.73d0 15.45d0))
(defparameter +periodic-24-c+ #(1934.136d0 32964.467d0 20.186d0 445267.112d0 45036.886d0
22518.443d0 65928.934d0 3034.906d0 9037.513d0 33718.147d0
150.678d0 2281.226d0 29929.562d0 31555.956d0 4443.417d0
67555.328d0 4562.452d0 62894.029d0 31436.921d0 14577.848d0
31931.756d0 34777.259d0 1222.114d0 16859.074d0))
(defun periodic-24 (t0)
(loop for i from 0 below 24
summing (* (aref +periodic-24-a+ i)
(cos-degrees (+ (aref +periodic-24-b+ i)
(* t0 (aref +periodic-24-c+ i)))))))
;; TDT -> UTC conversion: from Meeus' Astronomical Algorithms, Chapter 10
;; Applies affsets in seconds to convert from Terrestrial Dynamic Time to UTC
;;
;; Offsets are directly available for even-numbered years between 1620-2002.
;; Offsets for odd-numbered years are linearly interpolated.
;; Offsets for years before 1620 and after 2002 (upto 2100) are obtained by
;; applying interpolation formulae.
;; 2000 and 2002 year data is from NASA and others from Meeus.
(defparameter +tdt-offsets+
#(121 112 103 95 88 82 77 72 68 63 60 56 53 51 48 46 44 42 40 38 ; 1620-1658
35 33 31 29 26 24 22 20 18 16 14 12 11 10 9 8 7 7 7 7 ; 1660-1698
7 7 8 8 9 9 9 9 9 10 10 10 10 10 10 10 10 11 11 11 ; 1700-1738
11 11 12 12 12 12 13 13 13 14 14 14 14 15 15 15 15 15 16 16 ; 1740-1778
16 16 16 16 16 16 15 15 14 13 13.1 12.5 12.2 12 12 12 12 12 12 11.9 ; 1780-1818
11.6 11 10.2 9.2 8.2 7.1 6.2 5.6 5.4 5.3 5.4 5.6 5.9 6.2 6.5 ; 1820-1848
6.8 7.1 7.3 7.5 7.6 7.7 7.3 6.2 5.2 2.7 1.4 -1.2 -2.8 -3.8 -4.8 ; 1850-1878
-5.5 -5.3 -5.6 -5.7 -5.9 -6 -6.3 -6.5 -6.2 -4.7 -2.8 -0.1 2.6 5.3 7.7 ; 1880-1908
10.4 13.3 16 18.2 20.2 21.1 22.4 23.5 23.8 24.3 24 23.9 23.9 23.7 24 ; 1910-1938
24.3 25.3 26.2 27.3 28.2 29.1 30 30.7 31.4 32.2 33.1 34 35 36.5 38.3 ; 1940-1968
40.2 42.2 44.5 46.5 48.5 50.5 52.5 53.8 54.9 55.8 56.9 58.3 60 61.6 63 ; 1970-1998
63.8 64.3)) ; 2000-2002
(defparameter +offsets-first-year+ 1620)
(defparameter +offsets-last-year+ (+ +offsets-first-year+
(* 2 (1- (length +tdt-offsets+)))))
(defun tdt-to-utc (yy jd)
(let* ((yt (/ (- yy 2000) 100d0)) ; centuries from epoch
(delta-t ; calculated offset in seconds
(cond ((<= +offsets-first-year+ yy +offsets-last-year+)
;; correction directly available from table
(if (evenp yy)
;; lookup directly
(aref +tdt-offsets+ (* 1/2 (- yy +offsets-first-year+)))
;; interpolate
(* 1/2 (+ (aref +tdt-offsets+ (* 1/2 (- (1+ yy) +offsets-first-year+)))
(aref +tdt-offsets+ (* 1/2 (- (1- yy) +offsets-first-year+)))))))
((< yy 948)
(+ 2177d0 (* 497d0 yt) (* 44.1d0 yt yt)))
((< yy 947 +offsets-first-year+)
(+ 102d0 (* 102d0 yt) (* 25.3d0 yt yt)))
((<= 2000 yy 2100)
(+ 102d0 (* 102d0 yt) (* 25.3d0 yt yt)
(* 0.37d0 (- yy 2100))))
;; no adjustment available for years later than 2100
(t 0))))
;; decrement date by offset seconds (as a fraction of a day)
(decf jd (hms->day-fraction 0 0 delta-t))))

78
packages.lisp Normal file
View file

@ -0,0 +1,78 @@
;;; Copyright (c) 2017, Sudhir Shenoy. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-user)
(defpackage :cl-dates
(:nicknames :dt)
(:use :common-lisp)
(:export
;; Make a new date
:ymd->date ; date from y/m/d/h/m/s components
:string->date ; date from string
:todays-date ; system date
:todays-datetime ; system date-time
;; Date converters
:date->ymd ; to components
:date->string ; to string
:date->long-string ; to string (verbose)
:date->javascript-time ; to JS datetime
:date->local-time ; to local time zone
:month->string ; full name of month
:dow->string ; day of week as string
;; Special dates for given year
:easter-day ; easter day
:vernal-equinox ; spring equinox date-time
:summer-solstice ; summer solstice date-time
:autumnal-equinox ; autumn equinox date-time
:winter-solstice ; winter solstice date-time
;; Miscellaneous functions
:valid-date-p
:valid-time-p
:jday-number ; Julian day number
:day-of-week ; Day of week for date
;; Comparisons
:date= :date/=
:date< :date<=
:date> :date>=
;; Calendar date arithmetic
:date+ :date- ; add/subtract days to date
:date-diff ; days between two dates
:nth-day-of-week ; 'n' weeks offset from start of month
:first-of-next-month ; first day of next month
:last-day-of-month ; last calendar day in month
:last-day-of-prev-month ; last calendar day in previous month
;; Business date arithmetic
;; :previous-workday ; last working day before date (which can be a holiday)
;; :next-workday ; next working day after date (which can be a holiday)
;; :bdate+ :bdate- ; add/subtract working days to date
;; :add-calendar-months ; add/subtract months obeying day count conventions
;; :add-months ; add/subtract months obeying day count conventions
;; :last-workday-of-month ; Last working day in month
;; :generate-date-series ; Series of coupon dates following day conventions
))

592
parse-date.lisp Normal file
View file

@ -0,0 +1,592 @@
;;; Copyright (c) 2017, Sudhir Shenoy. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-dates)
(defparameter +white-space+ '(#\space #\tab #\return #\linefeed #\newline))
(defun white-space-p (char)
(member char +white-space+ :test #'char=))
(defun tokenize (str)
(let ((token-list nil)
(state nil)
(token nil)
(seen-alpha nil))
(labels ((split-list (test list &aux (start list) (end list))
(loop while (and end (setq start (member-if-not test end)))
collect (ldiff start (setq end (member-if test start)))))
(emit-token ()
(if (and (member state '(:in-alpha-num :in-num-alpha))
(or seen-alpha
(> (count #\. token) 1)
(char= #\. (car token)))
;; ugly special casing for a.m./p.m. strings
(not (equal token '(#\. #\m #\. #\a)))
(not (equal token '(#\m #\. #\a)))
(not (equal token '(#\. #\m #\. #\p)))
(not (equal token '(#\m #\. #\p))))
(progn
;; separate "23.jun.2017" => "23" "." "jun" "." "2017"
;; any trailing period will be dropped
(setf token (nreverse token))
(loop for tk on (split-list #'(lambda(x) (char= x #\.)) token)
do (progn
(push (coerce (car tk) 'string) token-list)
(unless (null (cdr tk))
(push "." token-list)))))
(push (coerce (nreverse token) 'string) token-list))
;; reset state
(setf state nil seen-alpha nil token nil)))
(do ((i 0 (1+ i))
(len-str (length str)))
((>= i len-str))
(let ((ch (schar str i)))
(case state
((nil)
(push ch token)
(setf state (cond ((alpha-char-p ch) :in-alpha)
((digit-char-p ch) :in-num)
((white-space-p ch) :in-space)
(t :in-separators))))
(:in-separators
(if (or (alphanumericp ch) (white-space-p ch))
(progn
(decf i)
(emit-token))
(push ch token)))
(:in-space
(when (not (white-space-p ch))
;; throw away white space and reset state
(decf i)
(setf token nil state nil)))
(:in-alpha
(setf seen-alpha t)
(cond ((alpha-char-p ch) (push ch token))
((char= ch #\.)
(push ch token)
(setf state :in-alpha-num))
(t (decf i)
(emit-token))))
(:in-num
(cond ((digit-char-p ch) (push ch token))
((char= ch #\.)
(push ch token)
(setf state :in-num-alpha))
(t (decf i)
(emit-token))))
(:in-alpha-num
(setf seen-alpha t)
(cond ((or (alpha-char-p ch) (char= ch #\.)) (push ch token))
((and (digit-char-p ch) token (char= #\. (car token)))
(push ch token)
(setf state :in-num-alpha))
(t (decf i)
(emit-token))))
(:in-num-alpha
(cond ((or (digit-char-p ch) (char= ch #\.)) (push ch token))
((and (alpha-char-p ch) token (char= #\. (car token)))
(push ch token)
(setf state :in-alpha-num))
(t(decf i)
(emit-token)))))))
(when (and token (not (member state '(:in-space :in-separators))))
(emit-token)))
(nreverse token-list)))
(defun advance-date (dt dow dir)
(if (eq dir :closest)
(let ((next (advance-date dt dow :next))
(prev (advance-date dt dow :prev)))
(if (< (- dt prev) (- next dt))
prev
next))
(let ((inc (if (eq dir :next) 1 -1)))
(loop
(if (eq (day-of-week dt) dow)
(return dt)
(incf dt inc))))))
(defun make-four-digit-year (year)
(if (> year 99)
year
(multiple-value-bind (s m h dd mm yy dw dst zone)
(decode-universal-time (get-universal-time) 0)
(declare (ignore s m h dd mm dw dst zone))
(let ((century (* 100 (truncate (/ yy 100)))))
(incf year century)
(if (>= (abs (- year yy)) 50)
(if (< year yy)
(+ year 100)
(- year 100))
year)))))
;; decide between yy/mm and mm/yy
(defun assign-yy-mm (list precedence)
(cond ((> (car list) 12) (values (car list) (cadr list)))
((> (cadr list) 12) (values (cadr list) (car list)))
((eq precedence :ymd) (values (car list) (cadr list)))
(t (values (cadr list) (car list)))))
;; decide between yy/dd and dd/yy
(defun assign-yy-dd (list precedence)
(cond ((> (car list) 31) (values (car list) (cadr list)))
((> (cadr list) 31) (values (cadr list) (car list)))
((eq precedence :ymd) (values (car list) (cadr list)))
(t (values (cadr list) (car list)))))
;; decide between dd/mm and mm/dd
(defun assign-mm-dd (list precedence)
(cond ((> (car list) 12) (values (cadr list) (car list)))
((> (cadr list) 12) (values (car list) (cadr list)))
((or (eq precedence :ymd) (eq precedence :mdy))
(values (car list) (cadr list)))
(t (values (cadr list) (car list)))))
;; decide order in which day, month and year appear given 2 or 3 numbers
(defun assign-yy-mm-dd (list precedence)
(if (= 2 (length list))
(cond ((and (> (car list) 12) (> (cadr list) 12))
(multiple-value-bind (yy dd) (assign-yy-dd list precedence)
(values yy nil dd)))
(t (multiple-value-bind (yy mm) (assign-yy-mm list precedence)
(values yy mm nil))))
(let (tmp)
(cond ((every #'(lambda(x) (<= x 12)) list)
;; 01/02/03
(cond ((eq precedence :mdy) (values (third list) (first list) (second list)))
((eq precedence :dmy) (values (third list) (second list) (first list)))
(t (values (first list) (second list) (third list)))))
((setf tmp (find-if #'(lambda(x) (> x 31)) list))
;; 12/5/55
(setf list (remove tmp list :count 1))
(multiple-value-bind (mm dd) (assign-mm-dd list precedence)
(values tmp mm dd)))
((= 1 (count-if #'(lambda(x) (<= x 12)) list))
(setf tmp (find-if #'(lambda(x) (<= x 12)) list)
list (remove tmp list :count 1))
(multiple-value-bind (yy dd) (assign-yy-dd list precedence)
(values yy tmp dd)))
(t ;; 5/6/27
(cond ((eq precedence :ymd)
(multiple-value-bind (mm dd) (assign-mm-dd (cdr list) precedence)
(values (car list) mm dd)))
((eq precedence :dmy)
(multiple-value-bind (yy mm) (assign-yy-mm (cdr list) precedence)
(values yy mm (car list))))
(t (multiple-value-bind (yy dd) (assign-yy-dd (cdr list) precedence)
(values yy (car list) dd)))))))))
;; struct to hold values during parse
(defstruct (date-components (:conc-name dt-))
dow yr mth day hr min sec tz)
(defparameter +date-separators+ '("." "/" "-"))
(defun string->date (string &key (reference-date (todays-date)) (precedence :ymd))
(setf string (string-downcase (string-trim +white-space+ string)))
(unless (member precedence '(:ymd :dmy :mdy))
(error "invalid precedence ~a" precedence))
(macrolet ((when-null-set (var field value)
`(when (null (,field ,var)) (setf (,field ,var) ,value))))
(let* ((res (make-date-components))
(tokens (tokenize string))
(num-tok (length tokens))
(skipped-tokens nil) ; tokens that were ignored
(relative-dow nil) ; when day of week is qualified by this/next/prev
(date-comps nil) ; uncertain whether day/month/year
(num-date-comps 0) ; length of date-comps + date components in res
(time-parsed nil)) ; whether all of h/m/s have been parsed
(do ((i 0 (1+ i)))
((>= i num-tok))
(let* ((token (elt tokens i))
(len (length token))
(next-tok (if (>= (1+ i) num-tok) nil (elt tokens (1+ i))))
(prev-tok (if (> i 0) (elt tokens (1- i)) nil))
(num (parse-number token))
tmp)
(when (numberp num)
(cond
;; e.g. yyyymmddThhmmss or yyyymmddThh:mm:ss
((and (= num-date-comps 3)
(or (= len 2) (= len 4) (= len 6))
prev-tok (string= prev-tok "t")
(null (find #\. token)))
;; if colon separated time, only hour will be parsed
;; cannot set time-parsed to T unless len > 2
(setf (dt-hr res) (parse-integer (subseq token 0 2)))
(when (>= len 4)
(setf (dt-min res) (parse-integer (subseq token 2 4))
time-parsed t))
(when (= len 6)
(setf (dt-sec res) (parse-integer (subseq token 4)))))
;; YYMMDD or HHMMSS
((or (= len 6)
(and (> len 7) (setf tmp (position #\. token)) (= tmp 6)))
(if (and (= 0 num-date-comps) (= len 6)
(or (null prev-tok) (string/= prev-tok "t")))
;; date if not yet parsed and not explicitly marked as time
(let* ((yy (truncate (/ num 10000)))
(mm (truncate (- (/ num 100) (* yy 100))))
(dd (truncate (- num (+ (* yy 10000) (* mm 100))))))
(setf date-comps (list dd mm yy)) ; reverse order of specification
(incf num-date-comps 3))
;; time
(setf (dt-hr res) (parse-integer (subseq token 0 2))
(dt-min res) (parse-integer (subseq token 2 4))
(dt-sec res) (parse-number (subseq token 4))
time-parsed t)))
;; YYYYMMDD - only format for 8 digit date (ddmmyyyy must be e.g. dd/mm/yyyy)
((= len 8)
(when (find #\. token)
;; nnnn.nnn
(return-from string->date nil))
(let* ((yy (truncate (/ num 10000)))
(mm (truncate (- (/ num 100) (* yy 100))))
(dd (truncate (- num (+ (* yy 10000) (* mm 100))))))
(setf (dt-yr res) yy (dt-mth res) mm (dt-day res) dd)
(incf num-date-comps 3)))
;; YYYYMMDDHHMM[SS[.ss]]
((or (= len 12) (= len 14)
(and (> len 15) (setf tmp (position #\. token)) (= tmp 14)))
(setf (dt-yr res) (parse-integer (subseq token 0 4))
(dt-mth res) (parse-integer (subseq token 4 6))
(dt-day res) (parse-integer (subseq token 6 8))
(dt-hr res) (parse-integer (subseq token 8 10))
(dt-min res) (parse-integer (subseq token 10 12)))
(incf num-date-comps 3)
(when (> len 12)
(setf (dt-sec res) (parse-number (subseq token 12))))
(setf time-parsed t))
;; HH:MM:SS
((or (and next-tok (string= next-tok ":"))
(and (not (null (dt-hr res))) prev-tok (string= prev-tok ":")))
;; distinguish case when coming here from yyyymmddThh:mm:ss
(unless (and prev-tok (not time-parsed) (string= prev-tok ":"))
(setf (dt-hr res) num)
(incf i 2)) ; advance pointer to minute
(setf num (parse-number (elt tokens i)))
(when (null num)
(return-from string->date nil))
;; also handle weirdness like hh:mm.ss
(multiple-value-bind (int frac) (truncate num)
(setf (dt-min res) int)
(when (> frac 0)
(setf (dt-sec res) (* 60 frac))
(when (and (< (1+ i) num-tok) (string= (elt tokens (1+ i)) ":"))
;; can't handle hh:mm.ss:wtf
(return-from string->date nil))))
(when (and (< (1+ i) num-tok) (string= (elt tokens (1+ i)) ":"))
(incf i 2) ; position on second
;; both hh:mm:<eos> and hh:mm:ss are acceptable
(when (< i num-tok)
(setf num (parse-number (elt tokens i)))
(when (null num)
(return-from string->date nil))
(setf (dt-sec res) num))))
;; dd/mm/yy and variants
((and next-tok (member next-tok +date-separators+ :test #'string=))
(let ((sep next-tok)
(is-ymd nil))
(if (> num 31)
;; year - default to yymmdd format
(setf (dt-yr res) num
is-ymd t)
(push num date-comps))
(incf num-date-comps)
(incf i 2) ; position on second component
(when (>= i num-tok)
;; reject strings ending in trailing slash
(return-from string->date nil))
(setf num (parse-number (elt tokens i)))
(if (numberp num)
(cond ((and is-ymd (<= num 12)) (setf (dt-mth res) num))
(is-ymd (setf (dt-day res) num))
(t (push num date-comps)))
(progn
(setf tmp (str-to-month (elt tokens i)))
(if tmp
(setf (dt-mth res) tmp)
;; not number or month name
(return-from string->date nil))))
(incf num-date-comps)
(when (and (< (1+ i) num-tok) (string= sep (elt tokens (1+ i))))
(incf i 2) ; position on last component
(when (>= i num-tok)
(return-from string->date nil)) ; trailing slash
(setf num (parse-number (elt tokens i)))
(when (null num)
;; month name in last position is not accepted
(return-from string->date nil))
(cond ((and is-ymd (not (null (dt-day res)))) (setf (dt-mth res) num))
(is-ymd (setf (dt-day res) num))
(t (push num date-comps)))
(incf num-date-comps))))
;; 2nd, 3rd, 21st etc. - parse as day
((and next-tok (str-is-day-suffix next-tok))
(incf i) ; skip suffix
(setf (dt-day res) num)
(incf num-date-comps))
;; 13h45m, 13h 45, etc - parse as time
((and next-tok (setf tmp (str-to-hms next-tok)))
(loop
;; consume following tokens as far as possible
(multiple-value-bind (int frac) (truncate num)
(cond ((eq tmp :hour)
(setf (dt-hr res) int)
(when (> frac 0)
(setf (dt-min res) (* 60 frac))))
((eq tmp :minute)
(setf (dt-min res) int)
(when (> frac 0)
(setf (dt-sec res) (* 60 frac))))
((eq tmp :second)
(setf (dt-sec res) num
time-parsed t))))
(incf i) ; pointer is on suffix
(when (or (>= (1+ i) num-tok) (eq tmp :second))
(return)) ; done
(setf num (parse-number (elt tokens (1+ i))))
(when (null num)
(return))
(incf i) ; pointer on number after time suffix
(if (or (>= (1+ i) num-tok)
(null (str-to-hms (elt tokens (1+ i)))))
;; no time suffix - set to min/sec based on what prev token was
(progn
(if (eq tmp :hour)
(multiple-value-bind (int frac) (truncate num)
(setf (dt-min res) int)
(when (> frac 0)
(setf (dt-sec res) (* 60 frac))))
(setf (dt-sec res) num))
(setf time-parsed t)
(return))
;; set up var for next loop iteration
(setf tmp (str-to-hms (elt tokens (1+ i)))))))
;; time with am/pm indicator e.g. 10 am
((and next-tok (setf tmp (str-to-ampm next-tok)))
(when (> num 12)
(return-from string->date nil))
(multiple-value-bind (int frac) (truncate num)
(if (and (< int 12) (eq tmp :pm))
(incf int 12)
(when (and (= int 12) (eq tmp :am))
(setf int 0)))
(setf (dt-hr res) int)
(when (> frac 0)
;; 10.37 pm - frac is minutes not fraction of hour
(setf (dt-min res) frac
time-parsed t))))
;; all other numbers - assume it is a date component
(t (if (and prev-tok (string= prev-tok "of") (not (null (dt-mth res))))
;; june of 1976
(setf (dt-yr res) num)
(push num date-comps))
(incf num-date-comps)))
;; avoid giant if-then-else
(go end-of-do-loop))
;; token is not a number
(cond
;; weekday
((setf tmp (str-to-weekday token)) (setf (dt-dow res) tmp))
;; relative day of week
((setf tmp (str-to-relative-dow token)) (setf relative-dow tmp))
;; today / tomorrow etc
((setf tmp (str-to-relative-date token))
(when (/= 0 num-date-comps)
(return-from string->date nil))
(multiple-value-bind (yy mm dd h m s) (date->ymd (+ reference-date tmp))
(setf (dt-yr res) yy
(dt-mth res) mm
(dt-day res) dd
num-date-comps 3)
(when-null-set res dt-hr h)
(when-null-set res dt-min m)
(when-null-set res dt-sec s)))
;; am/pm
((setf tmp (str-to-ampm token))
(let ((hr (dt-hr res)))
(when (null hr)
;; am/pm not accepted before time string
(return-from string->date nil))
(if (and (= hr 12) (eq tmp :am))
(setf hr 0)
(when (and (< hr 12) (eq tmp :pm))
(incf hr 12)))
(setf (dt-hr res) hr)))
;; time zone name
((or (and (> (length token) 2) (setf tmp (str-to-tz-offset token)))
;; military time zone spec valid only at end of string
(and (<= (length token) 2) (null next-tok) (setf tmp (str-to-tz-offset token))))
(when (null (dt-hr res))
(return-from string->date nil))
;; if a time zone is specified as e.g. GMT+9 or JST-1,
;; the next cond-clause for numeric offset will process it.
;; offset is stored as fractions of a day since we add it to the julian date
(setf (dt-tz res) (/ tmp 24)))
;; Numeric time zone offset: e.g., +0530 or +05:30 or -5
;; also handles GMT+9 etc in conjunction with previous clause
((and (or (string= token "+") (string= token "-"))
next-tok (not (null (parse-number next-tok))))
(when (null (dt-hr res))
(return-from string->date nil))
(let ((sign (if (string= token "+") 1 -1))
offset-hrs)
(incf i) ; position on number
(cond
;; e.g. 5:30
((and (< (1+ i) num-tok) (string= ":" (elt tokens (1+ i))))
(setf offset-hrs (/ (parse-integer next-tok) 24))
(incf i 2) ; position on minutes
(if (or (>= i num-tok) (null (setf tmp (parse-number (elt tokens i)))))
(return-from string->date nil)
(incf offset-hrs (/ tmp 1440))))
;; e.g., 3.5 or 11
((or (not (null (position #\. next-tok))) (< (length next-tok) 3))
(setf offset-hrs (/ (parse-number next-tok) 24)))
;; e.g., 0530
((= 4 (length next-tok))
(setf offset-hrs (+ (/ (parse-integer (subseq next-tok 0 2)) 24)
(/ (parse-integer (subseq next-tok 2 4)) 1440))))
;; e.g., 530
((= 3 (length next-tok))
(setf offset-hrs (+ (/ (parse-integer (subseq next-tok 0 1)) 24)
(/ (parse-integer (subseq next-tok 1 3)) 1440))))
;; all others are invalid
(t (return-from string->date nil)))
(setf offset-hrs (* sign offset-hrs))
(if (null (dt-tz res))
(setf (dt-tz res) offset-hrs)
(incf (dt-tz res) offset-hrs))))
;; Alphabetic month name
((setf tmp (str-to-month token))
(when (dt-mth res)
(return-from string->date nil)) ; duplicate spec
(setf (dt-mth res) tmp)
(incf num-date-comps)
(when (and next-tok (member next-tok +date-separators+ :test #'string=))
;; Jul/23/1956
(let ((sep next-tok))
(incf i 2) ; point to second component
(when (< i num-tok)
(setf num (parse-number (elt tokens i)))
(when (null num)
(return-from string->date nil))
(incf num-date-comps)
(if (> num 31)
(setf (dt-yr res) num) ; clearly a year
(push num date-comps))
(when (and (< (1+ i) num-tok) (string= sep (elt tokens (1+ i))))
(incf i 2) ; point to third component
(setf num (parse-number (elt tokens i)))
(when (null num)
(return-from string->date nil))
(incf num-date-comps)
(if (> num 31)
(if (dt-yr res)
;; Jul/99/1985
(return-from string->date nil)
;; unambiguous date
(setf (dt-yr res) num
(dt-day res) (pop date-comps)))
(if (dt-yr res)
(setf (dt-day res) num)
(push num date-comps))))))))
;; default - skip token
(t (push token skipped-tokens))))
end-of-do-loop)
(when (> num-date-comps 3)
(return-from string->date nil))
(when (and (= num-date-comps 0) (dt-dow res)
(null relative-dow))
;; day of week without date is relative to reference date
(setf relative-dow :closest))
(when date-comps
(setf date-comps (nreverse date-comps)) ; order of appearance
(let ((len (length date-comps)))
(cond ((or (= 3 num-date-comps len)
(= 2 num-date-comps len)) ; all uncertain
(multiple-value-bind (yy mm dd) (assign-yy-mm-dd date-comps precedence)
(setf (dt-yr res) yy (dt-mth res) mm (dt-day res) dd)))
((and (= 3 num-date-comps) (= 2 len)) ; 2 of 3 are not certain
(cond ((dt-day res) (multiple-value-bind (yy mm) (assign-yy-mm date-comps precedence)
(setf (dt-yr res) yy (dt-mth res) mm)))
((dt-mth res) (multiple-value-bind (yy dd) (assign-yy-dd date-comps precedence)
(setf (dt-yr res) yy (dt-day res) dd)))
((dt-yr res) (multiple-value-bind (mm dd) (assign-mm-dd date-comps precedence)
(setf (dt-mth res) mm (dt-day res) dd)))))
((and (= 3 num-date-comps) (= 1 len)) ; assign to null memeber in res
(when-null-set res dt-yr (car date-comps))
(when-null-set res dt-mth (car date-comps))
(when-null-set res dt-day (car date-comps)))
((and (= 2 num-date-comps) (= 1 len))
(cond ((dt-yr res) ;; dd or mm
(cond ((> (car date-comps) 12) (setf (dt-day res) (car date-comps)))
((eq precedence :dmy) (setf (dt-day res) (car date-comps)))
(t (setf (dt-mth res) (car date-comps)))))
((dt-mth res) ;; dd or yy
(if (> (car date-comps) 31)
(setf (dt-yr res) (car date-comps))
(setf (dt-day res) (car date-comps))))
((dt-day res) ;; mm or yy
(if (> (car date-comps) 12)
(setf (dt-yr res) (car date-comps))
(setf (dt-mth res) (car date-comps))))))
(t ;; i.e., num-date-comps = 1 so one of dd or mm or yy
(cond ((> (car date-comps) 31) (setf (dt-yr res) (car date-comps)))
((<= (car date-comps) 12) (setf (dt-mth res) (car date-comps)))
(t ;; between 12 and 31
(setf (dt-day res) (car date-comps))))))))
;; check that we could assign all date components
(when (/= num-date-comps (+ (if (dt-yr res) 1 0) (if (dt-mth res) 1 0) (if (dt-day res) 1 0)))
;; duplicate day / mth / year
(return-from string->date nil))
;; handle two-digit years
(when (dt-yr res)
(setf (dt-yr res) (make-four-digit-year (dt-yr res))))
;; copy all missing values from the reference date
(multiple-value-bind (yy mm dd h m s) (date->ymd reference-date)
(when-null-set res dt-yr yy)
(when-null-set res dt-mth mm)
(when-null-set res dt-day dd)
(when-null-set res dt-hr h)
(when-null-set res dt-min m)
(when-null-set res dt-sec s))
(unless (and (valid-date-p (dt-yr res) (dt-mth res) (dt-day res))
(valid-time-p (dt-hr res) (dt-min res) (dt-sec res)))
(return-from string->date nil))
(let ((dt (ymd->date (dt-yr res) (dt-mth res) (dt-day res)
(dt-hr res) (dt-min res) (dt-sec res))))
(if (and relative-dow (dt-dow res))
(setf dt (advance-date dt (dt-dow res) relative-dow))
(when (dt-dow res)
(when (and (= 3 num-date-comps) (not (eq (dt-dow res) (day-of-week dt))))
;; date was misparsed or day of week is not consistent with date
(return-from string->date nil))))
(when (dt-tz res)
;; +ve offset = subtract, -ve offset = add
(decf dt (dt-tz res)))
(values dt skipped-tokens)))))

108
print-date.lisp Normal file
View file

@ -0,0 +1,108 @@
;;; Copyright (c) 2017, Sudhir Shenoy. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-dates)
(defun date->string (date &key (format :human) zone)
"Return a string representation of a datetime as per the desired format.
Format must be specified as one of (:human :iso-8601 :asctime :rfc-822 :rfc-850).
The time is omitted if it is exactly midnight or noon
If timezone is not null, the datetime is first translated to the given timezone
from UTC and then converted to a string. Timezone can be specified as an alphabetic
code or a numeric offset in fractions of hours.
The :human format is the same as :iso-8601 except that the separators between date,
time and timezone are spaces to make it more readable to the human eye."
(let ((offset (zone-to-offset zone)))
(incf date (/ offset 24))
(multiple-value-bind (yy mm dd h m s) (date->ymd date)
(let ((year (format nil "~d" yy))
(month (case format
((:asctime :rfc-822 :rfc-850) (three-letter-month mm))
(otherwise (format nil "~2,'0d" mm))))
(day (format nil "~2,'0d" dd))
(dow (case format
((:asctime :rfc-822 :rfc-850) (three-letter-dow (day-of-week date)))
(otherwise ""))))
(if (or (integerp date)
(= 1/2 (mod date 1)))
(date-only-string year month day dow format)
(date-time-string year month day dow h m s offset format))))))
(defun date->long-string (date &key zone (date-only nil))
"Converts a date to a long string with day of week and month fully spelled out
e.g., \"Thursday, 6 July 2017, 09:38:43.567 +0900\".
If :date-only is true, the time and timezone are omitted."
(let ((offset (zone-to-offset zone)))
(incf date (/ offset 24))
(multiple-value-bind (yy mm dd h m s) (date->ymd date)
(if date-only
(format nil "~a, ~d ~a ~d" (dow->string (day-of-week date))
dd (month->string mm) yy)
(let* ((tz-hh (truncate (abs offset)))
(tz-mm (truncate (* 60 (- (abs offset) tz-hh))))
(tz-str (cond ((= 0 offset) "UTC")
((< offset 0) (format nil "-~2,'0d~2,'0d" tz-hh tz-mm))
(t (format nil "+~2,'0d~2,'0d" tz-hh tz-mm))))
(time-str (if (< (- s (truncate s)) 0.001)
(format nil "~2,'0d:~2,'0d:~2,'0d" h m (truncate s))
(format nil "~2,'0d:~2,'0d:~6,3,,,'0f" h m s))))
(format nil "~a, ~d ~a ~d, ~a ~a" (dow->string (day-of-week date))
dd (month->string mm) yy time-str tz-str))))))
(defun date-only-string (yy mm dd dow fmt)
(case fmt
(:rfc-822 (format nil "~a, ~a ~a ~a" dow dd mm yy))
(:asctime (format nil "~a ~a ~a ~a" dow mm dd yy))
(:rfc-850 (format nil "~a, ~a-~a-~a" dow dd mm yy))
(t (format nil "~a-~a-~a" yy mm dd))))
(defun date-time-string (yy mm dd dow h m s offset fmt)
(let* ((tz-hh (truncate (abs offset)))
(tz-mm (truncate (* 60 (- (abs offset) tz-hh))))
(tz-str (case fmt
((:rfc-822 :rfc-850 :asctime)
(cond ((= 0 offset) "GMT")
((< offset 0) (format nil "-~2,'0d~2,'0d" tz-hh tz-mm))
(t (format nil "+~2,'0d~2,'0d" tz-hh tz-mm))))
(t (cond ((= 0 offset) (if (eq fmt :iso-8601) "Z" "UTC"))
((< offset 0) (format nil "-~2,'0d:~2,'0d" tz-hh tz-mm))
(t (format nil "+~2,'0d:~2,'0d" tz-hh tz-mm))))))
(time-str (if (< (- s (truncate s)) 0.001)
(format nil "~2,'0d:~2,'0d:~2,'0d" h m (truncate s))
(format nil "~2,'0d:~2,'0d:~6,3,,,'0f" h m s))))
(case fmt
(:rfc-822 (format nil "~a, ~a ~a ~a ~a ~a" dow dd mm yy time-str tz-str))
(:asctime (format nil "~a ~a ~a ~a ~a ~a" dow mm dd time-str tz-str yy))
(:rfc-850 (format nil "~a, ~a-~a-~a ~a ~a" dow dd mm yy time-str tz-str))
(:iso-8601 (format nil "~a-~a-~aT~a~a" yy mm dd time-str tz-str))
(t (format nil "~a-~a-~a ~a ~a" yy mm dd time-str tz-str)))))

128
test-dates.lisp Normal file
View file

@ -0,0 +1,128 @@
;;; Copyright (c) 2017, Sudhir Shenoy. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-dates-test)
(deftest julian ()
(format t "Julian date conversions ...~%")
(check
(= (ymd->date 2017 2 5) 2457789.5)
(= (ymd->date 1959 12 29) 2436931.5)
(= (ymd->date 1959 12 29 18 12 26.3) 2436932.2586376667d0)
(equal '(2017 2 5 0 0 0.0d0)
(multiple-value-call #'list (date->ymd 2457789.5)))
(= (ymd->date 1600 2 29) 2305506.5)
(= (ymd->date 1600 2 29 9 31 23.5) 2305506.896799773d0)
(equal '(1600 2 29 9 31 23.500385284423828d0)
(multiple-value-call #'list (date->ymd 2305506.896799773d0)))
(= (date->javascript-time (ymd->date 2017 6 18)) 1497744000000)
(= (jday-number (ymd->date 2017 6 18)) 2457923)))
(deftest misc-fns ()
(format t "Miscellaneous date functions ...~%")
(check
(valid-date-p 2000 2 29)
(null (valid-date-p 1900 2 29))
(null (valid-date-p 1234 65 789))
(eq :monday (day-of-week (ymd->date 2017 2 6)))
(eq :wednesday (day-of-week (ymd->date 1959 9 23)))
(= (nth-day-of-week (ymd->date 2017 2 5) :tuesday 3) (ymd->date 2017 2 21))
(= (nth-day-of-week (ymd->date 2017 2 5) :thursday 3) (ymd->date 2017 2 16))
;; overflow month - returns last tuesday
(= (nth-day-of-week (ymd->date 2017 2 5) :tuesday 7) (ymd->date 2017 2 28))
;; any number <= 1 should return 1st tuesday
(= (nth-day-of-week (ymd->date 2017 2 5) :tuesday -7) (ymd->date 2017 2 7))))
(deftest print-fns ()
(format t "Conversions to strings ...~%")
(let ((dt1 (ymd->date 2017 2 16))
(dt2 (ymd->date 2017 2 16 17 30 25 +9)))
(check
(string= (dow->string :monday) "Monday")
(string= (dow->string :tuesday) "Tuesday")
(string= (dow->string :wednesday) "Wednesday")
(string= (dow->string :thursday) "Thursday")
(string= (dow->string :friday) "Friday")
(string= (dow->string :saturday) "Saturday")
(string= (dow->string :sunday) "Sunday")
(string= (month->string 1) "January")
(string= (month->string 2) "February")
(string= (month->string 3) "March")
(string= (month->string 4) "April")
(string= (month->string 5) "May")
(string= (month->string 6) "June")
(string= (month->string 7) "July")
(string= (month->string 8) "August")
(string= (month->string 9) "September")
(string= (month->string 10) "October")
(string= (month->string 11) "November")
(string= (month->string 12) "December")
(string= (date->string dt1) "2017-02-16")
(string= (date->string dt1 :format :iso-8601) "2017-02-16")
(string= (date->string dt1 :format :asctime) "Thu Feb 16 2017")
(string= (date->string dt1 :format :rfc-822) "Thu, 16 Feb 2017")
(string= (date->string dt1 :format :rfc-850) "Thu, 16-Feb-2017")
(string= (date->string dt2) "2017-02-16 08:30:25 UTC")
(string= (date->string dt2 :format :iso-8601) "2017-02-16T08:30:25Z")
(string= (date->string dt2 :format :asctime) "Thu Feb 16 08:30:25 GMT 2017")
(string= (date->string dt2 :format :rfc-822) "Thu, 16 Feb 2017 08:30:25 GMT")
(string= (date->string dt2 :format :rfc-850) "Thu, 16-Feb-2017 08:30:25 GMT")
(string= (date->string dt2 :zone "JST") "2017-02-16 17:30:25 +09:00")
(string= (date->string dt2 :zone "JST" :format :iso-8601) "2017-02-16T17:30:25+09:00")
(string= (date->string dt2 :zone "JST" :format :asctime) "Thu Feb 16 17:30:25 +0900 2017")
(string= (date->string dt2 :zone "JST" :format :rfc-822) "Thu, 16 Feb 2017 17:30:25 +0900")
(string= (date->string dt2 :zone "JST" :format :rfc-850) "Thu, 16-Feb-2017 17:30:25 +0900"))))
(deftest special-dates ()
(format t "Computation of special dates ...~%")
(check
(= (easter-day 2001) (ymd->date 2001 4 15))
(= (easter-day 2002) (ymd->date 2002 3 31))
(= (easter-day 2005) (ymd->date 2005 3 27))
(= (easter-day 2011) (ymd->date 2011 4 24))
(= (vernal-equinox 2017)
(ymd->date 2017 3 20 10 28 32.05221712589264d0))
(= (summer-solstice 2017)
(ymd->date 2017 6 21 4 23 43.49940687417984d0))
(= (autumnal-equinox 2017)
(ymd->date 2017 9 22 20 1 8.430179357528687D0))
(= (winter-solstice 2017)
(ymd->date 2017 12 21 16 27 51.39586955308914d0))
(= (vernal-equinox 1959)
(ymd->date 1959 3 21 8 55 7.991203665733337d0))
(= (summer-solstice 1959)
(ymd->date 1959 6 22 3 49 50.55352360010147d0))
(= (autumnal-equinox 1959)
(ymd->date 1959 9 23 19 8 29.363870322704315D0))
(= (winter-solstice 1959)
(ymd->date 1959 12 22 14 34 33.68946969509125d0))))

89
test-main.lisp Normal file
View file

@ -0,0 +1,89 @@
;;; Copyright (c) 2017, Sudhir Shenoy. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-user)
(defpackage :cl-dates-test
(:use :common-lisp :cl-dates)
(:export :run-all-tests))
(in-package :cl-dates-test)
;;;
;;; Peter Siebel's test framework from Practical Common Lisp with
;;; slight modifications
;;;
(defvar *test-name* nil)
(defvar *verbose-results* nil)
(defvar *total-tests* 0)
(defvar *failed-tests* 0)
(defmacro deftest (name parameters &body body)
"Define a test function. Within a test function we can call
other test functions or use 'check' to run individual test
cases."
`(defun ,name ,parameters
(let ((*test-name* (append *test-name* (list ',name))))
,@body)))
(defmacro check (&body forms)
"Run each expression in 'forms' as a test case."
`(combine-results
,@(loop for f in forms collect `(report-result ,f ',f))))
(defmacro combine-results (&body forms)
"Combine the results (as booleans) of evaluating 'forms' in order."
(let ((result (gensym)))
`(let ((,result t))
,@(loop for f in forms collect `(unless ,f (setf ,result nil)))
,result)))
(defun report-result (result form)
"Report the results of a single test case. Called by 'check'."
(incf *total-tests*)
(when (not result)
(incf *failed-tests*))
(if *verbose-results*
(format t "~:[FAIL~;pass~] ... ~a: ~a~%" result *test-name* form)
(when (not result)
(format t "FAIL ... ~a: ~a~%" *test-name* form)))
result)
(defun run-all-tests (&key (verbose nil))
(let ((*total-tests* 0)
(*failed-tests* 0)
(*verbose-results* verbose)
(status (combine-results
(julian)
(misc-fns)
(special-dates)
(print-fns)
(parse-dates))))
(unless (zerop *total-tests*)
(format t "~d tests executed - ~d passed (~,2f%)~%"
*total-tests* (- *total-tests* *failed-tests*)
(/ (* 100 (- *total-tests* *failed-tests*)) *total-tests*)))
status))

203
test-parse-date.lisp Normal file
View file

@ -0,0 +1,203 @@
;;; Copyright (c) 2017, Sudhir Shenoy. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-dates-test)
;; Rounding errors in fractional seconds when changing timezones require
;; testing for approximate equality in some test cases
(defparameter +max-error+ 1/1000000)
(defun a= (a b)
(< (abs (- a b)) +max-error+))
(deftest parse-dates ()
(format t "Parse dates from strings ...~%")
(let ((dt (ymd->date 2003 9 25 1 36 28)))
(check
;; Fully specified date with time and timezone
(= (string->date "Thu Sep 25 10:36:28 JST 2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(null (string->date "Wed Sep 25 10:36:28 JST 2003" :reference-date dt)) ; day of week doesn't match date
(= (string->date "2003 10:36:28 JST 25 Sep Thu" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "Thu, 25 Sep 2003 10:36:28 JST" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "Thu, 25 Sep 2003 10:36:28 +0900" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "2003-09-25T10:49:41-03:00" :reference-date dt) (ymd->date 2003 9 25 13 49 41))
(a= (string->date "2003-09-25T10:49:41.5-03:00" :reference-date dt) (ymd->date 2003 9 25 13 49 41.5))
(= (string->date "20030925T10:49:41-03:00" :reference-date dt) (ymd->date 2003 9 25 13 49 41))
(a= (string->date "20030925T10:49:41.5-03:00" :reference-date dt) (ymd->date 2003 9 25 13 49 41.5))
;; Partially specified dates (alphanumeric)
(= (string->date "Thu Sep 25 10:36:28 2003" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(= (string->date "Thu Sep 25 10:36:28" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(= (string->date "Thu Sep 10:36:28" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(= (string->date "Thu 10:36:28" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(= (string->date "Sep 10:36:28" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(= (string->date "10:36:28" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(= (string->date "10:36" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(= (string->date "Thu Sep 25 2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "Sep 25 2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "Sep 2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "Sep" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "2003-09-25T10:49:41" :reference-date dt) (ymd->date 2003 9 25 10 49 41))
(= (string->date "2003-09-25T10:49" :reference-date dt) (ymd->date 2003 9 25 10 49 28))
(= (string->date "2003-09-25T10" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(= (string->date "2003-09-25" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "20030925T104941" :reference-date dt) (ymd->date 2003 9 25 10 49 41))
(= (string->date "20030925T1049" :reference-date dt) (ymd->date 2003 9 25 10 49 28))
(= (string->date "20030925T10" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(= (string->date "20030925T10:49:41" :reference-date dt) (ymd->date 2003 9 25 10 49 41))
(= (string->date "20030925T10:49" :reference-date dt) (ymd->date 2003 9 25 10 49 28))
(= (string->date "20030925T10" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(= (string->date "20030925" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
;; Partially specified (numeric with possible alphabetic month name
(= (string->date "19970902090807" :reference-date dt) (ymd->date 1997 9 2 9 8 7))
(= (string->date "199709020908" :reference-date dt) (ymd->date 1997 9 2 9 8 28))
(= (string->date "2003-Sep-25" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "25-Sep-2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "Sep-25-2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "09-25-2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28)) ; no ambiguity because 25 is a day
(= (string->date "25-09-2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28)) ; no ambiguity because 25 is a day
(= (string->date "10-09-2003" :precedence :dmy :reference-date dt)
(ymd->date 2003 9 10 1 36 28)) ; explicitly dd/mm/yy
(= (string->date "10-09-2003" :precedence :mdy :reference-date dt)
(ymd->date 2003 10 9 1 36 28)) ; explicitly mm/dd/yy
(= (string->date "10-09-03" :precedence :mdy :reference-date dt)
(ymd->date 2003 10 9 1 36 28)) ; explicitly mm/dd/yy
(= (string->date "10-09-03" :precedence :ymd :reference-date dt)
(ymd->date 2010 9 3 1 36 28)) ; explicitly yy/mm/dd
(= (string->date "2003.09.25" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "2003.Sep.25" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "25.Sep.2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "09.25.2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "25.09.2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "2003/09/25" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "2003/Sep/25" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "25/Sep/2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "09/25/2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "25/09/2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "10.09.2003" :precedence :dmy :reference-date dt)
(ymd->date 2003 9 10 1 36 28)) ; explicitly dd/mm/yy
(= (string->date "10.09.2003" :precedence :mdy :reference-date dt)
(ymd->date 2003 10 9 1 36 28)) ; explicitly mm/dd/yy
(= (string->date "10.09.03" :precedence :dmy :reference-date dt)
(ymd->date 2003 9 10 1 36 28)) ; explicitly dd/mm/yy
(= (string->date "10.09.03" :precedence :mdy :reference-date dt)
(ymd->date 2003 10 9 1 36 28)) ; explicitly mm/dd/yy
(= (string->date "10/09/2003" :precedence :dmy :reference-date dt)
(ymd->date 2003 9 10 1 36 28)) ; explicitly dd/mm/yy
(= (string->date "10/09/2003" :precedence :mdy :reference-date dt)
(ymd->date 2003 10 9 1 36 28)) ; explicitly mm/dd/yy
(= (string->date "10/09/03" :precedence :dmy :reference-date dt)
(ymd->date 2003 9 10 1 36 28)) ; explicitly dd/mm/yy
(= (string->date "10/09/03" :precedence :mdy :reference-date dt)
(ymd->date 2003 10 9 1 36 28)) ; explicitly mm/dd/yy
(null (string->date "2003/25/Sep" :reference-date dt)) ; invalid - yy/dd/MMM
(= (string->date "2003 09 25" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "2003 Sep 25" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "2003 25 Sep" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "25 Sep 2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "Sep 25 2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "09 25 2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "25 09 2003" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "10 09 2003" :precedence :dmy :reference-date dt)
(ymd->date 2003 9 10 1 36 28)) ; explicitly dd/mm/yy
(= (string->date "10 09 2003" :precedence :mdy :reference-date dt)
(ymd->date 2003 10 9 1 36 28)) ; explicitly mm/dd/yy
(= (string->date "10 09 03" :precedence :dmy :reference-date dt)
(ymd->date 2003 9 10 1 36 28)) ; explicitly dd/mm/yy
(= (string->date "10 09 03" :precedence :mdy :reference-date dt)
(ymd->date 2003 10 9 1 36 28)) ; explicitly mm/dd/yy
(= (string->date "03 25 Sep" :reference-date dt)
(ymd->date 2003 9 25 1 36 28)) ; default is yy/mm/dd
(= (string->date "25 03 Sep" :precedence :dmy :reference-date dt)
(ymd->date 2003 9 25 1 36 28)) ; explicitly day before year
;; Assorted time formats
(a= (string->date "10h16m38.5s" :reference-date dt) (ymd->date 2003 9 25 10 16 38.5))
(= (string->date "10h16m38s" :reference-date dt) (ymd->date 2003 9 25 10 16 38))
(a= (string->date "10h16m" :reference-date dt) (ymd->date 2003 9 25 10 16 28))
(= (string->date "10h" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(a= (string->date "10 h 16" :reference-date dt) (ymd->date 2003 9 25 10 16 28))
(= (string->date "10h am" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(= (string->date "10h pm" :reference-date dt) (ymd->date 2003 9 25 22 36 28))
(= (string->date "10 am" :reference-date dt) (ymd->date 2003 9 25 10 36 28))
(= (string->date "10 pm" :reference-date dt) (ymd->date 2003 9 25 22 36 28))
(= (string->date "10:00 am" :reference-date dt) (ymd->date 2003 9 25 10 0 28))
(= (string->date "10:00 pm" :reference-date dt) (ymd->date 2003 9 25 22 0 28))
(= (string->date "10:00am" :reference-date dt) (ymd->date 2003 9 25 10 0 28))
(= (string->date "10:00pm" :reference-date dt) (ymd->date 2003 9 25 22 0 28))
(= (string->date "10:00a.m." :reference-date dt) (ymd->date 2003 9 25 10 0 28))
(= (string->date "10:00p.m." :reference-date dt) (ymd->date 2003 9 25 22 0 28))
(= (string->date "10:00a.m" :reference-date dt) (ymd->date 2003 9 25 10 0 28))
(= (string->date "10:00p.m" :reference-date dt) (ymd->date 2003 9 25 22 0 28))
;; relative dates etc
(= (string->date "Sep 03" :reference-date dt) (ymd->date 2003 9 3 1 36 28))
(= (string->date "Sep of 03" :reference-date dt) (ymd->date 2003 9 25 1 36 28))
(= (string->date "Wed" :reference-date dt) (ymd->date 2003 9 24 1 36 28))
(= (string->date "Wednesday" :reference-date dt) (ymd->date 2003 9 24 1 36 28))
(= (string->date "last Wednesday" :reference-date dt) (ymd->date 2003 9 24 1 36 28))
(= (string->date "next Wednesday" :reference-date dt) (ymd->date 2003 10 1 1 36 28))
(= (string->date "October" :reference-date dt) (ymd->date 2003 10 25 1 36 28))
(= (string->date "31-Dec-00" :precedence :dmy :reference-date dt)
(ymd->date 2000 12 31 1 36 28))
;; Random verbiage / unusual formats
(= (string->date "The date is the 25th of September of 2003, exactly at 10:49:41 with time zone -03:00"
:reference-date dt) (ymd->date 2003 9 25 13 49 41))
(null (string->date "Today is the 25th of September of 2003, exactly at 10:49:41 with time zone -03:00"
:reference-date dt)) ; 'today' is assumed to be a date spec so a duplicate date is detected
(= (string->date " July 4 , 1976 12:01:02 am " :reference-date dt)
(ymd->date 1976 7 4 0 1 2))
(= (string->date "today 12:35" :reference-date dt) (ymd->date 2003 9 25 12 35 28))
(= (string->date "today 12:35 JST" :reference-date dt) (ymd->date 2003 9 25 3 35 28))
(= (string->date "tomorrow 12:35" :reference-date dt) (ymd->date 2003 9 26 12 35 28))
(= (string->date "yesterday 12:35 am JST" :reference-date dt) (ymd->date 2003 9 23 15 35 28)) ; date is 2 days prior in UTC
(= (string->date "Wed Jul 10, '96" :reference-date dt) (ymd->date 1996 7 10 1 36 28))
(a= (string->date "1996.07.10 AD at 15:08:56 PDT" :reference-date dt) (ymd->date 1996 7 10 22 8 56))
(= (string->date "1996.07.10 AD at 12:08 PM" :reference-date dt) (ymd->date 1996 7 10 12 8 28))
(= (string->date "Saturday, April 12, 1952 AD 3:30:42pm PST" :reference-date dt) (ymd->date 1952 4 12 23 30 42))
(= (string->date "November 5, 1994, 8:15:30 am EST" :reference-date dt) (ymd->date 1994 11 5 13 15 30))
(= (string->date "1994-11-05T08:15:30-05:00" :reference-date dt) (ymd->date 1994 11 5 13 15 30))
(= (string->date "1994-11-05T08:15:30Z" :reference-date dt) (ymd->date 1994 11 5 8 15 30))
(= (string->date "0:01:02" :reference-date dt) (ymd->date 2003 9 25 0 1 2))
(= (string->date "12h 01m02s am" :reference-date dt) (ymd->date 2003 9 25 0 1 2))
(= (string->date "0:01:02 on July 4, 1976" :reference-date dt) (ymd->date 1976 7 4 0 1 2))
(null (string->date "July 4, 1976 pm 12:01:02" :reference-date dt)) ; am/pm must come after time spec
(= (string->date "July 4, 4pm 4:01:02" :reference-date dt)
(ymd->date 2003 7 4 4 1 2)) ; 4pm overridden by 4:01:02
(= (string->date "July 4, 4pm" :reference-date dt) (ymd->date 2003 7 4 16 36 28)) ; this is ok
(a= (string->date "04.04.95 00:22" :reference-date dt) (ymd->date 1995 4 4 0 22 28))
(= (string->date "950404 122212" :reference-date dt) (ymd->date 1995 4 4 12 22 12))
(= (string->date "0:00 PM, PST" :reference-date dt) (ymd->date 2003 9 25 20 0 28))
(= (string->date "12:08 PM" :reference-date dt) (ymd->date 2003 9 25 12 8 28))
(= (string->date "5:50 A.M on June 13, 1990" :reference-date dt) (ymd->date 1990 6 13 5 50 28))
(= (string->date "01h02m03" :reference-date dt) (ymd->date 2003 9 25 1 2 3))
(= (string->date "01h02" :reference-date dt) (ymd->date 2003 9 25 1 2 28))
(= (string->date "01h02s" :reference-date dt) (ymd->date 2003 9 25 1 36 2))
(= (string->date "01m02" :reference-date dt) (ymd->date 2003 9 25 1 1 2))
(a= (string->date "01m02h" :reference-date dt) (ymd->date 2003 9 25 2 1 28))
(= (string->date "2004 10 April 11h30m" :reference-date dt) (ymd->date 2004 4 10 11 30 28)))))

260
timezones.lisp Normal file
View file

@ -0,0 +1,260 @@
;;; Copyright (c) 2017, Sudhir Shenoy. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-dates)
;; hash table containing mappings from time zone abbreviation to GMT offset
(defparameter +tz-info+ (make-hash-table :test #'equalp))
(defun str-to-tz-offset (str)
(gethash str +tz-info+))
(defun zone-to-offset (zone)
(typecase zone
(number zone)
(string (or (str-to-tz-offset zone) 0))
(t 0)))
(progn
;; Time zone abbreviation to offset mapping table (source: Wikipedia)
;; Wherever there are duplicate abbreviations, the more economically significant
;; (in terms of trading centres) zone has been retained
(let ((info '(("ACDT" 10.5 "Australian Central Daylight Savings Time")
("ACST" 9.5 "Australian Central Standard Time")
("ACT" -5 "Acre Time")
("ADT" -3 "Atlantic Daylight Time")
("AEDT" 11 "Australian Eastern Daylight Savings Time")
("AEST" 10 "Australian Eastern Standard Time")
("AFT" 4.5 "Afghanistan Time")
("AKDT" -8 "Alaska Daylight Time")
("AKST" -9 "Alaska Standard Time")
("AMST" -3 "Amazon Summer Time (Brazil)")
("AMT" -4 "Amazon Time (Brazil)")
("AMT" 4 "Armenia Time")
("ART" -3 "Argentina Time")
("AST" 3 "Arabia Standard Time")
;; ("AST" -4 "Atlantic Standard Time")
("AWST" 8 "Australian Western Standard Time")
("AZOST" 0 "Azores Summer Time")
("AZOT" -1 "Azores Standard Time")
("AZT" 4 "Azerbaijan Time")
("BDT" 8 "Brunei Time")
("BIOT" 6 "British Indian Ocean Time")
("BIT" -12 "Baker Island Time")
("BOT" -4 "Bolivia Time")
("BRST" -2 "Brasilia Summer Time")
("BRT" -3 "Brasilia Time")
;; ("BST" 6 "Bangladesh Standard Time")
;; ("BST" 11 "Bougainville Standard Time")
("BST" 1 "British Summer Time")
("BTT" 6 "Bhutan Time")
("CAT" 2 "Central Africa Time")
("CCT" 6.5 "Cocos Islands Time")
("CDT" -5 "Central Daylight Time (North America)")
;; ("CDT" -4 "Cuba Daylight Time")
("CEST" 2 "Central European Summer Time (Cf. HAEC)")
("CET" 1 "Central European Time")
("CHADT" 13.75 "Chatham Daylight Time")
("CHAST" 12.75 "Chatham Standard Time")
("CHOT" 8 "Choibalsan Standard Time")
("CHOST" 9 "Choibalsan Summer Time")
("CHST" 10 "Chamorro Standard Time")
("CHUT" 10 "Chuuk Time")
("CIST" -8 "Clipperton Island Standard Time")
("CIT" 8 "Central Indonesia Time")
("CKT" -10 "Cook Island Time")
("CLST" -3 "Chile Summer Time")
("CLT" -4 "Chile Standard Time")
("COST" -4 "Colombia Summer Time")
("COT" -5 "Colombia Time")
("CST" -6 "Central Standard Time (North America)")
;; ("CST" 8 "China Standard Time")
;; ("CST" -5 "Cuba Standard Time")
("ACST" 9.5 "Central Standard Time (Australia)")
("ACDT" 10.5 "Central Summer Time (Australia)")
("CT" 8 "China time")
("CVT" -1 "Cape Verde Time")
("CXT" 7 "Christmas Island Time")
("DAVT" 7 "Davis Time")
("DDUT" 10 "Dumont d'Urville Time")
("DFT" 1 "AIX specific equivalent of Central European Time")
("EASST" -5 "Easter Island Summer Time")
("EAST" -6 "Easter Island Standard Time")
("EAT" 3 "East Africa Time")
("ECT" -4 "Eastern Caribbean Time (does not recognise DST)")
;; ("ECT" -5 "Ecuador Time")
("EDT" -4 "Eastern Daylight Time (North America)")
("AEDT" 11 "Eastern Summer Time (Australia)")
("EEST" 3 "Eastern European Summer Time")
("EET" 2 "Eastern European Time")
("EGST" 0 "Eastern Greenland Summer Time")
("EGT" -1 "Eastern Greenland Time")
("EIT" 9 "Eastern Indonesian Time")
("EST" -5 "Eastern Standard Time (North America)")
("AEST" 10 "Eastern Standard Time (Australia)")
("FET" 3 "Further-eastern European Time")
("FJT" 12 "Fiji Time")
("FKST" -3 "Falkland Islands Summer Time")
("FKT" -4 "Falkland Islands Time")
("FNT" -2 "Fernando de Noronha Time")
("GALT" -6 "Galapagos Time")
("GAMT" -9 "Gambier Islands")
("GET" 4 "Georgia Standard Time")
("GFT" -3 "French Guiana Time")
("GILT" 12 "Gilbert Island Time")
("GIT" -9 "Gambier Island Time")
("GMT" 0 "Greenwich Mean Time")
;; ("GST" -2 "South Georgia and the South Sandwich Islands")
("GST" 4 "Gulf Standard Time")
("GYT" -4 "Guyana Time")
("HADT" -9 "Hawaii-Aleutian Daylight Time")
("HAEC" 2 "Heure Avancée d'Europe Centrale francised name for CEST")
("HAST" -10 "Hawaii-Aleutian Standard Time")
("HKT" 8 "Hong Kong Time")
("HMT" 5 "Heard and McDonald Islands Time")
("HOVST" 8 "Khovd Summer Time")
("HOVT" 7 "Khovd Standard Time")
("ICT" 7 "Indochina Time")
("IDT" 3 "Israel Daylight Time")
("IOT" 3 "Indian Ocean Time")
("IRDT" 4.5 "Iran Daylight Time")
("IRKT" 8 "Irkutsk Time")
("IRST" 3.5 "Iran Standard Time")
("IST" 5.5 "Indian Standard Time")
;; ("IST" 1 "Irish Standard Time[6]")
;; ("IST" 2 "Israel Standard Time")
("JST" 9 "Japan Standard Time")
("KGT" 6 "Kyrgyzstan time")
("KOST" 11 "Kosrae Time")
("KRAT" 7 "Krasnoyarsk Time")
("KST" 9 "Korea Standard Time")
("LHST" 10.5 "Lord Howe Standard Time")
;; ("LHST" 11 "Lord Howe Summer Time")
("LINT" 14 "Line Islands Time")
("MAGT" 12 "Magadan Time")
("MART" -9.5 "Marquesas Islands Time")
("MAWT" 5 "Mawson Station Time")
("MDT" -6 "Mountain Daylight Time (North America)")
("MET" 1 "Middle European Time Same zone as CET")
("MEST" 2 "Middle European Summer Time Same zone as CEST")
("MHT" 12 "Marshall Islands")
("MIST" 11 "Macquarie Island Station Time")
("MIT" -9.5 "Marquesas Islands Time")
("MMT" 6.5 "Myanmar Standard Time")
("MSK" 3 "Moscow Time")
;; ("MST" 8 "Malaysia Standard Time")
("MST" -7 "Mountain Standard Time (North America)")
("MUT" 4 "Mauritius Time")
("MVT" 5 "Maldives Time")
("MYT" 8 "Malaysia Time")
("NCT" 11 "New Caledonia Time")
("NDT" -2.5 "Newfoundland Daylight Time")
("NFT" 11 "Norfolk Time")
("NPT" 5.75 "Nepal Time")
("NST" -3.5 "Newfoundland Standard Time")
("NT" -3.5 "Newfoundland Time")
("NUT" -11 "Niue Time")
("NZDT" 13 "New Zealand Daylight Time")
("NZST" 12 "New Zealand Standard Time")
("OMST" 6 "Omsk Time")
("ORAT" 5 "Oral Time")
("PDT" -7 "Pacific Daylight Time (North America)")
("PET" -5 "Peru Time")
("PETT" 12 "Kamchatka Time")
("PGT" 10 "Papua New Guinea Time")
("PHOT" 13 "Phoenix Island Time")
("PHT" 8 "Philippine Time")
("PKT" 5 "Pakistan Standard Time")
("PMDT" -2 "Saint Pierre and Miquelon Daylight time")
("PMST" -3 "Saint Pierre and Miquelon Standard Time")
("PONT" 11 "Pohnpei Standard Time")
("PST" -8 "Pacific Standard Time (North America)")
;; ("PST" 8 "Philippine Standard Time")
("PYST" -3 "Paraguay Summer Time (South America)[7]")
("PYT" -4 "Paraguay Time (South America)[8]")
("RET" 4 "Réunion Time")
("ROTT" -3 "Rothera Research Station Time")
("SAKT" 11 "Sakhalin Island time")
("SAMT" 4 "Samara Time")
("SAST" 2 "South African Standard Time")
("SBT" 11 "Solomon Islands Time")
("SCT" 4 "Seychelles Time")
("SGT" 8 "Singapore Time")
("SLST" 5.5 "Sri Lanka Standard Time")
("SRET" 11 "Srednekolymsk Time")
("SRT" -3 "Suriname Time")
;; ("SST" -11 "Samoa Standard Time")
("SST" 8 "Singapore Standard Time")
("SYOT" 3 "Showa Station Time")
("TAHT" -10 "Tahiti Time")
("THA" 7 "Thailand Standard Time")
("TFT" 5 "Indian/Kerguelen")
("TJT" 5 "Tajikistan Time")
("TKT" 13 "Tokelau Time")
("TLT" 9 "Timor Leste Time")
("TMT" 5 "Turkmenistan Time")
("TRT" 3 "Turkey Time")
("TOT" 13 "Tonga Time")
("TVT" 12 "Tuvalu Time")
("ULAST" 9 "Ulaanbaatar Summer Time")
("ULAT" 8 "Ulaanbaatar Standard Time")
("USZ1" 2 "Kaliningrad Time")
("UTC" 0 "Coordinated Universal Time")
("UYST" -2 "Uruguay Summer Time")
("UYT" -3 "Uruguay Standard Time")
("UZT" 5 "Uzbekistan Time")
("VET" -4 "Venezuelan Standard Time")
("VLAT" 10 "Vladivostok Time")
("VOLT" 4 "Volgograd Time")
("VOST" 6 "Vostok Station Time")
("VUT" 11 "Vanuatu Time")
("WAKT" 12 "Wake Island Time")
("WAST" 2 "West Africa Summer Time")
("WAT" 1 "West Africa Time")
("WEST" 1 "Western European Summer Time")
("WET" 0 "Western European Time")
("WIT" 7 "Western Indonesian Time")
("WST" 8 "Western Standard Time")
("YAKT" 9 "Yakutsk Time")
("YEKT" 5 "Yekaterinburg Time"))))
(dolist (tz info)
(setf (gethash (car tz) +tz-info+) (cadr tz))))
;; add Military time zones
(loop for ch across "ABCDEFGHI"
do (let ((offset (1+ (- (char-code ch) (char-code #\A)))))
(setf (gethash (string ch) +tz-info+) offset)))
(setf (gethash "K" +tz-info+) 10
(gethash "L" +tz-info+) 11
(gethash "M" +tz-info+) 12
(gethash "C*" +tz-info+) 3.5
(gethash "D*" +tz-info+) 4.5
(gethash "E*" +tz-info+) 5.5
(gethash "F*" +tz-info+) 6.5)
(loop for ch across "NOPQRSTUVWXY"
do (let ((offset (- (1+ (- (char-code ch) (char-code #\N))))))
(setf (gethash (string ch) +tz-info+) offset)))
(setf (gethash "Z" +tz-info+) 0))

117
util.lisp Normal file
View file

@ -0,0 +1,117 @@
;;; Copyright (c) 2017, Sudhir Shenoy. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-dates)
(defun parse-number (string)
"Returns a number if string is numeric (ignoring surrounding white-space) else NIL"
(handler-case (values (parse-integer string))
(parse-error ()
(multiple-value-bind (integer num-chars) (parse-integer string :junk-allowed t)
(let ((len (length string)))
(cond ((or (>= num-chars len)
(and (= num-chars (1- len))
(char= (char string num-chars) #\.)))
integer)
((char/= (char string num-chars) #\.) nil)
(t (handler-case
(multiple-value-bind (fraction frac-chars)
(parse-integer string :start (1+ num-chars))
(if (zerop fraction)
integer
(coerce (+ integer
(/ fraction (expt 10 (- frac-chars num-chars 1))))
'double-float)))
(parse-error () nil)))))))))
(defun hms->day-fraction (hh mm ss)
(/ (+ (* hh 3600) (* mm 60) ss) 86400))
(defun day-fraction->hms (day-frac)
(let* ((secs (* day-frac 86400))
(hh (floor (/ secs 3600))))
(setf secs (- secs (* hh 3600)))
(let* ((mm (floor (/ secs 60)))
(ss (- secs (* mm 60))))
(values hh mm ss))))
(defparameter +weekdays+ '((:monday . ("Mon" "Monday")) (:tuesday . ("Tue" "Tuesday" "Tues"))
(:wednesday . ("Wed" "Wednesday")) (:thursday . ("Thu" "Thursday" "Thurs"))
(:friday . ("Fri" "Friday")) (:saturday . ("Sat" "Saturday"))
(:sunday . ("Sun" "Sunday"))))
(defun dow->string (dow)
(third (assoc dow +weekdays+)))
(defun three-letter-dow (dow)
(second (assoc dow +weekdays+)))
(defun str-to-weekday (str)
(loop for i from 0 below 7
do (let ((list (elt +weekdays+ i)))
(when (member str (cdr list) :test #'string-equal)
(return-from str-to-weekday (car list))))))
(defparameter +months+ '((nil) ("Jan" "January") ("Feb" "February") ("Mar" "March") ("Apr" "April")
("May" "May") ("Jun" "June") ("Jul" "July") ("Aug" "August")
("Sep" "September" "Sept") ("Oct" "October") ("Nov" "November")
("Dec" "December")))
(defun month->string (mm)
(second (elt +months+ mm)))
(defun three-letter-month (mm)
(car (elt +months+ mm)))
(defun str-to-month (str)
(loop for i from 1 to 12
do (when (member str (elt +months+ i) :test #'string-equal)
(return-from str-to-month i))))
(defparameter +time-suffixes+ '((:hour . ("h" "hr" "hrs" "hour" "hours"))
(:minute . ("m" "min" "mins" "minute" "minutes"))
(:second . ("s" "sec" "secs" "second" "seconds"))))
(defun str-to-hms (str)
(loop for i from 0 below 3
do (let ((list (elt +time-suffixes+ i)))
(when (member str (cdr list) :test #'string-equal)
(return-from str-to-hms (car list))))))
(defun str-to-ampm (str)
(cond ((member str '("a.m." "a.m" "am" "morning") :test #'string-equal) :am)
((member str '("p.m." "p.m" "pm" "evening" "afternoon") :test #'string-equal) :pm)
(t nil)))
(defun str-is-day-suffix (str)
(not (null (member str '("st" "nd" "rd" "th") :test #'string-equal))))
(defun str-to-relative-dow (str)
(cond ((member str '("last" "prev" "previous") :test #'string-equal) :prev)
((member str '("next" "coming") :test #'string-equal) :next)
((string-equal str "this") :closest)
(t nil)))
(defparameter +date-words+ '(("today" . 0) ("tomorrow" . 1) ("yesterday" . -1)))
(defun str-to-relative-date (str)
(cdr (find str +date-words+ :test #'string-equal :key #'car)))