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