; date formatting

(define-syntax list-match
  (syntax-rules ()
    ((_ expr (pattern fender ... template) ...)
      (let ((obj expr))
        (cond ((list-match-aux obj pattern fender ...
                (list template)) => car) ...
              (else (error 'list-match "pattern failure")))))))

(define-syntax list-match-aux
  (lambda (stx)
    (define (underscore? x)
      (and (identifier? x) (free-identifier=? x (syntax _))))
    (syntax-case stx (quote quasiquote)
      ((_ obj pattern template)
        (syntax (list-match-aux obj pattern #t template)))
      ((_ obj () fender template)
        (syntax (and (null? obj) fender template)))
      ((_ obj underscore fender template)
        (underscore? (syntax underscore))
        (syntax (and fender template)))
      ((_ obj var fender template)
        (identifier? (syntax var))
        (syntax (let ((var obj)) (and fender template))))
      ((_ obj (quote datum) fender template)
        (syntax (and (equal? obj (quote datum)) fender template)))
      ((_ obj (quasiquote datum) fender template)
        (syntax (and (equal? obj (quasiquote datum)) fender template)))
      ((_ obj (kar . kdr) fender template)
        (syntax (and (pair? obj)
                (let ((kar-obj (car obj)) (kdr-obj (cdr obj)))
                  (list-match-aux kar-obj kar
                        (list-match-aux kdr-obj kdr fender template))))))
      ((_ obj const fender template)
        (syntax (and (equal? obj const) fender template))))))

(define (julian year month day)
  (let* ((a (quotient (- 14 month) 12))
         (y (+ year 4800 (- a)))
         (m (+ month (* 12 a) -3)))
    (+ day
       (quotient (+ (* 153 m) 2) 5)
       (* 365 y)
       (quotient y 4)
       (- (quotient y 100))
       (quotient y 400)
       (- 32045))))

(define (gregorian julian)
  (let* ((j (+ julian 32044))
         (g (quotient j 146097))
         (dg (modulo j 146097))
         (c (quotient (* (+ (quotient dg 36524) 1) 3) 4))
         (dc (- dg (* c 36524)))
         (b (quotient dc 1461))
         (db (modulo dc 1461))
         (a (quotient (* (+ (quotient db 365) 1) 3) 4))
         (da (- db (* a 365)))
         (y (+ (* g 400) (* c 100) (* b 4) a))
         (m (- (quotient (+ (* da 5) 308) 153) 2))
         (d (+ da (- (quotient (* (+ m 4) 153) 5)) 122))
         (year (+ y (- 4800) (quotient (+ m 2) 12)))
         (month (+ (modulo (+ m 2) 12) 1))
         (day (+ d 1)))
    (values year month day)))

; %% literal percent (%)
; %a abbreviated dayname (Tue)
; %A full dayname (Tuesday)
; %b abbreviated monthname (Apr)
; %B full monthname (April)
; %d day of month, zero padded (09)
; %D day of month (9)
; %m month number, zero padded (04)
; %M month number (4)
; %y two-digit year (13)
; %Y four-digit year (2013)

; %A, %B %D, %Y (Tuesday, April 16, 2013)
; %m/%d/%y (04/16/13)
; %M/%D/%Y (4/16/2013)

(define (date-format julian fmt-string)
  (define (pad n)
    (if (< 9 n) (number->string n)
      (string-append "0" (number->string n))))
  (let ((ds (vector "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
        (days (vector "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
        (ms (vector "" "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
        (months (vector "" "January" "February" "March" "April" "May" "June" "July" "August"
          "September" "October" "November" "December")))
    (let-values (((year month day) (gregorian julian)) ((weekday) (modulo julian 7)))
      (let loop ((fmt (string->list fmt-string)) (cs (string)))
        (list-match fmt
          (() cs)
          ((#\% #\% . rest) (loop (cddr fmt) (string-append cs "%")))
          ((#\% #\a . rest) (loop (cddr fmt) (string-append cs (vector-ref ds weekday))))
          ((#\% #\A . rest) (loop (cddr fmt) (string-append cs (vector-ref days weekday))))
          ((#\% #\b . rest) (loop (cddr fmt) (string-append cs (vector-ref ms month))))
          ((#\% #\B . rest) (loop (cddr fmt) (string-append cs (vector-ref months month))))
          ((#\% #\d . rest) (loop (cddr fmt) (string-append cs (pad day))))
          ((#\% #\D . rest) (loop (cddr fmt) (string-append cs (number->string day))))
          ((#\% #\m . rest) (loop (cddr fmt) (string-append cs (pad month))))
          ((#\% #\M . rest) (loop (cddr fmt) (string-append cs (number->string month))))
          ((#\% #\y . rest) (loop (cddr fmt) (string-append cs (substring (number->string year) 2 4))))
          ((#\% #\Y . rest) (loop (cddr fmt) (string-append cs (number->string year))))
          ((c . rest) (loop (cdr fmt) (string-append cs (string c)))))))))

(display (julian 2013 4 16)) (newline)
(display (date-format 2456399 "%% %a %A %b %B %d %D %m %M %X %y %Y")) (newline)
(display (date-format 2456399 "%A, %B %D, %Y")) (newline)
(display (date-format 2456399 "%m/%d/%y")) (newline)
(display (date-format 2456399 "%M/%D/%Y")) (newline)

2456399
% Tue Tuesday Apr April 16 16 04 4 %X 13 2013
Tuesday, April 16, 2013
04/16/13
4/16/2013