Holiday / weekend calendar class and methods

calendar.lisp

@@ -0,0 +1,192 @@
+;;; 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.
+
+;;;; Calendar.lisp - Holiday calendar class and associated methods to
+;;;; classify dates as business days / holidays / weekends
+
+(in-package :cl-dates)
+
+(defparameter +default-weekend+ '(:saturday :sunday))
+
+(defparameter +known-centres+
+  ;;    Centre              Hol function     discriminant
+  (list :Eurex       (list #'german-holidays :Eurex)
+	:Frankfurt   (list #'german-holidays :Eurex)
+	:Euwax       (list #'german-holidays :Euwax)
+	:Stuttgart   (list #'german-holidays :Euwax)
+	:Germany     (list #'german-holidays :settlement)
+	:DEM         (list #'german-holidays :settlement) ; Deutsche Mark doesn't exist but still ...
+	:Tokyo       (list #'japan-holidays  :settlement)
+	:Japan       (list #'japan-holidays  :settlement)
+	:JPY         (list #'japan-holidays  :settlement)
+	:Zurich      (list #'swiss-holidays  :settlement)
+	:Switzerland (list #'swiss-holidays  :settlement)
+	:CHF         (list #'swiss-holidays  :settlement)
+	:TARGET      (list #'target-holidays :settlement)
+	:EUR         (list #'target-holidays :settlement)
+	:London      (list #'uk-holidays     :settlement)
+	:UK          (list #'uk-holidays     :settlement)
+	:GBP         (list #'uk-holidays     :settlement)
+	:US          (list #'us-holidays     :settlement)
+	:USD         (list #'us-holidays     :settlement)
+	:NYSE        (list #'us-holidays     :NYSE)
+	:NY          (list #'us-holidays     :NYSE)
+	:UST         (list #'us-holidays     :bonds)
+	:US-Bond     (list #'us-holidays     :bonds)))
+
+;; base class - no functionality (null calendar)
+(defclass calendar ()
+  ((name :initarg :name :accessor name)
+   (weekend :initarg :weekend :accessor weekend)))
+
+(defclass calendar-single (calendar)
+  ((centre :initarg :centre :accessor centre)
+   (holidays :initarg :holidays :accessor holidays)
+   (holidays-min-year :accessor holidays-min-year)
+   (holidays-max-year :accessor holidays-max-year)))
+
+(defclass calendar-union (calendar)
+  ((calendars :initarg :calendars :accessor calendars))) ; list of calendars
+
+(defun make-calendar (centres &key (name nil) (weekend (copy-list +default-weekend+))
+				   (holidays nil) (base-year 0))
+  (typecase centres
+    (keyword (multiple-value-bind (hols from-year to-year) (get-holiday-hash centres base-year)
+		(let ((cal (make-instance 'calendar-single :name name :centre :centres
+							   :weekend weekend :holidays hols)))
+		  (setf (holidays-min-year cal) from-year
+			(holidays-max-year cal) to-year)
+		  (unless name
+		    (setf (name cal) (string centres)))
+		  (when holidays
+		    (dolist (hol holidays)
+		      (add-holiday cal hol)))
+		  cal)))
+    ((and list (not null)) (let ((cal (make-instance 'calendar-union :name name
+								     :calendars nil)))
+			     (unless name
+			       (setf (name cal) (format nil "~{~a~^+~}" centres)))
+			     (dolist (centre centres)
+			       (push (make-calendar centre :name nil :weekend weekend
+							   :holidays holidays
+							   :base-year base-year)
+				     (calendars cal)))
+			     cal))
+    (t (when (null name)
+	 (setf name "Null Calendar"))
+     (make-instance 'calendar :name name :weekend weekend))))
+
+(defun known-centres ()
+  "Return centres for which holiday auto-generation is supported"
+  (loop for x on +known-centres+ by #'cddr
+	collect (car x)))
+
+(defun get-holidays-for-centre (centre year)
+  (let ((spec (getf +known-centres+ centre)))
+    (if spec
+	(funcall (first spec) year :which (second spec))
+	nil)))
+
+(defun get-holiday-hash (centre base-year)
+  (when (or (not (integerp base-year)) (<= base-year 1950))
+    (setf base-year (date->ymd (todays-date))))
+  (let* ((from-year (- base-year 2))
+	 (to-year (+ base-year 3))
+	 (hols (loop for yy from from-year upto to-year
+		     collect (get-holidays-for-centre centre yy)))
+	 (hash (make-hash-table :test 'equal)))
+    (dolist (hols-for-year hols)
+      (dolist (hol hols-for-year)
+	(setf (gethash hol hash) 1)))
+    (values hash from-year to-year)))
+
+(defmethod has-holidays-for-year ((cal calendar) (year integer))
+  t)
+
+(defmethod has-holidays-for-year ((cal calendar-single) (year integer))
+  (<= (holidays-min-year cal) year (holidays-max-year cal)))
+
+(defmethod has-holidays-for-year ((cal calendar-union) (year integer))
+  (every #'identity (mapcar (lambda(x) (has-holidays-for-year x year)) (calendars cal))))
+
+(defmethod update-calendar ((cal calendar) (year integer))
+  cal)
+
+(defmethod update-calendar ((cal calendar-single) (year integer))
+  (let ((from-year (min (- year 2) (1+ (holidays-max-year cal))))
+	(to-year (max (+ year 3) (1- (holidays-min-year cal)))))
+    (loop for yy from from-year upto to-year
+	  when (or (< yy (holidays-min-year cal))
+		   (> yy (holidays-max-year cal)))
+	    do (let ((hols (get-holidays-for-centre (centre cal) yy)))
+		 (dolist (hol hols)
+		   (setf (gethash hol (holidays cal)) 1))))
+    (setf (holidays-min-year cal) (min (holidays-min-year cal) from-year)
+	  (holidays-max-year cal) (max (holidays-max-year cal) to-year)))
+  cal)
+
+(defmethod update-calendar ((cal calendar-union) (year integer))
+  (dolist (c (calendars cal))
+    (update-calendar c year))
+  cal)
+
+(defmethod weekend-p (date (weekend-days list))
+  (member (day-of-week date) weekend-days))
+
+(defmethod weekend-p (date (cal calendar))
+  (weekend-p date (weekend cal)))
+
+(defmethod weekday-p (date (weekend-days list))
+  (not (weekend-p date weekend-days)))
+
+(defmethod weekday-p (date (cal calendar))
+  (weekday-p date (weekend cal)))
+
+(defmethod holiday-p (date (cal calendar))
+  (declare (ignore date cal))
+  nil)
+
+(defmethod holiday-p (date (cal calendar-single))
+  (let ((year (date->ymd date)))
+    (unless (has-holidays-for-year cal year)
+      (update-calendar cal year)))
+  (not (null (gethash (jday-number date) (holidays cal)))))
+
+(defmethod holiday-p (date (cal calendar-union))
+  (some #'identity (lambda (cal) (holiday-p date cal)) (calendars cal)))
+
+(defmethod business-day-p (date (cal calendar))
+  (and (weekday-p date cal)
+       (not (holiday-p date cal))))
+
+(defmethod add-holiday ((cal calendar-single) date)
+  (let ((year (date->ymd date)))
+    (unless (<= (holidays-min-year cal) year (holidays-max-year cal))
+      (update-calendar cal year)))
+  (setf (gethash (jday-number date) (holidays cal)) 2))
+
+(defmethod remove-holiday ((cal calendar-single) date)
+  (remhash (jday-number date) (holidays cal)))