diff options
| -rw-r--r-- | lisp/ChangeLog | 20 | ||||
| -rw-r--r-- | lisp/calc/calc-forms.el | 323 | ||||
| -rw-r--r-- | lisp/calc/calc.el | 44 |
3 files changed, 313 insertions, 74 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 135ee569aa4..c9c879b5e88 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,23 @@ +2012-11-17 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc.el (calc-gregorian-switch): New variable. + + * calc/calc-forms.el (math-day-in-year, math-dt-before-p) + (math-absolute-from-gregorian-dt, math-absolute-from-julian-dt) + (math-date-to-julian-dt, math-date-to-gregorian-dt): New functions. + (math-leap-year-p): Add option to distinguish between Julian + and Gregorian calendars. + (math-day-number): Use `math-day-in-year' to do the computations. + (math-absolute-from-dt): Rename from `math-absolute-from-date'. + Use `math-absolute-from-gregorian' and `math-absolute-from-julian' + to do the computations. + (math-date-to-dt): Use `math-date-to-julian-dt' and + `math-date-to-gregorian-dt' to do the computations. + (calcFunc-weekday, math-format-date-part): Use the new version of + the DATE to determine the weekday. + (calcFunc-newmonth, calcFunc-newyear): Use `calc-gregorian-switch' + when necessary. + 2012-11-17 Eli Zaretskii <eliz@gnu.org> * term/w32-win.el (w32-handle-dropped-file): Use 'file://' only on diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index bd748158d66..4573377745c 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -369,17 +369,67 @@ ;;; Some of these functions are adapted from Edward Reingold's "calendar.el". ;;; These versions are rewritten to use arbitrary-size integers. -;;; The Julian calendar is used up to 9/2/1752, after which the Gregorian -;;; calendar is used; the first day after 9/2/1752 is 9/14/1752. ;;; A numerical date is the number of days since midnight on -;;; the morning of January 1, 1 A.D. If the date is a non-integer, -;;; it represents a specific date and time. +;;; the morning of December 31, 1 B.C. Emacs's calendar refers to such +;;; a date as an absolute date, some function names also use that +;;; terminology. If the date is a non-integer, it represents a specific date and time. ;;; A "dt" is a list of the form, (year month day), corresponding to ;;; an integer code, or (year month day hour minute second), corresponding ;;; to a non-integer code. +(defun math-date-to-gregorian-dt (date) + "Return the day (YEAR MONTH DAY) in the Gregorian calendar. +DATE is the number of days since December 31, -1 in the Gregorian calendar." + (let* ((month 1) + day + (year (math-quotient (math-add date (if (Math-lessp date 711859) + 365 ; for speed, we take + -108)) ; >1950 as a special case + (if (math-negp date) 366 365))) + ; this result may be an overestimate + temp) + (while (Math-lessp date (setq temp (math-absolute-from-gregorian-dt year 1 1))) + (setq year (math-add year -1))) + (if (eq year 0) (setq year -1)) + (setq date (1+ (math-sub date temp))) + (setq temp + (if (math-leap-year-p year) + [1 32 61 92 122 153 183 214 245 275 306 336 999] + [1 32 60 91 121 152 182 213 244 274 305 335 999])) + (while (>= date (aref temp month)) + (setq month (1+ month))) + (setq day (1+ (- date (aref temp (1- month))))) + (list year month day))) + +(defun math-date-to-julian-dt (date) + "Return the day (YEAR MONTH DAY) in the Julian calendar. +DATE is the number of days since December 31, -1 in the Gregorian calendar." + (let* ((month 1) + day + (year (math-quotient (math-add date (if (Math-lessp date 711859) + 365 ; for speed, we take + -108)) ; >1950 as a special case + (if (math-negp date) 366 365))) + ; this result may be an overestimate + temp) + (while (Math-lessp date (setq temp (math-absolute-from-julian-dt year 1 1))) + (setq year (math-add year -1))) + (if (eq year 0) (setq year -1)) + (setq date (1+ (math-sub date temp))) + (setq temp + (if (math-leap-year-p year t) + [1 32 61 92 122 153 183 214 245 275 306 336 999] + [1 32 60 91 121 152 182 213 244 274 305 335 999])) + (while (>= date (aref temp month)) + (setq month (1+ month))) + (setq day (1+ (- date (aref temp (1- month))))) + (list year month day))) + (defun math-date-to-dt (value) + "Return the day and time of VALUE. +The integer part of VALUE is the number of days since Dec 31, -1 +in the Gregorian calendar and the remaining part determines the time." (if (eq (car-safe value) 'date) (setq value (nth 1 value))) (or (math-realp value) @@ -387,32 +437,21 @@ (let* ((parts (math-date-parts value)) (date (car parts)) (time (nth 1 parts)) - (month 1) - day - (year (math-quotient (math-add date (if (Math-lessp date 711859) - 365 ; for speed, we take - -108)) ; >1950 as a special case - (if (math-negp value) 366 365))) - ; this result may be an overestimate - temp) - (while (Math-lessp date (setq temp (math-absolute-from-date year 1 1))) - (setq year (math-add year -1))) - (if (eq year 0) (setq year -1)) - (setq date (1+ (math-sub date temp))) - (and (eq year 1752) (>= date 247) - (setq date (+ date 11))) - (setq temp (if (math-leap-year-p year) - [1 32 61 92 122 153 183 214 245 275 306 336 999] - [1 32 60 91 121 152 182 213 244 274 305 335 999])) - (while (>= date (aref temp month)) - (setq month (1+ month))) - (setq day (1+ (- date (aref temp (1- month))))) + (dt (if (and calc-gregorian-switch + (Math-lessp value + (or + (nth 3 calc-gregorian-switch) + (apply 'math-absolute-from-gregorian-dt calc-gregorian-switch)) +)) + (math-date-to-julian-dt value) + (math-date-to-gregorian-dt value)))) (if (math-integerp value) - (list year month day) - (list year month day - (/ time 3600) - (% (/ time 60) 60) - (math-add (% time 60) (nth 2 parts)))))) + dt + (append dt + (list + (/ time 3600) + (% (/ time 60) 60) + (math-add (% time 60) (nth 2 parts))))))) (defun math-dt-to-date (dt) (or (integerp (nth 1 dt)) @@ -423,7 +462,7 @@ (math-reject-arg (nth 2 dt) 'fixnump)) (if (or (< (nth 2 dt) 1) (> (nth 2 dt) 31)) (math-reject-arg (nth 2 dt) "Day value is out of range")) - (let ((date (math-absolute-from-date (car dt) (nth 1 dt) (nth 2 dt)))) + (let ((date (math-absolute-from-dt (car dt) (nth 1 dt) (nth 2 dt)))) (if (nth 3 dt) (math-add (math-float date) (math-div (math-add (+ (* (nth 3 dt) 3600) @@ -446,8 +485,12 @@ (defun math-this-year () (nth 5 (decode-time))) -(defun math-leap-year-p (year) - (if (Math-lessp year 1752) +(defun math-leap-year-p (year &optional julian) + "Non-nil if YEAR is a leap year. +If JULIAN is non-nil, then use the criterion for leap years +in the Julian calendar, otherwise use the criterion in the +Gregorian calendar." + (if julian (if (math-negp year) (= (math-imod (math-neg year) 4) 1) (= (math-imod year 4) 0)) @@ -460,39 +503,100 @@ 29 (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) -(defun math-day-number (year month day) +(defun math-day-in-year (year month day &optional julian) + "Return the number of days of the year up to YEAR MONTH DAY. +The count includes the given date. +If JULIAN is non-nil, use the Julian calendar, otherwise +use the Gregorian calendar." (let ((day-of-year (+ day (* 31 (1- month))))) (if (> month 2) (progn (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) - (if (math-leap-year-p year) + (if (math-leap-year-p year julian) (setq day-of-year (1+ day-of-year))))) - (and (eq year 1752) - (or (> month 9) - (and (= month 9) (>= day 14))) - (setq day-of-year (- day-of-year 11))) day-of-year)) -(defun math-absolute-from-date (year month day) +(defun math-day-number (year month day) + "Return the number of days of the year up to YEAR MONTH DAY. +The count includes the given date." + (if calc-gregorian-switch + (cond ((math-equalp year (nth 0 calc-gregorian-switch)) + (1+ + (- (math-absolute-from-dt year month day) + (math-absolute-from-dt year 1 1)))) + ((Math-lessp year (nth 0 calc-gregorian-switch)) + (math-day-in-year year month day t)) + (t + (math-day-in-year year month day))) + (math-day-in-year year month day))) + +(defun math-dt-before-p (dt1 dt2) + "Non-nil if DT1 occurs before DT2. +A DT is a list of the form (YEAR MONTH DAY)." + (or (Math-lessp (nth 0 dt1) (nth 0 dt2)) + (and (equal (nth 0 dt1) (nth 0 dt2)) + (or (< (nth 1 dt1) (nth 1 dt2)) + (and (= (nth 1 dt1) (nth 1 dt2)) + (< (nth 2 dt1) (nth 2 dt2))))))) + +(defun math-absolute-from-gregorian-dt (year month day) + "Return the DATE of the day given by the Gregorian day YEAR MONTH DAY. +Recall that DATE is the number of days since December 31, -1 +in the Gregorian calendar." (if (eq year 0) (setq year -1)) (let ((yearm1 (math-sub year 1))) - (math-sub (math-add (math-day-number year month day) - (math-add (math-mul 365 yearm1) - (if (math-posp year) - (math-quotient yearm1 4) - (math-sub 365 - (math-quotient (math-sub 3 year) - 4))))) - (if (or (Math-lessp year 1753) - (and (eq year 1752) (<= month 9))) - 1 - (let ((correction (math-mul (math-quotient yearm1 100) 3))) - (let ((res (math-idivmod correction 4))) - (math-add (if (= (cdr res) 0) - -1 - 0) - (car res)))))))) - + (math-sub + ;; Add the number of days of the year and the numbers of days + ;; in the previous years (leap year days to be added separately) + (math-add (math-day-in-year year month day) + (math-add (math-mul 365 yearm1) + ;; Add the number of Julian leap years + (if (math-posp year) + (math-quotient yearm1 4) + (math-sub 365 + (math-quotient (math-sub 3 year) + 4))))) + ;; Subtract the number of Julian leap years which are not + ;; Gregorian leap years. In C=4N+r centuries, there will + ;; be 3N+r of these days. The following will compute + ;; 3N+r. + (let* ((correction (math-mul (math-quotient yearm1 100) 3)) + (res (math-idivmod correction 4))) + (math-add (if (= (cdr res) 0) + 0 + 1) + (car res)))))) + +(defun math-absolute-from-julian-dt (year month day) + "Return the DATE of the day given by the Julian day YEAR MONTH DAY. +Recall that DATE is the number of days since December 31, -1 +in the Gregorian calendar." + (if (eq year 0) (setq year -1)) + (let ((yearm1 (math-sub year 1))) + (math-sub + ;; Add the number of days of the year and the numbers of days + ;; in the previous years (leap year days to be added separately) + (math-add (math-day-in-year year month day) + (math-add (math-mul 365 yearm1) + ;; Add the number of Julian leap years + (if (math-posp year) + (math-quotient yearm1 4) + (math-sub 365 + (math-quotient (math-sub 3 year) + 4))))) + ;; Adjustment, since January 1, 1 (Julian) is absolute day -1 + 2))) + +(defun math-absolute-from-dt (year month day) + "Return the DATE of the day given by the day YEAR MONTH DAY. +Recall that DATE is the number of days since December 31, -1 +in the Gregorian calendar." + (if (and calc-gregorian-switch + ;; The next few lines determine if the given date + ;; occurs before the switch to the Gregorian calendar. + (math-dt-before-p (list year month day) calc-gregorian-switch)) + (math-absolute-from-julian-dt year month day) + (math-absolute-from-gregorian-dt year month day))) ;;; It is safe to redefine these in your init file to use a different ;;; language. @@ -585,8 +689,7 @@ as measured in the integer number of days before January 1 of the year 1AD.") math-fd-year (car math-fd-dt) math-fd-month (nth 1 math-fd-dt) math-fd-day (nth 2 math-fd-dt) - math-fd-weekday (math-mod - (math-add (math-floor math-fd-date) 6) 7) + math-fd-weekday (math-mod (math-floor math-fd-date) 7) math-fd-hour (nth 3 math-fd-dt) math-fd-minute (nth 4 math-fd-dt) math-fd-second (nth 5 math-fd-dt)) @@ -1098,7 +1201,7 @@ as measured in the integer number of days before January 1 of the year 1AD.") (setq date (nth 1 date))) (or (math-realp date) (math-reject-arg date 'datep)) - (math-mod (math-add (math-floor date) 6) 7)) + (math-mod (math-floor date) 7)) (defun calcFunc-yearday (date) (let ((dt (math-date-to-dt date))) @@ -1298,7 +1401,7 @@ second, the number of seconds offset for daylight savings." 0))) (rounded-abs-date (+ - (calendar-absolute-from-gregorian + (calendar-absolute-from-gregorian (list (nth 1 dt) (nth 2 dt) (nth 0 dt))) (/ (round (* 60 time)) 60.0 24.0)))) (if (dst-in-effect rounded-abs-date) @@ -1434,28 +1537,100 @@ and ends on the last Sunday of October at 2 a.m." (and (math-messy-integerp day) (setq day (math-trunc day))) (or (integerp day) (math-reject-arg day 'fixnump)) (and (or (< day 0) (> day 31)) (math-reject-arg day 'range)) - (let ((dt (math-date-to-dt date))) - (if (or (= day 0) (> day (math-days-in-month (car dt) (nth 1 dt)))) - (setq day (math-days-in-month (car dt) (nth 1 dt)))) - (and (eq (car dt) 1752) (= (nth 1 dt) 9) - (if (>= day 14) (setq day (- day 11)))) - (list 'date (math-add (math-dt-to-date (list (car dt) (nth 1 dt) 1)) - (1- day))))) + (let* ((dt (math-date-to-dt date)) + (dim (math-days-in-month (car dt) (nth 1 dt))) + (julian (if calc-gregorian-switch + (math-date-to-dt (math-sub + (or (nth 3 calc-gregorian-switch) + (apply 'math-absolute-from-gregorian-dt calc-gregorian-switch)) + 1))))) + (if (or (= day 0) (> day dim)) + (setq day (1- dim)) + (setq day (1- day))) + ;; Adjust if this occurs near the switch to the Gregorian calendar + (if calc-gregorian-switch + (cond + ((and (math-dt-before-p (list (car dt) (nth 1 dt) 1) calc-gregorian-switch) + (math-dt-before-p julian (list (car dt) (nth 1 dt) 1))) + ;; In this case, CALC-GREGORIAN-SWITCH is the first day of the month + (list 'date + (math-dt-to-date (list (car calc-gregorian-switch) + (nth 1 calc-gregorian-switch) + (if (> (+ (nth 2 calc-gregorian-switch) day) dim) + dim + (+ (nth 2 calc-gregorian-switch) day)))))) + ((and (eq (car dt) (car calc-gregorian-switch)) + (= (nth 1 dt) (nth 1 calc-gregorian-switch))) + ;; In this case, the switch to the Gregorian calendar occurs in the given month + (if (< (+ (nth 2 julian) day) (nth 2 calc-gregorian-switch)) + ;; If the DAYth day occurs before the switch, use it + (list 'date (math-dt-to-date (list (car dt) (nth 1 dt) (1+ day)))) + ;; Otherwise do some computations + (let ((tm (+ day (- (nth 2 calc-gregorian-switch) (nth 2 julian))))) + (list 'date (math-dt-to-date + (list (car dt) + (nth 1 dt) + ;; + (if (> tm dim) dim tm))))))) + ((and (eq (car dt) (car julian)) + (= (nth 1 dt) (nth 1 julian))) + ;; In this case, the current month is truncated because of the switch + ;; to the Gregorian calendar + (list 'date (math-dt-to-date + (list (car dt) + (nth 1 dt) + (if (>= day (nth 2 julian)) + (nth 2 julian) + (1+ day)))))) + (t + ;; The default + (list 'date (math-add (math-dt-to-date (list (car dt) (nth 1 dt) 1)) day)))) + (list 'date (math-add (math-dt-to-date (list (car dt) (nth 1 dt) 1)) day))))) (defun calcFunc-newyear (date &optional day) + (if (eq (car-safe date) 'date) (setq date (nth 1 date))) (or day (setq day 1)) (and (math-messy-integerp day) (setq day (math-trunc day))) (or (integerp day) (math-reject-arg day 'fixnump)) - (let ((dt (math-date-to-dt date))) + (let* ((dt (math-date-to-dt date)) + (gregbeg (if calc-gregorian-switch + (or (nth 3 calc-gregorian-switch) + (apply 'math-absolute-from-gregorian-dt calc-gregorian-switch)))) + (julianend (if calc-gregorian-switch (math-sub gregbeg 1))) + (julian (if calc-gregorian-switch + (math-date-to-dt julianend)))) (if (and (>= day 0) (<= day 366)) - (let ((max (if (eq (car dt) 1752) 355 - (if (math-leap-year-p (car dt)) 366 365)))) + (let ((max (if (math-leap-year-p (car dt)) 366 365))) (if (or (= day 0) (> day max)) (setq day max)) - (list 'date (math-add (math-dt-to-date (list (car dt) 1 1)) - (1- day)))) + (if calc-gregorian-switch + ;; Now to break this down into cases + (cond + ((and (math-dt-before-p (list (car dt) 1 1) calc-gregorian-switch) + (math-dt-before-p julian (list (car dt) 1 1))) + ;; In this case, CALC-GREGORIAN-SWITCH is the first day of the year + (list 'date (math-min (math-add gregbeg (1- day)) + (math-dt-to-date (list (car calc-gregorian-switch) 12 31))))) + ((eq (car dt) (car julian)) + ;; In this case, the switch to the Gregorian calendar occurs in the given year + (if (Math-lessp (car julian) (car calc-gregorian-switch)) + ;; Here, the last Julian day is the last day of the year. + (list 'date (math-min (math-add (math-dt-to-date (list (car dt) 1 1)) (1- day)) + julianend)) + ;; Otherwise, just make sure the date doesn't go past the end of the year + (list 'date (math-min (math-add (math-dt-to-date (list (car dt) 1 1)) (1- day)) + (math-dt-to-date (list (car dt) 12 31)))))) + (t + (list 'date (math-add (math-dt-to-date (list (car dt) 1 1)) + (1- day))))) + (list 'date (math-add (math-dt-to-date (list (car dt) 1 1)) + (1- day))))) (if (and (>= day -12) (<= day -1)) - (list 'date (math-dt-to-date (list (car dt) (- day) 1))) - (math-reject-arg day 'range))))) + (if (and calc-gregorian-switch + (math-dt-before-p (list (car dt) (- day) 1) calc-gregorian-switch) + (math-dt-before-p julian (list (car dt) (- day) 1))) + (list 'date gregbeg) + (list 'date (math-dt-to-date (list (car dt) (- day) 1)))) + (math-reject-arg day 'range))))) (defun calcFunc-incmonth (date &optional step) (or step (setq step 1)) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index f1643b10a76..2d75e897d9b 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -464,6 +464,50 @@ to be identified as that note." :type 'string :group 'calc) +;; Dates that are built-in options for `calc-gregorian-switch' should be +;; (YEAR MONTH DAY math-date-from-gregorian-dt(YEAR MONTH DAY)) for speed. +(defcustom calc-gregorian-switch nil + "The first day the Gregorian calendar is used by Calc's date forms. +This is `nil' (the default) if the Gregorian calendar is the only one used. +Otherwise, it should be a list `(YEAR MONTH DAY)' when Calc begins to use +the Gregorian calendar; Calc will use the Julian calendar for earlier dates. +The dates in which different regions of the world began to use the +Gregorian calendar vary quite a bit, even within a single country. +If you want Calc's date forms to switch between the Julian and +Gregorian calendar, you can specify the date or choose from several +common choices. Some of these choices should be taken with a grain +of salt; for example different parts of France changed calendars at +different times, and Sweden's change to the Gregorian calendar was +complicated. Also, the boundaries of the countries were different at +the times of the calendar changes than they are now. +The Vatican decided that the Gregorian calendar should take effect +on 15 October 1582 (Gregorian), and many Catholic countries made +the change then. Great Britian and its colonies had the Gregorian +calendar take effect on 14 September 1752 (Gregorian); this includes +the United States." + :group 'calc + :version "24.4" + :type '(choice (const :tag "Always use the Gregorian calendar" nil) + (const :tag "Great Britian and the US (1752 9 14)" (1752 9 14 639797)) + (const :tag "Vatican (1582 10 15)" (1582 10 15 577736)) + (const :tag "Czechoslovakia (1584 1 17)" (1584 1 17 578195)) + (const :tag "Denmark (1700 3 1)" (1700 3 1 620607)) + (const :tag "France (1582 12 20)" (1582 12 20 577802)) + (const :tag "Hungary (1587 11 1)" (1587 11 1 579579)) + (const :tag "Luxemburg (1582 12 25)" (1582 12 25 577807)) + (const :tag "Romania (1919 4 14)" (1919 4 14 700638)) + (const :tag "Russia (1918 2 14)" (1918 2 14 700214)) + (const :tag "Sweden (1753 3 1)" (1753 3 1 639965)) + (const :tag "Switzerland (Catholic) (1584 1 22)" (1584 1 22 578200)) + (const :tag "Switzerland (Protestant) (1701 1 12)" (1701 1 12 620924)) + (list :tag "(YEAR MONTH DAY)" + (integer :tag "Year") + (integer :tag "Month (integer)") + (integer :tag "Day"))) + :set (lambda (symbol value) + (set-default symbol value) + (setq math-format-date-cache nil))) + (defface calc-nonselected-face '((t :inherit shadow :slant italic)) |