Converting to racket and with contracts
original commit: 581458f0be2d6adf04933b00515643c6e383087a
This commit is contained in:
parent
7e00a44f62
commit
e2aeb764f6
|
@ -1,61 +1,28 @@
|
|||
#lang racket/base
|
||||
(require racket/promise
|
||||
racket/contract)
|
||||
|
||||
(module date mzscheme
|
||||
(provide/contract
|
||||
[date->string ((date?) (boolean?) . ->* . string?)]
|
||||
[date-display-format (parameter/c (symbols 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))]
|
||||
[find-seconds ((integer-in 0 61)
|
||||
(integer-in 0 59)
|
||||
(integer-in 0 23)
|
||||
(integer-in 1 31)
|
||||
(integer-in 1 12)
|
||||
exact-nonnegative-integer?
|
||||
. -> .
|
||||
exact-integer?)]
|
||||
[date->julian/scalinger (date? . -> . exact-integer?)]
|
||||
[julian/scalinger->string (exact-integer? . -> . string?)])
|
||||
|
||||
(require "list.rkt")
|
||||
;; Support for Julian calendar added by Shriram;
|
||||
;; current version only works until 2099 CE Gregorian
|
||||
|
||||
(provide date->string
|
||||
date-display-format
|
||||
find-seconds
|
||||
(define date-display-format
|
||||
(make-parameter 'american))
|
||||
|
||||
date->julian/scalinger
|
||||
julian/scalinger->string)
|
||||
|
||||
|
||||
;; Support for Julian calendar added by Shriram;
|
||||
;; current version only works until 2099 CE Gregorian
|
||||
|
||||
#|
|
||||
|
||||
(define-primitive seconds->date (num -> structure:date))
|
||||
(define-primitive current-seconds (-> num))
|
||||
(define-primitive date-second (structure:date -> num))
|
||||
(define-primitive date-minute (structure:date -> num))
|
||||
(define-primitive date-hour (structure:date -> num))
|
||||
(define-primitive date-day (structure:date -> num))
|
||||
(define-primitive date-month (structure:date -> num))
|
||||
(define-primitive date-year (structure:date -> num))
|
||||
(define-primitive date-week-day (structure:date -> num))
|
||||
(define-primitive date-year-day (structure:date -> num))
|
||||
(define-primitive date-dst? (structure:date -> bool))
|
||||
(define-primitive make-date (num num num num num num num num bool ->
|
||||
structure:date))
|
||||
(define-primitive expr->string (a -> string))
|
||||
(define-primitive foldl (case->
|
||||
((a z -> z) z (listof a) -> z)
|
||||
((a b z -> z) z (listof a) (listof b) -> z)
|
||||
((a b c z -> z) z (listof a) (listof b) (listof c) -> z)
|
||||
(((arglistof x) ->* z) z (listof (arglistof x)) ->* z)))
|
||||
(define-primitive foldr (case->
|
||||
((a z -> z) z (listof a) -> z)
|
||||
((a b z -> z) z (listof a) (listof b) -> z)
|
||||
((a b c z -> z) z (listof a) (listof b) (listof c) -> z)
|
||||
(((arglistof x) ->* z) z (listof (arglistof x)) ->* z)))
|
||||
|
||||
|#
|
||||
|
||||
(define legal-formats
|
||||
(list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))
|
||||
|
||||
(define date-display-format
|
||||
(make-parameter 'american
|
||||
(lambda (s)
|
||||
(unless (memq s legal-formats)
|
||||
(raise-type-error 'date-display-format
|
||||
(format "symbol in ~a" legal-formats)
|
||||
s))
|
||||
s)))
|
||||
|
||||
(define month/number->string
|
||||
(define month/number->string
|
||||
(lambda (x)
|
||||
(case x
|
||||
[(12) "December"] [(1) "January"] [(2) "February"]
|
||||
|
@ -64,7 +31,7 @@
|
|||
[(9) "September"] [(10) "October"] [(11) "November"]
|
||||
[else ""])))
|
||||
|
||||
(define day/number->string
|
||||
(define day/number->string
|
||||
(lambda (x)
|
||||
(case x
|
||||
[(0) "Sunday"]
|
||||
|
@ -76,7 +43,7 @@
|
|||
[(6) "Saturday"]
|
||||
[else ""])))
|
||||
|
||||
(define date->string
|
||||
(define date->string
|
||||
(case-lambda
|
||||
[(date) (date->string date #f)]
|
||||
[(date time?)
|
||||
|
@ -174,16 +141,16 @@
|
|||
(append day time)
|
||||
day))))]))
|
||||
|
||||
(define leap-year?
|
||||
(define leap-year?
|
||||
(lambda (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
|
||||
(define-struct date-offset (second minute hour day year))
|
||||
;; it's not clear what months mean in this context -- use days
|
||||
(define-struct date-offset (second minute hour day year))
|
||||
|
||||
(define date-
|
||||
(define date-
|
||||
(lambda (date1 date2)
|
||||
(let* ((second (- (date-second date1) (date-second date2)))
|
||||
(minute (+ (- (date-minute date1) (date-minute date2))
|
||||
|
@ -205,7 +172,7 @@
|
|||
year))))
|
||||
|
||||
|
||||
(define date-offset->string
|
||||
(define date-offset->string
|
||||
(let ((first car)
|
||||
(second cadr))
|
||||
(case-lambda
|
||||
|
@ -242,7 +209,7 @@
|
|||
""
|
||||
non-zero-fields)]))])))
|
||||
|
||||
(define days-per-month
|
||||
(define days-per-month
|
||||
(lambda (year month)
|
||||
(cond
|
||||
[(and (= month 2) (leap-year? year)) 29]
|
||||
|
@ -250,7 +217,7 @@
|
|||
[(<= month 7) (+ 30 (modulo month 2))]
|
||||
[else (+ 30 (- 1 (modulo month 2)))])))
|
||||
|
||||
(define find-extreme-date-seconds
|
||||
(define find-extreme-date-seconds
|
||||
(lambda (start offset)
|
||||
(let/ec found
|
||||
(letrec ([find-between
|
||||
|
@ -276,16 +243,16 @@
|
|||
; 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))])
|
||||
(lambda ()
|
||||
(force d))))
|
||||
(define get-max-seconds
|
||||
(define get-max-seconds
|
||||
(let ([d (delay (find-extreme-date-seconds (current-seconds) 1))])
|
||||
(lambda ()
|
||||
(force d))))
|
||||
|
||||
(define find-seconds
|
||||
(define find-seconds
|
||||
(lambda (sec min hour day month year)
|
||||
(let ([signal-error
|
||||
(lambda (msg)
|
||||
|
@ -325,12 +292,12 @@
|
|||
[(eq? compare 'test-smaller)
|
||||
(loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))))
|
||||
|
||||
;; date->julian/scalinger :
|
||||
;; date -> number [julian-day]
|
||||
;; date->julian/scalinger :
|
||||
;; date -> number [julian-day]
|
||||
|
||||
;; 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))
|
||||
(month (date-month date))
|
||||
(year (date-year date)))
|
||||
|
@ -362,10 +329,10 @@
|
|||
gregorian-adjustment)))
|
||||
final-date)))))))))))
|
||||
|
||||
;; julian/scalinger->string :
|
||||
;; number [julian-day] -> string [julian-day-format]
|
||||
;; julian/scalinger->string :
|
||||
;; number [julian-day] -> string [julian-day-format]
|
||||
|
||||
(define (julian/scalinger->string julian-day)
|
||||
(define (julian/scalinger->string julian-day)
|
||||
(apply string-append
|
||||
(cons "JD "
|
||||
(reverse
|
||||
|
@ -386,6 +353,3 @@
|
|||
(cadr reversed-digits)
|
||||
(car reversed-digits)))
|
||||
(loop (cdr (cdr (cdr reversed-digits))))))))))))
|
||||
|
||||
)
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user