(do ((year $it-cache-first-year (1+ year)))
        ((> year $it-cache-last-year) v)
      (declare (type fixnum year))
      (do ((month 0 (1+ month)))
          ((> month 12))
        (declare (type fixnum month))
        (setf (svref v (i+ month (i* 13 (i- year $it-cache-first-year))))
              (let* ((month (if (i= month 0) 1 month))
                     (time (encode-universal-time 0 0 0 1 month year 0)))
                (floor time $24hours))))))
  "An array which maps (year,month) --> (days preceding that year/month)
   where 'days' starts at the lisp epoch.
   The map starts with the first month of year '$it-cache-first-year'
   and ends with the last month of year '$it-cache-last-year'.
   And, there are 13 months in a year -- i.e. [0,12] are valid months,
   and month 0 is the same as month 1.")

(defun-inline %days-until-year-month (year month)
  "Return the number of days since the lisp epoch which precede the
   given (year, month).  For example:  (1900 2) --> 31 days."
  (svref $days-until-year-month
         (i+ month (i* 13 (i- year $it-cache-first-year)))))

)	;eval-when


(eval-when (:compile-toplevel :load-toplevel :execute)

(defconstant-equalp $days-per-february-year
  (let ((v (make-array (i+ 1 (i- $it-cache-last-year
                                 $it-cache-first-year)))))
    (do ((year $it-cache-first-year (1+ year)))
        ((> year $it-cache-last-year) v)
      (declare (type fixnum year))
      (setf (svref v (i- year $it-cache-first-year))
            (i- (%days-until-year-month year 3)
                (%days-until-year-month year 2)))))
  "An array which maps (year) --> (days in february that year)
   The map starts with the first month of year '$it-cache-first-year'
   and ends with the last month of year '$it-cache-last-year'.")

(defun-inline %days-per-february-year (year)
  "Return the number of days in February of the given year
   For example:  1900 --> 28 days."
  (svref $days-per-february-year
         (i- year $it-cache-first-year)))

)	;eval-when


(defconstant-equalp $days-per-month
  (make-array 12 :initial-contents '(31 28 31 30 31 30 31 31 30 31 30 31))
  "An array mapping (month) --> (days in month)
   The value for February is, of course, incorrect during leap years,
   hence the need for %days-per-february-year defined above.")


;; The following few definitions are defparameter instead of a
;; defconstant because the latter is always (in SBCL and CMCL)
;; evaluated at compile time.  We don't need these at compile time,
;; and they slow down the build by around 30 seconds for no good
;; reason. -- DLW 10/6/06

;; See note above for why this is a defparameter instead of a defconstant.
(defparameter $days-until-month
  (let ((v (make-array 12 :initial-element 0)))
    (loop for m from 0 below 12
          for total = 0 then (+ total next)
          for next = (svref $days-per-month m)
          doing (setf (svref v m) total))
    v)
  "An array mapping (month) --> (days before beginning of month)
   The value for months after February is, of course, incorrect
   during leap years.")


;; See note above for why this is a defparameter instead of a defconstant.
(defparameter $year-from-days
  (let ((v (make-array (- $it-cache-last-day $it-cache-first-day -1))))
    (do ((days $it-cache-first-day (1+ days)))
        ((> days $it-cache-last-day) v)
      (multiple-value-bind (s m h day month year)
          (decode-universal-time (* days $24hours) 0)
        (declare (ignore s m h day month))
        (setf (svref v days) year))))
  "An array which maps (days since epoch) --> (year)
   The zeroth entry in the array is for $it-cache-first-day,
   the last entry is for $it-cache-last-day.")

;; See note above for why this is a defparameter instead of a defconstant.
(defparameter $month-from-days
  (let ((v (make-array (- $it-cache-last-day $it-cache-first-day -1))))
    (do ((days $it-cache-first-day (1+ days)))
        ((> days $it-cache-last-day) v)
      (multiple-value-bind (s m h day month year)
          (decode-universal-time (* days $24hours) 0)
        (declare (ignore s m h day year))
        (setf (svref v days) month))))
  "An array which maps (days since epoch) --> (month-of-year),
   where month-of-year is in the range [1,12].
   The zeroth entry in the array is for $it-cache-first-day,
   the last entry is for $it-cache-last-day.")

;; See note above for why this is a defparameter instead of a defconstant.
(defparameter $day-from-days
  (let ((v (make-array (- $it-cache-last-day $it-cache-first-day -1))))
    (do ((days $it-cache-first-day (1+ days)))
        ((> days $it-cache-last-day) v)
      (multiple-value-bind (s m h day month year)
          (decode-universal-time (* days $24hours) 0)
        (declare (ignore s m h month year))
        (setf (svref v days) day))))
  "An array which maps (days since epoch) --> (day-of-month)
   where day-of-month is in the range [1,N].
   The zeroth entry in the array is for $it-cache-first-day,
   the last entry is for $it-cache-last-day.")

;; See note above for why this is a defparameter instead of a defconstant.
(defparameter $dofw-from-days
  (let ((v (make-array (- $it-cache-last-day $it-cache-first-day -1))))
    (do ((days $it-cache-first-day (1+ days)))
        ((> days $it-cache-last-day) v)
      (multiple-value-bind (s m h day month year weekday)
          (decode-universal-time (* days $24hours) 0)
        (declare (ignore s m h day month year))
        (setf (svref v days) weekday))))
  "An array which maps (days since epoch) --> (day-of-week)
   where day-of-week is in the range [0,6] for [mon,sun].
   The zeroth entry in the array is for $it-cache-first-day,
   the last entry is for $it-cache-last-day.")


(defun-inline %year-from-2digit-year (2digit-year)
  "Convert an ambiguous 2-digit year into an unambiguous 4+-digit year.

  Years before '70 are assumed to be in the 2000's.
  '70 and later are assumed to be in the 1900's.
  This function doesn't check that input *is* a 2-digit year."
  (if (i>= 2digit-year 70)
    (i+ 2digit-year 1900)
    (i+ 2digit-year 2000)))

(defun days-per-month (month year)
  "Return the number of days in a given month in a given year.

  'month' is in the range [1,12] (where 1 == January).
  'year' is the year -- which only affects the result for February."
  (check-types (fixnum month year))
  (if (i= month 2)
    (if (and (i>= year $it-cache-first-year)
	     (i<= year $it-cache-last-year))
      (%days-per-february-year year)
      (let ((feb-first (encode-universal-time 0 0 0 1 2 year 0))
	    (mar-first (encode-universal-time 0 0 0 1 3 year 0)))
	(floor (- mar-first feb-first) $24hours)))
    (svref $days-per-month (i- month 1))))

(defun encode-integer-time (seconds minutes hours day month year)
  "Encode a broken-down time specification into integer-time.
  Input is the seconds, minutes, hours, day, month, and year.
  Result is an integer-time (seconds since lisp epoch).

  This function is equivalent to (encode-univeral-time ... 0),
  but is precomputed and thus faster for years in the range
  [$it-cache-first-year,$it-cache-last-year]."
  (check-types (fixnum seconds minutes hours day month year))
  (when (i< year 100)
    (setq year (%year-from-2digit-year year)))
  (if (and (i>= year $it-cache-first-year)
           (i<= year $it-cache-last-year))
    (let ((days (i+ (%days-until-year-month year month)
		    (i- day 1)))
	  (seconds (i+ seconds
		       (i+ (i* minutes $1minute)
			   (i* hours $1hour)))))
      (+ (* days $24hours) seconds))
    (encode-universal-time seconds minutes hours day month year 0)))


(defun encode-integer-date (day month year)
  "Encode a broken-down date specification into integer-time.
  Input is the day, month, and year.
  Result is an integer-time (seconds since lisp epoch).

  This function is equivalent to (encode-integer-time 0 0 0 ...),
  but can be 3x as fast."
  (check-types (fixnum day month year))
  (when (i< year 100)
    (setq year (%year-from-2digit-year year)))
  (if (and (i>= year $it-cache-first-year)
           (i<= year $it-cache-last-year))
    (* (i+ (%days-until-year-month year month) (i- day 1)) $24hours)
    (encode-universal-time 0 0 0 day month year 0)))

;; check to make sure it's not time to revisit the function "%year-from-2digit-year" above
(assert (utc-is-before-utc-p
         (make-instance 'zoned-time :utc (server-system-time-utc))
         (make-instance 'zoned-time :utc (encode-integer-date 01 01 2030))))


(defun encode-integer-tofd (seconds minutes hours)
  "Encode a broken-down time-of-day specification into integer-time.
  Input is the seconds, minutes, and hours.
  Result is an integer-tofd (seconds since midnight).

  This function is equivalent to (encode-integer-time ... 0 0 0),
  but is 7.5x as fast and does almost no consing (since a tofd always
  fits in a fixnum."
  (check-types (fixnum seconds minutes hours))
  (i+ seconds
      (i+ (i* minutes $1minute)
          (i* hours $1hour))))


(defun decode-integer-time (time)
  "Decode an integer-time into its broken-down components.

  Input is an integer-time.
  Result is the values
      <seconds> <minutes> <hours> <day> <month> <year> <dofw>.
  This function is equivalent to (decode-universal-time ... 0),
  but is precomputed and thus faster for years in the range
  [$it-cache-first-year,$it-cache-last-year]."
  (check-types (integer-time time))
  (multiple-value-bind (days tofd) (floor time $24hours)
    (declare (type fixnum days tofd))
    (if (and (i>= days $it-cache-first-day)
             (i<= days $it-cache-last-day))
      (multiple-value-bind (hours tofd-min) (floor tofd $1hour)
	(declare (type fixnum hours tofd-min))
	(multiple-value-bind (minutes seconds) (floor tofd-min $1minute)
	  (declare (type fixnum minutes seconds))
	  (values seconds minutes hours
		  (svref $day-from-days days)
		  (svref $month-from-days days)
		  (svref $year-from-days days)
		  (svref $dofw-from-days days))))
      (multiple-value-bind (seconds minutes hours day month year weekday)
	  (decode-universal-time time 0)
	(values seconds minutes hours day month year weekday)))))


(defun decode-integer-date (date)
  "Decode an integer-time into only its broken-down date components.

  Input is an integer-time.
  Result is the values <day> <month> <year> <dofw>.
  This function is equivalent to (decode-universal-time ... 0),
  but is precomputed and thus faster for years in the range
  [$it-cache-first-year,$it-cache-last-year]."
  (check-types (integer-date date))
  (let ((days (floor date $24hours)))
    (declare (type fixnum days))
    (if (and (i>= days $it-cache-first-day)
             (i<= days $it-cache-last-day))
      (values (svref $day-from-days days)
	      (svref $month-from-days days)
	      (svref $year-from-days days)
	      (svref $dofw-from-days days))
      (multiple-value-bind (seconds minutes hours day month year weekday)
	  (decode-universal-time date 0)
	(declare (ignore seconds minutes hours))
	(values day month year weekday)))))


(defun decode-integer-tofd (tofd)
  "Decode an integer-time into only its broken-down time-of-day components.

  Input is an integer-time.
  Result is the values <seconds> <minutes> <hours>.
  This function is equivalent to (decode-universal-time ... 0),
  but is precomputed and thus faster for years in the range
  [$it-cache-first-year,$it-cache-last-year]."
  (check-types (integer-tofd tofd))
  (let ((tofd (mod tofd $24hours)))
    (declare (type fixnum tofd))
    (multiple-value-bind (hours tofd-min) (floor tofd $1hour)
      (declare (type fixnum hours tofd-min))
      (multiple-value-bind (minutes seconds) (floor tofd-min $1minute)
        (declare (type fixnum minutes seconds))
        (values seconds minutes hours)))))


(defun-inline %days-until-month (month year)
  "Return the number of days preceding the given month in the given year.
   For example:  March, 2004 --> (3 2004) --> 60 days"
  (i+ (svref $days-until-month (i1- month))
      (if (and (i= 29 (%days-per-february-year year))
               (> month 2))
          1
          0)))


(defun day-of-year (time)
  "Extract the 1-based day-of-year from an integer-time.
    E.g. January 1 (of any year) --> 1

  'time' is an integer-time.
  Result is an integer in the range [1,366]."
  (check-types (integer-time time))
  (let ((days (floor time $24hours)))
    (declare (type fixnum days))
    (if (and (i>= days $it-cache-first-day)
             (i<= days $it-cache-last-day))
      ;; Using cached time constants
      (let ((day   (svref $day-from-days days))
            (month (svref $month-from-days days))
            (year  (svref $year-from-days days)))
        ;; (Days from epoch til 'time') - (Days from epoch til January)
        (i+ day (%days-until-month month year)))
      ;; Outside of time cache
      (multiple-value-bind (s m h day month year)
          (decode-universal-time time 0)
        (declare (ignore s m h))
        (i+ day
            (loop for m from 1 below month
                  sum (days-per-month m year)))))))


(defun local-date-offset (time1 time2)
  "Return the (integer) difference in _date_ between two local times.

  This is essentially the difference in 'printed days', not the
  difference in '24-hour periods'.
  For example, '2005-03-05 23:00' and '2005-03-06 01:00' will yield
  a 1 day difference in date, even though they are only 2 hours apart.

  'time1' and 'time2' are local 'integer-times'.
  The result is positive if time2 is later than time1."
  (check-types (integer-time time1 time2))
  (- (floor time2 $24hours) (floor time1 $24hours)))


(defun-inline local-time-to-utc (time-local tzoffset)
  "Given a local integer-time and a TZ offset, return the UTC integer-time."
  (- time-local tzoffset))

(defun-inline utc-time-to-local (time-utc tzoffset)
  "Given a UTC integer-time and a TZ offset, return the local integer-time."
  (+ time-utc tzoffset))


(defun local-date-equal (date1 date2)
  "Return T if 'date1' and 'date2' have equal day, month, and year.

  'date1' and 'date2' are integer-time's."
  (= (local-date-only date1) (local-date-only date2)))


(defun merge-date-and-tofd (date tofd)
  "Merge a 'date' with a 'tofd'.

   Take the date components of 'date' (an integer-time)
   and merge them with the time components of 'tofd' (another
   integer-time), generating a new integer-time.

   ('date' and 'time' should be local to the same TZ, although
   the result is effectively in the same relative TZ as 'tofd'.)"
  (check-types (integer date tofd))
  (+ (local-date-only date) (local-tofd-only tofd)))


(defun local-date-to-utc (local-date local-tofd tzoffset)
  "Convert the given LOCAL-DATE/LOCAL-TOFD to UTC and return the date part.
   For example: 1-MAR 23:00 EST -> 2-MAR"
  (local-date-only (local-time-to-utc (merge-date-and-tofd local-date local-tofd) tzoffset)))

(defun utc-date-to-local (utc-date local-tofd tzoffset)
  "Return the local date for the given local time and UTC date.
   For example: 2-MAR 23:00 EST -> 1-MAR"
  (local-date-only (utc-time-to-local (merge-date-and-tofd utc-date (local-time-to-utc local-tofd tzoffset)) tzoffset)))

(defun override-local-time (time &key seconds minutes hours day month year)
  "Override specific date/tofd components of an integer-time.

  Returns the new integer-time constructed by replacing the specified
  components of the original integer-time 'time'."
  (check-types (integer-time time)
	       ((or integer null) seconds minutes hours day month year))
  (multiple-value-bind (_seconds _minutes _hours _day _month _year)
      (decode-integer-time time)
    (encode-integer-time (or seconds _seconds)
                         (or minutes _minutes)
                         (or hours   _hours)
                         (or day     _day)
                         (or month   _month)
                         (or year    _year))))

;;!!!TZ
(defun advance-to-next-day-of-week (time
				    weekday ; 0-6 corresponds to mon-sun
				    &key keep-tofd-p)
  "Return the time corresponding to the next WEEKDAY calculated from TIME.
   WEEKDAY is an integer with 0 corresponding to Monday, 6 to Sunday.
   KEEP-TOFD-P, if non-NIL, indicates that the time portion of TIME should be
   carried over to the generated time.  By default, 0:00h is returned for the
   time potions.  Returns a timezone agnostic universal time."
  (check-types (integer-time time)
	       (fixnum weekday))
  (multiple-value-bind (seconds minutes hours day month year old-weekday)
      (decode-universal-time time 0)
    (+ (encode-universal-time (if keep-tofd-p seconds 0)
                               (if keep-tofd-p minutes 0)
                               (if keep-tofd-p hours 0)
                               day month year
                               0)
       (* $24hours (let ((v (- weekday old-weekday)))
                     (if (< v 1)
                       (+ v 7)
                       v))))))

;;; Time and date parsing

(defconstant-equalp $uppercase-months
  '#("JAN" "FEB" "MAR" "APR" "MAY" "JUN" "JUL" "AUG" "SEP" "OCT" "NOV" "DEC"))

(defconstant-equalp $mixedcase-months
  '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))

(defconstant-equalp $lowercase-months
  '#("jan" "feb" "mar" "apr" "may" "jun" "jul" "aug" "sep" "oct" "nov" "dec"))

(defconstant-equalp $uppercase-months-long
  #("JANUARY" "FEBRUARY" "MARCH" "APRIL" "MAY" "JUNE"
    "JULY" "AUGUST" "SEPTEMBER" "OCTOBER" "NOVEMBER" "DECEMBER"))

(defconstant-equalp $mixedcase-months-long
  #("January" "February" "March" "April" "May" "June"
    "July" "August" "September" "October" "November" "December"))

(defconstant-equalp $lowercase-months-long
  #("january" "february" "march" "april" "may" "june"
    "july" "august" "september" "october" "november" "december"))


(defconstant-equalp $uppercase-days
  '#("MON" "TUE" "WED" "THU" "FRI" "SAT" "SUN"))

(defconstant-equalp $mixedcase-days
  '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))

(defconstant-equalp $lowercase-days
  '#("mon" "tue" "wed" "thu" "fri" "sat" "sun"))

(defconstant-equalp $uppercase-days-ws
  '#("MON " "TUE " "WED " "THU " "FRI " "SAT " "SUN "))

(defconstant-equalp $mixedcase-days-ws
  '#("Mon " "Tue " "Wed " "Thu " "Fri " "Sat " "Sun "))

(defconstant-equalp $lowercase-days-ws
  '#("mon " "tue " "wed " "thu " "fri " "sat " "sun "))

(defconstant-equalp $uppercase-days-long
  '#("MONDAY" "TUESDAY" "WEDNESDAY" "THURSDAY" "FRIDAY" "SATURDAY" "SUNDAY"))

(defconstant-equalp $mixedcase-days-long
  '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))

(defconstant-equalp $lowercase-days-long
  '#("monday" "tuesday" "wednesday" "thursday" "friday" "saturday" "sunday"))


(defun month-name (month &key (size :short) (case :upper))
  "Return a string containing the English name of a numeric month.

  'month' belongs to the range [1,12] (1==January).
  'size' is one of :short (default) or :long, specifying size of name.
  'case' is one of :upper (default), :mixed or :lower.
  Return value is a string, or NIL if the month is not in [1,12]."
  (check-types (fixnum month))
  (when (and (>= month 1) (<= month 12))
    (svref (ecase size
             (:short (ecase case
                       (:upper $uppercase-months)
                       (:mixed $mixedcase-months)
                       (:lower $lowercase-months)))
             (:long (ecase case
                      (:upper $uppercase-months-long)
                      (:mixed $mixedcase-months-long)
                      (:lower $lowercase-months-long))))
           (i1- month))))

(defun dofw-name (dofw &key (size :short) (case :upper))
  "Return a string containing the English name of a numeric day-of-week.

  'dofw' belongs to the range [0,6] (0==Monday).
  'size' is one of :short (default) or :long, specifying size of name.
  'case' is one of :upper (default), :mixed or :lower.
  Return value is a string, or NIL if the dofw is not in [0,6]."