From 844047d1e7609ed4879128aaa9e388bdd28f0d7a Mon Sep 17 00:00:00 2001 From: Sudhir Shenoy Date: Mon, 24 Jul 2017 20:30:30 +0900 Subject: [PATCH] Added business date arithmetic functions --- bus-date-arith.lisp | 112 ++++++++++++++++++++++++++++++++++++++++++++ cl-dates.asd | 3 +- packages.lisp | 19 ++++++-- 3 files changed, 129 insertions(+), 5 deletions(-) create mode 100644 bus-date-arith.lisp diff --git a/bus-date-arith.lisp b/bus-date-arith.lisp new file mode 100644 index 0000000..6ab0ed7 --- /dev/null +++ b/bus-date-arith.lisp @@ -0,0 +1,112 @@ +;;; 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. + +;;;; Bus-Date-Arith.lisp - Date arithmetic and movement functions that +;;;; operate as per a holiday calendar. Computed dates are forced to be +;;;; on business days, i.e., not weekends or holidays. + +(in-package :cl-dates) + +(defun workday-number (date calendar) + "Return the business day number in the year (out of approx. 252) +If date is not a business day, the number of working days prior to +that date is returned" + (let ((year (date->ymd date))) + (loop for dt = (ymd->date year 1 1) then (1+ dt) + until (date> dt date) + counting (business-day-p date calendar)))) + +(defun add-days-return-bus-day (date calendar days) + "Add days to date and if the result is not a business day, +advance the date to a business day in the same direction" + (let ((plus-minus (if (< days 0) #'- #'+))) + (loop for dt = (+ date days) then (funcall plus-minus dt 1) + until (business-day-p dt calendar) + finally (return dt)))) + +(defun next-workday (date calendar) + "Return the next business day after date" + (add-days-return-bus-day date calendar +1)) + +(defun prev-workday (date calendar) + "Return the business day immediately before date" + (add-days-return-bus-day date calendar -1)) + +(defun add-business-days (date calendar days) + (let ((fn (if (< days 0) #'prev-workday #'next-workday))) + (loop for i from 1 upto (abs days) + do (setf date (funcall fn date calendar)) + finally (return date)))) + +(defun diff-workdays (date1 date2 calendar) + "Counts the number of business days between two dates. +Dates may be in either order, returned count is always positive. +The earlier date is not included in the count and the later date +is included only when it is a business day" + (when (date< date2 date1) + (rotatef date1 date2)) + (loop for dt = (next-workday date1 calendar) then (next-workday dt calendar) + until (date> dt date2) + counting t)) + +(defun first-workday-of-month (date calendar) + "First business day of month that date is in" + (next-workday (last-day-of-prev-month date) calendar)) + +(defun last-workday-of-month (date calendar) + "Last business day of month that date falls in" + (let ((dt (last-day-of-month date))) + (if (business-day-p dt calendar) + dt + (prev-workday dt calendar)))) + +(defun last-workday-of-prev-month (date calendar) + "Last business day of month before the one that date falls in" + (let ((dt (last-day-of-prev-month date))) + (if (business-day-p dt calendar) + dt + (prev-workday dt calendar)))) + +(defun adjust-date (date calendar &optional (roll-convention :modified-following)) + "Move date if it falls on a holiday or weekend according to roll convention. +Roll convention can be one of- +:preceding - date is moved to the previous business day +:following - date is moved to the next business day +:modified-following - date is moved to the next business day unless that falls in +the next month in which case it is moved to the previous day" + (cond ((business-day-p date calendar) date) + ((eq roll-convention :preceding) (prev-workday date calendar)) + ((eq roll-convention :following) (next-workday date calendar)) + ((eq roll-convention :modified-following) + (let ((dt (next-workday date calendar))) + (multiple-value-bind (yy mm) (date->ymd dt) + (declare (ignore yy)) + (multiple-value-bind (yy1 mm1) (date->ymd date) + (declare (ignore yy1)) + (if (= mm mm1) + dt + (prev-workday date calendar)))))) + (t (error "Unknown roll convention ~s" roll-convention)))) diff --git a/cl-dates.asd b/cl-dates.asd index a9f05f9..e1f0688 100644 --- a/cl-dates.asd +++ b/cl-dates.asd @@ -45,7 +45,8 @@ (:file "print-date") (:file "date-arith") (:file "holidays") - (:file "calendar"))) + (:file "calendar") + (:file "bus-date-arith"))) (defsystem :cl-dates-test :description "Date-time library tests" diff --git a/packages.lisp b/packages.lisp index a319522..bc06cdb 100644 --- a/packages.lisp +++ b/packages.lisp @@ -59,6 +59,8 @@ :jday-number ; Julian day number :day-of-week ; Day of week for date :leap-year-p + :day-number ; day number in year + :week-number ; week of year ;; Comparisons :date= :date/= :date< :date<= @@ -74,11 +76,20 @@ :diff-days ; absolute number of days between two dates :diff-years ; years between dates using day count conventions ;; Holiday calendars and weekends - :make-calendar - :known-centres - :get-holidays-for-centre + :make-calendar ; create new holiday calendar + :known-centres ; centres for which holiday generators exist + :get-holidays-for-centre ; list of holidays for a centre+year :weekend-p :weekday-p :holiday-p - :business-day-p + :business-day-p ; not a holiday or weekend + ;; Business date arithmetic + :workday-number ; nth business day of year + :next-workday ; next business day after date + :prev-workday ; business day before date + :diff-workdays ; number of business days between dates + :first-workday-of-month + :last-workday-of-month + :last-workday-of-prev-month + :adjust-date ; move date if not a business day ))