Formatting changes only.
[emacs.git] / lisp / calendar / cal-persia.el
blob0ad05e99c860a16567e8db80b3beac60adc03b32
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>
8 ;; Keywords: calendar
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)
16 ;; any later version.
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.
28 ;;; Commentary:
30 ;; This collection of functions implements the features of calendar.el and
31 ;; diary.el that deal with the Persian calendar.
33 ;;; Code:
35 (require 'cal-julian)
37 (defconst persian-calendar-month-name-array
38 ["Farvardin" "Ordibehest" "Xordad" "Tir" "Mordad" "Sahrivar" "Mehr" "Aban"
39 "Azar" "Dey" "Bahman" "Esfand"])
41 (defconst persian-calendar-epoch (calendar-absolute-from-julian '(3 19 622))
42 "Absolute date of start of Persian calendar = March 19, 622 A.D. (Julian).")
44 (defun persian-calendar-leap-year-p (year)
45 "True if YEAR is a leap year on the Persian calendar."
46 (< (mod (* (mod (mod (if (<= 0 year)
47 (+ year 2346) ; no year zero
48 (+ year 2347))
49 2820)
50 768)
51 683)
52 2820)
53 683))
55 (defun persian-calendar-last-day-of-month (month year)
56 "Return last day of MONTH, YEAR on the Persian calendar."
57 (cond
58 ((< month 7) 31)
59 ((or (< month 12) (persian-calendar-leap-year-p year)) 30)
60 (t 29)))
62 (defun calendar-absolute-from-persian (date)
63 "Compute absolute date from Persian date DATE.
64 The absolute date is the number of days elapsed since the (imaginary)
65 Gregorian date Sunday, December 31, 1 BC."
66 (let ((month (extract-calendar-month date))
67 (day (extract-calendar-day date))
68 (year (extract-calendar-year date)))
69 (if (< year 0)
70 (+ (calendar-absolute-from-persian
71 (list month day (1+ (mod year 2820))))
72 (* 1029983 (floor year 2820)))
73 (+ (1- persian-calendar-epoch); Days before epoch
74 (* 365 (1- year)) ; Days in prior years.
75 (* 683 ; Leap days in prior 2820-year cycles
76 (floor (+ year 2345) 2820))
77 (* 186 ; Leap days in prior 768 year cycles
78 (floor (mod (+ year 2345) 2820) 768))
79 (floor; Leap years in current 768 or 516 year cycle
80 (* 683 (mod (mod (+ year 2345) 2820) 768))
81 2820)
82 -568 ; Leap years in Persian years -2345...-1
83 (calendar-sum ; Days in prior months this year.
84 m 1 (< m month)
85 (persian-calendar-last-day-of-month m year))
86 day)))) ; Days so far this month.
88 (defun calendar-persian-year-from-absolute (date)
89 "Persian year corresponding to the absolute DATE."
90 (let* ((d0 ; Prior days since start of 2820 cycles
91 (- date (calendar-absolute-from-persian (list 1 1 -2345))))
92 (n2820 ; Completed 2820-year cycles
93 (floor d0 1029983))
94 (d1 ; Prior days not in n2820
95 (mod d0 1029983))
96 (n768 ; 768-year cycles not in n2820
97 (floor d1 280506))
98 (d2 ; Prior days not in n2820 or n768
99 (mod d1 280506))
100 (n1 ; Years not in n2820 or n768
101 ; we want is
102 ; (floor (+ (* 2820 d2) (* 2820 366)) 1029983))
103 ; but that causes overflow, so we use
104 (let ((a (floor d2 366)); we use 366 as the divisor because
105 ; (2820*366 mod 1029983) is small
106 (b (mod d2 366)))
107 (+ 1 a (floor (+ (* 2137 a) (* 2820 b) 2137) 1029983))))
108 (year (+ (* 2820 n2820); Complete 2820 year cycles
109 (* 768 n768) ; Complete 768 year cycles
110 (if ; Remaining years
111 ; Last day of 2820 year cycle
112 (= d1 1029617)
113 (1- n1)
115 -2345))) ; Years before year 1
116 (if (< year 1)
117 (1- year); No year zero
118 year)))
120 (defun calendar-persian-from-absolute (date)
121 "Compute the Persian equivalent for absolute date DATE.
122 The result is a list of the form (MONTH DAY YEAR).
123 The absolute date is the number of days elapsed since the imaginary
124 Gregorian date Sunday, December 31, 1 BC."
125 (let* ((year (calendar-persian-year-from-absolute date))
126 (month ; Search forward from Farvardin
127 (1+ (calendar-sum m 1
128 (> date
129 (calendar-absolute-from-persian
130 (list
132 (persian-calendar-last-day-of-month m year)
133 year)))
134 1)))
135 (day ; Calculate the day by subtraction
136 (- date (1- (calendar-absolute-from-persian
137 (list month 1 year))))))
138 (list month day year)))
140 ;;;###autoload
141 (defun calendar-persian-date-string (&optional date)
142 "String of Persian date of Gregorian DATE.
143 Defaults to today's date if DATE is not given."
144 (let* ((persian-date (calendar-persian-from-absolute
145 (calendar-absolute-from-gregorian
146 (or date (calendar-current-date)))))
147 (y (extract-calendar-year persian-date))
148 (m (extract-calendar-month persian-date)))
149 (let ((monthname (aref persian-calendar-month-name-array (1- m)))
150 (day (int-to-string (extract-calendar-day persian-date)))
151 (dayname nil)
152 (month (int-to-string m))
153 (year (int-to-string y)))
154 (mapconcat 'eval calendar-date-display-form ""))))
156 ;;;###autoload
157 (defun calendar-print-persian-date ()
158 "Show the Persian calendar equivalent of the selected date."
159 (interactive)
160 (message "Persian date: %s"
161 (calendar-persian-date-string (calendar-cursor-to-date t))))
163 ;;;###autoload
164 (defun calendar-goto-persian-date (date &optional noecho)
165 "Move cursor to Persian date DATE.
166 Echo Persian date unless NOECHO is t."
167 (interactive (persian-prompt-for-date))
168 (calendar-goto-date (calendar-gregorian-from-absolute
169 (calendar-absolute-from-persian date)))
170 (or noecho (calendar-print-persian-date)))
172 (defun persian-prompt-for-date ()
173 "Ask for a Persian date."
174 (let* ((today (calendar-current-date))
175 (year (calendar-read
176 "Persian calendar year (not 0): "
177 (lambda (x) (not (zerop x)))
178 (int-to-string
179 (extract-calendar-year
180 (calendar-persian-from-absolute
181 (calendar-absolute-from-gregorian today))))))
182 (completion-ignore-case t)
183 (month (cdr (assoc
184 (completing-read
185 "Persian calendar month name: "
186 (mapcar 'list
187 (append persian-calendar-month-name-array nil))
188 nil t)
189 (calendar-make-alist persian-calendar-month-name-array
190 1))))
191 (last (persian-calendar-last-day-of-month month year))
192 (day (calendar-read
193 (format "Persian calendar day (1-%d): " last)
194 (lambda (x) (and (< 0 x) (<= x last))))))
195 (list (list month day year))))
197 (defvar date)
199 ;; To be called from list-sexp-diary-entries, where DATE is bound.
200 (defun diary-persian-date ()
201 "Persian calendar equivalent of date diary entry."
202 (format "Persian date: %s" (calendar-persian-date-string date)))
204 (provide 'cal-persia)
206 ;; Local Variables:
207 ;; generated-autoload-file: "cal-loaddefs.el"
208 ;; End:
210 ;; arch-tag: 2832383c-e4b4-4dc2-8ee9-cfbdd53e5e2d
211 ;;; cal-persia.el ends here