1 ;;; cal-persia.el --- calendar functions for the Persian calendar
3 ;; Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
4 ;; 2008 Free Software Foundation, Inc.
6 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
7 ;; Maintainer: Glenn Morris <rgm@gnu.org>
9 ;; Human-Keywords: Persian calendar, calendar, diary
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 3, or (at your option)
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26 ;; Boston, MA 02110-1301, USA.
36 (defconst persian-calendar-month-name-array
37 ["Farvardin" "Ordibehest" "Xordad" "Tir" "Mordad" "Sahrivar" "Mehr" "Aban"
38 "Azar" "Dey" "Bahman" "Esfand"]
39 "Names of the months in the Persian calendar.")
42 (autoload 'calendar-absolute-from-julian
"cal-julian"))
44 (defconst persian-calendar-epoch
45 (eval-when-compile (calendar-absolute-from-julian '(3 19 622)))
46 "Absolute date of start of Persian calendar = March 19, 622 AD (Julian).")
48 (defun persian-calendar-leap-year-p (year)
49 "True if YEAR is a leap year on the Persian calendar."
50 (< (mod (* (mod (mod (if (<= 0 year
)
51 (+ year
2346) ; no year zero
59 (defun persian-calendar-last-day-of-month (month year
)
60 "Return last day of MONTH, YEAR on the Persian calendar."
63 ((or (< month
12) (persian-calendar-leap-year-p year
)) 30)
66 (defun calendar-absolute-from-persian (date)
67 "Compute absolute date from Persian date DATE.
68 The absolute date is the number of days elapsed since the (imaginary)
69 Gregorian date Sunday, December 31, 1 BC."
70 (let ((month (extract-calendar-month date
))
71 (day (extract-calendar-day date
))
72 (year (extract-calendar-year date
)))
74 (+ (calendar-absolute-from-persian
75 (list month day
(1+ (mod year
2820))))
76 (* 1029983 (floor year
2820)))
77 (+ (1- persian-calendar-epoch
) ; days before epoch
78 (* 365 (1- year
)) ; days in prior years
79 (* 683 ; leap days in prior 2820-year cycles
80 (floor (+ year
2345) 2820))
81 (* 186 ; leap days in prior 768 year cycles
82 (floor (mod (+ year
2345) 2820) 768))
83 (floor ; leap years in current 768 or 516 year cycle
84 (* 683 (mod (mod (+ year
2345) 2820) 768))
86 -
568 ; leap years in Persian years -2345...-1
87 (calendar-sum ; days in prior months this year
89 (persian-calendar-last-day-of-month m year
))
90 day
)))) ; days so far this month
92 (defun calendar-persian-year-from-absolute (date)
93 "Persian year corresponding to the absolute DATE."
94 (let* ((d0 ; prior days since start of 2820 cycles
95 (- date
(calendar-absolute-from-persian (list 1 1 -
2345))))
96 (n2820 ; completed 2820-year cycles
98 (d1 ; prior days not in n2820
100 (n768 ; 768-year cycles not in n2820
102 (d2 ; prior days not in n2820 or n768
104 (n1 ; years not in n2820 or n768
106 ;; (floor (+ (* 2820 d2) (* 2820 366)) 1029983))
107 ;; but that causes overflow, so use the following.
108 ;; Use 366 as the divisor because (2820*366 mod 1029983) is small.
109 (let ((a (floor d2
366))
111 (+ 1 a
(floor (+ (* 2137 a
) (* 2820 b
) 2137) 1029983))))
112 (year (+ (* 2820 n2820
) ; complete 2820 year cycles
113 (* 768 n768
) ; complete 768 year cycles
115 (if (= d1
1029617) ; last day of 2820 year cycle
118 -
2345))) ; years before year 1
120 (1- year
) ; no year zero
123 (defun calendar-persian-from-absolute (date)
124 "Compute the Persian equivalent for absolute date DATE.
125 The result is a list of the form (MONTH DAY YEAR).
126 The absolute date is the number of days elapsed since the imaginary
127 Gregorian date Sunday, December 31, 1 BC."
128 (let* ((year (calendar-persian-year-from-absolute date
))
129 (month ; search forward from Farvardin
130 (1+ (calendar-sum m
1
132 (calendar-absolute-from-persian
135 (persian-calendar-last-day-of-month m year
)
138 (day ; calculate the day by subtraction
139 (- date
(1- (calendar-absolute-from-persian
140 (list month
1 year
))))))
141 (list month day year
)))
144 (defun calendar-persian-date-string (&optional date
)
145 "String of Persian date of Gregorian DATE, default today."
146 (let* ((persian-date (calendar-persian-from-absolute
147 (calendar-absolute-from-gregorian
148 (or date
(calendar-current-date)))))
149 (y (extract-calendar-year persian-date
))
150 (m (extract-calendar-month persian-date
))
151 (monthname (aref persian-calendar-month-name-array
(1- m
)))
152 (day (int-to-string (extract-calendar-day persian-date
)))
153 (year (int-to-string y
))
154 (month (int-to-string m
))
156 (mapconcat 'eval calendar-date-display-form
"")))
159 (defun calendar-print-persian-date ()
160 "Show the Persian calendar equivalent of the selected date."
162 (message "Persian date: %s"
163 (calendar-persian-date-string (calendar-cursor-to-date t
))))
165 (defun calendar-persian-read-date ()
166 "Interactively read the arguments for a Persian date command.
167 Reads a year, month, and day."
168 (let* ((year (calendar-read
169 "Persian calendar year (not 0): "
170 (lambda (x) (not (zerop x
)))
172 (extract-calendar-year
173 (calendar-persian-from-absolute
174 (calendar-absolute-from-gregorian
175 (calendar-current-date)))))))
176 (completion-ignore-case t
)
179 "Persian calendar month name: "
181 (append persian-calendar-month-name-array nil
))
183 (calendar-make-alist persian-calendar-month-name-array
185 (last (persian-calendar-last-day-of-month month year
))
187 (format "Persian calendar day (1-%d): " last
)
188 (lambda (x) (and (< 0 x
) (<= x last
))))))
189 (list (list month day year
))))
191 (define-obsolete-function-alias
192 'persian-prompt-for-date
'calendar-persian-read-date
"23.1")
195 (defun calendar-goto-persian-date (date &optional noecho
)
196 "Move cursor to Persian date DATE.
197 Echo Persian date unless NOECHO is non-nil."
198 (interactive (calendar-persian-read-date))
199 (calendar-goto-date (calendar-gregorian-from-absolute
200 (calendar-absolute-from-persian date
)))
201 (or noecho
(calendar-print-persian-date)))
205 ;; To be called from list-sexp-diary-entries, where DATE is bound.
207 (defun diary-persian-date ()
208 "Persian calendar equivalent of date diary entry."
209 (format "Persian date: %s" (calendar-persian-date-string date
)))
211 (provide 'cal-persia
)
213 ;; arch-tag: 2832383c-e4b4-4dc2-8ee9-cfbdd53e5e2d
214 ;;; cal-persia.el ends here