1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
;;; -*- Mode: Lisp -*-
;;; $Id: time-funcs.lisp,v 1.6 2001/11/12 19:48:20 jesse Exp $
;;;
;;; Copyright (c) 2000, 2001 onShore Development, Inc.
;;;
;;; Widely used time functions.
(in-package :local-time)
(defvar *days-per-lt-cycle* 146097)
(defun leap-year? (year)
"t if YEAR is a leap yeap in the Gregorian calendar"
(and (= 0 (mod year 4))
(or (not (= 0 (mod year 100)))
(= 0 (mod year 400)))))
(defun valid-month-p (month)
"t if MONTH exists in the Gregorian calendar"
(<= 1 month 12))
(defun valid-gregorian-date-p (date)
"t if DATE (year month day) exists in the Gregorian calendar"
(let ((max-day (days-in-month (nth 1 date) (nth 0 date))))
(<= 1 (nth 2 date) max-day)))
(defun days-in-month (month year &key (careful t))
"the number of days in MONTH of YEAR, observing Gregorian leap year
rules"
(declare (type fixnum month year))
(when careful
(check-type month (satisfies valid-month-p)
"between 1 (January) and 12 (December)"))
(if (eql month 2) ; feb
(if (leap-year? year)
29 28)
(let ((even (mod (1- month) 2)))
(if (< month 8) ; aug
(- 31 even)
(+ 30 even)))))
(defun day-of-year (year month day &key (careful t))
"the day number within the year of the date DATE. For example,
1987 1 1 returns 1"
(declare (type fixnum year month day))
(when careful
(let ((date (list year month day)))
(check-type date (satisfies valid-gregorian-date-p)
"a valid Gregorian date")))
(let ((doy (+ day (* 31 (1- month)))))
(declare (type fixnum doy))
(when (< 2 month)
(setq doy (- doy (floor (+ 23 (* 4 month)) 10)))
(when (leap-year? year)
(incf doy)))
doy))
;; Inspired by: http://www.interlog.com/~r937/doomsday.html
(defun day-of-week (year month day &key (careful t))
"Given a Gregorian year, month and day, return the day of the week,
zero-based on Sunday."
(when careful
(let ((date (list year month day)))
(check-type date (satisfies valid-gregorian-date-p)
"a valid Gregorian date")))
(flet ((month-value (month leap-year)
(let ((val (nth month '(0 3 0 0 4 9 6 11 8 5 10 7 12))))
(if (and leap-year (< month 3))
(1+ val)
val)))
(century-value (century)
(nth (mod century 4) '(2 0 5 3))))
(multiple-value-bind (century year-in-century)
(floor year 100)
(multiple-value-bind (p q)
(floor year-in-century 12)
(let ((doomsday (mod (+ p q (floor q 4) (century-value century)) 7)))
(mod (+ (- day (month-value month (leap-year? year))) doomsday 14) 7))))))
(defun day-of-gregorian-epoch (year month day)
"the number of days after 1 AD"
(declare (type fixnum year month day))
(let ((prior-years (1- year)))
(declare (type fixnum prior-years))
(+ (day-of-year year month day :careful nil)
(* 365 prior-years) ; days in prior years
(floor prior-years 4) ; Julian leap years
(- (floor prior-years 100)) ; century years
(floor prior-years 400)))) ; Gregorian leap years
(defun %lt-date (year month day)
"local-time epoch day number corresponding to Gregorian date"
(- (day-of-gregorian-epoch year month day)
(day-of-gregorian-epoch 2000 3 1)))
(defun %gregorian-date (lt)
(multiple-value-bind (cycle day)
(floor lt *days-per-lt-cycle*)
(multiple-value-bind (y m d wd)
(lt-entry-to-ymdw (lt-entry day))
(values (+ 2000 y (* cycle 400)) m d wd))))
(defun unix-to-lt ()
(* 24 60 60
(- (day-of-gregorian-epoch 2000 3 1)
(day-of-gregorian-epoch 1970 1 1))))
|