Mercurial > emacs
changeset 92924:31862b15d5bb
(date, displayed-month, displayed-year): Move declarations where needed.
(lunar-phase-list): Move definition after functions it uses.
(calendar-phases-of-moon, diary-phases-of-moon)
(lunar-new-moon-on-or-after): Use cadr, nth.
(lunar-new-moon-on-or-after): Doc fix.
| author | Glenn Morris <rgm@gnu.org> |
|---|---|
| date | Fri, 14 Mar 2008 07:08:37 +0000 |
| parents | c009a4916c6a |
| children | 85bb22fa60a0 |
| files | lisp/calendar/lunar.el |
| diffstat | 1 files changed, 113 insertions(+), 111 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/calendar/lunar.el Fri Mar 14 07:05:10 2008 +0000 +++ b/lisp/calendar/lunar.el Fri Mar 14 07:08:37 2008 +0000 @@ -45,45 +45,12 @@ ;;; Code: -(defvar date) -(defvar displayed-month) -(defvar displayed-year) - (if (fboundp 'atan) (require 'lisp-float-type) (error "Lunar calculations impossible since floating point is unavailable")) (require 'solar) -(defun lunar-phase-list (month year) - "List of lunar phases for three months starting with Gregorian MONTH, YEAR." - (let ((end-month month) - (end-year year) - (start-month month) - (start-year year)) - (increment-calendar-month end-month end-year 3) - (increment-calendar-month start-month start-year -1) - (let* ((end-date (list (list end-month 1 end-year))) - (start-date (list (list start-month - (calendar-last-day-of-month - start-month start-year) - start-year))) - (index (* 4 - (truncate - (* 12.3685 - (+ year - ( / (calendar-day-number (list month 1 year)) - 366.0) - -1900))))) - (new-moon (lunar-phase index)) - (list)) - (while (calendar-date-compare new-moon end-date) - (if (calendar-date-compare start-date new-moon) - (setq list (append list (list new-moon)))) - (setq index (1+ index)) - (setq new-moon (lunar-phase index))) - list))) - (defun lunar-phase (index) "Local date and time of lunar phase INDEX. Integer below INDEX/4 gives the lunation number, counting from Jan 1, 1900; @@ -155,7 +122,7 @@ (* 0.0004 (solar-sin-degrees (- sun-anomaly (* 2 moon-anomaly)))) (* -0.0003 (solar-sin-degrees - (+ (* 2 sun-anomaly) moon-anomaly)))))) + (+ (* 2 sun-anomaly) moon-anomaly)))))) (adj (+ 0.0028 (* -0.0004 (solar-cosine-degrees sun-anomaly)) @@ -176,6 +143,35 @@ (adj (dst-adjust-time date time))) (list (car adj) (apply 'solar-time-string (cdr adj)) phase))) +(defun lunar-phase-list (month year) + "List of lunar phases for three months starting with Gregorian MONTH, YEAR." + (let ((end-month month) + (end-year year) + (start-month month) + (start-year year)) + (increment-calendar-month end-month end-year 3) + (increment-calendar-month start-month start-year -1) + (let* ((end-date (list (list end-month 1 end-year))) + (start-date (list (list start-month + (calendar-last-day-of-month + start-month start-year) + start-year))) + (index (* 4 + (truncate + (* 12.3685 + (+ year + ( / (calendar-day-number (list month 1 year)) + 366.0) + -1900))))) + (new-moon (lunar-phase index)) + (list)) + (while (calendar-date-compare new-moon end-date) + (if (calendar-date-compare start-date new-moon) + (setq list (append list (list new-moon)))) + (setq index (1+ index) + new-moon (lunar-phase index))) + list))) + (defun lunar-phase-name (phase) "Name of lunar PHASE. 0 = new moon, 1 = first quarter, 2 = full moon, 3 = last quarter." @@ -184,6 +180,9 @@ ((= 2 phase) "Full Moon") ((= 3 phase) "Last Quarter Moon"))) +(defvar displayed-month) ; from generate-calendar +(defvar displayed-year) + ;;;###cal-autoload (defun calendar-phases-of-moon () "Create a buffer with the lunar phases for the current calendar window." @@ -207,14 +206,14 @@ (insert (mapconcat (lambda (x) - (let ((date (car x)) - (time (car (cdr x))) - (phase (car (cdr (cdr x))))) - (concat (calendar-date-string date) - ": " - (lunar-phase-name phase) - " " - time))) + (let ((date (car x)) + (time (cadr x)) + (phase (nth 2 x))) + (concat (calendar-date-string date) + ": " + (lunar-phase-name phase) + " " + time))) (lunar-phase-list m1 y1) "\n")) (goto-char (point-min)) (set-buffer-modified-p nil) @@ -229,16 +228,19 @@ This function is suitable for execution in a .emacs file." (interactive "P") (save-excursion - (let* ((date (if arg - (calendar-read-date t) + (let* ((date (if arg (calendar-read-date t) (calendar-current-date))) (displayed-month (extract-calendar-month date)) (displayed-year (extract-calendar-year date))) (calendar-phases-of-moon)))) +(defvar date) + +;; To be called from list-sexp-diary-entries, where DATE is bound. + ;;;###diary-autoload (defun diary-phases-of-moon (&optional mark) -"Moon phases diary entry. + "Moon phases diary entry. An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." (let* ((index (* 4 @@ -250,14 +252,14 @@ -1900))))) (phase (lunar-phase index))) (while (calendar-date-compare phase (list date)) - (setq index (1+ index)) - (setq phase (lunar-phase index))) + (setq index (1+ index) + phase (lunar-phase index))) (if (calendar-date-equal (car phase) date) - (cons mark (concat (lunar-phase-name (car (cdr (cdr phase)))) " " - (car (cdr phase))))))) + (cons mark (concat (lunar-phase-name (nth 2 phase)) " " + (cadr phase)))))) -;; For the Chinese calendar the calculations for the new moon need to be more -;; accurate than those above, so we use more terms in the approximation. +;; For the Chinese calendar the calculations for the new moon need to be more +;; accurate than those above, so we use more terms in the approximation. (defun lunar-new-moon-time (k) "Astronomical (Julian) day number of K th new moon." (let* ((T (/ k 1236.85)) @@ -303,60 +305,60 @@ (A13 (+ 239.56 (* 25.513099 k))) (A14 (+ 331.55 (* 3.592518 k))) (correction - (+ (* -0.40720 (solar-sin-degrees moon-anomaly)) - (* 0.17241 E (solar-sin-degrees sun-anomaly)) - (* 0.01608 (solar-sin-degrees (* 2 moon-anomaly))) - (* 0.01039 (solar-sin-degrees (* 2 moon-argument))) - (* 0.00739 E (solar-sin-degrees (- moon-anomaly sun-anomaly))) - (* -0.00514 E (solar-sin-degrees (+ moon-anomaly sun-anomaly))) - (* 0.00208 E E (solar-sin-degrees (* 2 sun-anomaly))) - (* -0.00111 (solar-sin-degrees - (- moon-anomaly (* 2 moon-argument)))) - (* -0.00057 (solar-sin-degrees - (+ moon-anomaly (* 2 moon-argument)))) - (* 0.00056 E (solar-sin-degrees - (+ (* 2 moon-anomaly) sun-anomaly))) - (* -0.00042 (solar-sin-degrees (* 3 moon-anomaly))) - (* 0.00042 E (solar-sin-degrees - (+ sun-anomaly (* 2 moon-argument)))) - (* 0.00038 E (solar-sin-degrees - (- sun-anomaly (* 2 moon-argument)))) - (* -0.00024 E (solar-sin-degrees - (- (* 2 moon-anomaly) sun-anomaly))) - (* -0.00017 (solar-sin-degrees omega)) - (* -0.00007 (solar-sin-degrees - (+ moon-anomaly (* 2 sun-anomaly)))) - (* 0.00004 (solar-sin-degrees - (- (* 2 moon-anomaly) (* 2 moon-argument)))) - (* 0.00004 (solar-sin-degrees (* 3 sun-anomaly))) - (* 0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly - (* -2 moon-argument)))) - (* 0.00003 (solar-sin-degrees - (+ (* 2 moon-anomaly) (* 2 moon-argument)))) - (* -0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly - (* 2 moon-argument)))) - (* 0.00003 (solar-sin-degrees (- moon-anomaly sun-anomaly - (* -2 moon-argument)))) - (* -0.00002 (solar-sin-degrees (- moon-anomaly sun-anomaly - (* 2 moon-argument)))) - (* -0.00002 (solar-sin-degrees - (+ (* 3 moon-anomaly) sun-anomaly))) - (* 0.00002 (solar-sin-degrees (* 4 moon-anomaly))))) + (+ (* -0.40720 (solar-sin-degrees moon-anomaly)) + (* 0.17241 E (solar-sin-degrees sun-anomaly)) + (* 0.01608 (solar-sin-degrees (* 2 moon-anomaly))) + (* 0.01039 (solar-sin-degrees (* 2 moon-argument))) + (* 0.00739 E (solar-sin-degrees (- moon-anomaly sun-anomaly))) + (* -0.00514 E (solar-sin-degrees (+ moon-anomaly sun-anomaly))) + (* 0.00208 E E (solar-sin-degrees (* 2 sun-anomaly))) + (* -0.00111 (solar-sin-degrees + (- moon-anomaly (* 2 moon-argument)))) + (* -0.00057 (solar-sin-degrees + (+ moon-anomaly (* 2 moon-argument)))) + (* 0.00056 E (solar-sin-degrees + (+ (* 2 moon-anomaly) sun-anomaly))) + (* -0.00042 (solar-sin-degrees (* 3 moon-anomaly))) + (* 0.00042 E (solar-sin-degrees + (+ sun-anomaly (* 2 moon-argument)))) + (* 0.00038 E (solar-sin-degrees + (- sun-anomaly (* 2 moon-argument)))) + (* -0.00024 E (solar-sin-degrees + (- (* 2 moon-anomaly) sun-anomaly))) + (* -0.00017 (solar-sin-degrees omega)) + (* -0.00007 (solar-sin-degrees + (+ moon-anomaly (* 2 sun-anomaly)))) + (* 0.00004 (solar-sin-degrees + (- (* 2 moon-anomaly) (* 2 moon-argument)))) + (* 0.00004 (solar-sin-degrees (* 3 sun-anomaly))) + (* 0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly + (* -2 moon-argument)))) + (* 0.00003 (solar-sin-degrees + (+ (* 2 moon-anomaly) (* 2 moon-argument)))) + (* -0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly + (* 2 moon-argument)))) + (* 0.00003 (solar-sin-degrees (- moon-anomaly sun-anomaly + (* -2 moon-argument)))) + (* -0.00002 (solar-sin-degrees (- moon-anomaly sun-anomaly + (* 2 moon-argument)))) + (* -0.00002 (solar-sin-degrees + (+ (* 3 moon-anomaly) sun-anomaly))) + (* 0.00002 (solar-sin-degrees (* 4 moon-anomaly))))) (additional - (+ (* 0.000325 (solar-sin-degrees A1)) - (* 0.000165 (solar-sin-degrees A2)) - (* 0.000164 (solar-sin-degrees A3)) - (* 0.000126 (solar-sin-degrees A4)) - (* 0.000110 (solar-sin-degrees A5)) - (* 0.000062 (solar-sin-degrees A6)) - (* 0.000060 (solar-sin-degrees A7)) - (* 0.000056 (solar-sin-degrees A8)) - (* 0.000047 (solar-sin-degrees A9)) - (* 0.000042 (solar-sin-degrees A10)) - (* 0.000040 (solar-sin-degrees A11)) - (* 0.000037 (solar-sin-degrees A12)) - (* 0.000035 (solar-sin-degrees A13)) - (* 0.000023 (solar-sin-degrees A14)))) + (+ (* 0.000325 (solar-sin-degrees A1)) + (* 0.000165 (solar-sin-degrees A2)) + (* 0.000164 (solar-sin-degrees A3)) + (* 0.000126 (solar-sin-degrees A4)) + (* 0.000110 (solar-sin-degrees A5)) + (* 0.000062 (solar-sin-degrees A6)) + (* 0.000060 (solar-sin-degrees A7)) + (* 0.000056 (solar-sin-degrees A8)) + (* 0.000047 (solar-sin-degrees A9)) + (* 0.000042 (solar-sin-degrees A10)) + (* 0.000040 (solar-sin-degrees A11)) + (* 0.000037 (solar-sin-degrees A12)) + (* 0.000035 (solar-sin-degrees A13)) + (* 0.000023 (solar-sin-degrees A14)))) (newJDE (+ JDE correction additional))) (+ newJDE (- (solar-ephemeris-correction @@ -370,10 +372,10 @@ The fractional part is the time of day. The date and time are local time, including any daylight saving rules, -as governed by the values of calendar-daylight-savings-starts, -calendar-daylight-savings-starts-time, calendar-daylight-savings-ends, -calendar-daylight-savings-ends-time, calendar-daylight-time-offset, and -calendar-time-zone." +as governed by the values of `calendar-daylight-savings-starts', +`calendar-daylight-savings-starts-time', `calendar-daylight-savings-ends', +`calendar-daylight-savings-ends-time', `calendar-daylight-time-offset', and +`calendar-time-zone'." (let* ((date (calendar-gregorian-from-absolute (floor (calendar-absolute-from-astro d)))) (year (+ (extract-calendar-year date) @@ -381,15 +383,15 @@ (k (floor (* (- year 2000.0) 12.3685))) (date (lunar-new-moon-time k))) (while (< date d) - (setq k (1+ k)) - (setq date (lunar-new-moon-time k))) + (setq k (1+ k) + date (lunar-new-moon-time k))) (let* ((a-date (calendar-absolute-from-astro date)) (time (* 24 (- a-date (truncate a-date)))) (date (calendar-gregorian-from-absolute (truncate a-date))) (adj (dst-adjust-time date time))) (calendar-astro-from-absolute (+ (calendar-absolute-from-gregorian (car adj)) - (/ (car (cdr adj)) 24.0)))))) + (/ (cadr adj) 24.0)))))) (provide 'lunar)