/[cl-date-calc]/cl-date-calc/date-calc.lisp
ViewVC logotype

Contents of /cl-date-calc/date-calc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Wed Feb 1 15:45:52 2006 UTC (8 years, 2 months ago) by hschroter
Branch: cl-date-calc, MAIN
CVS Tags: start, HEAD
Changes since 1.1: +0 -0 lines
cl-date-calc
1 ;;; Package: date-calc.lisp
2 ;;; Heiko Schroeter, Dec 2005
3 ;;;
4 ;;; Ver 0.2 ALPHA
5 ;;; License: GNU, Version 2, June 1991
6 ;;;
7 ;;; Legal issues:
8 ;;; -------------
9 ;;; This package with all its parts is
10 ;;; Copyright (c) 2005 by Heiko Schroeter.
11
12 ;;; This package is free software; you can use, modify and redistribute
13 ;;; under the "GNU General Public License" and the "Artistic License".
14
15 ;;; This package is intended as a date-calc module for "everyday" purposes. It is not intended
16 ;;; , nor claims to be,
17 ;;; a bullet proofed implementation of 'scientific' datum calculus.
18
19 ;;; Parts taken from DateCalc.el (EMACS, Doug Alcorn, <doug@lathi.net>, Ver. 0.1, 2003)
20 ;;; and the
21 ;;; Perl Package "Date::Calc" Version 5.4,Copyright (c) 1995 - 2004 by Steffen Beyer.
22
23 ;;; Some Documentation strings are only slightly edited from DateCalc.el
24
25 ;;; THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
26 ;;; IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
27 ;;; WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
28
29 ;;; The following routines are a sidestep for CL Day Of Week (DOW) conformance.
30 ;;; (See Hyperspec 25.1.4.1 X3J13).
31 ;;; "An integer between 0 and 6, inclusive; 0 means Monday, 1 means Tuesday, and so on; 6 means Sunday."
32 ;;; PERLs Date::Calc module range is from 1(Monday) to 7(Sunday).
33
34
35 ;;; CL conform ,Perl' Conform
36 ;;; ---------- --------------
37 ;;; cl-day-of-week day-of-week
38 ;;; cl-weeks-in-year weeks-in-year
39 ;;; cl-check-business-p check-business-p
40 ;;; cl-nth-weekday-of-month-year nth-weekday-of-month-year
41 ;;; cl-standard-to-business standard-to-business
42 ;;; cl-business-to-standard business-to-standard
43 ;;; cl-system-clock system-clock
44 ;;; cl-decode-day-of-week decode-day-of-week
45
46 ;;; Pls report bugs to schroete @ iup physik uni-bremen de
47
48
49 (in-package #:cl-user)
50
51 (defpackage #:date-calc
52 (:use #:cl)
53 (:export #:*language*
54 #:decode-day-of-week
55 #:cl-decode-day-of-week
56 #:decode-month
57 #:decode-language
58 #:iso-lc
59 #:iso-uc
60 #:year-to-days
61 #:fixed-window
62 #:center
63 #:valid-year-p
64 #:valid-month-p
65 #:leap-year
66 #:leap-year-p
67 #:days-in-month
68 #:days-in-year
69 #:check-date
70 #:check-business-p
71 #:check-time-p
72 #:day-of-year
73 #:date-to-days
74 #:day-of-week
75 #:weeks-in-year
76 #:delta-days
77 #:week-number
78 #:week-of-year
79 #:add-delta-days
80 #:monday-of-week
81 #:nth-weekday-of-month-year
82 #:standard-to-business
83 #:business-to-standard
84 #:delta-hms
85 #:delta-dhms
86 #:delta-ymd
87 #:delta-ymdhms
88 #:normalize-dhms
89 #:add-delta-dhms
90 #:add-year-month
91 #:add-delta-ym
92 #:add-delta-ymd
93 #:add-delta-ymdhms
94 #:system-clock
95 #:cl-system-clock
96 #:gmtime
97 #:localtime
98 #:today
99 #:yesterday
100 #:tomorrow
101 #:now
102 #:today-and-now
103 #:this-year
104 #:date-to-text
105 #:date-to-text-long
106 #:cl-day-of-week
107 #:cl-weeks-in-year
108 #:cl-check-business-p
109 #:cl-nth-weekday-of-month-year
110 #:cl-standard-to-business
111 #:cl-business-to-standard))
112
113 (pushnew :date-calc *features*)
114 (in-package #:date-calc)
115
116 ;;;; Parameters
117 (defparameter year-of-epoc 70 "Year of reference (epoc)")
118 (defparameter century-of-epoc 1900 "Century of reference (epoc)")
119 (defparameter eopoc (+ year-of-epoc century-of-epoc) "reference year (epoc)")
120
121 (defparameter days-in-year-arr (make-array '(2 13) :initial-contents
122 '((0 31 59 90 120 151 181 212 243 273 304 334 365)
123 (0 31 60 91 121 152 182 213 244 274 305 335 366))))
124
125 (defparameter days-in-month-arr (make-array '(2 13) :initial-contents
126 '((0 31 28 31 30 31 30 31 31 30 31 30 31)
127 (0 31 29 31 30 31 30 31 31 30 31 30 31))))
128
129 (defparameter languages 11)
130 (defparameter *language* 1) ; Default English
131
132 ;; (defconstant num-of-lingos (1+ languages))
133
134 (defparameter month-to-text (make-hash-table))
135 (setf (gethash 0 month-to-text)
136 #("???" "???" "???" "???"
137 "???" "???" "???" "???"
138 "???" "???" "???" "???" "???"))
139 (setf (gethash 1 month-to-text)
140 #("???" "January" "February" "March"
141 "April" "May" "June" "July" "August"
142 "September" "October" "November" "December"))
143 (setf (gethash 2 month-to-text)
144 #("???" "janvier" "fevrier" "mars"
145 "avril" "mai" "juin" "juillet" "aout"
146 "septembre" "octobre" "novembre" "decembre"))
147 (setf (gethash 3 month-to-text)
148 #("???" "Januar" "Februar" "Maerz"
149 "April" "Mai" "Juni" "Juli" "August"
150 "September" "Oktober" "November" "Dezember"))
151 (setf (gethash 4 month-to-text)
152 #("???" "enero" "febrero" "marzo"
153 "abril" "mayo" "junio" "julio" "agosto"
154 "septiembre" "octubre" "noviembre" "diciembre"))
155 (setf (gethash 5 month-to-text)
156 #("???" "janeiro" "fevereiro" "marco"
157 "abril" "maio" "junho" "julho" "agosto"
158 "setembro" "outubro" "novembro" "dezembro"))
159 (setf (gethash 6 month-to-text)
160 #("???" "januari" "februari" "maart"
161 "april" "mei" "juni" "juli" "augustus"
162 "september" "october" "november" "december"))
163 (setf (gethash 7 month-to-text)
164 #("???" "Gennaio" "Febbraio" "Marzo"
165 "Aprile" "Maggio" "Giugno" "Luglio" "Agosto"
166 "Settembre" "Ottobre" "Novembre" "Dicembre"))
167 (setf (gethash 8 month-to-text)
168 #("???" "januar" "februar" "mars"
169 "april" "mai" "juni" "juli" "august"
170 "september" "oktober" "november" "desember"))
171 (setf (gethash 9 month-to-text)
172 #("???" "januari" "februari" "mars"
173 "april" "maj" "juni" "juli" "augusti"
174 "september" "oktober" "november" "december"))
175 (setf (gethash 10 month-to-text)
176 #("???" "januar" "februar" "marts"
177 "april" "maj" "juni" "juli" "august"
178 "september" "oktober" "november" "december"))
179 (setf (gethash 11 month-to-text)
180 #("???" "tammikuu" "helmikuu" "maaliskuu"
181 "huhtikuu" "toukokuu" "kesaekuu" "heinaekuu"
182 "elokuu" "syyskuu" "lokakuu" "marraskuu" "joulukuu"))
183
184 (defparameter day-of-week-to-text (make-hash-table))
185 (setf (gethash 0 day-of-week-to-text)
186 #("???" "???" "???" "???" "???" "???" "???" "???"))
187 (setf (gethash 1 day-of-week-to-text)
188 #("???" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
189 (setf (gethash 2 day-of-week-to-text)
190 #("???" "Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche"))
191 (setf (gethash 3 day-of-week-to-text)
192 #("???" "Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag" "Sonntag"))
193 (setf (gethash 4 day-of-week-to-text)
194 #("???" "Lunes" "Martes" "Miercoles" "Jueves" "Viernes" "Sabado" "Domingo"))
195 (setf (gethash 5 day-of-week-to-text)
196 #("???" "Segunda-feira" "Terca-feira" "Quarta-feira" "Quinta-feira" "Sexta-feira" "Sabado" "Domingo"))
197 (setf (gethash 6 day-of-week-to-text)
198 #("???" "Maandag" "Dinsdag" "Woensdag" "Donderdag" "Vrijdag" "Zaterdag" "Zondag"))
199 (setf (gethash 7 day-of-week-to-text)
200 #("???" "Lunedi" "Martedi" "Mercoledi" "Giovedi" "Venerdi" "Sabato" "Domenica"))
201 (setf (gethash 8 day-of-week-to-text)
202 #("???" "mandag" "tirsdag" "onsdag" "torsdag" "fredag" "loerdag" "soendag"))
203 (setf (gethash 9 day-of-week-to-text)
204 #("???" "mandag" "tisdag" "onsdag" "torsdag" "fredag" "loerdag" "soendag"))
205 (setf (gethash 10 day-of-week-to-text)
206 #("???" "mandag" "tirsdag" "onsdag" "torsdag" "fredag" "loerdag" "soendag"))
207 (setf (gethash 11 day-of-week-to-text)
208 #("???" "maanantai" "tiistai" "keskiviikko" "torstai" "perjantai" "lauantai" "sunnuntai"))
209
210 (defparameter day-of-week-abbreviation (make-hash-table))
211 (setf (gethash 0 day-of-week-abbreviation) #("" "" "" "" "" "" "" ""))
212 (setf (gethash 1 day-of-week-abbreviation) #("??" "Mon" "Tue" "Wen" "Thu" "Fri" "Sat" "Sun"))
213 (setf (gethash 2 day-of-week-abbreviation) #("" "" "" "" "" "" "" ""))
214 (setf (gethash 3 day-of-week-abbreviation) #("??" "Mo" "Di" "Mi" "Do" "Fr" "Sa" "So"))
215 (setf (gethash 4 day-of-week-abbreviation) #("" "" "" "" "" "" "" ""))
216 (setf (gethash 5 day-of-week-abbreviation) #("???" "2" "3" "4" "5" "6" "Sam" "Dom"))
217 (setf (gethash 6 day-of-week-abbreviation) #("" "" "" "" "" "" "" ""))
218 (setf (gethash 7 day-of-week-abbreviation) #("" "" "" "" "" "" "" ""))
219 (setf (gethash 8 day-of-week-abbreviation) #("" "" "" "" "" "" "" ""))
220 (setf (gethash 9 day-of-week-abbreviation) #("??" "Mo" "Ti" "On" "To" "Fr" "Lo" "So"))
221 (setf (gethash 10 day-of-week-abbreviation) #("" "" "" "" "" "" "" ""))
222 (setf (gethash 11 day-of-week-abbreviation) #("" "" "" "" "" "" "" ""))
223
224 (defparameter long-format (make-array '(12) :initial-contents
225 '(("~A, ~A ~A ~A" 10) ; 0 Default, the second value describes order:
226 ("~A, ~A ~A ~A" 10) ; 1 English 11=DMY 10=MDY see #'date-to-text-long
227 ("~A ~A ~A ~A" 10) ; 2 Francais
228 ("~A, den ~A ~A ~A" 11) ; 3 Deutsch
229 ("~A, ~A de ~A de ~A" 10) ; 4 Espanol
230 ("~A, dia ~A de ~A de ~A" 10) ; 5 Portugues
231 ("~A, ~A ~A ~A" 10) ; 6 Nederlands
232 ("~A, ~A ~A ~A" 10) ; 7 Italiano
233 ("~A, ~A. ~A ~A" 10) ; 8 Norsk
234 ("~A, ~A ~A ~A" 10) ; 9 Svenska
235 ("~A, ~A. ~A ~A" 10) ; 10 Dansk
236 ("~A, ~A. ~A ta ~A" 10)))) ; 11 suomi
237
238 (defparameter language-to-text
239 (vector "???" "English" "Francais" "Deutsch" "Espanol"
240 "Portugues" "Nederlands" "Italiano" "Norsk"
241 "Svenska" "Dansk" "suomi"))
242
243 ;;;; Functions
244 (defun decode-day-of-week (str)
245 "Returns number of weekday. STR can partially name the Weekday. DOW is not CL conform."
246 (let ((week-vector (gethash *language* day-of-week-to-text))
247 (i 0))
248 (loop for weekday across week-vector
249 until (search str weekday :test #'char-equal)
250 do (incf i)
251 finally (return (if (<= i 7) i nil)))))
252
253 (defun cl-decode-day-of-week (str)
254 "Returns number of weekday. STR can partially name the Weekday. DOW is CL conform."
255 (let ((week-vector (gethash *language* day-of-week-to-text))
256 (i 0))
257 (loop for weekday across week-vector
258 until (search str weekday :test #'char-equal)
259 do (incf i)
260 finally (return (if (<= i 7) (1- i) nil)))))
261
262 (defun decode-month (str)
263 "Returns number of month. STR can partially name the month. Computes a (search ...:test #'char-equal)."
264 (let ((month-vector (gethash *language* month-to-text))
265 (i 0))
266 (loop for month across month-vector
267 until (search str month :test #'char-equal)
268 do (incf i)
269 finally (return (if (<= i 12) i nil)))))
270
271 (defun decode-language (num)
272 "Returns the Language of number NUM."
273 (svref language-to-text num))
274
275 (defun iso-lc (char)
276 "Returns lower case CHAR."
277 (char-downcase char))
278
279 (defun iso-uc (char)
280 "Returns upper case CHAR."
281 (char-upcase char))
282
283 (defun year-to-days (year)
284 "Returns the number of days for YEAR since 1 Jan 1."
285 (+ (- (+ (* year 365) (ash year -2))
286 (floor (/ (ash year -2) 25)))
287 (ash (floor (/ (ash year -2) 25)) -2)))
288
289 (defun fixed-window (year)
290 "Convert two digit YEAR to four digit YEAR; YEAR<=70 -> 2000+YEAR; YEAR<100&&>70 -> 1900+YEAR."
291 (if (and (> year 70) (< year 100))
292 (+ 1900 year)
293 (+ 2000 year)))
294
295 (defun center (string width)
296 "Return a string that is WIDTH long with STRING centered in it."
297 (let* ((pad (- width (length string)))
298 (lpad (truncate pad 2))
299 (rpad (- pad (truncate pad 2))))
300 (if (<= pad 0)
301 string
302 (concatenate 'string (make-string lpad :initial-element #\Space) string (make-string rpad :initial-element #\Space)))))
303
304 (defun normalize-time (dd dh dm ds)
305 "Internal fn for normalize-dhms. Returns the normalized (values DD DH DM DS)."
306 (values (+ dd (floor (+ dh (floor (+ dm (floor ds 60)) 60)) 24)) ; dd
307 (- (+ dh (floor (+ dm (floor ds 60)) 60))
308 (* (floor (+ dh (floor (+ dm (floor ds 60)) 60)) 24) 24)) ; dh
309 (- (+ dm (floor ds 60)) (* (floor (+ dm (floor ds 60)) 60) 60)) ;dm
310 (- ds (* (floor ds 60) 60)))) ;ds
311
312 (defun normalize-ranges (dd dh dm ds)
313 "Internal fn for normalize-dhms. Returns the normalized (values DD DH DM DS). This function prevents overflow errors on systems with short longs (e.g. 32-bits) (If need be for CL ???)."
314 (normalize-time (+ dd (floor dh 24))
315 (+ (- dh (* (floor dh 24) 24)) (floor dm 60))
316 (- dm (* (floor dm 60) 60))
317 ds))
318
319 (defun normalize-signs (dd dh dm ds)
320 "Internal fn for normalize-dhms."
321 (let* ((quot (floor ds 86400))
322 (ds1 (- ds (* quot 86400)))
323 (dd1 (+ dd quot)))
324 (setq dh 0 dm 0)
325 (if (not (= dd1 0))
326 (if (> dd1 0)
327 (when (< ds 0)
328 (setq ds1 (+ ds 86400)
329 dd1 (1- dd1)))
330 (when (> ds 0)
331 (setq ds1 (- ds 86400)
332 dd1 (1+ dd1)))))
333 (if (not (= ds1 0))
334 (normalize-time dd1 dh dm ds1)
335 (values dd1 dh dm ds1))))
336
337 (defun valid-year-p (year) (>= year 1))
338 (defun valid-month-p (month) (and month (>= month 1) (<= month 12)))
339
340 (defun leap-year (year)
341 "This function returns 1 if the given YEAR is a leap year and 0 otherwise."
342 (if (or (and (zerop (mod year 4))
343 (not (zerop (mod year 100))))
344 (zerop (mod year 400)))
345 1
346 0))
347
348 (defun leap-year-p (year)
349 "This function returns t if the given YEAR is a leap year and nil otherwise."
350 (if (or (and (zerop (mod year 4))
351 (not (zerop (mod year 100))))
352 (zerop (mod year 400)))
353 t
354 nil))
355
356 (defun days-in-month (year month)
357 "This function returns the number of days in the given MONTH of the given YEAR."
358 (if (and (valid-year-p year)
359 (valid-month-p month))
360 (aref days-in-month-arr (leap-year year) month)))
361
362 (defun days-in-year (year &optional month)
363 "This function returns the number of days in the given YEAR and optional MONTH. If MONTH is [1..12], return the number of days in that YEAR as of the last of that MONTH."
364 (aref days-in-year-arr (leap-year year) (if (and month (>= month 0) (<= month 12))
365 month
366 12)))
367
368 (defun check-date (year month day)
369 "This function returns t if the given three numerical values YEAR MONTH DAY constitute a valid date, and nil otherwise."
370 (and (valid-year-p year)
371 (valid-month-p month)
372 (>= day 1)
373 (<= day (days-in-month year month))))
374
375 (defun check-time-p (hour min sec)
376 "This function returns t if the given three numerical values HOUR MIN SEC constitute a valid time, and nil otherwise."
377 (and (>= hour 0) (< hour 24)
378 (>= min 0) (< min 60)
379 (>= sec 0) (< sec 60)))
380
381 (defun day-of-year (year month day)
382 "This function returns the sum of the number of days in the months starting with January up to and including MONTH in
383 the given year YEAR. 0 on failure."
384 (if (check-date year month day)
385 (+ day (aref days-in-year-arr (leap-year year) (1- month)))
386 0))
387
388 (defun date-to-days (year month day)
389 "This function returns the (absolute) number of the day of the given date, where counting starts at the 1.Jan 1."
390 (if (check-date year month day)
391 (+ (year-to-days (1- year))
392 (day-of-year year month day))
393 0))
394
395 (defun day-of-week (year month day)
396 "This function returns the DOW of YEAR MONTH DAY. DOW not CL conform."
397 (let ((days (date-to-days year month day)))
398 (if (> days 0)
399 (1+ (mod (1- days) 7))
400 days)))
401
402 (defun cl-day-of-week (year month day)
403 "This function returns the DOW of YEAR MONTH DAY. DOW CL conform."
404 (let ((days (date-to-days year month day)))
405 (if (> days 0)
406 (mod (1- days) 7)
407 days)))
408
409 (defun weeks-in-year (year)
410 "This function returns the number of weeks in the given YEAR, i.e., either 52 or 53."
411 (if (or (= 4 (day-of-week year 1 1))
412 (= 4 (day-of-week year 12 31)))
413 53 52))
414
415 (defun cl-weeks-in-year (year)
416 "This function returns the number of weeks in the given YEAR for CL DOW conform numbering (Monday=0)., i.e., either 52 or 53."
417 (if (or (= 3 (cl-day-of-week year 1 1))
418 (= 3 (cl-day-of-week year 12 31)))
419 53 52))
420
421 (defun check-business-p (year week dow)
422 "This function returns true if the given three numerical values YEAR WEEK DOW constitute a valid date in business format, and nil otherwise. Beware that this function does NOT compute whether a given date is a business day (i.e., Monday to Friday)! To do so, use (< (day-of-week year month day) 6) instead. DOW not CL conform."
423 (and (>= year 1)
424 (>= week 1)
425 (<= week (weeks-in-year year))
426 (>= dow 1)
427 (<= dow 7)))
428
429 (defun cl-check-business-p (year week dow)
430 "This function returns true if the given three numerical values YEAR WEEK DOW constitute a valid date in business format for CL (Monday=0), and nil otherwise. DOW is CL conform."
431 (and (>= year 1)
432 (>= week 1)
433 (<= week (weeks-in-year year))
434 (>= dow 0)
435 (<= dow 6)))
436
437 (defun delta-days (year1 month1 day1 year2 month2 day2)
438 "This function returns the difference in days between Y1 M1 D1 and Y2 M2 D2."
439 (- (date-to-days year2 month2 day2)
440 (date-to-days year1 month1 day1)))
441
442 (defun week-number (year month day)
443 "This function returns the number of the week of the given Y M D lies in. If the given date lies in the LAST week of the PREVIOUS year, 0 is returned."
444 (let ((first-jan (1- (day-of-week year 1 1))))
445 (if (< first-jan 4)
446 (1+ (truncate (+ first-jan (delta-days year 1 1 year month day)) 7))
447 (+ 0 (truncate (+ first-jan (delta-days year 1 1 year month day)) 7))))) ; + 0..-> only return one value
448
449 (defun week-of-year (year month day)
450 "Return (values week year) where week is the week number of YEAR"
451 (if (not (check-date year month day))
452 nil
453 (progn
454 (let ((week (week-number year month day)))
455 (if (= week 0)
456 (values (weeks-in-year (1- year)) year)
457 (progn
458 (if (> week (weeks-in-year year))
459 (values 1 (1+ year))
460 (values week year))))))))
461
462 (defun add-delta-days (year month day delta)
463 "This function returns (values year month day) such that it is YEAR MONTH DAY plus DELTA days"
464 ;; Be careful when changing things in this fn ! Side effects !
465 ;; Fairly direct port from the PERL routine. Pretty imperative style.
466 (let* ((days (+ (date-to-days year month day) delta))
467 (y1 (round (/ days 365.2425)))
468 (d1 (- days (year-to-days y1))))
469 (when (> days 0)
470 (progn
471 (if (< d1 1)
472 (setf d1 (- days (year-to-days (1- y1)))) ; then
473 (setf y1 (1+ y1))) ; else
474 (if (> d1 (days-in-year y1))
475 (setf d1 (- d1 (days-in-year y1))
476 y1 (1+ y1)))
477 (loop for index downfrom 12 to 1
478 until (> d1 (days-in-year y1 index))
479 finally (return (values y1 (1+ index) (- d1 (days-in-year y1 index))))))))) ; index=month just one to low here after until, thats why (1+ index) as return value
480
481 (defun monday-of-week (week year)
482 "Return (values year month day) where month and day correspond to the Monday of WEEK in YEAR"
483 (let ((erst (1- (day-of-week year 1 1))))
484 (if (< erst 4)
485 (add-delta-days year 1 1 (- (* (1- week) 7) erst))
486 (add-delta-days year 1 1 (- (* week 7) erst)))))
487
488 (defun nth-weekday-of-month-year (year month dow n)
489 "This function returns the (year month day) of the N-th day of week DOW in the given MONTH and YEAR; such as, for example, the 3rd Thursday of a given month and year. DOW is not CL conform."
490 (when (and (check-date year month 1) ; check params
491 (>= dow 1) (<= dow 7)
492 (> n 0) (< n 5))
493 (let* ((erst (day-of-week year month 1))
494 (tow (if (< dow erst)
495 (+ dow 7)
496 dow)))
497 (multiple-value-bind (y m d)
498 (add-delta-days year month 1 (+ (- tow erst) (* (1- n) 7)))
499 (when (= month m)
500 (values y m d))))))
501
502 (defun cl-nth-weekday-of-month-year (year month dow n)
503 "This function returns the (year month day) of the N-th day of week DOW in the given MONTH and YEAR; such as, for example, the 3rd Thursday of a given month and year. DOW is CL conform."
504 (when (and (check-date year month 1) ; check params
505 (>= dow 0) (<= dow 6)
506 (> n 0) (< n 5))
507 (let* ((erst (cl-day-of-week year month 1))
508 (tow (if (< dow erst)
509 (+ dow 7)
510 dow)))
511 (multiple-value-bind (y m d)
512 (add-delta-days year month 1 (+ (- tow erst) (* (1- n) 7)))
513 (when (= month m)
514 (values y m d))))))
515
516 (defun standard-to-business (year month day)
517 "This function converts a given date from standard notation YEAR MONTH DAY to business notation year week dow. DOW is not CL conform."
518 (multiple-value-bind (week y) (week-of-year year month day)
519 (when week
520 (values y week (day-of-week year month day)))))
521
522 (defun cl-standard-to-business (year month day)
523 "This function converts a given date from standard notation YEAR MONTH DAY to business notation year week day of week. DOW is CL conform."
524 (multiple-value-bind (week y) (week-of-year year month day)
525 (when week
526 (values y week (cl-day-of-week year month day)))))
527
528
529 (defun business-to-standard (year week dow)
530 "This function converts a given date from business notation YEAR WEEK DOW to standard notation year month day. DOW is not CL conform."
531 (when (check-business-p year week dow)
532 (let* ((erst (day-of-week year 1 1))
533 (delta (+ (- dow erst) (* 7 (1- (+ week (if (> erst 4) 1 0)))))))
534 (add-delta-days year 1 1 delta))))
535
536 (defun cl-business-to-standard (year week dow)
537 "This function converts a given date from business notation YEAR WEEK DOW to standard notation year month day. DOW is CL conform."
538 (when (cl-check-business-p year week dow)
539 (let* ((erst (cl-day-of-week year 1 1))
540 (delta (+ (- dow erst) (* 7 (1- (+ week (if (> erst 4) 1 0)))))))
541 (add-delta-days year 1 1 delta))))
542
543 (defun delta-hms (hour1 min1 sec1 hour2 min2 sec2)
544 "This function returns the difference of H1 M1 S1 and H2 M2 S2 in (values d h m s)."
545 (when (and (check-time-p hour1 min1 sec1)
546 (check-time-p hour2 min2 sec2))
547 (normalize-signs 0 0 0 (- (+ sec2 (* 60 (+ min2 (* 60 hour2))))
548 (+ sec1 (* 60 (+ min1 (* 60 hour1))))))))
549
550 (defun delta-dhms (year1 month1 day1 hour1 min1 sec1 year2 month2 day2 hour2 min2 sec2)
551 "Returns the difference in (values d h m s) between the two given dates with times (Y1 M1 D1 H1 MIN1 SEC1 and Y2 M2 D2 H2 MIN2 SEC2)."
552 (let ((dd (delta-days year1 month1 day1 year2 month2 day2)))
553 (multiple-value-bind (d h m s) (delta-hms hour1 min1 sec1 hour2 min2 sec2)
554 (if d
555 (values (+ d dd) h m s)
556 (values d h m s)))))
557
558 (defun delta-ymd (year1 month1 day1 year2 month2 day2)
559 "This function returns the difference (values YEAR MONTH DAYS) between the two dates Y1M1D1 and Y2M2D2."
560 (if (and (check-date year1 month1 day1)
561 (check-date year2 month2 day2))
562 (values (- year2 year1)(- month2 month1)(- day2 day1))
563 nil))
564
565 (defun delta-ymdhms (year1 month1 day1 hour1 min1 sec1
566 year2 month2 day2 hour2 min2 sec2)
567 "This function returns the difference (values YEAR MONTH DAYS HOUR MINUTE SEC) between
568 the two dates Y1 M1 D1 H1 MI1 S1 and Y2 M2 D2 H2 MI2 S2."
569 (multiple-value-bind (y m d) (delta-ymd year1 month1 day1 year2 month2 day2)
570 (when y
571 (multiple-value-bind (dd hh mm ss)
572 (delta-hms hour1 min1 sec1 hour2 min2 sec2)
573 (when dd
574 (values y m (+ dd d) hh mm ss))))))
575
576 (defun normalize-dhms (day hour min sec)
577 "This function takes four arbitrary values for days, hours, minutes and seconds (which may have different signs) and renormalizes them so that the values for hours, minutes and seconds will lie in the ranges [-23..23], [-59..59] and [-59..59], respectively, and so that they have the same sign."
578 (multiple-value-bind (dd dh dm ds) (normalize-ranges day hour min sec)
579 (when ds
580 (normalize-signs dd dm dh (+ ds (* 60 (+ dm (* 60 dh))))))))
581
582 (defun add-delta-dhms (year month day hour min sec dd dh dm ds)
583 "This function serves to add a days, hours, minutes and seconds offset to a given date and time (YEAR MONTH DAY HOUR MINUTE SECOND DDAY DHOUR DMINUTE DSECOND), in order to answer questions like \"today and now plus 7 days but minus 5 hours and then plus 30 minutes, what date and time gives that?\". Returns: (values y m d h min sec)"
584 (when (and (check-date year month day)
585 (check-time-p hour min sec))
586 (multiple-value-bind (d1 h1 m1 s1) (normalize-ranges dd dh dm ds)
587 (when d1
588 (progn
589 (let ((s2 (+ s1 (* 60 (+ m1 (* 60 h1))) (+ sec (* 60 (+ min (* 60 hour)))))))
590 (when (= 0 s2)
591 (multiple-value-bind (yy mm ddd) (add-delta-days year month day d1)
592 (values yy mm ddd 0 0 0)))
593 (when (< s2 0)
594 (multiple-value-bind (dd1 ss2) (truncate s2 86400)
595 (multiple-value-bind (ddd hh mm ss) (normalize-time (+ d1 dd1) 0 0 ss2)
596 (multiple-value-bind (yy mmm dddd) (add-delta-days year month day ddd)
597 (values yy mmm dddd hh mm ss)))))
598 (when (> s2 0)
599 (multiple-value-bind (ddd hh mm ss) (normalize-time d1 0 0 s2)
600 (multiple-value-bind (yy mmm dddd) (add-delta-days year month day ddd)
601 (values yy mmm dddd hh mm ss))))))))))
602
603 (defun add-year-month (year month dy dm)
604 "This function adds DYEAR and DMONTH offset to YEAR and MONTH."
605 (let ((mt (+ month dm)))
606 (if (> mt 0)
607 (multiple-value-bind (jahre monate) (truncate (1- mt) 12)
608 (values (+ jahre (+ year dy)) (1+ monate)))
609 (multiple-value-bind (jahre monate) (truncate mt 12)
610 (values (+ (+ year dy) jahre -1) (+ 12 monate))))))
611
612 (defun add-delta-ym (year month day dy dm)
613 "This function adds DYEAR and DMONTH offset to YEAR MONTH DAY."
614 (when (check-date year month day)
615 (multiple-value-bind (jahr monat) (add-year-month year month dy dm)
616 (values jahr monat day))))
617
618 (defun add-delta-ymd (year month day dy dm dd)
619 "This function adds DYEAR DMONTH and DDAY offset to YEAR MONTH DAY."
620 (when (check-date year month day)
621 (multiple-value-bind (jahr monat tag) (add-delta-ym year month day dy dm)
622 (when jahr
623 (add-delta-days jahr monat tag dd)))))
624
625 (defun add-delta-ymdhms (year month day hour min sec dyear dmonth dday dh dm ds)
626 "This function is the same as add-delta-ymd except that a time offset may be given in addition to the year, month and day offset"
627 (multiple-value-bind (jahr monat) (add-year-month year month dyear dmonth)
628 (when jahr
629 (add-delta-dhms jahr monat 1 hour min sec (+ dday (1- day)) dh dm ds))))
630
631 (defun system-clock (gmt time)
632 "This function returns (values year month day hour min sec doy dow dst) based on current system clock. DOW is not CL conform."
633 (multiple-value-bind (second minute hour day month year dow daylight-p dst)
634 (decode-universal-time time)
635 (declare (ignorable daylight-p))
636 (let ((doy (day-of-year year month day)))
637 (if gmt
638 (multiple-value-bind (jahr monat tag std min sek)
639 (add-delta-dhms year month day hour minute second 0 0 dst 0)
640 (values jahr monat tag std min sek doy (1+ dow) dst))
641 (values year month day hour minute second doy (1+ dow) dst)))))
642
643 (defun cl-system-clock (gmt time)
644 "This function returns (values year month day hour min sec doy dow dst) based on current system clock. DOW is CL conform."
645 (multiple-value-bind (second minute hour day month year dow daylight-p dst)
646 (decode-universal-time time)
647 (declare (ignorable daylight-p))
648 (let ((doy (day-of-year year month day)))
649 (if gmt
650 (multiple-value-bind (jahr monat tag std min sek)
651 (add-delta-dhms year month day hour minute second 0 0 dst 0)
652 (values jahr monat tag std min sek doy dow dst))
653 (values year month day hour minute second doy dow dst)))))
654
655 ;;;;;;; Add gmt flag
656 (defun gmtime ()
657 (system-clock t (get-universal-time)))
658
659 (defun localtime ()
660 (system-clock nil (get-universal-time)))
661
662 (defun today ()
663 "This function returns (year month day) for today."
664 (multiple-value-bind (sec minute hour day month year) (get-decoded-time)
665 (declare (ignorable sec minute hour))
666 (values year month day)))
667
668 (defun yesterday ()
669 (multiple-value-bind (jahr monat tag) (today)
670 (add-delta-days jahr monat tag -1)))
671
672 (defun tomorrow ()
673 (multiple-value-bind (jahr monat tag) (today)
674 (add-delta-days jahr monat tag 1)))
675
676 (defun now ()
677 "This function returns (hour minute second) for right now."
678 (multiple-value-bind (second minute hour) (get-decoded-time)
679 (values hour minute second)))
680
681 (defun today-and-now ()
682 "This function returns (year month day hour minute second) for the current date and time."
683 (multiple-value-bind (second minute hour day month year) (get-decoded-time)
684 (values year month day hour minute second)))
685
686 (defun this-year ()
687 "This function returns the current year in localtime."
688 (multiple-value-bind (second minute hour day month year) (get-decoded-time)
689 (declare (ignorable second minute hour day month))
690 year))
691
692 (defun date-to-text (year month day)
693 "Return a pretty print string of YEAR MONTH DAY in DOW-TXT(SHORT) DAY MONTH YEAR with a little bit of sorting for language."
694 (let ((prn (first (aref long-format *language*)))) ; get print format
695 (multiple-value-bind (a b c) ; What order is the date DMY , MDY ....
696 (let ((k (second (aref long-format *language*))))
697 (case k ; return the order of DMY
698 (10 (values month day year))
699 (11 (values day month year))
700 (otherwise (values month day year)))) ; return english by default
701 (format nil prn ; make the return string
702 (svref (gethash *language* day-of-week-abbreviation) ; Get Name of Weekday
703 (day-of-week year month day))
704 a b c))))
705
706 (defun date-to-text-long (year month day)
707 "Return a pretty print string of YEAR MONTH DAY in DOW-TXT(LONG) DAY MONTH YEAR with a little bit of sorting for language."
708 (let ((prn (first (aref long-format *language*)))) ; get print format
709 (multiple-value-bind (a b c) ; What order is the date DMY , MDY ....
710 (let ((k (second (aref long-format *language*))))
711 (case k ; return the order of DMY
712 (10 (values month day year))
713 (11 (values day month year))
714 (otherwise (values month day year)))) ; return english by default
715 (format nil prn ; make the return string
716 (svref (gethash *language* day-of-week-to-text) ; Get Name of Weekday
717 (day-of-week year month day))
718 a b c))))
719

  ViewVC Help
Powered by ViewVC 1.1.5