97 lines
3.6 KiB
Common Lisp
97 lines
3.6 KiB
Common Lisp
;;; Copyright (c) 2017, Sudhir Shenoy. 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 :cl-dates)
|
|
|
|
;; Date comparisons - strip off time component
|
|
(defun date= (&rest dates)
|
|
(every (lambda (a b) (= (jday-number a) (jday-number b))) dates (cdr dates)))
|
|
|
|
(defun date/= (&rest dates)
|
|
(notevery (lambda (a b) (= (jday-number a) (jday-number b))) dates (cdr dates)))
|
|
|
|
(defun date> (&rest dates)
|
|
(every (lambda (a b) (> (jday-number a) (jday-number b))) dates (cdr dates)))
|
|
|
|
(defun date< (&rest dates)
|
|
(every (lambda (a b) (< (jday-number a) (jday-number b))) dates (cdr dates)))
|
|
|
|
(defun date>= (&rest dates)
|
|
(every (lambda (a b) (>= (jday-number a) (jday-number b))) dates (cdr dates)))
|
|
|
|
(defun date<= (&rest dates)
|
|
(every (lambda (a b) (<= (jday-number a) (jday-number b))) dates (cdr dates)))
|
|
|
|
;; Date arithmetic
|
|
|
|
(defun date+ (date days)
|
|
"Advance date by given number of days"
|
|
(+ date days))
|
|
|
|
(defun date- (date days)
|
|
"Retreat date by given number of days"
|
|
(- date days))
|
|
|
|
(defun date-diff (dt1 dt2)
|
|
"Return (positive) number of days between two dates"
|
|
(abs (- (jday-number dt1) (jday-number dt2))))
|
|
|
|
(defun nth-day-of-week (date dow n)
|
|
"Returns the nth day of the week e.g., second Saturday of the month in which date falls.
|
|
If n is large enough to make the date fall in a future month, the last valid day in
|
|
the month is returned."
|
|
(multiple-value-bind (yy mm dd h m s) (date->ymd date)
|
|
(declare (ignore dd))
|
|
(let ((dt (loop for dd = (ymd->date yy mm 1 h m s) then (1+ dd)
|
|
until (eq dow (day-of-week dd))
|
|
finally (return dd))))
|
|
(if (< n 2)
|
|
dt
|
|
(dotimes (i (1- n) dt)
|
|
(let ((next-dt (+ 7 dt)))
|
|
(multiple-value-bind (yy1 mm1 dd1 h1 m1 s1) (date->ymd next-dt)
|
|
(declare (ignore yy1 dd1 h1 m1 s1))
|
|
(if (/= mm1 mm)
|
|
(return dt)
|
|
(setf dt next-dt)))))))))
|
|
|
|
(defun first-of-next-month (date)
|
|
"Returns date for 1st of the following month"
|
|
(multiple-value-bind (yy mm dd h m s) (date->ymd date)
|
|
(declare (ignore dd))
|
|
(if (= mm 12)
|
|
(ymd->date (1+ yy) 1 1 h m s)
|
|
(ymd->date yy (1+ m) 1 h m s))))
|
|
|
|
(defun last-day-of-month (date)
|
|
"Returns last day in curent month"
|
|
(1- (first-of-next-month date)))
|
|
|
|
(defun last-day-of-prev-month (date)
|
|
"Returns last day of previous month"
|
|
(multiple-value-bind (yy mm dd h m s) (date->ymd date)
|
|
(declare (ignore dd))
|
|
(1- (ymd->date yy mm 1 h m s))))
|