#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DATE.plt
;;
;; date-specific routines.  Reexports srfi/19
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; date.ss - date creation & manipulations
;; yc 8/31/2009 - first version
;; yc 10/18/2009 - adding day>?, day<?, day>=?, day<=?, day!=?
;; yc 10/19/2009 - convert all date & day comparison to take rest parameter (i.e. all date comparison
;;                 functions can now take multiple dates instead of just 2)...
;; yc 10/19/2009 - added date-comp-type to allow for date object comparison,
;;                 day-only, day+time, date, date+tz (requires the same tz)
;; yc 10/19/2009 - use depend.ss to manage dependency
(require "base.ss"
         "depend.ss"
         )

;; we'll ensure the leap year, month, day, etc are taken care of...
;; but not leap seconds, yet.
(define (build-date year month day (hour 0) (min 0) (sec 0) (nano 0) #:tz (tz 0))
  (define (helper year month day)
    (make-date nano sec min hour day month year tz))
  (apply helper (normalize-year/month/day year month day)))

;; date->date/tz
;; change the date's offset - use this to convert a date into its appropriate localtime
;; (date->date/offset
(define (date->date/tz d (tz #f))
  (julian-day->date (date->julian-day d)
                    (if (not tz)
                        (date-zone-offset d)
                        tz)))

;; use this to determine the type of the comparison we'll do
;; (all date+time day)
(define date-comp-type (make-parameter 'all))

(define (date-comp? comp?)
  (define (helper d) 
    (date->julian-day (case (date-comp-type)
                        ((day+time) 
                         (make-date (date-nanosecond d)
                                    (date-second d)
                                    (date-minute d)
                                    (date-hour d)
                                    (date-day d)
                                    (date-month d)
                                    (date-year d)
                                    0))
                        ((day-only)
                         (make-date 0 0 0 0 
                                    (date-day d)
                                    (date-month d)
                                    (date-year d)
                                    0))
                        (else d)
                        )))
  (lambda (d1 d2 . dates)
    (let ((dates (list* d1 d2 dates)))
      (and (if (equal? (date-comp-type) 'date+tz)
               (apply = (map date-zone-offset dates))
               #t)
           (apply comp? (map helper dates))))))

(define date=? (date-comp? =))
(define date>? (date-comp? >))
(define date<? (date-comp? <))
(define date>=? (date-comp? >=))
(define date<=? (date-comp? <=))
(define date!=? (date-comp? (compose not)))

(define (day-comp? comp?)
  (lambda dates
    (parameterize ((date-comp-type 'day-only))
      (apply comp? dates))))

(define day=? (day-comp? date=?)) 
(define day>? (day-comp? date>?))
(define day<? (day-comp? date<?)) 
(define day>=? (day-comp? date>=?)) 
(define day<=? (day-comp? date<=?))
(define day!=? (day-comp? date!=?))

(define (date===? d1 d2 . dates)
  (let ((dates (list* d1 d2 dates)))
    (and (apply = (map date-zone-offset dates))
         (apply date=? dates))))

(define (date->seconds d)
  (time-second (date->time-utc d)))

(define (seconds->date s (tz 0)) 
  (time-utc->date (make-time time-utc 0 s) tz))

(define (current-local-tz-offset)
  (date-zone-offset (current-date))) 

;; date object manipulation!!
;; does not account for leap seconds.
;; the day is a regular number, as long as it's not +inf.0 or -inf.0.
;; this date+ function does not work with daylight savings... it would be cool if it does...
;; this is of course a very simple function.
;; what is needed is a function that'll account for the correct timezone + daylight saving.
;; for that we'll need to figure out whether we've crossed a particular daylight saving boundary
;; and then change the offset by that amount (but keep the time exactly the same)
(define (date+ date day)
  (julian-day->date (+ (date->julian-day date) day)
                    (date-zone-offset date)))

(define (date- d1 d2) 
  (- (date->julian-day d1) (date->julian-day d2)))

(define (date->alarm date)
  (alarm-evt (* 1000 (date->seconds date))))

(define (date->future-alarm date (d (current-date)))
  (if (date>? date d)
      (date->alarm date)
      #f))

(define date-comp/c
  (->* (date? date?)
       ()
       #:rest (listof date?) 
       boolean?))

(provide/contract 
 (build-date (->* (integer? (integer-in 1 12) (integer-in 1 31))
                  ((integer-in 0 23) (integer-in 0 59) (integer-in 0 60)
                                     exact-nonnegative-integer?
                                     #:tz (integer-in -86400 86400))
                  date?))
 (date->date/tz (->* (date?)
                     ((or/c #f (integer-in -86400 86400)))
                     date?))
 (current-local-tz-offset (-> number?))
 (date-comp-type (parameter/c (or/c 'day-only 'day+time 'date 'date+tz)))
 (date=? date-comp/c) 
 (date>? date-comp/c)
 (date<? date-comp/c)
 (date!=? date-comp/c) 
 (date>=? date-comp/c)
 (date<=? date-comp/c)
 (day=? date-comp/c) 
 (day>? date-comp/c)
 (day<? date-comp/c)
 (day!=? date-comp/c) 
 (day>=? date-comp/c)
 (day<=? date-comp/c)
 (date===? date-comp/c)
 (date+ (-> date? (lambda (n)
                    (and (number? n)
                         (not (equal? n +inf.0))
                         (not (equal? n -inf.0))))
            date?))
 (date- (-> date? date? number?))
 (date->seconds (-> date? number?))
 (seconds->date (->* (exact-nonnegative-integer?)
                     ((integer-in -86400 86400))
                     date?))
 (date->alarm (-> date? evt?))
 (date->future-alarm (->* (date?)
                          (date?)
                          (or/c #f evt?)))
 )