;;;; This file is part of P36-lib
;;;; Copyright (C) 2016-2021 Alexa Jones-Gonzales <alexa@partition36.com>
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :p36-lib/time)
(deftype t/day-of-week ()
'(member :monday :tuesday :wednesday :thursday :friday :saturday :sunday))
(defining-consts
(+unix-time-offset+ (encode-universal-time 0 0 0 1 1 1970 0)
"The difference between Universal Time and Unix Time")
(+month-names+ '("January" "February" "March"
"April" "May" "June"
"July" "August" "September"
"October" "November" "December"))
(+short-month-names+ '("Jan" "Feb" "Mar"
"Apr" "May" "Jun"
"Jul" "Aug" "Sep"
"Oct" "Nov" "Dec"))
(+day-names+ '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
(+short-day-names+ '("Mon" "Tues" "Wed" "Thurs" "Fri" "Sat" "Sun")))
(defgeneric leap-year-p (value))
(defmethod leap-year-p ((year integer))
"Returns T if YEAR is a leap year, or NIL otherwise."
(destructuring-bind (fh h f)
(mapcar #'(lambda (n) (zerop (mod year n))) '(400 100 4))
(or fh (and (not h) f))))
(declaim (inline t/day-of-week->num))
(defun t/day-of-week->num (dow)
"Converts a T/DAY-OF-WEEK to a day number (1 to 7)."
(declare (type t/day-of-week dow))
(ecase dow
(:monday 1)
(:tuesday 2)
(:wednesday 3)
(:thursday 4)
(:friday 5)
(:saturday 6)
(:sunday 7)))
(declaim (inline num->t/day-of-week))
(defun num->t/day-of-week (dow)
"Converts a day number (1 to 7) to a T/DAY-OF-WEEK."
(declare (type (integer 1 7) dow))
(ecase dow
(1 :monday)
(2 :tuesday)
(3 :wednesday)
(4 :thursday)
(5 :friday)
(6 :saturday)
(7 :sunday)))
(declaim (inline day-num->name))
(defun day-num->name (num &optional use-short-names)
"Converts a day number (1 to 7) to a string containing the name of the day.
If USE-SHORT-NAMES is truthy, this will return the short name, otherwise it
returns the long name."
(declare (type (integer 1 7) num))
(nth (1- num) (if use-short-names
+short-day-names+
+day-names+)))
(declaim (inline t/day-of-week->name))
(defun t/day-of-week->name (dow &optional use-short-names)
"Converts a T/DAY-OF-WEEK to a string containing the name of the day. If
USE-SHORT-NAMES is truthy, this will return the short name, otherwise it returns
the long name."
(declare (type t/day-of-week dow))
(day-num->name (t/day-of-week->num dow) use-short-names))
(defun day-name->num (name)
"Converts NAME to a day number between 1 and 7. NAME should be the name of a
day in English, as found in +DAY-NAMES+ or +SHORT-DAY-NAMES+. If NAME does not
match any, NIL is returned. The search is case insensitive."
(declare (type string name))
;; Check the long names first
(let ((ret (position name +day-names+ :test #'caseless-string=)))
;; If we didn't find anything in the long names, check the short names
(unless ret
(setf ret (position name +short-day-names+ :test #'caseless-string=)))
(when ret
(1+ ret))))
(defun month-num->name (num &optional use-short-names)
"Converts a month number (1 to 12) to a string containing the name of the
month. If USE-SHORT-NAMES is truthy, this returns the short name, otherwise it
returns the full name."
(declare (type (integer 1 12) num))
(nth (1- num) (if use-short-names
+short-month-names+
+month-names+)))
(defun month-name->num (name)
"Converts NAME to a month number between 1 and 12. NAME should be the name of
a day in English, as found in +MONTH-NAMES+ or +SHORT-MONTH-NAMES+. If NAME
does not match any, NIL is returned. The search is case insensitive."
(declare (type string name))
;; Check the long names first
(let ((ret (position name +month-names+ :test #'caseless-string=)))
;; If we didn't find anything in the long names, check the short
;; names
(unless ret
(setf ret (position name +short-month-names+ :test #'caseless-string=)))
(when ret
(1+ ret))))
(defun days-in-month (month &optional is-leap-year)
"Returns the number of a days in MONTH. MONTH can be a number between 1 and
12 inclusive, a short month name, or a long month name. If IS-LEAP-YEAR is
truthy, February will have one extra day."
(declare (type (or string (integer 1 12)) month))
(when (stringp month)
(setf month (month-name->num month)))
(case month
((9 4 6 11) 30)
((1 3 5 7 8 10 12) 31)
(otherwise
(if is-leap-year 29 28))))
(declaim (inline universal-time>unix))
(defun universal-time->unix (ut)
"Converts a Lisp universal time to Unix time."
(- ut +unix-time-offset+))
(declaim (inline unix->universal-time))
(defun unix->universal-time (ut)
"Converts Unix time to a a Lisp universal time."
(+ ut +unix-time-offset+))