(defconst persian-calendar-month-name-array
["Farvardin" "Ordibehest" "Xordad" "Tir" "Mordad" "Sahrivar" "Mehr" "Aban"
- "Azar" "Dey" "Bahman" "Esfand"])
+ "Azar" "Dey" "Bahman" "Esfand"]
+ "Names of the months in the Persian calendar.")
(defconst persian-calendar-epoch (calendar-absolute-from-julian '(3 19 622))
- "Absolute date of start of Persian calendar = March 19, 622 A.D. (Julian).")
+ "Absolute date of start of Persian calendar = March 19, 622 AD (Julian).")
(defun persian-calendar-leap-year-p (year)
"True if YEAR is a leap year on the Persian calendar."
(+ (calendar-absolute-from-persian
(list month day (1+ (mod year 2820))))
(* 1029983 (floor year 2820)))
- (+ (1- persian-calendar-epoch); Days before epoch
- (* 365 (1- year)) ; Days in prior years.
- (* 683 ; Leap days in prior 2820-year cycles
+ (+ (1- persian-calendar-epoch) ; days before epoch
+ (* 365 (1- year)) ; days in prior years
+ (* 683 ; leap days in prior 2820-year cycles
(floor (+ year 2345) 2820))
- (* 186 ; Leap days in prior 768 year cycles
+ (* 186 ; leap days in prior 768 year cycles
(floor (mod (+ year 2345) 2820) 768))
- (floor; Leap years in current 768 or 516 year cycle
+ (floor ; leap years in current 768 or 516 year cycle
(* 683 (mod (mod (+ year 2345) 2820) 768))
2820)
- -568 ; Leap years in Persian years -2345...-1
- (calendar-sum ; Days in prior months this year.
+ -568 ; leap years in Persian years -2345...-1
+ (calendar-sum ; days in prior months this year
m 1 (< m month)
(persian-calendar-last-day-of-month m year))
- day)))) ; Days so far this month.
+ day)))) ; days so far this month
(defun calendar-persian-year-from-absolute (date)
"Persian year corresponding to the absolute DATE."
- (let* ((d0 ; Prior days since start of 2820 cycles
+ (let* ((d0 ; prior days since start of 2820 cycles
(- date (calendar-absolute-from-persian (list 1 1 -2345))))
- (n2820 ; Completed 2820-year cycles
+ (n2820 ; completed 2820-year cycles
(floor d0 1029983))
- (d1 ; Prior days not in n2820
+ (d1 ; prior days not in n2820
(mod d0 1029983))
- (n768 ; 768-year cycles not in n2820
+ (n768 ; 768-year cycles not in n2820
(floor d1 280506))
- (d2 ; Prior days not in n2820 or n768
+ (d2 ; prior days not in n2820 or n768
(mod d1 280506))
- (n1 ; Years not in n2820 or n768
- ; we want is
- ; (floor (+ (* 2820 d2) (* 2820 366)) 1029983))
- ; but that causes overflow, so we use
- (let ((a (floor d2 366)); we use 366 as the divisor because
- ; (2820*366 mod 1029983) is small
+ (n1 ; years not in n2820 or n768
+ ;; Want:
+ ;; (floor (+ (* 2820 d2) (* 2820 366)) 1029983))
+ ;; but that causes overflow, so use the following.
+ ;; Use 366 as the divisor because (2820*366 mod 1029983) is small.
+ (let ((a (floor d2 366))
(b (mod d2 366)))
(+ 1 a (floor (+ (* 2137 a) (* 2820 b) 2137) 1029983))))
- (year (+ (* 2820 n2820); Complete 2820 year cycles
- (* 768 n768) ; Complete 768 year cycles
- (if ; Remaining years
- ; Last day of 2820 year cycle
- (= d1 1029617)
+ (year (+ (* 2820 n2820) ; complete 2820 year cycles
+ (* 768 n768) ; complete 768 year cycles
+ ;; Remaining years.
+ (if (= d1 1029617) ; last day of 2820 year cycle
(1- n1)
n1)
- -2345))) ; Years before year 1
+ -2345))) ; years before year 1
(if (< year 1)
- (1- year); No year zero
+ (1- year) ; no year zero
year)))
(defun calendar-persian-from-absolute (date)
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 ; Search forward from Farvardin
+ (month ; search forward from Farvardin
(1+ (calendar-sum m 1
(> date
(calendar-absolute-from-persian
(persian-calendar-last-day-of-month m year)
year)))
1)))
- (day ; Calculate the day by subtraction
+ (day ; calculate the day by subtraction
(- date (1- (calendar-absolute-from-persian
(list month 1 year))))))
(list month day year)))
;;;###autoload
(defun calendar-persian-date-string (&optional date)
- "String of Persian date of Gregorian DATE.
-Defaults to today's date if DATE is not given."
+ "String of Persian date of Gregorian DATE, default today."
(let* ((persian-date (calendar-persian-from-absolute
(calendar-absolute-from-gregorian
(or date (calendar-current-date)))))
(defun persian-prompt-for-date ()
"Ask for a Persian date."
- (let* ((today (calendar-current-date))
- (year (calendar-read
+ (let* ((year (calendar-read
"Persian calendar year (not 0): "
(lambda (x) (not (zerop x)))
(int-to-string
(extract-calendar-year
(calendar-persian-from-absolute
- (calendar-absolute-from-gregorian today))))))
+ (calendar-absolute-from-gregorian
+ (calendar-current-date)))))))
(completion-ignore-case t)
(month (cdr (assoc
(completing-read