;;; -*- Mode: Lisp -*-
;;; $Id: local-time.lisp,v 1.38 2002/04/05 00:04:09 craig Exp $
;;;
;;; Copyright (c) 2000, 2001 onShore Development, Inc.
;;;
;;; package implementing Erik Naggum's local-time representation

(in-package :local-time)

;; ------------------------------------------------------------
;; local time: constructors

(defvar *UTC* "UTC")
(defvar *default-timezone* "CST")

(defun local-time (&key universal internal unix java (msec 0))
  "produce a local-time instance from the provided numeric time
representation"
  (let (local-time)
    (cond (unix
           (setq local-time (%unix-to-local-time unix msec)))
          (java
           (setq local-time (%java-to-local-time java msec)))
          (internal
           (error ":internal argument unsupported"))
          (universal
           (setq local-time (%universal-to-local-time universal msec)))
          (t
           (error "Specify one of :universal, :java, :internal or :unix keywords")))
    local-time))

(defun get-local-time ()
  "return the current time as a local-time instance"
  (local-time :universal (get-universal-time)))


;; Accept 3 values representing the components of a local-time
;; instance, and normalize them so that the seconds and milliseconds
;; fall within their specified ranges:
;;
;; msec:         0 ... 999
;;  sec:         0 ... 86399
;;  day: -infinity ... +infinity
;;
;; return the three new values

(defun %normalize-lt-slots (day sec msec)
  (multiple-value-bind (msec-seconds msecs)
      (floor msec 1000)
    (multiple-value-bind (sec-days seconds)
        (floor (+ msec-seconds sec) +seconds/day+)
      (values (+ day sec-days) seconds msecs))))

(defun make-local-time (&key (day 0) (sec 0) (msec 0))
  "Make a local-time instance"
  (multiple-value-bind (%day %sec %msec)
      (%normalize-lt-slots day sec msec)
    (%make-local-time :day %day :sec %sec :msec %msec)))


;; arithmetic operators

