source: trunk/source/contrib/krueger/InterfaceProjects/Utilities/date.lisp @ 13390

Last change on this file since 13390 was 13390, checked in by plkrueger, 10 years ago

New contrib from Paul Krueger

  • Property svn:executable set to *
File size: 10.1 KB
Line 
1;; date.lisp
2
3#|
4The MIT license.
5
6Copyright (c) 2010 Paul L. Krueger
7
8Permission is hereby granted, free of charge, to any person obtaining a copy of this software
9and associated documentation files (the "Software"), to deal in the Software without restriction,
10including without limitation the rights to use, copy, modify, merge, publish, distribute,
11sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is
12furnished to do so, subject to the following conditions:
13
14The above copyright notice and this permission notice shall be included in all copies or substantial
15portions of the Software.
16
17THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
18LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
19IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
20WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
23|#
24
25(defpackage :interface-utilities
26  (:nicknames :iu)
27  (:export now dt dt-diff day-of-wk abbrev-day-of-wk day-char
28           next-day prev-day inc-months next-month prev-month
29           inc-years next-year  prev-year same-day-p days-to-sec
30           do-dates do-interval-dates do-months days-between 
31           days-from +days date-string short-date-string 
32           mmdd-string mmddyy-list dt-yr date-list day-set-bit
33           add-day remove-day has-day-p in-dayset-p day-set
34           num-days-in-dayset random-date intl-string-dt
35           lisp-to-ns-date ns-to-lisp-date))
36
37(in-package :iu)
38
39;;; some general date utility routines
40
41(defun now ()
42  (get-universal-time))
43
44(defun dt (mm dd yy &optional (hour 12) (min 0) (sec 0) (zone nil))
45  ;; yy can be 2 or 4 digit year
46  (if zone
47    (encode-universal-time sec min hour dd mm yy zone)
48    (encode-universal-time sec min hour dd mm yy)))
49
50(defun dt-diff (dt1 dt2)
51  ;; computes the number of days between the two dates
52  (round (abs (- dt1 dt2)) 86400))
53
54(defun day-of-wk (dt)
55  (multiple-value-bind (sec min hr dd mm yr day dst zone)
56                       (decode-universal-time dt)
57    (declare (ignore sec min hr dd mm yr dst zone))
58    (nth day '(monday tuesday wednesday thursday friday saturday sunday))))
59
60(defun abbrev-day-of-wk (dt)
61  (multiple-value-bind (sec min hr dd mm yr day dst zone)
62                       (decode-universal-time dt)
63    (declare (ignore sec min hr dd mm yr dst zone))
64    (nth day '(mon tue wed thu fri sat sun))))
65
66(defun day-char (dt)
67  (multiple-value-bind (sec min hr dd mm yr day dst zone)
68                       (decode-universal-time dt)
69    (declare (ignore sec min hr dd mm yr dst zone))
70    (nth day '(m t w t f s s))))
71
72(defun next-day (dt)
73  (+ 86400 dt))
74
75(defun prev-day (dt)
76  (- dt 86400))
77
78(defun inc-months (dt num-mm)
79  (multiple-value-bind (sec min hr dd mm yr day dst zone)
80                       (decode-universal-time dt)
81    (declare (ignore day dst))
82    (multiple-value-bind (yy-inc new-mm)
83                         (floor (+ num-mm mm -1) 12)
84      (encode-universal-time sec 
85                             min 
86                             hr 
87                             dd 
88                             (1+ new-mm)
89                             (+ yr yy-inc)
90                             zone))))
91(defun next-month (dt)
92  (inc-months dt 1))
93                           
94(defun prev-month (dt)
95  (inc-months dt -1))
96
97(defun inc-years (dt num-yy)
98  (multiple-value-bind (sec min hr dd mm yr day dst zone)
99                       (decode-universal-time dt)
100    (declare (ignore day dst))
101    (encode-universal-time sec 
102                           min 
103                           hr 
104                           dd 
105                           mm
106                           (+ yr num-yy)
107                           zone)))
108
109(defun next-year (dt)
110  (inc-years dt 1))
111
112(defun prev-year (dt)
113  (inc-years dt -1))
114
115(defun same-day-p (dt1 dt2)
116  (multiple-value-bind (sec min hr dd1 mm1 yr1 day dst zone)
117                       (decode-universal-time dt1)
118    (declare (ignore sec min hr day dst zone))
119    (multiple-value-bind (sec min hr dd2 mm2 yr2 day dst zone)
120                       (decode-universal-time dt2)
121      (declare (ignore sec min hr day dst zone))
122      (and (eql dd1 dd2) (eql mm1 mm2) (eql yr1 yr2)))))
123
124(defun days-to-sec (num-days)
125  ;; convert a number of days to seconds, which can be added/subtracted
126  ;; from a date to get a new date
127  (* num-days 86400))
128
129(defmacro do-dates ((dt start end &optional (return-form nil ret-p)) &rest forms)
130  `(do* ((,dt ,start (+ ,dt 86400)))
131        ((> ,dt ,end) (if ,ret-p ,return-form (values)))
132     ,@forms))
133
134(defmacro do-interval-dates ((dt start end interval &optional (return-form nil ret-p)) &rest forms)
135  `(do* ((,dt ,start (+ ,dt (days-to-sec ,interval))))
136        ((> ,dt ,end) (if ,ret-p ,return-form (values)))
137     ,@forms))
138
139(defmacro do-months ((dt start end mm-interval &optional (return-form nil ret-p)) &rest forms)
140  `(do* ((,dt ,start (inc-months ,dt ,mm-interval)))
141        ((> ,dt ,end) (if ,ret-p ,return-form (values)))
142     ,@forms))
143
144(defun days-between (dt1 dt2)
145  (round (abs (- dt2 dt1)) 86400))
146
147(defmethod days-from ((dt1 integer) (dt2 integer))
148  (days-between dt1 dt2))
149
150(defmethod days-from ((dt integer) (day symbol))
151  (let* ((abbrev-days '(sun mon tue wed thu fri sat))
152         (days '(sunday monday tuesday wednesday thursday friday saturday))
153         (dow (abbrev-day-of-wk dt))
154         (today (position dow abbrev-days))
155         (day-pos (or (position day days)
156                      (position day abbrev-days))))
157    (if (<= today day-pos)
158      (- day-pos today)
159      (- 7 (- today day-pos)))))
160
161(defmethod days-from ((day symbol) (dt integer))
162  (let* ((abbrev-days '(sun mon tue wed thu fri sat))
163         (days '(sunday monday tuesday wednesday thursday friday saturday))
164         (dow (abbrev-day-of-wk dt))
165         (day-pos (position dow abbrev-days))
166         (today (or (position day days)
167                    (position day abbrev-days))))
168    (if (<= today day-pos)
169      (- day-pos today)
170      (- 7 (- today day-pos)))))
171
172(defmethod days-from ((day1 symbol) (day2 symbol))
173  (let* ((abbrev-days '(sun mon tue wed thu fri sat))
174         (days '(sunday monday tuesday wednesday thursday friday saturday))
175         (today (or (position day1 days)
176                    (position day1 abbrev-days)))
177         (day-pos (or (position day2 days)
178                      (position day2 abbrev-days))))
179    (if (<= today day-pos)
180      (- day-pos today)
181      (- 7 (- today day-pos)))))
182
183(defun +days (dt days)
184  (+ dt (days-to-sec days)))
185
186(defun date-string (dt)
187  (multiple-value-bind (sec min hr dd mm yr day dst zone)
188                       (decode-universal-time dt)
189    (declare (ignore sec min hr dst zone))
190    (format nil 
191            "~9s ~2,'0d/~2,'0d/~2,'0d" 
192            (nth day '(monday tuesday wednesday thursday friday saturday sunday))
193            mm dd (mod yr 100))))
194
195(defun short-date-string (dt)
196  (multiple-value-bind (sec min hr dd mm yr day dst zone)
197                       (decode-universal-time dt)
198    (declare (ignore sec min hr day dst zone))
199    (format nil 
200            "~2,'0d/~2,'0d/~2,'0d" mm dd (mod yr 100))))
201
202(defun mmdd-string (dt)
203  (multiple-value-bind (sec min hr dd mm yr day dst zone)
204                       (decode-universal-time dt)
205    (declare (ignore sec min hr yr day dst zone))
206    (format nil 
207            "~2,'0d/~2,'0d" mm dd)))
208
209(defun mmddyy-list (dt)
210  (multiple-value-bind (sec min hr dd mm yr day dst zone)
211                       (decode-universal-time dt)
212    (declare (ignore sec min hr day dst zone))
213    (list mm dd yr)))
214
215(defun dt-yr (dt)
216    (multiple-value-bind (sec min hr dd mm yr day dst zone)
217                       (decode-universal-time dt)
218    (declare (ignore sec min hr dd mm day dst zone))
219    yr))
220
221(defun date-list (strt end)
222  (do* ((res (list strt) (cons next res))
223        (next (next-day strt) (next-day next)))
224       ((> next end) (nreverse res))))
225
226;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
227
228;; utility functions supporting the use of an integer as a set days of
229;; the week. The low-order 7 bits of the integer represent sun thru sat
230;; Bit 0 = sun ... Bit 6 = sat.
231
232(defun day-set-bit (day)
233  (or (position day '(sun mon tue wed thu fri sat))
234      (position day '(sunday monday tuesday wednesday thursday friday saturday))))
235
236(defun add-day (day day-set)
237  (dpb 1 (byte 1 (day-set-bit day)) day-set))
238
239(defun remove-day (day day-set)
240  (dpb 0 (byte 1 (day-set-bit day)) day-set))
241
242(defun has-day-p (day-set day)
243  (logbitp (day-set-bit day) day-set))
244
245(defun in-dayset-p (dt day-set)
246  (has-day-p day-set (abbrev-day-of-wk dt)))
247
248(defun day-set (&rest days)
249  (let ((ds 0))
250    (dolist (day days ds)
251      (setf ds (dpb 1 (byte 1 (day-set-bit day)) ds)))))
252
253(defun num-days-in-dayset (dayset strt end)
254  (count-if #'(lambda (dt)
255                (in-dayset-p dt dayset))
256            (date-list strt end)))
257
258(defun random-date (begin-dt end-dt)
259  (+ begin-dt (random (- end-dt begin-dt))))
260
261(defun intl-string-dt (dt)
262  ;; A string that specifies a date and time value in the international string representation format—
263  ;; YYYY-MM-DD HH:MM:SS ±HHMM, where ±HHMM is a time zone offset in hours and minutes from GMT
264  ;; (for example, “2001-03-24 10:45:32 +0600”).
265  (multiple-value-bind (sec min hr dd mm yr day dst zone)
266                       (decode-universal-time dt)
267    (declare (ignore dst day))
268    (format nil "~4d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d ~a~4,'0d"
269            yr
270            mm
271            dd
272            hr
273            min
274            sec
275            (if (plusp zone) "+" "-")
276            (* zone 100))))
277
278;; The reference used for NSDate objects is 01/01/2001
279;; This represents the difference between lisp's reference date and NSDate's
280(defconstant $ns-lisp-ref-date-diff$ (dt 01 01 2001 0 0 0 0))
281
282(defun lisp-to-ns-date (dt)
283  (#/dateWithTimeIntervalSinceReferenceDate:
284   ns:ns-date
285   (coerce (- dt $ns-lisp-ref-date-diff$) 'double-float)))
286
287(defun ns-to-lisp-date (ns-date)
288  (+ (round (#/timeIntervalSinceReferenceDate ns-date)) $ns-lisp-ref-date-diff$))
289
290(provide :date)
Note: See TracBrowser for help on using the repository browser.