source: release/1.10/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/date.lisp

;; date.lisp

#|
The MIT license.

Copyright (c) 2013 Paul L. Krueger

Permission is hereby granted, free of charge, to any person obtaining a copy of this software 
and associated documentation files (the "Software"), to deal in the Software without restriction, 
including without limitation the rights to use, copy, modify, merge, publish, distribute, 
sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is 
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial 
portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT 
LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

|#
(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; (require :tagged-dates) See note at end of this file if you are using this code on a CCL before 1.9 released
  (require :iu-classes))

(in-package :iu)

;;; some general date utility routines

(defun now ()
  (get-universal-time))

(defun today-date ()
  (multiple-value-bind (sec min hr dd mm yy day dst zone)
                       (decode-universal-time (get-universal-time))
    (declare (ignore sec min hr day dst))
    (encode-universal-time 0 0 12 dd mm yy zone)))

(defun dt (mm dd yy &optional (hour 12) (min 0) (sec 0) (zone nil))
  ;; yy can be 2 or 4 digit year
  ;; any dd greater than the end of the month is reduced to the last day of the month
  ;; To avoid complications associated with daylight savings time, we use 12 noon as
  ;; the time if not specified.
  (let ((max-dd (if (and (eql mm 2)
                         (not (logtest yy 3))
                         (or (eql 0 (mod yy 400))
                             (not (eql 0 (mod yy 100)))))
                  29
                  (svref #(31 28 31 30 31 30 31 31 30 31 30 31) (1- mm)))))
    (if zone
      (encode-universal-time sec min hour (min max-dd dd) mm yy zone)
      (encode-universal-time sec min hour (min max-dd dd) mm yy))))

(defun dt-diff (dt1 dt2)
  ;; computes the number of days between the two dates
  (round (abs (- dt1 dt2)) 86400))

(defun day-of-wk (dt)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore sec min hr dd mm yr dst zone))
    (nth day '(monday tuesday wednesday thursday friday saturday sunday))))

(defun abbrev-day-of-wk (dt)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore sec min hr dd mm yr dst zone))
    (nth day '(mon tue wed thu fri sat sun))))

(defun day-char (dt)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore sec min hr dd mm yr dst zone))
    (nth day '(m t w t f s s))))

(defun next-day (dt)
  (+ 86400 dt))

(defun prev-day (dt)
  (- dt 86400))

(defun inc-date (dt num interval-type)
  ;; interval-type should be one of :day :month :quarter :year
  (case interval-type
    (:day (inc-days dt num))
    (:month (inc-months dt num))
    (:quarter (inc-months dt (* 3 num)))
    (:year (inc-years dt num))))

(defun inc-days (dt num-dd)
  (+ (* 86400 num-dd) dt))

(defun inc-months (dt num-mm)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore day dst))
    (multiple-value-bind (yy-inc new-mm)
                         (floor (+ num-mm mm -1) 12)
      (dt (1+ new-mm) dd (+ yr yy-inc) hr min sec zone))))

(defun next-month (dt)
  (inc-months dt 1))
                           
(defun prev-month (dt)
  (inc-months dt -1))

(defun inc-years (dt num-yy)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore day dst))
    (dt mm dd (+ yr num-yy) hr min sec zone)))

(defun next-year (dt)
  (inc-years dt 1))

(defun prev-year (dt)
  (inc-years dt -1))

(defun last-dt-of-month (mm yy)
  (dt mm 31 yy))

(defun same-day-p (dt1 dt2)
  (multiple-value-bind (sec min hr dd1 mm1 yr1 day dst zone)
                       (decode-universal-time dt1)
    (declare (ignore sec min hr day dst zone))
    (multiple-value-bind (sec min hr dd2 mm2 yr2 day dst zone)
                       (decode-universal-time dt2)
      (declare (ignore sec min hr day dst zone))
      (and (eql dd1 dd2) (eql mm1 mm2) (eql yr1 yr2)))))

(defun days-to-sec (num-days)
  ;; convert a number of days to seconds, which can be added/subtracted
  ;; from a date to get a new date
  (* num-days 86400))

