lisp/calendar/cal-persia.el

1 ;;; cal-persia.el --- calendar functions for the Persian calendar
8 ;; Keywords: calendar
9 ;; Human-Keywords: Persian calendar, calendar, diary
30 ;; This collection of functions implements the features of calendar.el and
31 ;; diary.el that deal with the Persian calendar.
39 (defvar persian-calendar-month-name-array
43 (defvar persian-calendar-epoch (calendar-absolute-from-julian '(3 19 622))
44   "Absolute date of start of Persian calendar = March 19, 622 A.D. (Julian).")
46 (defun persian-calendar-leap-year-p (year)
47   "True if YEAR is a leap year on the Persian calendar."
58 (defun persian-calendar-last-day-of-month (month year)
59   "Return last day of MONTH, YEAR on the Persian calendar."
61    ((< month 7) 31)
62    ((or (< month 12) (persian-calendar-leap-year-p year)) 30)
65 (defun calendar-absolute-from-persian (date)
69   (let ((month (extract-calendar-month date))
70         (day (extract-calendar-day date))
71         (year (extract-calendar-year date)))
73         (+ (calendar-absolute-from-persian
74             (list month day (1+ (mod year 2820))))
76       (+ (1- persian-calendar-epoch); Days before epoch
86          (calendar-sum ; Days in prior months this year.
87           m 1 (< m month)
88           (persian-calendar-last-day-of-month m year))
89          day))))        ; Days so far this month.
91 (defun calendar-persian-year-from-absolute (date)
94           (- date (calendar-absolute-from-persian (list 1 1 -2345))))
123 (defun calendar-persian-from-absolute (date)
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)
139           (- date (1- (calendar-absolute-from-persian
140                        (list month 1 year))))))
141     (list month day year)))
143 (defun calendar-persian-date-string (&optional date)
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     (let ((monthname (aref persian-calendar-month-name-array (1- m)))
152           (day (int-to-string (extract-calendar-day persian-date)))
154           (month (int-to-string m))
156       (mapconcat 'eval calendar-date-display-form ""))))
158 (defun calendar-print-persian-date ()
159   "Show the Persian calendar equivalent of the selected date."
162            (calendar-persian-date-string (calendar-cursor-to-date t))))
164 (defun calendar-goto-persian-date (date &optional noecho)
168   (calendar-goto-date (calendar-gregorian-from-absolute
169                        (calendar-absolute-from-persian date)))
170   (or noecho (calendar-print-persian-date)))
174   (let* ((today (calendar-current-date))
175          (year (calendar-read
176                 "Persian calendar year (not 0): "
179                  (extract-calendar-year
180                   (calendar-persian-from-absolute
181                    (calendar-absolute-from-gregorian today))))))
183          (month (cdr (assoc
185                         "Persian calendar month name: "
187                                 (append persian-calendar-month-name-array nil))
189                       (calendar-make-alist persian-calendar-month-name-array
191          (last (persian-calendar-last-day-of-month month year))
192          (day (calendar-read
193                (format "Persian calendar day (1-%d): " last)
195     (list (list month day year))))
198   "Persian calendar equivalent of date diary entry."
199   (format "Persian date: %s" (calendar-persian-date-string date)))