Some functions on dates

[cameyo]

Code Select Expand

; 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)))