;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: src/local-time.lisp $

;;; Copyright (c) 2008, Andrea Chiumenti.  All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :claw-as)

(defun local-time-add-year (local-time value)
  "Adds or removes years, expressed by the value parameter, to a local-time instance"
  (multiple-value-bind (ns ss mm hh day month year)
      (decode-local-time local-time)
    (encode-local-time ns ss mm hh day month (+ year value))))

(defun local-time-add-month (local-time value)
  "Adds or removes monthes, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
  (multiple-value-bind (d-month d-year)
      (floor (abs value) 12)
    (when (< value 0)
      (setf d-month (- d-month)
            d-year (- d-year))
      (multiple-value-bind (ns ss mm hh day month year)
          (decode-local-time local-time)
        (multiple-value-bind (ns ss mm hh day month-ignore year)
            (decode-local-time (encode-local-time ns ss mm hh day 1 (+ year d-year)))
          (declare (ignore month-ignore))
          (encode-local-time ns ss mm hh day month year))))))

(defun local-time-add-day (local-time value)
  "Adds or removes days, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
  (let* ((curr-day (day-of local-time))
         (local-time-result (make-instance 'local-time
                                           :day curr-day
                                           :sec (sec-of local-time)
                                           :nsec (nsec-of local-time)
                                           :time-zone (timezone-of local-time))))
    (setf (day-of local-time-result) (+ curr-day value))
    local-time-result))

(defun local-time-add-hour (local-time value)
  "Adds or removes hours, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
  (multiple-value-bind (ns-ignore ss-ignore mm-ignore hh day-ignore month-ignore year-ignore)
      (decode-local-time local-time)
    (declare (ignore ns-ignore ss-ignore mm-ignore day-ignore month-ignore year-ignore))
    (multiple-value-bind (d-hour d-day)
        (floor (abs value) 24)
      (when (< value 0)
        (setf d-hour (- d-hour)
              d-day (- d-day)))
      (let ((local-time-result (local-time-add-day local-time d-day)))
        (multiple-value-bind (ns2 ss2 mm2 hh-ignore day2 month2 year2)
            (decode-local-time local-time-result)
          (declare (ignore hh-ignore))
          (encode-local-time ns2 ss2 mm2 (+ hh d-hour) day2 month2 year2))))))

(defun local-time-add-min (local-time value)
  "Adds or removes minutes, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
  (multiple-value-bind (ns-ignore ss-ignore mm hh-ignore day-ignore month-ignore year-ignore)
      (decode-local-time local-time)
    (declare (ignore ns-ignore ss-ignore hh-ignore day-ignore month-ignore year-ignore))
    (multiple-value-bind (d-min d-hour)
        (floor (abs value) 60)
      (when (< value 0)
        (setf d-min (- d-min)
              d-hour (- d-hour)))
      (let ((local-time-result (local-time-add-hour local-time d-hour)))
        (multiple-value-bind (ns2 ss2 mm-ignore hh2 day2 month2 year2)
            (decode-local-time local-time-result)
          (declare (ignore mm-ignore))
          (encode-local-time ns2 ss2 (+ mm d-min) hh2 day2 month2 year2))))))

(defun local-time-add-sec (local-time value)
  "Adds or removes seconds, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
  (multiple-value-bind (ns-ignore ss mm-ignore hh-ignore day-ignore month-ignore year-ignore)
      (decode-local-time local-time)
    (declare (ignore ns-ignore mm-ignore hh-ignore day-ignore month-ignore year-ignore))
    (multiple-value-bind (d-sec d-min)
        (floor (abs value) 60)
      (when (< value 0)
        (setf d-sec (- d-sec)
              d-min (- d-min)))
      (let ((local-time-result (local-time-add-min local-time d-min)))
        (multiple-value-bind (ns2 ss-ignore mm2 hh2 day2 month2 year2)
            (decode-local-time local-time-result)
          (declare (ignore ss-ignore))
          (encode-local-time ns2 (+ ss d-sec) mm2 hh2 day2 month2 year2))))))

(defun local-time-add-nsec (local-time value)
  "Adds or removes nanoseconds, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
  (multiple-value-bind (ns ss-ignore mm-ignore hh-ignore day-ignore month-ignore year-ignore)
      (decode-local-time local-time)
    (declare (ignore ss-ignore mm-ignore hh-ignore day-ignore month-ignore year-ignore))
    (multiple-value-bind (d-nsec d-sec)
        (floor (abs value) 10000000)
      (when (< value 0)
        (setf d-nsec (- d-nsec)
              d-sec (- d-sec)))
      (let ((local-time-result (local-time-add-sec local-time d-sec)))
        (multiple-value-bind (ns-ignore ss2 mm2 hh2 day2 month2 year2)
            (decode-local-time local-time-result)
          (declare (ignore ns-ignore))
          (encode-local-time (+ ns d-nsec) ss2 mm2 hh2 day2 month2 year2))))))

(defun local-time-add (local-time field value)
  "Adds the specified amount of VALUE to the LOCAL_TIME.
FIELD may be any of:
* 'NSEC nano-seconds
* 'MSEC milli-seconds
* 'SEC seconds
* 'MIN minutes
* 'HR hours
* 'DAY days
* 'MONTH monthes
* 'YEARS years.
And other FIELD value will produce an error condition."
  (ccase field
    (NSEC (local-time-add-nsec local-time value))
    (SEC (local-time-add-sec local-time value))
    (MIN (local-time-add-min local-time value))
    (HR (local-time-add-hour local-time value))
    (DAY (local-time-add-day local-time value))
    (MONTH (local-time-add-month local-time value))
    (YEAR (local-time-add-year local-time value))))