(require (lib "frtime.ss" "frtime") (lib "list.ss") (lib "etc.ss")) ;// Absolute dates ; ;// "Absolute date" means the number of days elapsed since the Gregorian date ;// Sunday, December 31, 1 BC. (Since there was no year 0, the year following ;// 1 BC is 1 AD.) Thus the Gregorian date January 1, 1 AD is absolute date ;// number 1. ; ;// Absolute date of the x-day on or before absolute date d. ;// x=0 means Sunday, x=1 means Monday, and so on. (define (Kday-on-or-before d k) (- d (remainder (- d k) 7))) ;leap-year : number -> boolean (define (leap-year? year) (or (and (= (remainder year 4) 0) (not (= (remainder year 100) 0))) (= (remainder year 400) 0)) ) ;(leap-year? 1988) true ;(leap-year? 1900) false ;(leap-year? 2000) true ;last-day-of-gregorian-month : number number -> number [1..31] ;determines the last day of a given month and year. (define (last-day-of-gregorian-month month year) (let ((year (inexact->exact (truncate year)))) ;// Compute the last date of the month for the Gregorian calendar. (case month ((2) (if (leap-year? year) 29 28)) ((4 6 9 11) 30) (else 31)))) ;(LastDayOfGregorianMonth 8 2006) 31 ;(LastDayOfGregorianMonth 9 2006) 30 ;(LastDayOfGregorianMonth 10 2006) 31 ;(LastDayOfGregorianMonth 11 2006) 30 ;(LastDayOfGregorianMonth 12 2006) 31 ;(LastDayOfGregorianMonth 1 2007) 31 ;(LastDayOfGregorianMonth 2 2007) 28 ;gregorian->absolute : (list number number number) -> number ; Computes the absolute date from the Gregorian date (define (gregorian->absolute gregorian) ; Computes the absolute date from the Gregorian date. (let* ( (day (car gregorian)) (year (caddr gregorian)) (months (filter (lambda(m) (< m (cadr gregorian))) (build-list 12 (lambda(x) (+ x 1))))) (N (foldr (lambda(m y) (+ (last-day-of-gregorian-month m year) y)) day months)) ) (+ N ;// days this year (* 365 (- year 1)) ;// days in previous years ignoring leap days (quotient (- year 1) 4 ) ; // Julian leap days before this year... (* -1 (quotient (- year 1) 100)) ;// ...minus prior century years... (quotient (- year 1) 400)); // ...plus prior years divisible by 400 ) ) (define date1 (gregorian->absolute '(1 1 2007))) (define date2 (gregorian->absolute '(29 1 2007))) (define date3 (gregorian->absolute '(28 2 2006))) (define date4 (gregorian->absolute '(1 3 2006))) (define date5 (gregorian->absolute '(14 3 2007))) (define date6 (gregorian->absolute '(28 6 2006))) (define date7 (gregorian->absolute '(5 9 2006))) (define date8 (gregorian->absolute '(12 12 2006))) (define date9 (gregorian->absolute '(31 12 2006))) (define (Nth-Kday n k month year) ;; Absolute date of the \$n\$th \$k\$day in Gregorian \$month\$, \$year\$. ;; If \$n\$<0, the \$n\$th \$k\$day from the end of month is returned ;; (that is, -1 is the last \$k\$day, -2 is the penultimate \$k\$day, ;; and so on). \$k=0\$ means Sunday, \$k=1\$ means Monday, and so on. (if (> n 0) ;; Then return (+ (Kday-on-or-before ;; First \$k\$day in month. (gregorian->absolute (list 7 month year)) k) (* 7 (sub1 n))) ;; Advance \$n-1\$ \$k\$days. ;; Else return (+ (Kday-on-or-before ;; Last \$k\$day in month. (gregorian->absolute (list (last-day-of-gregorian-month month year) month year)) k) (* 7 (add1 n))))) ;(absolute->gregorian (Nth-Kday 1 1 9 2006)) '(4 9 2006) ;(absolute->gregorian (Nth-Kday 2 2 9 2006)) '(12 9 2006) ;(absolute->gregorian (Nth-Kday -1 1 5 2007))) (define (absolute->year date year) (cond [(< date (gregorian->absolute (list 1 1 (+ year 1)))) year] [(>= date (gregorian->absolute (list 1 1 (+ year 1)))) (absolute->year date (add1 year))])) (define (absolute->month d month year) (cond [(<= d (gregorian->absolute (list (last-day-of-gregorian-month month year) month year))) month] [else (absolute->month d (add1 month) year)])) (define (absolute->day d month year) (+ (- d (gregorian->absolute (list 1 month year))) 1)) (define (absolute->gregorian d) (let* ( (approximate-year (quotient d 366)) (year (absolute->year d approximate-year)) (month (absolute->month d 1 year)) (day (absolute->day d month year)) ) (list day month year))) ;converts seconds to a (list day month year) (define (now->gregorian) (let ((today (seconds->date seconds))) (list (date-day today) (date-month today) (date-year today)))) (now->gregorian) ;this is a list of day month year for today's date (list 19 12 2006) ;this is a list of day month year for today's date as well (gregorian->absolute (list 19 12 2006)) ;this returns a value... (gregorian->absolute (now->gregorian)) ;this returns a different value... ;The problem is that given identical inputs, my program produces different outputs...