Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
emacs
emacs
Commits
71ea27ee
Commit
71ea27ee
authored
Mar 13, 2008
by
Glenn Morris
Browse files
Whitespace only.
parent
6eb61c70
Changes
12
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
12 changed files
with
961 additions
and
955 deletions
+961
-955
lisp/calendar/cal-bahai.el
lisp/calendar/cal-bahai.el
+63
-62
lisp/calendar/cal-dst.el
lisp/calendar/cal-dst.el
+87
-86
lisp/calendar/cal-french.el
lisp/calendar/cal-french.el
+50
-48
lisp/calendar/cal-hebrew.el
lisp/calendar/cal-hebrew.el
+223
-221
lisp/calendar/cal-mayan.el
lisp/calendar/cal-mayan.el
+40
-40
lisp/calendar/cal-menu.el
lisp/calendar/cal-menu.el
+1
-1
lisp/calendar/cal-move.el
lisp/calendar/cal-move.el
+8
-8
lisp/calendar/cal-tex.el
lisp/calendar/cal-tex.el
+1
-1
lisp/calendar/cal-x.el
lisp/calendar/cal-x.el
+5
-5
lisp/calendar/calendar.el
lisp/calendar/calendar.el
+64
-64
lisp/calendar/diary-lib.el
lisp/calendar/diary-lib.el
+316
-316
lisp/calendar/lunar.el
lisp/calendar/lunar.el
+103
-103
No files found.
lisp/calendar/cal-bahai.el
View file @
71ea27ee
...
@@ -77,36 +77,36 @@
...
@@ -77,36 +77,36 @@
The absolute date is the number of days elapsed since the (imaginary)
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
Gregorian date Sunday, December 31, 1 BC."
(let* ((month (extract-calendar-month date))
(let* ((month (extract-calendar-month date))
(
day
(
extract-calendar-day
date
))
(day (extract-calendar-day date))
(
year
(
extract-calendar-year
date
))
(year (extract-calendar-year date))
(
prior-years
(
+
(
1-
year
)
1844
))
(prior-years (+ (1- year) 1844))
(
leap-days
(
-
(
+
(
/
prior-years
4
)
; leap days in prior years
(leap-days (- (+ (/ prior-years 4) ; leap days in prior years
(
-
(
/
prior-years
100
))
(- (/ prior-years 100))
(
/
prior-years
400
))
(/ prior-years 400))
calendar-bahai-leap-base
)))
calendar-bahai-leap-base)))
(
+
(
1-
calendar-bahai-epoch
)
; days before epoch
(+ (1- calendar-bahai-epoch)
; days before epoch
(
*
365
(
1-
year
))
; days in prior years
(* 365 (1- year))
; days in prior years
leap-days
leap-days
(calendar-sum m 1 (< m month) 19)
(calendar-sum m 1 (< m month) 19)
(if (= month 19) 4 0)
(if (= month 19) 4 0)
day
)))
; days so far this month
day)))
; days so far this month
(defun calendar-bahai-from-absolute (date)
(defun calendar-bahai-from-absolute (date)
"Bahá'í year corresponding to the absolute DATE."
"Bahá'í year corresponding to the absolute DATE."
(if (< date calendar-bahai-epoch)
(if (< date calendar-bahai-epoch)
(list 0 0 0) ; pre-Bahá'í date
(list 0 0 0) ; pre-Bahá'í date
(let* ((greg (calendar-gregorian-from-absolute date))
(let* ((greg (calendar-gregorian-from-absolute date))
(
year
(
+
(
-
(
extract-calendar-year
greg
)
1844
)
(year (+ (- (extract-calendar-year greg) 1844)
(
if
(
or
(
>
(
extract-calendar-month
greg
)
3
)
(if (or (> (extract-calendar-month greg) 3)
(
and
(
=
(
extract-calendar-month
greg
)
3
)
(and (= (extract-calendar-month greg) 3)
(
>=
(
extract-calendar-day
greg
)
21
)))
(>= (extract-calendar-day greg) 21)))
1
0
)))
1 0)))
(month ; search forward from Baha
(month ; search forward from Baha
(1+ (calendar-sum m 1
(1+ (calendar-sum m 1
(
>
date
(> date
(
calendar-absolute-from-bahai
(calendar-absolute-from-bahai
(
list
m
19
year
)))
(list m 19 year)))
1
)))
1)))
(day ; calculate the day by subtraction
(day ; calculate the day by subtraction
(- date
(- date
(1- (calendar-absolute-from-bahai (list month 1 year))))))
(1- (calendar-absolute-from-bahai (list month 1 year))))))
...
@@ -117,25 +117,25 @@ Gregorian date Sunday, December 31, 1 BC."
...
@@ -117,25 +117,25 @@ Gregorian date Sunday, December 31, 1 BC."
"String of Bahá'í date of Gregorian DATE.
"String of Bahá'í date of Gregorian DATE.
Defaults to today's date if DATE is not given."
Defaults to today's date if DATE is not given."
(let* ((bahai-date (calendar-bahai-from-absolute
(let* ((bahai-date (calendar-bahai-from-absolute
(
calendar-absolute-from-gregorian
(calendar-absolute-from-gregorian
(
or
date
(
calendar-current-date
)))))
(or date (calendar-current-date)))))
(y (extract-calendar-year bahai-date))
(y (extract-calendar-year bahai-date))
(m (extract-calendar-month bahai-date))
(m (extract-calendar-month bahai-date))
(d (extract-calendar-day bahai-date)))
(d (extract-calendar-day bahai-date)))
(let ((monthname
(let ((monthname
(
if
(
and
(
=
m
19
)
(if (and (= m 19)
(
<=
d
0
))
(<= d 0))
"Ayyám-i-Há"
"Ayyám-i-Há"
(
aref
calendar-bahai-month-name-array
(
1-
m
))))
(aref calendar-bahai-month-name-array (1- m))))
(
day
(
int-to-string
(day (int-to-string
(
if
(
<=
d
0
)
(if (<= d 0)
(
if
(
calendar-bahai-leap-year-p
y
)
(if (calendar-bahai-leap-year-p y)
(
+
d
5
)
(+ d 5)
(
+
d
4
))
(+ d 4))
d
)))
d)))
(
dayname
nil
)
(dayname nil)
(
month
(
int-to-string
m
))
(month (int-to-string m))
(
year
(
int-to-string
y
)))
(year (int-to-string y)))
(mapconcat 'eval calendar-date-display-form ""))))
(mapconcat 'eval calendar-date-display-form ""))))
;;;###cal-autoload
;;;###cal-autoload
...
@@ -166,15 +166,15 @@ Echo Bahá'í date unless NOECHO is t."
...
@@ -166,15 +166,15 @@ Echo Bahá'í date unless NOECHO is t."
(calendar-absolute-from-gregorian today))))))
(calendar-absolute-from-gregorian today))))))
(completion-ignore-case t)
(completion-ignore-case t)
(month (cdr (assoc
(month (cdr (assoc
(
completing-read
(completing-read
"Bahá'í calendar month name: "
"Bahá'í calendar month name: "
(
mapcar
'list
(mapcar 'list
(
append
calendar-bahai-month-name-array
nil
))
(append calendar-bahai-month-name-array nil))
nil
t
)
nil t)
(calendar-make-alist calendar-bahai-month-name-array
(calendar-make-alist calendar-bahai-month-name-array
1))))
1))))
(day (calendar-read "Bahá'í calendar day (1-19): "
(day (calendar-read "Bahá'í calendar day (1-19): "
(
lambda
(
x
)
(
and
(
<
0
x
)
(
<=
x
19
))))))
(lambda (x) (and (< 0 x) (<= x 19))))))
(list (list month day year))))
(list (list month day year))))
(defvar displayed-month)
(defvar displayed-month)
...
@@ -187,15 +187,15 @@ If MONTH, DAY (Bahá'í) is visible, the value returned is corresponding
...
@@ -187,15 +187,15 @@ If MONTH, DAY (Bahá'í) is visible, the value returned is corresponding
Gregorian date in the form of the list (((month day year) STRING)). Returns
Gregorian date in the form of the list (((month day year) STRING)). Returns
nil if it is not visible in the current calendar window."
nil if it is not visible in the current calendar window."
(let* ((bahai-date (calendar-bahai-from-absolute
(let* ((bahai-date (calendar-bahai-from-absolute
(
calendar-absolute-from-gregorian
(calendar-absolute-from-gregorian
(
list
displayed-month
15
displayed-year
))))
(list displayed-month 15 displayed-year))))
(m (extract-calendar-month bahai-date))
(m (extract-calendar-month bahai-date))
(y (extract-calendar-year bahai-date))
(y (extract-calendar-year bahai-date))
(
date
))
(date))
(if (< m 1)
(if (< m 1)
nil
; Bahá'í calendar doesn't apply
nil
; Bahá'í calendar doesn't apply
(increment-calendar-month m y (- 10 month))
(increment-calendar-month m y (- 10 month))
(
if
(
>
m
7
)
; Bahá'í date might be visible
(if (> m 7)
; Bahá'í date might be visible
(let ((date (calendar-gregorian-from-absolute
(let ((date (calendar-gregorian-from-absolute
(calendar-absolute-from-bahai (list month day y)))))
(calendar-absolute-from-bahai (list month day y)))))
(if (calendar-date-is-visible-p date)
(if (calendar-date-is-visible-p date)
...
@@ -406,7 +406,7 @@ part of `nongregorian-diary-marking-hook'."
...
@@ -406,7 +406,7 @@ part of `nongregorian-diary-marking-hook'."
(cdr (assoc-string
(cdr (assoc-string
mm-name
mm-name
(calendar-make-alist
(calendar-make-alist
calendar-bahai-month-name-array
)
calendar-bahai-month-name-array)
t)))))
t)))))
(calendar-bahai-mark-date-pattern mm dd yy)))))
(calendar-bahai-mark-date-pattern mm dd yy)))))
(setq d (cdr d)))))
(setq d (cdr d)))))
...
@@ -427,15 +427,15 @@ A value of 0 in any position is a wildcard."
...
@@ -427,15 +427,15 @@ A value of 0 in any position is a wildcard."
(mark-visible-calendar-date date)))
(mark-visible-calendar-date date)))
;; Month and day in any year--this taken from the holiday stuff.
;; Month and day in any year--this taken from the holiday stuff.
(let* ((bahai-date (calendar-bahai-from-absolute
(let* ((bahai-date (calendar-bahai-from-absolute
(
calendar-absolute-from-gregorian
(calendar-absolute-from-gregorian
(
list
displayed-month
15
displayed-year
))))
(list displayed-month 15 displayed-year))))
(m (extract-calendar-month bahai-date))
(m (extract-calendar-month bahai-date))
(y (extract-calendar-year bahai-date))
(y (extract-calendar-year bahai-date))
(date))
(date))
(if (< m 1)
(if (< m 1)
nil
; Bahá'í calendar doesn't apply
nil
; Bahá'í calendar doesn't apply
(increment-calendar-month m y (- 10 month))
(increment-calendar-month m y (- 10 month))
(
if
(
>
m
7
)
; Bahá'í date might be visible
(if (> m 7)
; Bahá'í date might be visible
(let ((date (calendar-gregorian-from-absolute
(let ((date (calendar-gregorian-from-absolute
(calendar-absolute-from-bahai
(calendar-absolute-from-bahai
(list month day y)))))
(list month day y)))))
...
@@ -457,18 +457,19 @@ A value of 0 in any position is a wildcard."
...
@@ -457,18 +457,19 @@ A value of 0 in any position is a wildcard."
(calendar-absolute-from-gregorian
(calendar-absolute-from-gregorian
(list m (calendar-last-day-of-month m y) y)))
(list m (calendar-last-day-of-month m y) y)))
(calendar-for-loop date from first-date to last-date do
(calendar-for-loop date from first-date to last-date do
(
let*
((
b-date
(
calendar-bahai-from-absolute
date
))
(let* ((b-date (calendar-bahai-from-absolute date))
(
i-month
(
extract-calendar-month
b-date
))
(i-month (extract-calendar-month b-date))
(
i-day
(
extract-calendar-day
b-date
))
(i-day (extract-calendar-day b-date))
(
i-year
(
extract-calendar-year
b-date
)))
(i-year (extract-calendar-year b-date)))
(
and
(
or
(
zerop
month
)
(and (or (zerop month)
(
=
month
i-month
))
(= month i-month))
(
or
(
zerop
day
)
(or (zerop day)
(
=
day
i-day
))
(= day i-day))
(
or
(
zerop
year
)
(or (zerop year)
(
=
year
i-year
))
(= year i-year))
(
mark-visible-calendar-date
(mark-visible-calendar-date
(
calendar-gregorian-from-absolute
date
)))))))))
(calendar-gregorian-from-absolute
date)))))))))
;;;###cal-autoload
;;;###cal-autoload
(defun diary-bahai-insert-entry (arg)
(defun diary-bahai-insert-entry (arg)
...
...
lisp/calendar/cal-dst.el
View file @
71ea27ee
...
@@ -4,7 +4,7 @@
...
@@ -4,7 +4,7 @@
;; 2006, 2007, 2008 Free Software Foundation, Inc.
;; 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Paul Eggert <eggert@twinsun.com>
;; Author: Paul Eggert <eggert@twinsun.com>
;;
Edward M. Reingold <reingold@cs.uiuc.edu>
;;
Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Keywords: calendar
;; Human-Keywords: daylight saving time, calendar, diary, holidays
;; Human-Keywords: daylight saving time, calendar, diary, holidays
...
@@ -113,15 +113,15 @@ high and low 16 bits, respectively, of the number of seconds since
...
@@ -113,15 +113,15 @@ high and low 16 bits, respectively, of the number of seconds since
Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on
Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on
absolute date ABS-DATE is the equivalent moment to X."
absolute date ABS-DATE is the equivalent moment to X."
(
let*
((
h
(
car
x
))
(
let*
((
h
(
car
x
))
(
xtail
(
cdr
x
))
(
xtail
(
cdr
x
))
(
l
(
+
utc-diff
(
if
(
numberp
xtail
)
xtail
(
car
xtail
))))
(
l
(
+
utc-diff
(
if
(
numberp
xtail
)
xtail
(
car
xtail
))))
(
u
(
+
(
*
512
(
mod
h
675
))
(
floor
l
128
))))
(
u
(
+
(
*
512
(
mod
h
675
))
(
floor
l
128
))))
;; Overflow is a terrible thing!
;; Overflow is a terrible thing!
(
cons
(
+
calendar-system-time-basis
(
cons
(
+
calendar-system-time-basis
;; floor((2^16 h +l) / (60*60*24))
;; floor((2^16 h +l) / (60*60*24))
(
*
512
(
floor
h
675
))
(
floor
u
675
))
(
*
512
(
floor
h
675
))
(
floor
u
675
))
;; (2^16 h +l) mod (60*60*24)
;; (2^16 h +l) mod (60*60*24)
(
+
(
*
(
mod
u
675
)
128
)
(
mod
l
128
)))))
(
+
(
*
(
mod
u
675
)
128
)
(
mod
l
128
)))))
(
defun
calendar-time-from-absolute
(
abs-date
s
)
(
defun
calendar-time-from-absolute
(
abs-date
s
)
"Time of absolute date ABS-DATE, S seconds after midnight.
"Time of absolute date ABS-DATE, S seconds after midnight.
...
@@ -143,12 +143,12 @@ midnight UTC on absolute date ABS-DATE."
...
@@ -143,12 +143,12 @@ midnight UTC on absolute date ABS-DATE."
"Return the time of the next time zone transition after TIME.
"Return the time of the next time zone transition after TIME.
Both TIME and the result are acceptable arguments to `current-time-zone'.
Both TIME and the result are acceptable arguments to `current-time-zone'.
Return nil if no such transition can be found."
Return nil if no such transition can be found."
(
let*
((
base
65536
)
;; 2^16 = base of current-time output
(
let*
((
base
65536
)
;; 2^16 = base of current-time output
(
quarter-multiple
120
)
;; approx = (seconds per quarter year) / base
(
quarter-multiple
120
)
;; approx = (seconds per quarter year) / base
(
time-zone
(
current-time-zone
time
))
(
time-zone
(
current-time-zone
time
))
(
time-utc-diff
(
car
time-zone
))
(
time-utc-diff
(
car
time-zone
))
hi
hi
hi-zone
hi-zone
(
hi-utc-diff
time-utc-diff
)
(
hi-utc-diff
time-utc-diff
)
(
quarters
'
(
2
1
3
)))
(
quarters
'
(
2
1
3
)))
;; Heuristic: probe the time zone offset in the next three calendar
;; Heuristic: probe the time zone offset in the next three calendar
...
@@ -166,21 +166,21 @@ Return nil if no such transition can be found."
...
@@ -166,21 +166,21 @@ Return nil if no such transition can be found."
;; Set LO to TIME, and then binary search to increase LO and decrease HI
;; Set LO to TIME, and then binary search to increase LO and decrease HI
;; until LO is just before and HI is just after the time zone transition.
;; until LO is just before and HI is just after the time zone transition.
(
let*
((
tail
(
cdr
time
))
(
let*
((
tail
(
cdr
time
))
(
lo
(
cons
(
car
time
)
(
if
(
numberp
tail
)
tail
(
car
tail
))))
(
lo
(
cons
(
car
time
)
(
if
(
numberp
tail
)
tail
(
car
tail
))))
probe
)
probe
)
(
while
(
while
;; Set PROBE to halfway between LO and HI, rounding down.
;; Set PROBE to halfway between LO and HI, rounding down.
;; If PROBE equals LO, we are done.
;; If PROBE equals LO, we are done.
(
let*
((
lsum
(
+
(
cdr
lo
)
(
cdr
hi
)))
(
let*
((
lsum
(
+
(
cdr
lo
)
(
cdr
hi
)))
(
hsum
(
+
(
car
lo
)
(
car
hi
)
(
/
lsum
base
)))
(
hsum
(
+
(
car
lo
)
(
car
hi
)
(
/
lsum
base
)))
(
hsumodd
(
logand
1
hsum
)))
(
hsumodd
(
logand
1
hsum
)))
(
setq
probe
(
cons
(
/
(
-
hsum
hsumodd
)
2
)
(
setq
probe
(
cons
(
/
(
-
hsum
hsumodd
)
2
)
(
/
(
+
(
*
hsumodd
base
)
(
%
lsum
base
))
2
)))
(
/
(
+
(
*
hsumodd
base
)
(
%
lsum
base
))
2
)))
(
not
(
equal
lo
probe
)))
(
not
(
equal
lo
probe
)))
;; Set either LO or HI to PROBE, depending on probe results.
;; Set either LO or HI to PROBE, depending on probe results.
(
if
(
eq
(
car
(
current-time-zone
probe
))
hi-utc-diff
)
(
if
(
eq
(
car
(
current-time-zone
probe
))
hi-utc-diff
)
(
setq
hi
probe
)
(
setq
hi
probe
)
(
setq
lo
probe
)))
(
setq
lo
probe
)))
hi
))))
hi
))))
(
defun
calendar-time-zone-daylight-rules
(
abs-date
utc-diff
)
(
defun
calendar-time-zone-daylight-rules
(
abs-date
utc-diff
)
...
@@ -188,69 +188,70 @@ Return nil if no such transition can be found."
...
@@ -188,69 +188,70 @@ Return nil if no such transition can be found."
ABS-DATE must specify a day that contains a daylight saving transition.
ABS-DATE must specify a day that contains a daylight saving transition.
The result has the proper form for `calendar-daylight-savings-starts'."
The result has the proper form for `calendar-daylight-savings-starts'."
(
let*
((
date
(
calendar-gregorian-from-absolute
abs-date
))
(
let*
((
date
(
calendar-gregorian-from-absolute
abs-date
))
(
weekday
(
%
abs-date
7
))
(
weekday
(
%
abs-date
7
))
(
m
(
extract-calendar-month
date
))
(
m
(
extract-calendar-month
date
))
(
d
(
extract-calendar-day
date
))
(
d
(
extract-calendar-day
date
))
(
y
(
extract-calendar-year
date
))
(
y
(
extract-calendar-year
date
))
(
last
(
calendar-last-day-of-month
m
y
))
(
last
(
calendar-last-day-of-month
m
y
))
(
candidate-rules
(
candidate-rules
(
append
(
append
;; Day D of month M.
;; Day D of month M.
(
list
(
list
'list
m
d
'year
))
(
list
(
list
'list
m
d
'year
))
;; The first WEEKDAY of month M.
;; The first WEEKDAY of month M.
(
if
(
<
d
8
)
(
if
(
<
d
8
)
(
list
(
list
'calendar-nth-named-day
1
weekday
m
'year
)))
(
list
(
list
'calendar-nth-named-day
1
weekday
m
'year
)))
;; The last WEEKDAY of month M.
;; The last WEEKDAY of month M.
(
if
(
>
d
(
-
last
7
))
(
if
(
>
d
(
-
last
7
))
(
list
(
list
'calendar-nth-named-day
-1
weekday
m
'year
)))
(
list
(
list
'calendar-nth-named-day
-1
weekday
m
'year
)))
;; The first WEEKDAY after day J of month M, for D-6 < J <= D.
;; The first WEEKDAY after day J of month M, for D-6 < J <= D.
(
let
(
l
)
(
let
(
l
)
(
calendar-for-loop
j
from
(
max
2
(
-
d
6
))
to
(
min
d
(
-
last
8
))
do
(
calendar-for-loop
j
from
(
max
2
(
-
d
6
))
to
(
min
d
(
-
last
8
))
do
(
setq
l
(
setq
l
(
cons
(
cons
(
list
'calendar-nth-named-day
1
weekday
m
'year
j
)
(
list
'calendar-nth-named-day
l
)))
1
weekday
m
'year
j
)
l
)
l
)))
;; 01-01 and 07-01 for this year's Persian calendar.
l
)
(
if
(
and
(
=
m
3
)
(
<=
20
d
)
(
<=
d
21
))
;; 01-01 and 07-01 for this year's Persian calendar.
'
((
calendar-gregorian-from-absolute
(
if
(
and
(
=
m
3
)
(
<=
20
d
)
(
<=
d
21
))
(
calendar-absolute-from-persian
'
((
calendar-gregorian-from-absolute
(
list
1
1
(
-
year
621
))))))
(
calendar-absolute-from-persian
(
if
(
and
(
=
m
9
)
(
<=
22
d
)
(
<=
d
23
))
(
list
1
1
(
-
year
621
))))))
'
((
calendar-gregorian-from-absolute
(
if
(
and
(
=
m
9
)
(
<=
22
d
)
(
<=
d
23
))
(
calendar-absolute-from-persian
'
((
calendar-gregorian-from-absolute
(
list
7
1
(
-
year
621
))))))))
(
calendar-absolute-from-persian
(
prevday-sec
(
-
-1
utc-diff
))
;; last sec of previous local day
(
list
7
1
(
-
year
621
))))))))
(
year
(
1+
y
)))
(
prevday-sec
(
-
-1
utc-diff
))
;; last sec of previous local day
(
year
(
1+
y
)))
;; Scan through the next few years until only one rule remains.
;; Scan through the next few years until only one rule remains.
(
while
(
while
(
let
((
rules
candidate-rules
)
(
let
((
rules
candidate-rules
)
new-rules
)
new-rules
)
(
while
(
while
(
let*
(
let*
((
rule
(
car
rules
))
((
rule
(
car
rules
))
(
date
(
date
;; The following is much faster than
;; The following is much faster than
;; (calendar-absolute-from-gregorian (eval rule)).
;; (calendar-absolute-from-gregorian (eval rule)).
(
cond
((
eq
(
car
rule
)
'calendar-nth-named-day
)
(
cond
((
eq
(
car
rule
)
'calendar-nth-named-day
)
(
eval
(
cons
'calendar-nth-named-absday
(
cdr
rule
))))
(
eval
(
cons
'calendar-nth-named-absday
(
cdr
rule
))))
((
eq
(
car
rule
)
'calendar-gregorian-from-absolute
)
((
eq
(
car
rule
)
'calendar-gregorian-from-absolute
)
(
eval
(
car
(
cdr
rule
))))
(
eval
(
car
(
cdr
rule
))))
(
t
(
let
((
g
(
eval
rule
)))
(
t
(
let
((
g
(
eval
rule
)))
(
calendar-absolute-from-gregorian
g
))))))
(
calendar-absolute-from-gregorian
g
))))))
(
or
(
equal
(
or
(
equal
(
current-time-zone
(
current-time-zone
(
calendar-time-from-absolute
date
prevday-sec
))
(
calendar-time-from-absolute
date
prevday-sec
))
(
current-time-zone
(
current-time-zone
(
calendar-time-from-absolute
(
1+
date
)
prevday-sec
)))
(
calendar-time-from-absolute
(
1+
date
)
prevday-sec
)))
(
setq
new-rules
(
cons
rule
new-rules
)))
(
setq
new-rules
(
cons
rule
new-rules
)))
(
setq
rules
(
cdr
rules
))))
(
setq
rules
(
cdr
rules
))))
;; If no rules remain, just use the first candidate rule;
;; If no rules remain, just use the first candidate rule;
;; it's wrong in general, but it's right for at least one year.
;; it's wrong in general, but it's right for at least one year.
(
setq
candidate-rules
(
if
new-rules
(
nreverse
new-rules
)
(
setq
candidate-rules
(
if
new-rules
(
nreverse
new-rules
)
(
list
(
car
candidate-rules
))))
(
list
(
car
candidate-rules
))))
(
setq
year
(
1+
year
))
(
setq
year
(
1+
year
))
(
cdr
candidate-rules
)))
(
cdr
candidate-rules
)))
(
car
candidate-rules
)))
(
car
candidate-rules
)))
;; TODO it might be better to extract this information directly from
;; TODO it might be better to extract this information directly from
...
@@ -414,7 +415,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
...
@@ -414,7 +415,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
(
cadr
(
calendar-dst-find-startend
year
))
(
cadr
(
calendar-dst-find-startend
year
))
(
nth
4
calendar-current-time-zone-cache
))))
(
nth
4
calendar-current-time-zone-cache
))))
(
if
expr
(
eval
expr
)))
(
if
expr
(
eval
expr
)))
;; New US rules commencing 2007.
ftp://elsie.nci.nih.gov/pub/.
;; New US rules commencing 2007.
ftp://elsie.nci.nih.gov/pub/.
(
and
(
not
(
zerop
calendar-daylight-time-offset
))
(
and
(
not
(
zerop
calendar-daylight-time-offset
))
(
calendar-nth-named-day
2
0
3
year
))))
(
calendar-nth-named-day
2
0
3
year
))))
...
@@ -425,7 +426,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
...
@@ -425,7 +426,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
(
nth
2
(
calendar-dst-find-startend
year
))
(
nth
2
(
calendar-dst-find-startend
year
))
(
nth
5
calendar-current-time-zone-cache
))))
(
nth
5
calendar-current-time-zone-cache
))))
(
if
expr
(
eval
expr
)))
(
if
expr
(
eval
expr
)))
;; New US rules commencing 2007.
ftp://elsie.nci.nih.gov/pub/.
;; New US rules commencing 2007.
ftp://elsie.nci.nih.gov/pub/.
(
and
(
not
(
zerop
calendar-daylight-time-offset
))
(
and
(
not
(
zerop
calendar-daylight-time-offset
))
(
calendar-nth-named-day
1
0
11
year
))))
(
calendar-nth-named-day
1
0
11
year
))))
...
@@ -469,12 +470,12 @@ Conversion to daylight saving time is done according to
...
@@ -469,12 +470,12 @@ Conversion to daylight saving time is done according to
`calendar-daylight-savings-offset'."
`calendar-daylight-savings-offset'."
(
let*
((
rounded-abs-date
(
+
(
calendar-absolute-from-gregorian
date
)
(
let*
((
rounded-abs-date
(
+
(
calendar-absolute-from-gregorian
date
)
(
/
(
round
(
*
60
time
))
60.0
24.0
)))
(
/
(
round
(
*
60
time
))
60.0
24.0
)))
(
dst
(
dst-in-effect
rounded-abs-date
))
(
dst
(
dst-in-effect
rounded-abs-date
))
(
time-zone
(
if
dst
(
time-zone
(
if
dst
calendar-daylight-time-zone-name
calendar-daylight-time-zone-name
calendar-standard-time-zone-name
))
calendar-standard-time-zone-name
))
(
time
(
+
rounded-abs-date
(
time
(
+
rounded-abs-date
(
if
dst
(
/
calendar-daylight-time-offset
24.0
60.0
)
0
))))
(
if
dst
(
/
calendar-daylight-time-offset
24.0
60.0
)
0
))))
(
list
(
calendar-gregorian-from-absolute
(
truncate
time
))
(
list
(
calendar-gregorian-from-absolute
(
truncate
time
))
(
*
24.0
(
-
time
(
truncate
time
)))
(
*
24.0
(
-
time
(
truncate
time
)))
...
...
lisp/calendar/cal-french.el
View file @
71ea27ee
...
@@ -44,10 +44,10 @@
...
@@ -44,10 +44,10 @@
(
defun
french-calendar-accents
()
(
defun
french-calendar-accents
()
"True if diacritical marks are available."
"True if diacritical marks are available."
(
and
(
or
window-system
(
and
(
or
window-system
(
terminal-coding-system
))
(
terminal-coding-system
))
(
or
enable-multibyte-characters
(
or
enable-multibyte-characters
(
and
(
char-table-p
standard-display-table
)
(
and
(
char-table-p
standard-display-table
)
(
equal
(
aref
standard-display-table
161
)
[161]
)))))
(
equal
(
aref
standard-display-table
161
)
[161]
)))))
(
defconst
french-calendar-epoch
(
calendar-absolute-from-gregorian
'
(
9
22
1792
))
(
defconst
french-calendar-epoch
(
calendar-absolute-from-gregorian
'
(
9
22
1792
))
"Absolute date of start of French Revolutionary calendar = September 22, 1792."
)
"Absolute date of start of French Revolutionary calendar = September 22, 1792."
)
...
@@ -145,20 +145,22 @@ The absolute date is the number of days elapsed since the
...
@@ -145,20 +145,22 @@ The absolute date is the number of days elapsed since the
(
year
; search forward from the approximation
(
year
; search forward from the approximation
(
+
approx
(
+
approx
(
calendar-sum
y
approx
(
calendar-sum
y
approx
(
>=
date
(
calendar-absolute-from-french
(
list
1
1
(
1+
y
))))
(
>=
date
(
calendar-absolute-from-french
1
)))
(
list
1
1
(
1+
y
))))
1
)))
(
month
; search forward from Vendemiaire
(
month
; search forward from Vendemiaire
(
1+
(
calendar-sum
m
1
(
1+
(
calendar-sum
m
1
(
>
date
(
>
date
(
calendar-absolute-from-french
(
calendar-absolute-from-french
(
list
m
(
list
m
(
french-calendar-last-day-of-month
m
year
)
(
french-calendar-last-day-of-month
year
)))
m
year
)
1
)))
year
)))
1
)))
(
day
; calculate the day by subtraction
(
day
; calculate the day by subtraction
(
-
date
(
-
date
(
1-
(
calendar-absolute-from-french
(
list
month
1
year
))))))
(
1-
(
calendar-absolute-from-french
(
list
month
1
year
))))))
(
list
month
day
year
))))
(
list
month
day
year
))))
;;;###cal-autoload
;;;###cal-autoload
(
defun
calendar-french-date-string
(
&optional
date
)
(
defun
calendar-french-date-string
(
&optional
date
)
...
@@ -201,47 +203,47 @@ Defaults to today's date if DATE is not given."
...
@@ -201,47 +203,47 @@ Defaults to today's date if DATE is not given."
Echo French Revolutionary date unless NOECHO is t."
Echo French Revolutionary date unless NOECHO is t."
(
interactive
(
interactive
(
let
((
accents
(
french-calendar-accents
))
(
let
((
accents
(
french-calendar-accents
))
(
months
(
french-calendar-month-name-array
))
(
months
(
french-calendar-month-name-array
))
(
special-days
(
french-calendar-special-days-array
)))
(
special-days
(
french-calendar-special-days-array
)))
(
let*
((
year
(
let*
((
year
(
progn
(
progn
(
calendar-read
(
calendar-read
(
if
accents
(
if
accents
"Anne de la Rvolution (>0): "
"Anne de la Rvolution (>0): "
"Anne'e de la Re'volution (>0): "
)
"Anne'e de la Re'volution (>0): "
)
(
lambda
(
x
)
(
>
x
0
))
(
lambda
(
x
)
(
>
x
0
))
(
int-to-string
(
int-to-string
(
extract-calendar-year
(
extract-calendar-year
(
calendar-french-from-absolute
(
calendar-french-from-absolute
(
calendar-absolute-from-gregorian
(
calendar-absolute-from-gregorian
(
calendar-current-date
))))))))