lib/date-utils.rkt
#lang racket

(require racket/date)

(provide add-day add1-month sub1-month add-year)

(define (add-day the-date days)
  (seconds->date (+ (date->seconds the-date) (* days 60 60 24))))

(define (count-up-day year month day)
  (let ([v-year year]
        [v-month month]
        [v-day day])
    (set! v-day (add1 day))
    (when (= v-day 32)
      (begin
        (set! v-day 1)
        (set! v-month (add1 month))
        (when (= v-month 13)
          (set! v-month 1)
          (set! v-year (add1 year)))))
    (values v-year v-month v-day)))

(define (count-down-day year month day)
  (let ([v-year year]
        [v-month month]
        [v-day day])
    (set! v-day (sub1 day))
    (when (= v-day 0)
      (begin
        (set! v-day 31)
        (set! v-month (sub1 month))
        (when (= v-month 0)
          (set! v-month 12)
          (set! v-year (sub1 year)))))
    (values v-year v-month v-day)))
     
(define (find-exists-date year month day #:align align)
  (with-handlers
      ([exn:fail?
        (lambda (exn)
          (if (eq? align 'down)
              (let-values ([(l-year l-month l-day) (count-down-day year month day)])
                (find-exists-date l-year l-month l-day #:align align))
              (let-values ([(l-year l-month l-day) (count-up-day year month day)])
                (find-exists-date l-year l-month l-day #:align align))))])
    (seconds->date (find-seconds 0 0 0 day month year))))

(define (add1-month the-date #:align [align 'down])
  (let ([new-month (add1 (date-month the-date))])
    (if (= new-month 13)
        (find-exists-date (add1 (date-year the-date)) 1 (date-day the-date) #:align align)
        (find-exists-date (date-year the-date) new-month (date-day the-date) #:align align))))

(define (sub1-month the-date #:align [align 'down])
  (let ([new-month (sub1 (date-month the-date))])
    (if (= new-month 0)
        (find-exists-date (sub1 (date-year the-date)) 12 (date-day the-date) #:align align)
        (find-exists-date (date-year the-date) new-month (date-day the-date) #:align align))))

(define (add-year the-date years #:align [align 'down])
    (find-exists-date (+ (date-year the-date) years) (date-month the-date) (date-day the-date) #:align align))