bug#20583: calendar-absolute-from-gregorian

[Nicholas Strauss <nicholas.strauss@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 784 bytes --]

Corrected comments to calendar-julianday-from-proleptic-gregorian
and cond for year 1582.
File requires calendar.el

Nick

On Fri, May 22, 2015 at 8:36 AM, Nicholas Strauss
<nicholas.strauss@gmail.com> wrote:
> There are other day number systems more common than the  emacs
> "absolute" day number --
> the "astro" or Julian day number and the proleptic Gregorian system
> used by sqlite3
> e.g. select julianday("-4713-11-24").
> cal-julian.el:alendar-astro-to-absolute refers to  "astro".
> Proleptic Gregorian day 0 = November 24, 4714 BC while "astro" day 0 =
>  January 1, 4713 BC.
> I'm attaching julian.lisp which has calendar-correlate-from-date and
> calendar-correlate-from-julianday
> may help with days before 1582. These are based on Peter
> Duffett-Smiths calculations.

[-- Attachment #2: julian.lisp --]
[-- Type: application/octet-stream, Size: 5986 bytes --]

 ;; julian.lisp Copyright 2015 Nicholas C. Strauss (ncs@alum.mit.edu)
 ;;
 ;;   This program is free software: you can redistribute it and/or modify
 ;;   it under the terms of the GNU General Public License as published by
 ;;   the Free Software Foundation, either version 3 of the License, or
 ;;   (at your option) any later version.
 ;;
 ;;   This program is distributed in the hope that it will be useful,
 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;   GNU General Public License for more details.
 ;;
 ;;   You should have received a copy of the GNU General Public License
 ;;   along with this program.  If not, see <http://www.gnu.org/licenses/>

;; requires calendar.el 

;;;###cal-autoload
(defun calendar-julianday-from-gregorian (date)
  "Compute the Julian day corresponding to the date
   calculated from Monday, Jan 1, 4713 BCE using 
   the Julian calendar until October 5, 1582 thence the
    Gregorian calendar from October 15, 1582"
  (let ((day (calendar-extract-day date))
	(month (calendar-extract-month date))
	(year (calendar-extract-year date)))
    ;; b=gregorian correction
    ;; c=elapsed years
    ;; d=elapsed months this year
    (if (and (= year 1582) (= month 10)
	     (>= day 5)
	     (< day 15))
	0.0e+NaN      
      (progn
	(if (< year 1) (setq year (+ year 1)))
	(if (< month 3)	(progn
			  (setq year (+ year -1))
			  (setq month (+ month 12)))
	  )
	(setq a (ffloor (/ year 100)))
	(if (or (< year 1582)
		(and (= year 1582) (< month 10))
		(and (= year 1582) (= month 10) (< day 5)))
	    (setq b 0)                                     ;; julian
	  (setq b (+ 2 (- a)                               ;; gregorian
		     (ffloor (/ a 4)))))                   
	(if (< year 0)
	    (setq c (+ (ftruncate (+ (* 365.25 year) -0.75))
		       -694025))
	  (setq c (+ (ffloor (* 365.25 year))
		     -694025)))
	(setq d (ffloor (* 30.6001 (+ month 1))))
	(+ day b c d -0.5 2415020)
	)
      )
 )
)

;;;###cal-autoload
(defun calendar-gregorian-from-julianday (julianday)
  "Compute the date corresponding to the Julian day
   calculated from Monday, Jan 1, 4713 BCE using 
   the Julian calendar until October 5, 1582 thence the
    Gregorian calendar from October 15, 1582"
  (cond
   ((isnan julianday)
	 julianday)
   (t 
       (progn
	(setq julianday (+ julianday -2415020))
	(setq d (+ julianday 0.5))
	(setq i (ffloor d))
	(setq fd (+ d (- i)))
	(if (< (abs (+ fd -1.0))
	       1.0e-10)
	    (progn
	      (setq fd 0.0)
	      (setq i (+ i 1)))
	  )
	(if (> i -115860)
	    (progn
	      (setq a (+ (ffloor (+ (/ i 36524.25) 0.99835726))
				 14))
	      (setq i (+ i 1 a
			 (- (ffloor (/ a 4.0)))))
	      )
	  )
	(setq b (ffloor (+ (/ i 365.25) 0.802601)))
	(setq c (+ i (- (ffloor (+ (* 365.25 b)
				  0.750001)))
		   416))
	(setq g (ffloor (/ c 30.6001)))
	(setq day (ffloor (+ c
			    (- (ffloor (* 30.6001 g)))
			    fd)))
	(if (> g 13.5)
	    (setq month (+ g -13))
	  (setq month (+ g -1)))
	(if (> month 2.5)
	    (setq year (+ b 1899))
	  (setq year (+ b 1900)))
	(if (< year 0)
	    (setq year (+ year -1)))
	(setq julianday (+ julianday 2415020))
	(setq b (* (ftruncate (/ (+ julianday 1.5) 7))
		   7))
	(setq dayofweek (+ 1
			   (ftruncate (+ julianday 1.5 (- b)))
			   ))
;;	(list dayofweek
;;	      (* fd 24) 
;;	      month 
;;	      day 
;;	      year))
	(list month 
	      day 
	      year))
       )
   )
)
;;;###cal-autoload
(defun calendar-julianday-from-proleptic-gregorian (date)
  "Compute the julian day corresponding to the date
   calculated from Monday, November 24, 4713 BCE using 
   the Gregorian calendar."
  (let ((day (calendar-extract-day date))
	(month (calendar-extract-month date))
	(year (calendar-extract-year date)))
    (progn
      (if (< month 3)	(progn
			  (setq year (+ year -1))
			  (setq month (+ month 12)))
	)
      (setq a (ffloor (/ year 100)))
      (setq b (+ 2 
		 (- a)
		 (ffloor (/ a 4))))
      (if (< year 0)
	  (setq c (+ (ftruncate (+ (* 365.25 year) -0.75))
		     -694025))
	(setq c (+ (ffloor (* 365.25 year))
		   -694025)))
      (setq d (ffloor (* 30.6001 (+ month 1))))
      (+ day b c d -0.5 2415020)
      )
    )
)

