Code: Select all
; julian day = 0 on monday 1 january 4713 B.C. (-4712 1 1)
;; @syntax (gdate-julian gdate)
;; @description Convert gregorian date to julian day number (valid only from 15 ottobre 1582 A.D.)
;; @param <gdate> gregorian date (year month day)
;; @return julian day number (int)
;; @example
;; (gdate-julian '(2019 11 11)) ==> 2458799
;; (gdate-julian '(2019 11 12)) ==> 2458800
;; (gdate-julian '(-4712 1 1)) ==> 38
(define (gdate-julian gdate)
(local (a y m)
(setq a (/ (- 14 (gdate 1)) 12))
(setq y (+ (gdate 0) 4800 (- a)))
(setq m (+ (gdate 1) (* 12 a) (- 3)))
(+ (gdate 2) (/ (+ (* 153 m) 2) 5) (* y 365) (/ y 4) (- (/ y 100)) (/ y 400) (- 32045))))
;; @syntax (jdate-julian jdate)
;; @description Convert julian date to julian day number (valid only until 4 ottobre 1582 A.D.)
;; @param <jdate> julian date (year month day)
;; @return julian day number (int)
;; @example
;; (jdate-julian '(2019 11 11)) ==> 2458812
;; (jdate-julian '(2019 11 12)) ==> 2458813
;; (jdate-julian '(-4712 1 1)) ==> 0
(define (jdate-julian jdate)
(local (a y m)
(setq a (/ (- 14 (jdate 1)) 12))
(setq y (+ (jdate 0) 4800 (- a)))
(setq m (+ (jdate 1) (* 12 a) (- 3)))
(+ (jdate 2) (/ (+ (* 153 m) 2) 5) (* y 365) (/ y 4) (- 32083))))
;; @syntax (julian-gdate jd)
;; @description Convert julian day number to gregorian date (valid only from 15 ottobre 1582 A.D.)
;; @param <jd> julian day number (int)
;; @return gregorian date (year month day)
;; @example
;; (julian-gdate 2458799) ==> (2019 11 11)
;; (julian-gdate 2458800) ==> (2019 11 12)
;; (julian-gdate (gdate-julian '(2019 11 12))) ==> (2019 11 12)
(define (julian-gdate jd)
(local (a b c d e m)
(setq a (+ jd 32044))
(setq b (/ (+ (* 4 a) 3) 146097))
(setq c (- a (/ (* b 146097) 4)))
(setq d (/ (+ (* 4 c) 3) 1461))
(setq e (- c (/ (* 1461 d) 4)))
(setq m (/ (+ (* 5 e) 2) 153))
(list
(+ (* b 100) d (- 4800) (/ m 10))
(+ m 3 (- (* 12 (/ m 10))))
(+ e (- (/ (+ (* 153 m) 2) 5)) 1))))
;; @syntax (julian-jdate jd)
;; @description Convert julian day number to julian date (valid only until 4 ottobre 1582 A.D.)
;; @param <jd> julian day number (int)
;; @return julian date (year month day)
;; @example
;; (julian-jdate 2458812) ==> (2019 11 11)
;; (julian-jdate 2458813) ==> (2019 11 12)
;; (julian-jdate 0) ==> (-4712 1 1)
(define (julian-jdate jd)
(local (a b c d e m)
(setq a 0)
(setq b 0)
(setq c (+ jd 32082))
(setq d (/ (+ (* 4 c) 3) 1461))
(setq e (- c (/ (* 1461 d) 4)))
(setq m (/ (+ (* 5 e) 2) 153))
(list
(+ (* b 100) d (- 4800) (/ m 10))
(+ m 3 (- (* 12 (/ m 10))))
(+ e (- (/ (+ (* 153 m) 2) 5)) 1))))
;; @syntax (julian-weekday jd)
;; @description Find the day of week (number) of a julian day number
;; @param <jd> julian day number (int)
;; @return day of week number (ISO: Mon=1 ... Sun=7) (int)
;; @example
;; (julian-weekday (gdate-julian '(1900 3 15))) ==> 4
;; (julian-weekday (gdate-julian '(1821 5 5))) ==> 6
;; (julian-weekday (jdate-julian '(1400 1 1))) ==> 4
(define (julian-weekday jd) (+ (% jd 7) 1))
;; @syntax (gdate-diff gdate1 gdate2)
;; @description Calculate the difference between two gregorian dates
;; @param <gdate1> first gregorian date (year month day)
;; @param <gdate2> second gregorian date (year month day)
;; @return (date1 - date2 = interval of days) (int)
;; @example
;; (gdate-diff '(2012 11 28) '(2010 4 22)) ==> 951
(define (gdate-diff gdate1 gdate2)
(- (gdate-julian gdate1) (gdate-julian gdate2)))
;; @syntax (gdate-add gdate num-days)
;; @description Adds days to a gregorian date
;; @param <gdate> gregorian date (year month day)
;; @param <num-days> days to add (int)
;; @return gregorian date (year month day)
;; @example (gdate-add '(1980 3 15) 10) ==> (1980 3 25)
(define (gdate-add gdate num-days)
(julian-gdate (+ (gdate-julian gdate) num-days)))
;; @syntax (gdate-sub gdate num-days)
;; @description Subtracts days from a gregorian date
;; @param <gdate> gregorian date (year month day)
;; @param <num-days> days to sub (int)
;; @return gregorian date (year month day)
;; @example
;; (gdate-sub '(1980 3 15) 31) ==> (1980 2 13)
(define (gdate-sub gdate num-days)
(julian-gdate (- (gdate-julian gdate) num-days)))