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)))

6
date-arith.lisp
View file

@ -24,6 +24,12 @@
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;; Date-Arith.lisp - Functions to compare dates, add days or months to dates
;;;; and calculate the number of days or years between two dates.
;;;; The day convention may be specified when calculating date differences or
;;;; advancing dates by months - different results may be returned depending
;;;; on the convention used.
(in-package :cl-dates)
;; Date comparisons - strip off time component

4
dates.lisp
View file

@ -24,6 +24,10 @@
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;; Dates.lisp - basic date routines to convert from Gregorian dates to Julian dates
;;;; and vice versa. Also contains functions to calculate astronomical dates such as
;;;; Easter, the equinozes, etc.
(in-package :cl-dates)
(defun jday-number (date)

2
packages.lisp
View file

@ -24,6 +24,8 @@
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;; Packages.lisp - defines the cl-dates package and all exported symbols
(in-package :cl-user)
(defpackage :cl-dates

32
parse-date.lisp
View file

@ -24,17 +24,17 @@
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;
;; Contains a string to date-time converter that accurately parses most common
;; ways of writing dates. See test-parse-dates.lisp for examples.
;;
;; Only the string->date function is exported from this file - all other functions
;; are simply supporting functions for string->date and are not meant to be used
;; elsewhere.
;;
;; The code is largely based on the Python dateutils library but there are some
;; differences and optimizations
;;
;;;; Parse-Date.lisp - Contains a string to date-time converter that accurately
;;;; parses most common ways of writing dates.
;;;;
;;;; See test-parse-dates.lisp for examples.
;;;;
;;;; Only the string->date function is exported from this file - all other functions
;;;; are simply supporting functions for string->date and are not meant to be used
;;;; elsewhere.
;;;;
;;;; The code is largely based on the Python dateutils library but there are some
;;;; differences and optimizations
(in-package :cl-dates)
@ -64,7 +64,7 @@
;; separate "23.jun.2017" => "23" "." "jun" "." "2017"
;; any trailing period will be dropped
(setf token (nreverse token))
(loop for tk on (split-list #'(lambda(x) (char= x #\.)) token)
(loop for tk on (split-list (lambda(x) (char= x #\.)) token)
do (progn
(push (coerce (car tk) 'string) token-list)
(unless (null (cdr tk))
@ -186,18 +186,18 @@
(t (multiple-value-bind (yy mm) (assign-yy-mm list precedence)
(values yy mm nil))))
(let (tmp)
(cond ((every #'(lambda(x) (<= x 12)) list)
(cond ((every (lambda(x) (<= x 12)) list)
;; 01/02/03
(cond ((eq precedence :mdy) (values (third list) (first list) (second list)))
((eq precedence :dmy) (values (third list) (second list) (first list)))
(t (values (first list) (second list) (third list)))))
((setf tmp (find-if #'(lambda(x) (> x 31)) list))
((setf tmp (find-if (lambda(x) (> x 31)) list))
;; 12/5/55
(setf list (remove tmp list :count 1))
(multiple-value-bind (mm dd) (assign-mm-dd list precedence)
(values tmp mm dd)))
((= 1 (count-if #'(lambda(x) (<= x 12)) list))
(setf tmp (find-if #'(lambda(x) (<= x 12)) list)
((= 1 (count-if (lambda(x) (<= x 12)) list))
(setf tmp (find-if (lambda(x) (<= x 12)) list)
list (remove tmp list :count 1))
(multiple-value-bind (yy dd) (assign-yy-dd list precedence)
(values yy tmp dd)))

3
print-date.lisp
View file

@ -24,6 +24,9 @@
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;; Print-Date.lisp - functions to convert a date-time into various string
;;;; formats
(in-package :cl-dates)
(defun date->string (date &key (format :human) zone)

2
timezones.lisp
View file

@ -24,6 +24,8 @@
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;; TimeZones.lisp - Contains a table mapping timezones to their offsets from GMT
(in-package :cl-dates)
;; hash table containing mappings from time zone abbreviation to GMT offset

4
util.lisp
View file

@ -24,6 +24,10 @@
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;; Util.lisp - small utility functions used across the cl-dates package.
;;;; E.g., functions to convert symbols for day of week, date convention,
;;;; etc to strings for printing
(in-package :cl-dates)
(defun parse-number (string)