(require 'cal-julian)
(defvar persian-calendar-month-name-array
["Farvardin" "Ordibehest" "Xordad" "Tir" "Mordad" "Sahrivar" "Mehr" "Aban"
"Azar" "Dey" "Bahman" "Esfand"])
(defvar persian-calendar-epoch (calendar-absolute-from-julian '(3 19 622))
"Absolute date of start of Persian calendar = March 19, 622 A.D. (Julian).")
(defun persian-calendar-leap-year-p (year)
"True if YEAR is a leap year on the Persian calendar."
(< (mod (* (mod (mod (if (<= 0 year)
(+ year 2346)
(+ year 2347))
2820)
768)
683)
2820)
683))
(defun persian-calendar-last-day-of-month (month year)
"Return last day of MONTH, YEAR on the Persian calendar."
(cond
((< month 7) 31)
((or (< month 12) (persian-calendar-leap-year-p year)) 30)
(t 29)))
(defun calendar-absolute-from-persian (date)
"Compute absolute date from Persian date DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
(let ((month (extract-calendar-month date))
(day (extract-calendar-day date))
(year (extract-calendar-year date)))
(if (< year 0)
(+ (calendar-absolute-from-persian
(list month day (1+ (mod year 2820))))
(* 1029983 (floor year 2820)))
(+ (1- persian-calendar-epoch) (* 365 (1- year)) (* 683 (floor (+ year 2345) 2820))
(* 186 (floor (mod (+ year 2345) 2820) 768))
(floor (* 683 (mod (mod (+ year 2345) 2820) 768))
2820)
-568 (calendar-sum m 1 (< m month)
(persian-calendar-last-day-of-month m year))
day))))
(defun calendar-persian-year-from-absolute (date)
"Persian year corresponding to the absolute DATE."
(let* ((d0 (- date (calendar-absolute-from-persian (list 1 1 -2345))))
(n2820 (floor d0 1029983))
(d1 (mod d0 1029983))
(n768 (floor d1 280506))
(d2 (mod d1 280506))
(n1 (let ((a (floor d2 366)) (b (mod d2 366)))
(+ 1 a (floor (+ (* 2137 a) (* 2820 b) 2137) 1029983))))
(year (+ (* 2820 n2820) (* 768 n768) (if (= d1 1029617)
(1- n1)
n1)
-2345))) (if (< year 1)
(1- year) year)))
(defun calendar-persian-from-absolute (date)
"Compute the Persian equivalent for absolute date DATE.
The result is a list of the form (MONTH DAY YEAR).
The absolute date is the number of days elapsed since the imaginary
Gregorian date Sunday, December 31, 1 BC."
(let* ((year (calendar-persian-year-from-absolute date))
(month (1+ (calendar-sum m 1
(> date
(calendar-absolute-from-persian
(list
m
(persian-calendar-last-day-of-month m year)
year)))
1)))
(day (- date (1- (calendar-absolute-from-persian
(list month 1 year))))))
(list month day year)))
(defun calendar-persian-date-string (&optional date)
"String of Persian date of Gregorian DATE.
Defaults to today's date if DATE is not given."
(let* ((persian-date (calendar-persian-from-absolute
(calendar-absolute-from-gregorian
(or date (calendar-current-date)))))
(y (extract-calendar-year persian-date))
(m (extract-calendar-month persian-date)))
(let ((monthname (aref persian-calendar-month-name-array (1- m)))
(day (int-to-string (extract-calendar-day persian-date)))
(dayname nil)
(month (int-to-string m))
(year (int-to-string y)))
(mapconcat 'eval calendar-date-display-form ""))))
(defun calendar-print-persian-date ()
"Show the Persian calendar equivalent of the selected date."
(interactive)
(message "Persian date: %s"
(calendar-persian-date-string (calendar-cursor-to-date t))))
(defun calendar-goto-persian-date (date &optional noecho)
"Move cursor to Persian date DATE.
Echo Persian date unless NOECHO is t."
(interactive (persian-prompt-for-date))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-absolute-from-persian date)))
(or noecho (calendar-print-persian-date)))
(defun persian-prompt-for-date ()
"Ask for a Persian date."
(let* ((today (calendar-current-date))
(year (calendar-read
"Persian calendar year (not 0): "
'(lambda (x) (/= x 0))
(int-to-string
(extract-calendar-year
(calendar-persian-from-absolute
(calendar-absolute-from-gregorian today))))))
(completion-ignore-case t)
(month (cdr (assoc
(completing-read
"Persian calendar month name: "
(mapcar 'list
(append persian-calendar-month-name-array nil))
nil t)
(calendar-make-alist persian-calendar-month-name-array
1))))
(last (persian-calendar-last-day-of-month month year))
(day (calendar-read
(format "Persian calendar day (1-%d): " last)
'(lambda (x) (and (< 0 x) (<= x last))))))
(list (list month day year))))
(defun diary-persian-date ()
"Persian calendar equivalent of date diary entry."
(format "Persian date: %s" (calendar-persian-date-string date)))
(provide 'cal-persia)