;;;###cal-autoload
(defun calendar-proleptic-gregorian-from-julianday (julianday)
  "Compute the date corresponding to the Julian day
   calculated from Monday, November 24, 4713 BCE using 
   the Gregorian calendar."
  (cond
   ((isnan julianday)
	 julianday)
   (t 
       (progn
	(setq julianday (+ julianday -2415020))
	(setq d (+ julianday 0.5))
	(setq i (ffloor d))
	(setq fd (+ d (- i)))
	(if (< (abs (+ fd -1.0))
	       1.0e-10)
	    (progn
	      (setq fd 0.0)
	      (setq i (+ i 1)))
	  )
	(setq a (+ (ffloor (+ (/ i 36524.25) 0.99835726))
		   14))
	(setq i (+ i 1 a
		   (- (ffloor (/ a 4.0)))))
	(setq b (ffloor (+ (/ i 365.25) 0.802601)))
	(setq c (+ i (- (ffloor (+ (* 365.25 b)
				  0.750001)))
		   416))
	(setq g (ffloor (/ c 30.6001)))
	(setq day (ffloor (+ c
			    (- (ffloor (* 30.6001 g)))
			    fd)))
	(if (> g 13.5)
	    (setq month (+ g -13))
	  (setq month (+ g -1)))
	(if (> month 2.5)
	    (setq year (+ b 1899))
	  (setq year (+ b 1900)))
	(setq julianday (+ julianday 2415020))
	(setq b (* (ftruncate (/ (+ julianday 1.5) 7))
		   7))
	(setq dayofweek (+ 1
			   (ftruncate (+ julianday 1.5 (- b)))
			   ))
;;	(list dayofweek
;;	      (* fd 24) 
;;	      month 
;;	      day 
;;	      year))
	(list month 
	      day 
	      year))
       )
   )
)

(defun calendar-correlate-from-julianday (julianday)
  (let ((date-proleptic (calendar-proleptic-gregorian-from-julianday julianday))
	(date-gregorian (calendar-gregorian-from-julianday julianday)))
    (list date-proleptic date-gregorian))
)

(defun calendar-correlate-from-date (date)
  (let ((jd-proleptic (calendar-julianday-from-proleptic-gregorian date))
	(jd-gregorian (calendar-julianday-from-gregorian date)))
    (list jd-proleptic jd-gregorian))
)