aland/cl-dates
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Added comments and documentation strings

Browse source
This commit is contained in:
Sudhir Shenoy 2017-07-22 22:03:53 +09:00
parent c17039fd47
commit 9d06952341
8 changed files with 103 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

74
calendar.lisp
View file

@ -33,7 +33,10 @@
(defparameter +known-centres+
;; Centre Hol function discriminant
(list :Eurex (list #'german-holidays :Eurex)
(list :Australia (list #'aus-holidays :settlement)
:Sydney (list #'aus-holidays :settlement)
:AUD (list #'aus-holidays :settlement)
:Eurex (list #'german-holidays :Eurex)
:Frankfurt (list #'german-holidays :Eurex)
:Euwax (list #'german-holidays :Euwax)
:Stuttgart (list #'german-holidays :Euwax)
@ -57,25 +60,59 @@
:UST (list #'us-holidays :bonds)
:US-Bond (list #'us-holidays :bonds)))
;; base class - no functionality (null calendar)
;; base class - no holidays other than weekends
(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)))
(defmethod print-object ((cal calendar) stream)
(print-unreadable-object (cal stream :type t)
(format stream "Name: ~a; Weekend: ~a; No holidays defined" (name cal) (weekend cal))))
;; The main class - holds holidays corresponding to a single location / trading centre
;; Holidays are lazily loaded as and when required
(defclass calendar-single (calendar)
((centre :initarg :centre :accessor centre) ; trading centre
(holidays :initarg :holidays :accessor holidays) ; hash table with dates as keys
(holidays-min-year :accessor holidays-min-year) ; earliest year for which hols are loaded
(holidays-max-year :accessor holidays-max-year))) ; last year for which hols are loaded
(defmethod print-object ((cal calendar-single) stream)
(print-unreadable-object (cal stream :type t)
(format stream "Name: ~a (Centre: ~a); Weekend: ~a; Holidays for ~d-~d"
(name cal) (centre cal) (weekend cal)
(holidays-min-year cal) (holidays-max-year cal))))
;; Container for multiple calendars
;; A date is deemed to be a holiday if it is a holiday in any of the contained calendars
(defclass calendar-union (calendar)
((calendars :initarg :calendars :accessor calendars))) ; list of calendars
(defmethod print-object ((cal calendar-union) stream)
(print-unreadable-object (cal stream :type t)
(format stream "Name: ~a; ~a"
(name cal) (calendars cal))))
(defun make-calendar (centres &key (name nil) (weekend (copy-list +default-weekend+))
(holidays nil) (base-year 0))
"Create a new holiday calendar. Holidays are populated from a holiday computation
function (if available) and holidays explicitly specified (if any).
The 'centres' parameter may be
a keyword - an object of type calendar-single will be returned
a list of keywords - an object of type calendar-union is returned, each contained calendar
will be of type calendar-single
any other object - an object of type calendar will be returned.
The keyword parameters are:
name - a name used when printing the calendar (not used by any code)
weekend - the days comprising the weekend (Sat/Sun by default)
holidays - a list of dates that are holidays. This is useful when special holidays are declared
or when there is no function available to generate holidays.
base-year - Year around which holidays should be generated initially (current year if not specified).
Holidays are generated from base year - 2 to base year + 3."
(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
(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)
@ -105,12 +142,16 @@
collect (car x)))
(defun get-holidays-for-centre (centre year)
"Return a list of holidays for the given centre and year. NIL is returned if
there is no available function to generate holidays"
(let ((spec (getf +known-centres+ centre)))
(if spec
(funcall (first spec) year :which (second spec))
nil)))
(defun get-holiday-hash (centre base-year)
"Return a hash table with holidays as keys. Holidays are generated from base=year - 2
to base-year + 3."
(when (or (not (integerp base-year)) (<= base-year 1950))
(setf base-year (date->ymd (todays-date))))
(let* ((from-year (- base-year 2))
@ -124,18 +165,24 @@
(values hash from-year to-year)))
(defmethod has-holidays-for-year ((cal calendar) (year integer))
"Have holidays been generated for the current year? Always true since this
class does not store holidays"
t)
(defmethod has-holidays-for-year ((cal calendar-single) (year integer))
"Have holidays been generated for the current year?"
(<= (holidays-min-year cal) year (holidays-max-year cal)))
(defmethod has-holidays-for-year ((cal calendar-union) (year integer))
"Have holidays been generated for the current year? Check every sub-calendar"
(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))
"Extend generated holidays to include given year. All intervening years
are also generated so that the range of years is continuous"
(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
@ -149,44 +196,55 @@
cal)
(defmethod update-calendar ((cal calendar-union) (year integer))
"Extend generated holidays to include given year in all sub-calendars"
(dolist (c (calendars cal))
(update-calendar c year))
cal)
(defmethod weekend-p (date (weekend-days list))
"Return true if day of week of the given date is on a weekend"
(member (day-of-week date) weekend-days))
(defmethod weekend-p (date (cal calendar))
"Return true if day of week of the given date is on a weekend"
(weekend-p date (weekend cal)))
(defmethod weekday-p (date (weekend-days list))
"Return true if day of week of the given date is not on a weekend"
(not (weekend-p date weekend-days)))
(defmethod weekday-p (date (cal calendar))
"Return true if day of week of the given date is not on a weekend"
(weekday-p date (weekend cal)))
(defmethod holiday-p (date (cal calendar))
"True if date is a holiday in this calendar"
(declare (ignore date cal))
nil)
(defmethod holiday-p (date (cal calendar-single))
"True if date is a holiday in this calendar"
(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))
"True if date is a holiday in any contained calendar"
(some #'identity (lambda (cal) (holiday-p date cal)) (calendars cal)))
(defmethod business-day-p (date (cal calendar))
"True if date is not a holiday or weekend in the given calendar"
(and (weekday-p date cal)
(not (holiday-p date cal))))
(defmethod add-holiday ((cal calendar-single) date)
"Mark given date as a holiday in the calendar"
(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)
"Remove given date from list of holidays in the calendar"
(remhash (jday-number date) (holidays cal)))