(defun local-time< (&rest local-times)
  (apply #'< (mapcar #'designate-local-time local-times)))

(defun %local-time< (a b)
  "dangerous time comparator: check your args"
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (or (< (the fixnum (local-time-day a))
         (the fixnum (local-time-day b)))
      (and (= (the fixnum (local-time-day a))
              (the fixnum (local-time-day b)))
           (or (< (the fixnum (local-time-sec a))
                  (the fixnum (local-time-sec b)))
               (and (= (the fixnum (local-time-sec a))
                       (the fixnum (local-time-sec b)))
                    (< (the fixnum (local-time-msec a))
                       (the fixnum (local-time-msec b))))))))

(defun local-time<= (&rest local-times)
  (apply #'<= (mapcar #'designate-local-time local-times)))

(defun local-time> (&rest local-times)
  (apply #'> (mapcar #'designate-local-time local-times)))

(defun local-time>= (&rest local-times)
  (apply #'>= (mapcar #'designate-local-time local-times)))

(defun local-time= (&rest local-times)
  (apply #'= (mapcar #'designate-local-time local-times)))

(defun %local-time= (a b)
  "dangerous time comparator: check your args"
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (and (= (the fixnum (local-time-sec a))
          (the fixnum (local-time-sec b)))
       (= (the fixnum (local-time-day a))
          (the fixnum (local-time-day b)))
       (= (the fixnum (local-time-msec a))
          (the fixnum (local-time-msec b)))))

(defun local-time/= (&rest local-times)
  (apply #'/= (mapcar #'designate-local-time local-times)))

(defun local-time-min (&rest local-times)
  (make-local-time :msec (apply #'min (mapcar #'designate-local-time local-times))))

(defun local-time-max (&rest local-times)
  (make-local-time :msec (apply #'max (mapcar #'designate-local-time local-times))))


;; 2000-01-01 14:00 GMT  - CST6CDT => 

(defun designate-local-time (local-time &key (adjust nil))
  "Returns a designator for LOCAL-TIME, the number of milliseconds
since/before the local-time epoch."
  (declare (ignore adjust))
  (+ (* (local-time-day local-time) +msecs/day+)
     (* (local-time-sec local-time) 1000)
     (local-time-msec local-time)))

;; both are durations
(defun local-time/ (time duration)
  (make-local-time :msec (floor (designate-local-time time)
                                (designate-duration duration))))

;; Date + Duration
(defun local-time+ (time &rest durations)
  "Add each DURATION to TIME, returning a new local-time value."
  (let* ((new-time (+ (designate-local-time time)
                      (designate-duration (apply #'duration+ durations))))
         (new-inst (make-local-time :msec new-time)))
    new-inst))

(defun local-time- (time &rest durations)
  "Subtract each DURATION from TIME, returning a new local-time value."
  (let ((new-time (- (designate-local-time time)
                     (designate-duration (apply #'duration+ durations)))))
    (make-local-time :msec new-time)))

(defun local-time-difference (time1 time2)
  "Returns a DURATION representing the difference between TIME1 and
TIME2."
  (duration-designator (- (designate-local-time time1)
                          (designate-local-time time2))))

(defun encode-local-time (ms ss mm hh day month year &optional (timezone *UTC*)) 
  "return a new local-time instance corresponding to the specified
time elements"
  (declare (ignore ms))
  (unless (eql timezone *UTC*)
    (error "not implemented"))
  (parse-timestring (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d-00"
                            year (1+ month) day hh mm ss)))

(defun local-time-to-string (local-time &key pretty short-pretty)
  (let ((stream (make-string-output-stream)))
    (format-timestring stream local-time :pretty pretty :short-pretty short-pretty)
    (get-output-stream-string stream)))

;; these :pretty keywords should really be some kind of format-like directives.
(defun format-timestring (stream local-time &key pretty short-pretty universal-p
				 (timezone-p t)
				 date-elements time-elements date-separator
				 time-separator internal-separator)
  "produces on stream the timestring corresponding to the local-time
with the given options"
  (declare (ignore universal-p date-elements time-elements ;; FIXME
                   date-separator time-separator internal-separator))
  (multiple-value-bind (ms ss mm hh day month year dow dst-p tz tzabbr)
      (decode-local-time-for-display local-time)
    (declare (ignore ms dst-p))
    (cond
     (pretty
      (format stream "~A ~A, ~A ~D, ~D ~A"
	      (pretty-time hh mm)
	      (day-name dow)
	      (month-name month)
	      day
	      year
	      tzabbr))
     (short-pretty
      (format stream "~A, ~D/~D/~D"
	      (pretty-time hh mm)
	      (1+ month) day year))
     (timezone-p
      (let ((tzhours (truncate tz (* 60 60))))
	(format stream "~2,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D~A~2,'0D"
		year (1+ month) day hh mm ss (if (< tzhours 0) "-" "+") (abs tzhours))))
     (t
      (format stream "~2,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
	      year (1+ month) day hh mm ss)))))

(defun pretty-time (hour minute)
  (cond
   ((eq hour 0)
    (format nil "12:~2,'0D AM" minute))
   ((eq hour 12)
    (format nil "12:~2,'0D PM" minute))
   ((< hour 12)
    (format nil "~D:~2,'0D AM" hour minute))
   ((and (> hour 12) (< hour 24))
    (format nil "~D:~2,'0D PM" (- hour 12) minute))
   (t
    (error "pretty-time got bad hour"))))

(defun iso-timestring (local-time)
  (multiple-value-bind (ms ss mm hh day month year dow dst-p tz tzabbr)
      (decode-local-time-for-display local-time)
    (declare (ignore dow tzabbr ms dst-p))
    (let ((tzhours (truncate tz (* 60 60))))
      (format nil "~2,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D~A~2,'0D"
              year (1+ month) day hh mm ss (if (< tzhours 0) "-" "+") (abs tzhours)))))

(defun get-timezone-offset (&optional (local-time (get-local-time)))
  (multiple-value-bind (ms ss mm hh day month year dow dst-p tz tzabbr)
      (decode-local-time-for-display local-time)
    (declare (ignore ms ss mm hh day month year dow tzabbr ms dst-p))
    (let ((tzhours (truncate tz (* 60 60))))
      (format nil "~A~2,'0D"
	      (if (< tzhours 0) "-" "+") (abs tzhours)))))
    
(defun daylight-savings-p (local-time)
  (declare (ignore local-time))
  nil)

(defun leap-days-in-days (days)
  ;; return the number of leap days between Mar 1 2000 and
  ;; (Mar 1 2000) + days, where days can be negative
  (if (< days 0)
      (ceiling (/ (- days) (* 365 4)))
      (floor (/ days (* 365 4)))))


;; conversion between time systems

(defconstant +java-to-unix+ 1000)
(defconstant +unix-to-universal+ 2208988800)
(defconstant +universal-to-local+ 3160857600)

(defun %java-to-local-time (java &optional (msec2 0))
  "Convert java timeval to local-time instance. Java is unix * 1000"
  (multiple-value-bind (sec msec)
      (floor java +java-to-unix+)
    (%unix-to-local-time sec (+ msec msec2))))

(defun %local-time-to-java (local-time)
  (multiple-value-bind (unix msec)
      (%local-time-to-unix local-time)
    (+ (* unix +java-to-unix+) msec)))

(defun %unix-to-local-time (unix &optional (msec 0))
  "Convert unix timeval to local-time instance."
  (let ((universal (+ unix +unix-to-universal+)))
    (%universal-to-local-time universal msec)))

(defun %local-time-to-unix (local-time)
  (multiple-value-bind (universal msec)
      (local-time-to-universal local-time)
    (values (- universal +unix-to-universal+)
            msec)))

(defun %universal-to-local-time (universal &optional (msec 0))
  "Convert universal timeval to local-time instance."
  (let ((seconds (- universal +universal-to-local+)))
    (make-local-time :sec seconds :msec msec)))

(defun local-time-to-universal (local-time)
  (let ((day (local-time-day local-time))
        (sec (local-time-sec local-time)))
    (values (+ sec (* day +seconds/day+) +universal-to-local+)
            (local-time-msec local-time))))

(defun local-time-ymd (local-time)
  "return as multiple values the normal year, month, and day of the local-time"
  (if (typep local-time 'duration)
      (values 0 0 (local-time-day local-time))
      (%gregorian-date (local-time-day local-time))))

(defun %local-time-hms (seconds)
  (multiple-value-bind (minutes seconds)
      (floor seconds +seconds/minute+)
    (multiple-value-bind (hours minutes)
        (floor minutes +minutes/hour+)
      (values hours minutes seconds))))

(defun local-time-hms (local-time)
  "return as multiple values the hour, minute and second of the local time"
  (%local-time-hms (local-time-sec local-time)))

(defun decode-local-time (local-time) 
  "returns the decoded time as multiple values: ms, ss, mm, hh, day,
month, year, day-of-week, daylight-saving-time-p, timezone, and the
customary timezone abbreviation"
  (let ((unix (%local-time-to-unix local-time)))
    (multiple-value-bind (ss mm hh dom mon yr dow ydy dst)
        (libc-gmtime (%local-time-to-unix local-time))
      (declare (ignore ydy))
      (values 0 ss mm hh dom mon (+ 1900 yr) dow (= 1 dst) (gmt-offset unix) "Not Implemented"))))

(defun decode-local-time-for-display (local-time)
  "returns the decoded time as multiple values: ms, ss, mm, hh, day,
month, year, day-of-week, daylight-saving-time-p, timezone, and the
customary timezone abbreviation"
  (let ((unix (%local-time-to-unix local-time)))
    (multiple-value-bind (ss mm hh dom mon yr dow ydy dst)
        (libc-localtime unix)
      (declare (ignore ydy))
      (values 0 ss mm hh dom mon (+ 1900 yr) dow (= 1 dst) (gmt-offset unix) "Not Implemented"))))

(defun day-of-week (local-time)
  (nth (nth 7 (multiple-value-list (decode-local-time-for-display local-time)))
       *day-keywords*))

(defun decode-special (local-time) 
  "msec seconds day dom month year zone"
  (let ((msec    (local-time-msec local-time))
        (seconds (local-time-sec  local-time))
        (days    (local-time-day  local-time)))
    (multiple-value-bind (year month day)
        (%gregorian-date days)
      (values msec seconds days day month year))))

(defun local-time-hours (local-time)
  "return the local-time as a number of hours, rounded down"
  (let* ((day-hours (* 24 (local-time-day local-time))))
    (+ day-hours
       (floor (/ (local-time-sec local-time) +seconds/hour+)))))

(defun universal-time (local-time)
  "return the universal-time corresponding to the local-time"
  (declare (ignore local-time))
  (error "not implemented"))

(defun internal-time (local-time)
  "return the internal system time corresponding to the local-time"
  (declare (ignore local-time))
  (error "not implemented"))

(defun unix-time (local-time)
  "return the unix time corresponding to the local-time"
  (declare (ignore local-time))
  (error "not implemented"))

(defun timezone (local-time &optional timezone) 
  "return as multiple values the time zone as the number of seconds
east of utc, a boolean daylight-saving-p, the customary abbreviation
of the timezone, the starting time of this timezone, and the ending
time of this timezone"
  (declare (ignore local-time timezone))
  (error "not implemented"))

(defun local-timezone (adjusted-local-time &optional timezone) 
  "return the local timezone adjustment applicable at the already
adjusted-local-time.  used to reverse the effect of timezone and
local-time-adjust"
  (declare (ignore adjusted-local-time timezone))
  (error "not implemented"))

(defmacro define-timezone (zone-name zone-file &key load) 
  "define zone-name (a symbol or a string) as a new timezone,
lazy-loaded from zone-file (a pathname designator relative to the
zoneinfo directory on this system).  if load is true, load
immediately"
  (declare (ignore zone-name zone-file load))
  (error "not implemented"))

(defun local-time-gmt-offset (local-time)
  (gmt-offset (%local-time-to-unix local-time)))


(push :local-time *features*)