[local-time-devel] Adding java Calendar 'like' math to local-time

[Andrea Chiumenti]

Hello ppl,

I've added the following functionality to local time,
I only wonder if it's not the case to render the internal *-add-*
functions as methods.

Have a nice day,
kiuma


(defgeneric local-time-add (local-time field value)
  (:documentation "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."))

(defun local-time-add-year (local-time value)
  (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)
  (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)))
            (encode-local-time ns ss mm hh day month year))))))

(defun local-time-add-day (local-time value)
  (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)
  (multiple-value-bind (ns ss mm hh day month year)
          (decode-local-time local-time)
    (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 hh2 day2 month2 year2)
            (decode-local-time local-time-result)
          (encode-local-time ns2 ss2 mm2 (+ hh d-hour) day2 month2 year2))))))

(defun local-time-add-min (local-time value)
  (multiple-value-bind (ns ss mm hh day month year)
          (decode-local-time local-time)
    (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 mm2 hh2 day2 month2 year2)
            (decode-local-time local-time-result)
          (encode-local-time ns2 ss2 (+ mm d-min) hh2 day2 month2 year2))))))

(defun local-time-add-sec (local-time value)
  (multiple-value-bind (ns ss mm hh day month year)
          (decode-local-time local-time)
    (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 ss2 mm2 hh2 day2 month2 year2)
            (decode-local-time local-time-result)
          (encode-local-time ns2 (+ ss d-sec) mm2 hh2 day2 month2 year2))))))

(defun local-time-add-nsec (local-time value)
  (multiple-value-bind (ns ss mm hh day month year)
          (decode-local-time local-time)
    (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 (ns2 ss2 mm2 hh2 day2 month2 year2)
            (decode-local-time local-time-result)
          (encode-local-time (+ ns d-nsec) ss2 mm2 hh2 day2 month2 year2))))))


;;; make this extern <<-----------------------------
(defmethod local-time-add ((local-time local-time) field value)
  (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))))