(module date
  (seconds->date-list
   today
   date-list->seconds
   date<?
   day-of-week
   days-in-month
   valid-date?
   valid-partial-date?)

(import chicken scheme)
(use srfi-1 posix)

(define (seconds->date-list secs)
  (let ((t (seconds->utc-time secs)))
    (list (+ 1900 (vector-ref t 5))
          (add1 (vector-ref t 4))
          (vector-ref t 3))))

(define (today)
 (seconds->date-list (current-seconds)))

(define (date-list->seconds d)
  (let ((t (make-vector 10 0)))
    (set! (vector-ref t 5) (- (first d) 1900))
    (set! (vector-ref t 4) (sub1 (second d)))
    (set! (vector-ref t 3) (third d))
    (utc-time->seconds t)))

(define (date<? a b)
  (if (= (first a) (first b))
      (if (= (second a) (second b))
          (< (third a) (third b))
          (< (second a) (second b)))
      (< (first a) (first b))))


(define (leap-year? y)
  (cond ((not (zero? (modulo y 4))) #f)
        ((zero? (modulo y 400)) #t)
        ((zero? (modulo y 100)) #f)
        (else #t)))

(define days-in-month-list '(#f 31 28 31 30 31 30 31 31 30 31 30 31))
;; This is probably not correct for *all* julian calendars and their
;; reforms over the centuries but at least it has been stable for the
;; last 115 years now.

(define (days-in-month date)
  (let ((m (second date)))
    (if (and (= m 2) (leap-year? (car date)))
        29
        (list-ref days-in-month-list m))))

(define (valid-date? d)
  (and-let* ((_ (every number? d))
             (_ (= (length d) 3))
             (y (first d))
             (m (second d))
             (d (third d))
             (_ (<= 1900 y))
             (_ (<= 1 m 12))
             (max-days (days-in-month m)))
            (<= 1 d max-days)))

(define (valid-partial-date? date)
  (or (null? date)
      (and-let* ((_ (<= 1 (length date) 3))
                 (filled-partial (append date (make-list (- 3 (length date)) 1))))
                (valid-date? filled-partial))))

;; Calculates the weekday of a given date using Gauss's method
;; https://en.wikipedia.org/wiki/Determination_of_the_day_of_the_week
;; Weekday of the first day of a year A:
;;
;; R(1 + 5R(A-1,4) + 4R(A-1,100) + 6R(A-1,400),7) where R(y,m) = (modulo y m)
(define (day-of-week date)
  (let* ((A (first date))
         (m (second date))
         (d (third date))
         (first-day (modulo (+ 1
                               (* 5 (modulo (sub1 A) 4))
                               (* 4 (modulo (sub1 A) 100))
                               (* 6 (modulo (sub1 A) 400)))
                           7))
         (month-days (cond
                      ((and (= m 1) (= d 1)) -1)
                      ((> m 1)
                       (+ (if (and (> m 2) (leap-year? A)) 1 0)
                          (sub1 (apply + (take (cdr days-in-month-list) (sub1 m))))))
                      (else -1))))
    ;; The gauss method reorders the weekdays, starting at sunday (0)
    ;; We however want the week to start on monday, hence the renumbering
    (let ((dow (modulo (+ first-day d month-days) 7)))
      (if (< (sub1 dow) 0) 6 (sub1 dow)))))



;; Ben Daglish's simple method, see http://www.ben-daglish.net/moon.shtml
;; Returns the phase day (0 to 29, where 0=new moon, 15=full etc.) for
;; the selected date.
#;(define (moon-phase date)
  (let ((lunar-phase 2551443)
        (new-moon 588900000)
        (date (time->milliseconds
               (date->time (date-subtract-duration
                            (make-date 0 0 0 0 day month year)
                            (make-duration #:months 1))))))
    (inexact->exact (add1 (floor (/ (modulo (/ (- date new-moon) 1000) lunar-phase)
                                    (* 24 3600)))))))




) ;; Module