Mercurial > emacs
comparison lisp/calendar/cal-persia.el @ 93644:05a344ce267f
Update for cal-julian name changes.
(calendar-persian-month-name-array): Rename persian-calendar-month-name-array.
Update callers.
(calendar-persian-epoch): Rename persian-calendar-epoch. Update callers.
(calendar-persian-leap-year-p): Rename persian-calendar-leap-year-p.
Update callers.
(calendar-persian-last-day-of-month): Rename persian-calendar-last-day-of-month.
Update callers.
(calendar-persian-to-absolute): Rename calendar-absolute-from-persian.
Update callers, keep old name as alias.
(calendar-persian-print-date): Rename calendar-print-persian-date.
Update callers, keep old name as alias.
(calendar-persian-goto-date): Rename calendar-goto-persian-date.
Keep old name as alias.
author | Glenn Morris <rgm@gnu.org> |
---|---|
date | Fri, 04 Apr 2008 07:22:05 +0000 |
parents | 426872139a89 |
children | df192d334c0a |
comparison
equal
deleted
inserted
replaced
93643:e6a9bdb70ed7 | 93644:05a344ce267f |
---|---|
31 | 31 |
32 ;;; Code: | 32 ;;; Code: |
33 | 33 |
34 (require 'calendar) | 34 (require 'calendar) |
35 | 35 |
36 (defconst persian-calendar-month-name-array | 36 (defconst calendar-persian-month-name-array |
37 ["Farvardin" "Ordibehest" "Xordad" "Tir" "Mordad" "Sahrivar" "Mehr" "Aban" | 37 ["Farvardin" "Ordibehest" "Xordad" "Tir" "Mordad" "Sahrivar" "Mehr" "Aban" |
38 "Azar" "Dey" "Bahman" "Esfand"] | 38 "Azar" "Dey" "Bahman" "Esfand"] |
39 "Names of the months in the Persian calendar.") | 39 "Names of the months in the Persian calendar.") |
40 | 40 |
41 (eval-and-compile | 41 (eval-and-compile |
42 (autoload 'calendar-absolute-from-julian "cal-julian")) | 42 (autoload 'calendar-julian-to-absolute "cal-julian")) |
43 | 43 |
44 (defconst persian-calendar-epoch | 44 (defconst calendar-persian-epoch |
45 (eval-when-compile (calendar-absolute-from-julian '(3 19 622))) | 45 (eval-when-compile (calendar-julian-to-absolute '(3 19 622))) |
46 "Absolute date of start of Persian calendar = March 19, 622 AD (Julian).") | 46 "Absolute date of start of Persian calendar = March 19, 622 AD (Julian).") |
47 | 47 |
48 (defun persian-calendar-leap-year-p (year) | 48 (defun calendar-persian-leap-year-p (year) |
49 "True if YEAR is a leap year on the Persian calendar." | 49 "True if YEAR is a leap year on the Persian calendar." |
50 (< (mod (* (mod (mod (if (<= 0 year) | 50 (< (mod (* (mod (mod (if (<= 0 year) |
51 (+ year 2346) ; no year zero | 51 (+ year 2346) ; no year zero |
52 (+ year 2347)) | 52 (+ year 2347)) |
53 2820) | 53 2820) |
54 768) | 54 768) |
55 683) | 55 683) |
56 2820) | 56 2820) |
57 683)) | 57 683)) |
58 | 58 |
59 (defun persian-calendar-last-day-of-month (month year) | 59 (defun calendar-persian-last-day-of-month (month year) |
60 "Return last day of MONTH, YEAR on the Persian calendar." | 60 "Return last day of MONTH, YEAR on the Persian calendar." |
61 (cond | 61 (cond |
62 ((< month 7) 31) | 62 ((< month 7) 31) |
63 ((or (< month 12) (persian-calendar-leap-year-p year)) 30) | 63 ((or (< month 12) (calendar-persian-leap-year-p year)) 30) |
64 (t 29))) | 64 (t 29))) |
65 | 65 |
66 (defun calendar-absolute-from-persian (date) | 66 (defun calendar-persian-to-absolute (date) |
67 "Compute absolute date from Persian date DATE. | 67 "Compute absolute date from Persian date DATE. |
68 The absolute date is the number of days elapsed since the (imaginary) | 68 The absolute date is the number of days elapsed since the (imaginary) |
69 Gregorian date Sunday, December 31, 1 BC." | 69 Gregorian date Sunday, December 31, 1 BC." |
70 (let ((month (extract-calendar-month date)) | 70 (let ((month (extract-calendar-month date)) |
71 (day (extract-calendar-day date)) | 71 (day (extract-calendar-day date)) |
72 (year (extract-calendar-year date))) | 72 (year (extract-calendar-year date))) |
73 (if (< year 0) | 73 (if (< year 0) |
74 (+ (calendar-absolute-from-persian | 74 (+ (calendar-persian-to-absolute |
75 (list month day (1+ (mod year 2820)))) | 75 (list month day (1+ (mod year 2820)))) |
76 (* 1029983 (floor year 2820))) | 76 (* 1029983 (floor year 2820))) |
77 (+ (1- persian-calendar-epoch) ; days before epoch | 77 (+ (1- calendar-persian-epoch) ; days before epoch |
78 (* 365 (1- year)) ; days in prior years | 78 (* 365 (1- year)) ; days in prior years |
79 (* 683 ; leap days in prior 2820-year cycles | 79 (* 683 ; leap days in prior 2820-year cycles |
80 (floor (+ year 2345) 2820)) | 80 (floor (+ year 2345) 2820)) |
81 (* 186 ; leap days in prior 768 year cycles | 81 (* 186 ; leap days in prior 768 year cycles |
82 (floor (mod (+ year 2345) 2820) 768)) | 82 (floor (mod (+ year 2345) 2820) 768)) |
84 (* 683 (mod (mod (+ year 2345) 2820) 768)) | 84 (* 683 (mod (mod (+ year 2345) 2820) 768)) |
85 2820) | 85 2820) |
86 -568 ; leap years in Persian years -2345...-1 | 86 -568 ; leap years in Persian years -2345...-1 |
87 (calendar-sum ; days in prior months this year | 87 (calendar-sum ; days in prior months this year |
88 m 1 (< m month) | 88 m 1 (< m month) |
89 (persian-calendar-last-day-of-month m year)) | 89 (calendar-persian-last-day-of-month m year)) |
90 day)))) ; days so far this month | 90 day)))) ; days so far this month |
91 | |
92 (define-obsolete-function-alias 'calendar-absolute-from-persian | |
93 'calendar-persian-to-absolute "23.1") | |
91 | 94 |
92 (defun calendar-persian-year-from-absolute (date) | 95 (defun calendar-persian-year-from-absolute (date) |
93 "Persian year corresponding to the absolute DATE." | 96 "Persian year corresponding to the absolute DATE." |
94 (let* ((d0 ; prior days since start of 2820 cycles | 97 (let* ((d0 ; prior days since start of 2820 cycles |
95 (- date (calendar-absolute-from-persian (list 1 1 -2345)))) | 98 (- date (calendar-persian-to-absolute (list 1 1 -2345)))) |
96 (n2820 ; completed 2820-year cycles | 99 (n2820 ; completed 2820-year cycles |
97 (floor d0 1029983)) | 100 (floor d0 1029983)) |
98 (d1 ; prior days not in n2820 | 101 (d1 ; prior days not in n2820 |
99 (mod d0 1029983)) | 102 (mod d0 1029983)) |
100 (n768 ; 768-year cycles not in n2820 | 103 (n768 ; 768-year cycles not in n2820 |
127 Gregorian date Sunday, December 31, 1 BC." | 130 Gregorian date Sunday, December 31, 1 BC." |
128 (let* ((year (calendar-persian-year-from-absolute date)) | 131 (let* ((year (calendar-persian-year-from-absolute date)) |
129 (month ; search forward from Farvardin | 132 (month ; search forward from Farvardin |
130 (1+ (calendar-sum m 1 | 133 (1+ (calendar-sum m 1 |
131 (> date | 134 (> date |
132 (calendar-absolute-from-persian | 135 (calendar-persian-to-absolute |
133 (list | 136 (list |
134 m | 137 m |
135 (persian-calendar-last-day-of-month m year) | 138 (calendar-persian-last-day-of-month m year) |
136 year))) | 139 year))) |
137 1))) | 140 1))) |
138 (day ; calculate the day by subtraction | 141 (day ; calculate the day by subtraction |
139 (- date (1- (calendar-absolute-from-persian | 142 (- date (1- (calendar-persian-to-absolute |
140 (list month 1 year)))))) | 143 (list month 1 year)))))) |
141 (list month day year))) | 144 (list month day year))) |
142 | 145 |
143 ;;;###cal-autoload | 146 ;;;###cal-autoload |
144 (defun calendar-persian-date-string (&optional date) | 147 (defun calendar-persian-date-string (&optional date) |
146 (let* ((persian-date (calendar-persian-from-absolute | 149 (let* ((persian-date (calendar-persian-from-absolute |
147 (calendar-absolute-from-gregorian | 150 (calendar-absolute-from-gregorian |
148 (or date (calendar-current-date))))) | 151 (or date (calendar-current-date))))) |
149 (y (extract-calendar-year persian-date)) | 152 (y (extract-calendar-year persian-date)) |
150 (m (extract-calendar-month persian-date)) | 153 (m (extract-calendar-month persian-date)) |
151 (monthname (aref persian-calendar-month-name-array (1- m))) | 154 (monthname (aref calendar-persian-month-name-array (1- m))) |
152 (day (int-to-string (extract-calendar-day persian-date))) | 155 (day (int-to-string (extract-calendar-day persian-date))) |
153 (year (int-to-string y)) | 156 (year (int-to-string y)) |
154 (month (int-to-string m)) | 157 (month (int-to-string m)) |
155 dayname) | 158 dayname) |
156 (mapconcat 'eval calendar-date-display-form ""))) | 159 (mapconcat 'eval calendar-date-display-form ""))) |
157 | 160 |
158 ;;;###cal-autoload | 161 ;;;###cal-autoload |
159 (defun calendar-print-persian-date () | 162 (defun calendar-persian-print-date () |
160 "Show the Persian calendar equivalent of the selected date." | 163 "Show the Persian calendar equivalent of the selected date." |
161 (interactive) | 164 (interactive) |
162 (message "Persian date: %s" | 165 (message "Persian date: %s" |
163 (calendar-persian-date-string (calendar-cursor-to-date t)))) | 166 (calendar-persian-date-string (calendar-cursor-to-date t)))) |
167 | |
168 (define-obsolete-function-alias 'calendar-print-persian-date | |
169 'calendar-persian-print-date "23.1") | |
164 | 170 |
165 (defun calendar-persian-read-date () | 171 (defun calendar-persian-read-date () |
166 "Interactively read the arguments for a Persian date command. | 172 "Interactively read the arguments for a Persian date command. |
167 Reads a year, month, and day." | 173 Reads a year, month, and day." |
168 (let* ((year (calendar-read | 174 (let* ((year (calendar-read |
176 (completion-ignore-case t) | 182 (completion-ignore-case t) |
177 (month (cdr (assoc | 183 (month (cdr (assoc |
178 (completing-read | 184 (completing-read |
179 "Persian calendar month name: " | 185 "Persian calendar month name: " |
180 (mapcar 'list | 186 (mapcar 'list |
181 (append persian-calendar-month-name-array nil)) | 187 (append calendar-persian-month-name-array nil)) |
182 nil t) | 188 nil t) |
183 (calendar-make-alist persian-calendar-month-name-array | 189 (calendar-make-alist calendar-persian-month-name-array |
184 1)))) | 190 1)))) |
185 (last (persian-calendar-last-day-of-month month year)) | 191 (last (calendar-persian-last-day-of-month month year)) |
186 (day (calendar-read | 192 (day (calendar-read |
187 (format "Persian calendar day (1-%d): " last) | 193 (format "Persian calendar day (1-%d): " last) |
188 (lambda (x) (and (< 0 x) (<= x last)))))) | 194 (lambda (x) (and (< 0 x) (<= x last)))))) |
189 (list (list month day year)))) | 195 (list (list month day year)))) |
190 | 196 |
191 (define-obsolete-function-alias | 197 (define-obsolete-function-alias 'persian-prompt-for-date |
192 'persian-prompt-for-date 'calendar-persian-read-date "23.1") | 198 'calendar-persian-read-date "23.1") |
193 | 199 |
194 ;;;###cal-autoload | 200 ;;;###cal-autoload |
195 (defun calendar-goto-persian-date (date &optional noecho) | 201 (defun calendar-persian-goto-date (date &optional noecho) |
196 "Move cursor to Persian date DATE. | 202 "Move cursor to Persian date DATE. |
197 Echo Persian date unless NOECHO is non-nil." | 203 Echo Persian date unless NOECHO is non-nil." |
198 (interactive (calendar-persian-read-date)) | 204 (interactive (calendar-persian-read-date)) |
199 (calendar-goto-date (calendar-gregorian-from-absolute | 205 (calendar-goto-date (calendar-gregorian-from-absolute |
200 (calendar-absolute-from-persian date))) | 206 (calendar-persian-to-absolute date))) |
201 (or noecho (calendar-print-persian-date))) | 207 (or noecho (calendar-persian-print-date))) |
208 | |
209 (define-obsolete-function-alias 'calendar-goto-persian-date | |
210 'calendar-persian-goto-date "23.1") | |
202 | 211 |
203 (defvar date) | 212 (defvar date) |
204 | 213 |
205 ;; To be called from list-sexp-diary-entries, where DATE is bound. | 214 ;; To be called from list-sexp-diary-entries, where DATE is bound. |
206 ;;;###diary-autoload | 215 ;;;###diary-autoload |