diff --git a/collects/mzlib/date.rkt b/collects/mzlib/date.rkt
index 7274248..5c06ec5 100644
--- a/collects/mzlib/date.rkt
+++ b/collects/mzlib/date.rkt
@@ -1,391 +1,355 @@
+#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
-
- date->julian/scalinger
- julian/scalinger->string)
+(define date-display-format
+ (make-parameter 'american))
+
+(define month/number->string
+ (lambda (x)
+ (case x
+ [(12) "December"] [(1) "January"] [(2) "February"]
+ [(3) "March"] [(4) "April"] [(5) "May"]
+ [(6) "June"] [(7) "July"] [(8) "August"]
+ [(9) "September"] [(10) "October"] [(11) "November"]
+ [else ""])))
+
+(define day/number->string
+ (lambda (x)
+ (case x
+ [(0) "Sunday"]
+ [(1) "Monday"]
+ [(2) "Tuesday"]
+ [(3) "Wednesday"]
+ [(4) "Thursday"]
+ [(5) "Friday"]
+ [(6) "Saturday"]
+ [else ""])))
+
+(define date->string
+ (case-lambda
+ [(date) (date->string date #f)]
+ [(date time?)
+ (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?
+ (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))
+
+(define date-
+ (lambda (date1 date2)
+ (let* ((second (- (date-second date1) (date-second date2)))
+ (minute (+ (- (date-minute date1) (date-minute date2))
+ (if (< second 0) -1 0)))
+ (hour (+ (- (date-hour date1) (date-hour date2))
+ (if (< minute 0) -1 0)
+ (cond [(equal? (date-dst? date1) (date-dst? date2)) 0]
+ [(date-dst? date1) -1]
+ [(date-dst? date2) 1])))
+ (day (+ (- (date-year-day date1) (date-year-day date2))
+ (if (< hour 0) -1 0)))
+ (year (+ (- (date-year date1) (date-year date2))
+ (if (< day 0) -1 0)))
+ (fixup (lambda (s x) (if (< s 0) (+ s x) s))))
+ (make-date-offset (fixup second 60)
+ (fixup minute 60)
+ (fixup hour 24)
+ (fixup day (if (leap-year? (date-year date1)) 366 365))
+ year))))
- ;; 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
- (lambda (x)
- (case x
- [(12) "December"] [(1) "January"] [(2) "February"]
- [(3) "March"] [(4) "April"] [(5) "May"]
- [(6) "June"] [(7) "July"] [(8) "August"]
- [(9) "September"] [(10) "October"] [(11) "November"]
- [else ""])))
-
- (define day/number->string
- (lambda (x)
- (case x
- [(0) "Sunday"]
- [(1) "Monday"]
- [(2) "Tuesday"]
- [(3) "Wednesday"]
- [(4) "Thursday"]
- [(5) "Friday"]
- [(6) "Saturday"]
- [else ""])))
-
- (define date->string
+(define date-offset->string
+ (let ((first car)
+ (second cadr))
(case-lambda
- [(date) (date->string date #f)]
- [(date time?)
- (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?
- (lambda (year)
- (or (= 0 (modulo year 400))
- (and (= 0 (modulo year 4))
- (not (= 0 (modulo year 100)))))))
+ [(date) (date-offset->string date #f)]
+ [(date seconds?)
+ (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)]))])))
- ;; it's not clear what months mean in this context -- use days
- (define-struct date-offset (second minute hour day year))
+(define days-per-month
+ (lambda (year month)
+ (cond
+ [(and (= month 2) (leap-year? year)) 29]
+ [(= month 2) 28]
+ [(<= month 7) (+ 30 (modulo month 2))]
+ [else (+ 30 (- 1 (modulo month 2)))])))
- (define date-
- (lambda (date1 date2)
- (let* ((second (- (date-second date1) (date-second date2)))
- (minute (+ (- (date-minute date1) (date-minute date2))
- (if (< second 0) -1 0)))
- (hour (+ (- (date-hour date1) (date-hour date2))
- (if (< minute 0) -1 0)
- (cond [(equal? (date-dst? date1) (date-dst? date2)) 0]
- [(date-dst? date1) -1]
- [(date-dst? date2) 1])))
- (day (+ (- (date-year-day date1) (date-year-day date2))
- (if (< hour 0) -1 0)))
- (year (+ (- (date-year date1) (date-year date2))
- (if (< day 0) -1 0)))
- (fixup (lambda (s x) (if (< s 0) (+ s x) s))))
- (make-date-offset (fixup second 60)
- (fixup minute 60)
- (fixup hour 24)
- (fixup day (if (leap-year? (date-year date1)) 366 365))
- year))))
+(define find-extreme-date-seconds
+ (lambda (start offset)
+ (let/ec found
+ (letrec ([find-between
+ (lambda (lo hi)
+ (let ([mid (floor (/ (+ lo hi) 2))])
+ (if (or (and (positive? offset) (= lo mid))
+ (and (negative? offset) (= hi mid)))
+ (found lo)
+ (let ([mid-ok?
+ (with-handlers ([exn:fail? (lambda (exn) #f)])
+ (seconds->date mid)
+ #t)])
+ (if mid-ok?
+ (find-between mid hi)
+ (find-between lo mid))))))])
+ (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
+ (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))])
+ (lambda ()
+ (force d))))
+(define get-max-seconds
+ (let ([d (delay (find-extreme-date-seconds (current-seconds) 1))])
+ (lambda ()
+ (force d))))
- (define date-offset->string
- (let ((first car)
- (second cadr))
- (case-lambda
- [(date) (date-offset->string date #f)]
- [(date seconds?)
- (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 find-seconds
+ (lambda (sec min hour day month year)
+ (let ([signal-error
+ (lambda (msg)
+ (error 'find-secs (string-append
+ msg
+ " (inputs: ~a ~a ~a ~a ~a ~a)")
+ sec min hour day month year))])
+ (let loop ([below-secs (get-min-seconds)]
+ [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))]
+ [above-secs (get-max-seconds)])
+ (let* ([date (seconds->date secs)]
+ [compare
+ (let loop ([inputs (list year month day
+ hour min sec)]
+ [tests (list (date-year date)
+ (date-month date)
+ (date-day date)
+ (date-hour date)
+ (date-minute date)
+ (date-second date))])
+ (cond
+ [(null? inputs) 'equal]
+ [else (let ([input (car inputs)]
+ [test (car tests)])
+ (if (= input test)
+ (loop (cdr inputs) (cdr tests))
+ (if (<= input test)
+ 'input-smaller
+ 'test-smaller)))]))])
+ ; (printf "~a ~a ~a~n" compare secs (date->string date))
+ (cond
+ [(eq? compare 'equal) secs]
+ [(or (= secs below-secs) (= secs above-secs))
+ (signal-error "non-existent date")]
+ [(eq? compare 'input-smaller)
+ (loop below-secs (floor (/ (+ secs below-secs) 2)) secs)]
+ [(eq? compare 'test-smaller)
+ (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))))
- (define days-per-month
- (lambda (year month)
- (cond
- [(and (= month 2) (leap-year? year)) 29]
- [(= month 2) 28]
- [(<= month 7) (+ 30 (modulo month 2))]
- [else (+ 30 (- 1 (modulo month 2)))])))
+;; date->julian/scalinger :
+;; date -> number [julian-day]
- (define find-extreme-date-seconds
- (lambda (start offset)
- (let/ec found
- (letrec ([find-between
- (lambda (lo hi)
- (let ([mid (floor (/ (+ lo hi) 2))])
- (if (or (and (positive? offset) (= lo mid))
- (and (negative? offset) (= hi mid)))
- (found lo)
- (let ([mid-ok?
- (with-handlers ([exn:fail? (lambda (exn) #f)])
- (seconds->date mid)
- #t)])
- (if mid-ok?
- (find-between mid hi)
- (find-between lo mid))))))])
- (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))))))))
+;; Note: This code is correct until 2099 CE Gregorian
- (define get-min-seconds
- (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))])
- (lambda ()
- (force d))))
- (define get-max-seconds
- (let ([d (delay (find-extreme-date-seconds (current-seconds) 1))])
- (lambda ()
- (force d))))
+(define (date->julian/scalinger date)
+ (let ((day (date-day date))
+ (month (date-month date))
+ (year (date-year date)))
+ (let ((year (+ 4712 year)))
+ (let ((year (if (< month 3) (sub1 year) year)))
+ (let ((cycle-number (quotient year 4))
+ (cycle-position (remainder year 4)))
+ (let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position))))
+ (let ((month-day-number (case month
+ ((3) 0)
+ ((4) 31)
+ ((5) 61)
+ ((6) 92)
+ ((7) 122)
+ ((8) 153)
+ ((9) 184)
+ ((10) 214)
+ ((11) 245)
+ ((12) 275)
+ ((1) 306)
+ ((2) 337))))
+ (let ((total-days (+ base-day month-day-number day)))
+ (let ((total-days/march-adjustment (+ total-days 59)))
+ (let ((gregorian-adjustment (cond
+ ((< year 1700) 11)
+ ((< year 1800) 12)
+ (else 13))))
+ (let ((final-date (- total-days/march-adjustment
+ gregorian-adjustment)))
+ final-date)))))))))))
- (define find-seconds
- (lambda (sec min hour day month year)
- (let ([signal-error
- (lambda (msg)
- (error 'find-secs (string-append
- msg
- " (inputs: ~a ~a ~a ~a ~a ~a)")
- sec min hour day month year))])
- (let loop ([below-secs (get-min-seconds)]
- [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))]
- [above-secs (get-max-seconds)])
- (let* ([date (seconds->date secs)]
- [compare
- (let loop ([inputs (list year month day
- hour min sec)]
- [tests (list (date-year date)
- (date-month date)
- (date-day date)
- (date-hour date)
- (date-minute date)
- (date-second date))])
- (cond
- [(null? inputs) 'equal]
- [else (let ([input (car inputs)]
- [test (car tests)])
- (if (= input test)
- (loop (cdr inputs) (cdr tests))
- (if (<= input test)
- 'input-smaller
- 'test-smaller)))]))])
- ; (printf "~a ~a ~a~n" compare secs (date->string date))
- (cond
- [(eq? compare 'equal) secs]
- [(or (= secs below-secs) (= secs above-secs))
- (signal-error "non-existent date")]
- [(eq? compare 'input-smaller)
- (loop below-secs (floor (/ (+ secs below-secs) 2)) secs)]
- [(eq? compare 'test-smaller)
- (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))))
-
- ;; date->julian/scalinger :
- ;; date -> number [julian-day]
-
- ;; Note: This code is correct until 2099 CE Gregorian
-
- (define (date->julian/scalinger date)
- (let ((day (date-day date))
- (month (date-month date))
- (year (date-year date)))
- (let ((year (+ 4712 year)))
- (let ((year (if (< month 3) (sub1 year) year)))
- (let ((cycle-number (quotient year 4))
- (cycle-position (remainder year 4)))
- (let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position))))
- (let ((month-day-number (case month
- ((3) 0)
- ((4) 31)
- ((5) 61)
- ((6) 92)
- ((7) 122)
- ((8) 153)
- ((9) 184)
- ((10) 214)
- ((11) 245)
- ((12) 275)
- ((1) 306)
- ((2) 337))))
- (let ((total-days (+ base-day month-day-number day)))
- (let ((total-days/march-adjustment (+ total-days 59)))
- (let ((gregorian-adjustment (cond
- ((< year 1700) 11)
- ((< year 1800) 12)
- (else 13))))
- (let ((final-date (- total-days/march-adjustment
- gregorian-adjustment)))
- final-date)))))))))))
-
- ;; julian/scalinger->string :
- ;; number [julian-day] -> string [julian-day-format]
-
- (define (julian/scalinger->string julian-day)
- (apply string-append
- (cons "JD "
- (reverse
- (let loop ((reversed-digits (map number->string
- (let loop ((jd julian-day))
- (if (zero? jd) null
- (cons (remainder jd 10)
- (loop (quotient jd 10))))))))
- (cond
- ((or (null? reversed-digits)
- (null? (cdr reversed-digits))
- (null? (cdr (cdr reversed-digits)))
- (null? (cdr (cdr (cdr reversed-digits)))))
- (list (apply string-append (reverse reversed-digits))))
- (else (cons (apply string-append
- (list " "
- (caddr reversed-digits)
- (cadr reversed-digits)
- (car reversed-digits)))
- (loop (cdr (cdr (cdr reversed-digits))))))))))))
-
- )
+;; julian/scalinger->string :
+;; number [julian-day] -> string [julian-day-format]
+(define (julian/scalinger->string julian-day)
+ (apply string-append
+ (cons "JD "
+ (reverse
+ (let loop ((reversed-digits (map number->string
+ (let loop ((jd julian-day))
+ (if (zero? jd) null
+ (cons (remainder jd 10)
+ (loop (quotient jd 10))))))))
+ (cond
+ ((or (null? reversed-digits)
+ (null? (cdr reversed-digits))
+ (null? (cdr (cdr reversed-digits)))
+ (null? (cdr (cdr (cdr reversed-digits)))))
+ (list (apply string-append (reverse reversed-digits))))
+ (else (cons (apply string-append
+ (list " "
+ (caddr reversed-digits)
+ (cadr reversed-digits)
+ (car reversed-digits)))
+ (loop (cdr (cdr (cdr reversed-digits))))))))))))
\ No newline at end of file