suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Using modern style a little

Browse Source 
original commit: 991e2a4064b48402dc272f5cad40be50c560fd08
This commit is contained in:
Jay McCarthy 2010-05-24 13:56:43 -06:00
parent e2aeb764f6
commit 1f7868ea09
1 changed files with 275 additions and 279 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

554
collects/mzlib/date.rkt
View File

@ -1,5 +1,8 @@
#lang racket/base #lang racket/base
(require racket/promise (require racket/promise
racket/match
racket/list
racket/function
racket/contract) racket/contract)
(provide/contract (provide/contract
@ -22,226 +25,218 @@
(define date-display-format (define date-display-format
(make-parameter 'american)) (make-parameter 'american))
(define month/number->string (define (month/number->string x)
(lambda (x) (case x
(case x [(12) "December"] [(1) "January"] [(2) "February"]
[(12) "December"] [(1) "January"] [(2) "February"] [(3) "March"] [(4) "April"] [(5) "May"]
[(3) "March"] [(4) "April"] [(5) "May"] [(6) "June"] [(7) "July"] [(8) "August"]
[(6) "June"] [(7) "July"] [(8) "August"] [(9) "September"] [(10) "October"] [(11) "November"]
[(9) "September"] [(10) "October"] [(11) "November"] [else ""]))
[else ""])))
(define day/number->string (define (day/number->string x)
(lambda (x) (case x
(case x [(0) "Sunday"]
[(0) "Sunday"] [(1) "Monday"]
[(1) "Monday"] [(2) "Tuesday"]
[(2) "Tuesday"] [(3) "Wednesday"]
[(3) "Wednesday"] [(4) "Thursday"]
[(4) "Thursday"] [(5) "Friday"]
[(5) "Friday"] [(6) "Saturday"]
[(6) "Saturday"] [else ""]))
[else ""])))
(define date->string (define (add-zero n)
(case-lambda (if (< n 10)
[(date) (date->string date #f)] (string-append "0" (number->string n))
[(date time?) (number->string n)))
(let* ((add-zero (lambda (n) (if (< n 10)
(string-append "0" (number->string n))
(number->string n))))
(year (number->string (date-year date)))
(num-month (number->string (date-month date)))
(week-day (day/number->string (date-week-day date)))
(week-day-num (date-week-day date))
(month (month/number->string (date-month date)))
(day (number->string (date-day date)))
(day-th (if (<= 11 (date-day date) 13)
"th"
(case (modulo (date-day date) 10)
[(1) "st"]
[(2) "nd"]
[(3) "rd"]
[(0 4 5 6 7 8 9) "th"])))
(hour (date-hour date))
(am-pm (if (>= hour 12) "pm" "am"))
(hour24 (add-zero hour))
(hour12 (number->string
(cond
[(zero? hour) 12]
[(> hour 12) (- hour 12)]
[else hour])))
(minute (add-zero (date-minute date)))
(second (add-zero (date-second date))))
(let-values
([(day time)
(case (date-display-format)
[(american)
(values (list week-day ", " month " " day day-th ", " year)
(list " " hour12 ":" minute ":" second am-pm))]
[(chinese)
(values
(list year "/" num-month "/" day
" \u661F\u671F" (case (date-week-day date)
[(0) "\u5929"]
[(1) "\u4E00"]
[(2) "\u4E8C"]
[(3) "\u4e09"]
[(4) "\u56DB"]
[(5) "\u4E94"]
[(6) "\u516D"]
[else ""]))
(list " " hour24 ":" minute ":" second))]
[(indian)
(values (list day "-" num-month "-" year)
(list " " hour12 ":" minute ":" second am-pm))]
[(german)
(values (list day ". "
(case (date-month date)
[(1) "Januar"]
[(2) "Februar"]
[(3) "M\344rz"]
[(4) "April"]
[(5) "Mai"]
[(6) "Juni"]
[(7) "Juli"]
[(8) "August"]
[(9) "September"]
[(10) "Oktober"]
[(11) "November"]
[(12) "Dezember"]
[else ""])
" " year)
(list ", " hour24 "." minute))]
[(irish)
(values (list week-day ", " day day-th " " month " " year)
(list ", " hour12 ":" minute am-pm))]
[(julian)
(values (list (julian/scalinger->string
(date->julian/scalinger date)))
(list ", " hour24 ":" minute ":" second))]
[(iso-8601)
(values
(list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date)))
(list " " hour24 ":" minute ":" second))]
[(rfc2822)
(values
(list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year)
(list* " " hour24 ":" minute ":" second " "
(let* ([delta (date-time-zone-offset date)]
[hours (quotient delta 3600)]
[minutes (modulo (quotient delta 60) 60)])
(list
(if (negative? delta) "-" "+")
(add-zero (abs hours))
(add-zero minutes)))))]
[else (error 'date->string "unknown date-display-format: ~s"
(date-display-format))])])
(apply string-append (if time?
(append day time)
day))))]))
(define leap-year? (define (date->string date [time? #f])
(lambda (year) (define year (number->string (date-year date)))
(or (= 0 (modulo year 400)) (define num-month (number->string (date-month date)))
(and (= 0 (modulo year 4)) (define week-day (day/number->string (date-week-day date)))
(not (= 0 (modulo year 100))))))) (define week-day-num (date-week-day date))
(define month (month/number->string (date-month date)))
(define day (number->string (date-day date)))
(define day-th
(if (<= 11 (date-day date) 13)
"th"
(case (modulo (date-day date) 10)
[(1) "st"]
[(2) "nd"]
[(3) "rd"]
[(0 4 5 6 7 8 9) "th"])))
(define hour (date-hour date))
(define am-pm (if (>= hour 12) "pm" "am"))
(define hour24 (add-zero hour))
(define hour12
(number->string
(cond
[(zero? hour) 12]
[(> hour 12) (- hour 12)]
[else hour])))
(define minute (add-zero (date-minute date)))
(define second (add-zero (date-second date)))
(define-values
(day-strs time-strs)
(case (date-display-format)
[(american)
(values (list week-day ", " month " " day day-th ", " year)
(list " " hour12 ":" minute ":" second am-pm))]
[(chinese)
(values
(list year "/" num-month "/" day
" \u661F\u671F" (case (date-week-day date)
[(0) "\u5929"]
[(1) "\u4E00"]
[(2) "\u4E8C"]
[(3) "\u4e09"]
[(4) "\u56DB"]
[(5) "\u4E94"]
[(6) "\u516D"]
[else ""]))
(list " " hour24 ":" minute ":" second))]
[(indian)
(values (list day "-" num-month "-" year)
(list " " hour12 ":" minute ":" second am-pm))]
[(german)
(values (list day ". "
(case (date-month date)
[(1) "Januar"]
[(2) "Februar"]
[(3) "M\344rz"]
[(4) "April"]
[(5) "Mai"]
[(6) "Juni"]
[(7) "Juli"]
[(8) "August"]
[(9) "September"]
[(10) "Oktober"]
[(11) "November"]
[(12) "Dezember"]
[else ""])
" " year)
(list ", " hour24 "." minute))]
[(irish)
(values (list week-day ", " day day-th " " month " " year)
(list ", " hour12 ":" minute am-pm))]
[(julian)
(values (list (julian/scalinger->string
(date->julian/scalinger date)))
(list ", " hour24 ":" minute ":" second))]
[(iso-8601)
(values
(list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date)))
(list " " hour24 ":" minute ":" second))]
[(rfc2822)
(values
(list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year)
(list* " " hour24 ":" minute ":" second " "
(let* ([delta (date-time-zone-offset date)]
[hours (quotient delta 3600)]
[minutes (modulo (quotient delta 60) 60)])
(list
(if (negative? delta) "-" "+")
(add-zero (abs hours))
(add-zero minutes)))))]
[else (error 'date->string "unknown date-display-format: ~s"
(date-display-format))]))
(apply string-append
(if time?
(append day-strs time-strs)
day-strs)))
(define (leap-year? year)
(or (= 0 (modulo year 400))
(and (= 0 (modulo year 4))
(not (= 0 (modulo year 100))))))
;; it's not clear what months mean in this context -- use days ;; it's not clear what months mean in this context -- use days
(define-struct date-offset (second minute hour day year)) (define-struct date-offset (second minute hour day year))
(define date- (define (fixup s x) (if (< s 0) (+ s x) s))
(lambda (date1 date2) (define (date- date1 date2)
(let* ((second (- (date-second date1) (date-second date2))) (define second (- (date-second date1) (date-second date2)))
(minute (+ (- (date-minute date1) (date-minute date2)) (define minute
(if (< second 0) -1 0))) (+ (- (date-minute date1) (date-minute date2))
(hour (+ (- (date-hour date1) (date-hour date2)) (if (< second 0) -1 0)))
(if (< minute 0) -1 0) (define hour
(cond [(equal? (date-dst? date1) (date-dst? date2)) 0] (+ (- (date-hour date1) (date-hour date2))
[(date-dst? date1) -1] (if (< minute 0) -1 0)
[(date-dst? date2) 1]))) (cond [(equal? (date-dst? date1) (date-dst? date2)) 0]
(day (+ (- (date-year-day date1) (date-year-day date2)) [(date-dst? date1) -1]
(if (< hour 0) -1 0))) [(date-dst? date2) 1])))
(year (+ (- (date-year date1) (date-year date2)) (define day
(if (< day 0) -1 0))) (+ (- (date-year-day date1) (date-year-day date2))
(fixup (lambda (s x) (if (< s 0) (+ s x) s)))) (if (< hour 0) -1 0)))
(make-date-offset (fixup second 60) (define year
(fixup minute 60) (+ (- (date-year date1) (date-year date2))
(fixup hour 24) (if (< day 0) -1 0)))
(fixup day (if (leap-year? (date-year date1)) 366 365)) (make-date-offset
year)))) (fixup second 60)
(fixup minute 60)
(fixup hour 24)
(fixup day (if (leap-year? (date-year date1)) 366 365))
year))
(define (one-entry b)
(string-append
(number->string (first b))
" "
(second b)
(if (= 1 (first b)) "" "s")))
(define (date-offset->string date [seconds? #f])
(define fields
(list (list (date-offset-year date) "year")
(list (date-offset-day date) "day")
(list (date-offset-hour date) "hour")
(list (date-offset-minute date) "minute")
(list (if seconds? (date-offset-second date) 0) "second")))
(define non-zero-fields
(filter (negate (compose (curry = 0) first)) fields))
(match non-zero-fields
[(list) ""]
[(list one) (one-entry one)]
[_
(for/fold ([string ""])
([b (in-list non-zero-fields)])
(cond
[(= 0 (first b)) string]
[(string=? string "")
(string-append "and "
(one-entry b)
string)]
[else (string-append (one-entry b) ", " string)]))]))
(define date-offset->string (define (days-per-month year month)
(let ((first car) (cond
(second cadr)) [(and (= month 2) (leap-year? year)) 29]
(case-lambda [(= month 2) 28]
[(date) (date-offset->string date #f)] [(<= month 7) (+ 30 (modulo month 2))]
[(date seconds?) [else (+ 30 (- 1 (modulo month 2)))]))
(let* ((fields (list (list (date-offset-year date) "year")
(list (date-offset-day date) "day")
(list (date-offset-hour date) "hour")
(list (date-offset-minute date) "minute")
(list (if seconds? (date-offset-second date) 0) "second")))
(non-zero-fields (foldl (lambda (x l)
(if (= 0 (first x))
l
(cons x l)))
null
fields))
(one-entry (lambda (b)
(string-append
(number->string (first b))
" "
(second b)
(if (= 1 (first b)) "" "s")))))
(cond
[(null? non-zero-fields) ""]
[(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))]
[else (foldl (lambda (b string)
(cond
[(= 0 (first b)) string]
[(string=? string "")
(string-append "and "
(one-entry b)
string)]
[else (string-append (one-entry b) ", " string)]))
""
non-zero-fields)]))])))
(define days-per-month (define (find-extreme-date-seconds start offset)
(lambda (year month) (let/ec found
(cond (letrec ([find-between
[(and (= month 2) (leap-year? year)) 29] (lambda (lo hi)
[(= month 2) 28] (let ([mid (floor (/ (+ lo hi) 2))])
[(<= month 7) (+ 30 (modulo month 2))] (if (or (and (positive? offset) (= lo mid))
[else (+ 30 (- 1 (modulo month 2)))]))) (and (negative? offset) (= hi mid)))
(found lo)
(define find-extreme-date-seconds (let ([mid-ok?
(lambda (start offset) (with-handlers ([exn:fail? (lambda (exn) #f)])
(let/ec found (seconds->date mid)
(letrec ([find-between #t)])
(lambda (lo hi) (if mid-ok?
(let ([mid (floor (/ (+ lo hi) 2))]) (find-between mid hi)
(if (or (and (positive? offset) (= lo mid)) (find-between lo mid))))))])
(and (negative? offset) (= hi mid))) (let loop ([lo start][offset offset])
(found lo) (let ([hi (+ lo offset)])
(let ([mid-ok? (with-handlers ([exn:fail?
(with-handlers ([exn:fail? (lambda (exn) #f)]) (lambda (exn)
(seconds->date mid) ; failed - must be between lo & hi
#t)]) (find-between lo hi))])
(if mid-ok? (seconds->date hi))
(find-between mid hi) ; succeeded; double offset again
(find-between lo mid))))))]) (loop hi (* 2 offset)))))))
(let loop ([lo start][offset offset])
(let ([hi (+ lo offset)])
(with-handlers ([exn:fail?
(lambda (exn)
; failed - must be between lo & hi
(find-between lo hi))])
(seconds->date hi))
; succeeded; double offset again
(loop hi (* 2 offset))))))))
(define get-min-seconds (define get-min-seconds
(let ([d (delay (find-extreme-date-seconds (current-seconds) -1))]) (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))])
@ -252,45 +247,43 @@
(lambda () (lambda ()
(force d)))) (force d))))
(define find-seconds (define (find-seconds sec min hour day month year)
(lambda (sec min hour day month year) (define (signal-error msg)
(let ([signal-error (error 'find-secs (string-append
(lambda (msg) msg
(error 'find-secs (string-append " (inputs: ~a ~a ~a ~a ~a ~a)")
msg sec min hour day month year))
" (inputs: ~a ~a ~a ~a ~a ~a)") (let loop ([below-secs (get-min-seconds)]
sec min hour day month year))]) [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))]
(let loop ([below-secs (get-min-seconds)] [above-secs (get-max-seconds)])
[secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))] (let* ([date (seconds->date secs)]
[above-secs (get-max-seconds)]) [compare
(let* ([date (seconds->date secs)] (let loop ([inputs (list year month day
[compare hour min sec)]
(let loop ([inputs (list year month day [tests (list (date-year date)
hour min sec)] (date-month date)
[tests (list (date-year date) (date-day date)
(date-month date) (date-hour date)
(date-day date) (date-minute date)
(date-hour date) (date-second date))])
(date-minute date) (cond
(date-second date))]) [(null? inputs) 'equal]
(cond [else (let ([input (car inputs)]
[(null? inputs) 'equal] [test (car tests)])
[else (let ([input (car inputs)] (if (= input test)
[test (car tests)]) (loop (cdr inputs) (cdr tests))
(if (= input test) (if (<= input test)
(loop (cdr inputs) (cdr tests)) 'input-smaller
(if (<= input test) 'test-smaller)))]))])
'input-smaller ; (printf "~a ~a ~a~n" compare secs (date->string date))
'test-smaller)))]))]) (cond
; (printf "~a ~a ~a~n" compare secs (date->string date)) [(eq? compare 'equal) secs]
(cond [(or (= secs below-secs) (= secs above-secs))
[(eq? compare 'equal) secs] (signal-error "non-existent date")]
[(or (= secs below-secs) (= secs above-secs)) [(eq? compare 'input-smaller)
(signal-error "non-existent date")] (loop below-secs (floor (/ (+ secs below-secs) 2)) secs)]
[(eq? compare 'input-smaller) [(eq? compare 'test-smaller)
(loop below-secs (floor (/ (+ secs below-secs) 2)) secs)] (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))
[(eq? compare 'test-smaller)
(loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))))
;; date->julian/scalinger : ;; date->julian/scalinger :
;; date -> number [julian-day] ;; date -> number [julian-day]
@ -298,36 +291,39 @@
;; Note: This code is correct until 2099 CE Gregorian ;; Note: This code is correct until 2099 CE Gregorian
(define (date->julian/scalinger date) (define (date->julian/scalinger date)
(let ((day (date-day date)) (define day (date-day date))
(month (date-month date)) (define month (date-month date))
(year (date-year date))) (define d-year (date-year date))
(let ((year (+ 4712 year))) (define year (+ 4712 d-year))
(let ((year (if (< month 3) (sub1 year) year))) (define adj-year (if (< month 3) (sub1 year) year))
(let ((cycle-number (quotient year 4)) (define cycle-number (quotient adj-year 4))
(cycle-position (remainder year 4))) (define cycle-position (remainder adj-year 4))
(let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position)))) (define base-day (+ (* 1461 cycle-number) (* 365 cycle-position)))
(let ((month-day-number (case month (define month-day-number
((3) 0) (case month
((4) 31) ((3) 0)
((5) 61) ((4) 31)
((6) 92) ((5) 61)
((7) 122) ((6) 92)
((8) 153) ((7) 122)
((9) 184) ((8) 153)
((10) 214) ((9) 184)
((11) 245) ((10) 214)
((12) 275) ((11) 245)
((1) 306) ((12) 275)
((2) 337)))) ((1) 306)
(let ((total-days (+ base-day month-day-number day))) ((2) 337)))
(let ((total-days/march-adjustment (+ total-days 59))) (define total-days (+ base-day month-day-number day))
(let ((gregorian-adjustment (cond (define total-days/march-adjustment (+ total-days 59))
((< year 1700) 11) (define gregorian-adjustment
((< year 1800) 12) (cond
(else 13)))) ((< adj-year 1700) 11)
(let ((final-date (- total-days/march-adjustment ((< adj-year 1800) 12)
gregorian-adjustment))) (else 13)))
final-date))))))))))) (define final-date
(- total-days/march-adjustment
gregorian-adjustment))
final-date)
;; julian/scalinger->string : ;; julian/scalinger->string :
;; number [julian-day] -> string [julian-day-format] ;; number [julian-day] -> string [julian-day-format]