(defmacro do-dates ((dt start end &optional (return-form nil ret-p)) &rest forms)
  `(do* ((,dt ,start (+ ,dt 86400)))
        ((> ,dt ,end) (if ,ret-p ,return-form (values)))
     ,@forms))

(defmacro do-interval-dates ((dt start end interval &optional (return-form nil ret-p)) &rest forms)
  `(do* ((,dt ,start (+ ,dt (days-to-sec ,interval))))
        ((> ,dt ,end) (if ,ret-p ,return-form (values)))
     ,@forms))

(defmacro do-months ((dt start end mm-interval &optional (return-form nil ret-p)) &rest forms)
  `(do* ((,dt ,start (inc-months ,dt ,mm-interval)))
        ((> ,dt ,end) (if ,ret-p ,return-form (values)))
     ,@forms))

(defun days-between (dt1 dt2)
  (round (abs (- dt2 dt1)) 86400))

(defun months-between (dt1 dt2)
  ;; computes a floating point value of months where the fraction of a month is
  ;; computed using 7 days as .25 of 1 month
  ;; round the result if you want an integer
  ;; This has some use if you want to treat each month as a constant span on a graph
  ;; or something like that. For example (iu::months-between (iu::dt 2 3 2012) (iu::dt 4 3 2012))
  ;; will return 2.0.
  (multiple-value-bind (sec min hr dd1 mm1 yr1 day dst zone)
                       (decode-universal-time dt1)
    (declare (ignore sec min hr day dst zone))
    (multiple-value-bind (sec min hr dd2 mm2 yr2 day dst zone)
                       (decode-universal-time dt2)
      (declare (ignore sec min hr day dst zone))
      (float (abs (+ (* 12 (- yr2 yr1)) (- mm2 mm1) (/ (- dd2 dd1) 28)))))))

(defun years-between (dt1 dt2)
  ;; computes a floating point value of years where the fraction of a year is
  ;; computed treating each month as 1/12 of a year and each day as 1/365 of 1 year
  ;; round the result if you want an integer
  (multiple-value-bind (sec min hr dd1 mm1 yr1 day dst zone)
                       (decode-universal-time dt1)
    (declare (ignore sec min hr day dst zone))
    (multiple-value-bind (sec min hr dd2 mm2 yr2 day dst zone)
                       (decode-universal-time dt2)
      (declare (ignore sec min hr day dst zone))
      (float (abs (+ (- yr2 yr1) (/ (- mm2 mm1) 12) (/ (- dd2 dd1) 365)))))))

(defmethod days-from ((dt1 integer) (dt2 integer))
  (days-between dt1 dt2))

(defmethod days-from ((dt integer) (day symbol))
  (let* ((abbrev-days '(sun mon tue wed thu fri sat))
         (days '(sunday monday tuesday wednesday thursday friday saturday))
         (dow (abbrev-day-of-wk dt))
         (today (position dow abbrev-days))
         (day-pos (or (position day days)
                      (position day abbrev-days))))
    (if (<= today day-pos)
      (- day-pos today)
      (- 7 (- today day-pos)))))

(defmethod days-from ((day symbol) (dt integer))
  (let* ((abbrev-days '(sun mon tue wed thu fri sat))
         (days '(sunday monday tuesday wednesday thursday friday saturday))
         (dow (abbrev-day-of-wk dt))
         (day-pos (position dow abbrev-days))
         (today (or (position day days)
                    (position day abbrev-days))))
    (if (<= today day-pos)
      (- day-pos today)
      (- 7 (- today day-pos)))))

(defmethod days-from ((day1 symbol) (day2 symbol))
  (let* ((abbrev-days '(sun mon tue wed thu fri sat))
         (days '(sunday monday tuesday wednesday thursday friday saturday))
         (today (or (position day1 days)
                    (position day1 abbrev-days)))
         (day-pos (or (position day2 days)
                      (position day2 abbrev-days))))
    (if (<= today day-pos)
      (- day-pos today)
      (- 7 (- today day-pos)))))

(defun +days (dt days)
  (+ dt (days-to-sec days)))

(defun date-string (dt)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore sec min hr dst zone))
    (format nil 
            "~9a ~2,'0d/~2,'0d/~2,'0d" 
            (nth day '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
            mm dd (mod yr 100))))

(defun short-date-string (dt)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore sec min hr day dst zone))
    (format nil 
            "~2,'0d/~2,'0d/~2,'0d" mm dd (mod yr 100))))

(defun short-time-string (dt)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore sec dd mm yr day dst zone))
    (format nil 
            "~2,'0d:~2,'0d" hr min)))

(defun time-string (dt)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore dd mm yr day dst zone))
    (format nil 
            "~2,'0d:~2,'0d:~2,'0d on ~a" hr min sec (date-string dt))))

(defun mmdd-string (dt)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore sec min hr yr day dst zone))
    (format nil 
            "~2,'0d/~2,'0d" mm dd)))

(defun mmyy-string (dt)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore sec min hr dd day dst zone))
    (format nil 
            "~2,'0d/~2,'0d" mm (mod yr 100))))

(defun yr-string (dt)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore sec min hr dd mm day dst zone))
    (format nil 
            "~4,'0d" yr)))

(defun mmddyy-list (dt)
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore sec min hr day dst zone))
    (list mm dd yr)))

(defun dt-yr (dt)
    (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore sec min hr dd mm day dst zone))
    yr))

(defun date-list (strt end)
  (do* ((res (list strt) (cons next res))
        (next (next-day strt) (next-day next)))
       ((> next end) (nreverse res))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; utility functions supporting the use of an integer as a set days of
;; the week. The low-order 7 bits of the integer represent sun thru sat
;; Bit 0 = sun ... Bit 6 = sat.

(defun day-set-bit (day)
  (or (position day '(sun mon tue wed thu fri sat))
      (position day '(sunday monday tuesday wednesday thursday friday saturday))))

(defun add-day (day day-set)
  (dpb 1 (byte 1 (day-set-bit day)) day-set))

(defun remove-day (day day-set)
  (dpb 0 (byte 1 (day-set-bit day)) day-set))

(defun has-day-p (day-set day)
  (logbitp (day-set-bit day) day-set))

(defun in-dayset-p (dt day-set)
  (has-day-p day-set (abbrev-day-of-wk dt)))

(defun day-set (&rest days)
  (let ((ds 0))
    (dolist (day days ds)
      (setf ds (dpb 1 (byte 1 (day-set-bit day)) ds)))))

(defun num-days-in-dayset (dayset strt end)
  (count-if #'(lambda (dt)
                (in-dayset-p dt dayset))
            (date-list strt end)))

(defun random-date (begin-dt end-dt)
  (+ begin-dt (random (- end-dt begin-dt))))

(defun intl-date-string (dt)
  ;; A string that specifies a date and time value in the international string representation format—
  ;; YYYY-MM-DD HH:MM:SS ±HHMM, where ±HHMM is a time zone offset in hours and minutes from GMT
  ;; (for example, “2001-03-24 10:45:32 -0600” is a date in the USA central time zone).
  (multiple-value-bind (sec min hr dd mm yr day dst zone)
                       (decode-universal-time dt)
    (declare (ignore dst day))
    (format nil "~4d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d ~a~4,'0d"
            yr
            mm
            dd
            hr
            min
            sec
            (if (plusp zone) "-" "+" ) ;; lisp zone offset is opposite from typical universal formats
            (multiple-value-bind (h frac) (floor (abs zone))
              (floor (+ (* h 100) (* frac 60)))))))

;; The reference used for NSDate objects is 01/01/2001
;; This represents the difference between lisp's reference date and NSDate's
(defconstant $ns-lisp-ref-date-diff$ (dt 01 01 2001 0 0 0 0))

(defun lisp-to-ns-date (dt)
  (#/dateWithTimeIntervalSinceReferenceDate:
   ns:ns-date
   (coerce (- (or dt (now)) $ns-lisp-ref-date-diff$) 'double-float)))


(defun ns-to-lisp-date (ns-date)
  (+ (round (#/timeIntervalSinceReferenceDate ns-date)) $ns-lisp-ref-date-diff$))

(defun string-to-ns-date (str)
  (let ((obj (#/dateWithNaturalLanguageString: ns:ns-date
                                               (iu::lisp-to-temp-nsstring str))))
    (if (eql obj (%null-ptr))
      (error "~s is not a suitable date string" str)
      obj)))

(defun string-to-date (str)
  ;; make use of Cocoa's date construction method
  (ns-to-lisp-date (string-to-ns-date str)))

;; OSX is now using tagged dates that CCL doesn't know about before the released version of 1.9. So if you are running
;; something less than this, you must inform CCL about these objects. Do (require :tagged-dates) and then make the call below
;; when this is loaded.

;; (ccl::setup-class-info-for-tagged-instance (lisp-to-ns-date (now)))

(provide :date)