diff options
Diffstat (limited to 'third_party/lisp/sclf/time.lisp')
| -rw-r--r-- | third_party/lisp/sclf/time.lisp | 311 |
1 files changed, 311 insertions, 0 deletions
diff --git a/third_party/lisp/sclf/time.lisp b/third_party/lisp/sclf/time.lisp new file mode 100644 index 000000000000..ca1e1902a92c --- /dev/null +++ b/third_party/lisp/sclf/time.lisp @@ -0,0 +1,311 @@ +;;; time.lisp --- time primitives + +;;; Copyright (C) 2006, 2007, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: sclf + +#+cmu (ext:file-comment "$Module: time.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library 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 +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :sclf) + +(defun year (epoch &optional time-zone) + "Return the year of EPOCH." + (sixth (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun month (epoch &optional time-zone) + "Return the month of EPOCH." + (fifth (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun day (epoch &optional time-zone) + "Return the day of EPOCH." + (fourth (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun week-day (epoch &optional time-zone) + "Return the day of the week of EPOCH." + (seventh (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun hour (epoch &optional time-zone) + "Return the hour of EPOCH." + (third (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun minute (epoch &optional time-zone) + "Return the minute of EPOCH." + (second (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun leap-year-p (year) + "Return true if YEAR is a leap year." + (and (zerop (mod year 4)) + (or (not (zerop (mod year 100))) + (zerop (mod year 400))))) + +(defun last-day-of-month (month year) + "Return the last day of the month as integer." + (be last (elt #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month)) + (if (and (= last 28) + (leap-year-p year)) + (1+ last) + last))) + +(defun add-months (months epoch &optional time-zone) + "Add MONTHS to EPOCH, which is a universal time. MONTHS can be +negative." + (multiple-value-bind (ss mm hh day month year) (decode-universal-time epoch time-zone) + (multiple-value-bind (y m) (floor (+ month months -1) 12) + (let ((new-month (1+ m)) + (new-year (+ year y))) + (encode-universal-time ss mm hh + (min day (last-day-of-month new-month (year epoch))) + new-month + new-year + time-zone))))) + +(defun add-days (days epoch) + "Add DAYS to EPOCH, which is an universal time. DAYS can be +negative." + (+ (* 60 60 24 days) epoch)) + +;; The following two functions are based on Thomas Russ <tar@isi.edu> +;; code which didn't carry any copyright notice, so I assume it was in +;; the public domain. + +(defun iso-time-string (time &key time-zone with-timezone-p basic) + "Return an ISO 8601 string representing TIME. The time zone is +included if WITH-TIMEZONE-P is true." + (flet ((format-timezone (zone) + (if (zerop zone) + "Z" + (multiple-value-bind (h m) (truncate (abs zone) 1.0) + ;; Sign of time zone is reversed in ISO 8601 relative + ;; to Common Lisp convention! + (format nil "~:[+~;-~]~2,'0D:~2,'0D" + (> zone 0) h (round m)))))) + (multiple-value-bind (second minute hour day month year dow dst zone) + (decode-universal-time time time-zone) + (declare (ignore dow dst)) + (if basic + (format nil "~4,'0D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D~[~*~;~A~]" + year month day hour minute second + with-timezone-p (format-timezone zone)) + (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]" + year month day hour minute second + with-timezone-p (format-timezone zone)))))) + +(defun parse-iso-time-string (time-string) + "Parse an ISO 8601 formated string and return the universal time. +It can parse the basic and the extended format, but may not be able to +cover all the cases." + (labels ((parse-delimited-string (string delimiter n) + ;; Parses a delimited string and returns a list of + ;; n integers found in that string. + (let ((answer (make-list n :initial-element 0))) + (loop + for i upfrom 0 + for start = 0 then (1+ end) + for end = (position delimiter string :start (1+ start)) + do (setf (nth i answer) + (parse-integer (subseq string start end))) + when (null end) return t) + (values-list answer))) + (parse-fixed-field-string (string field-sizes) + ;; Parses a string with fixed length fields and returns + ;; a list of integers found in that string. + (let ((answer (make-list (length field-sizes) :initial-element 0))) + (loop + with len = (length string) + for start = 0 then (+ start field-size) + for field-size in field-sizes + for i upfrom 0 + while (< start len) + do (setf (nth i answer) + (parse-integer (subseq string start (+ start field-size))))) + (values-list answer))) + (parse-iso8601-date (date-string) + (let ((hyphen-pos (position #\- date-string))) + (if hyphen-pos + (parse-delimited-string date-string #\- 3) + (parse-fixed-field-string date-string '(4 2 2))))) + (parse-iso8601-timeonly (time-string) + (let* ((colon-pos (position #\: time-string)) + (zone-pos (or (position #\- time-string) + (position #\+ time-string))) + (timeonly-string (subseq time-string 0 zone-pos)) + (zone-string (when zone-pos (subseq time-string (1+ zone-pos)))) + (time-zone nil)) + (when zone-pos + (multiple-value-bind (zone-h zone-m) + (parse-delimited-string zone-string #\: 2) + (setq time-zone (+ zone-h (/ zone-m 60))) + (when (char= (char time-string zone-pos) #\-) + (setq time-zone (- time-zone))))) + (multiple-value-bind (hh mm ss) + (if colon-pos + (parse-delimited-string timeonly-string #\: 3) + (parse-fixed-field-string timeonly-string '(2 2 2))) + (values hh mm ss time-zone))))) + (let ((time-separator (position #\T time-string))) + (multiple-value-bind (year month date) + (parse-iso8601-date + (subseq time-string 0 time-separator)) + (if time-separator + (multiple-value-bind (hh mm ss zone) + (parse-iso8601-timeonly + (subseq time-string (1+ time-separator))) + (if zone + ;; Sign of time zone is reversed in ISO 8601 + ;; relative to Common Lisp convention! + (encode-universal-time ss mm hh date month year (- zone)) + (encode-universal-time ss mm hh date month year))) + (encode-universal-time 0 0 0 date month year)))))) + +(defun time-string (time &optional time-zone) + "Return a string representing TIME in the form: + Tue Jan 25 12:55:40 2005" + (multiple-value-bind (ss mm hh day month year week-day) + (decode-universal-time time time-zone) + (format nil "~A ~A ~A ~D:~2,'0D:~2,'0D ~A" + (subseq (week-day->string week-day) 0 3) + (subseq (month->string month) 0 3) + day + hh mm ss + year))) + +(defun beginning-of-month (month year &optional time-zone) + (encode-universal-time 0 0 0 1 month year time-zone)) + +(defun end-of-month (month year &optional time-zone) + (1- (add-months 1 (encode-universal-time 0 0 0 1 month year time-zone)))) + +(defun beginning-of-first-week (year &optional time-zone) + "Return the epoch of the first week of YEAR. As the first week +of the year needs to have Thursday in this YEAR, the returned +time can actually fall in the previous year." + (let* ((Jan-1st (encode-universal-time 0 0 0 1 1 year time-zone)) + (start (- 4 (week-day (add-days 4 Jan-1st))))) + (add-days start Jan-1st))) + +(defun beginning-of-week (week year &optional time-zone) + "Return the epoch of the beginning of WEEK of YEAR." + (add-days (* (1- week) 7) (beginning-of-first-week year time-zone))) + +(defun end-of-week (week year &optional time-zone) + "Return the epoch of the beginning of WEEK of YEAR." + (1- (beginning-of-week (1+ week) year time-zone))) + +(defun end-of-last-week (year &optional time-zone) + "Return the epoch of the last week of YEAR. As the last week +of the year needs to have Thursday in this YEAR, the returned +time can fall in the next year." + (1- (beginning-of-first-week (1+ year) time-zone))) + +(defun seconds-from-beginning-of-the-year (time &optional time-zone) + (- time (encode-universal-time 0 0 0 1 1 (year time) time-zone))) + +(defun day-of-the-year (time &optional time-zone) + "Return the day within the year of TIME starting from 1 up to +365 (or 366)." + (1+ (truncate (seconds-from-beginning-of-the-year time time-zone) + (* 60 60 24)))) + +(defun week (time &optional time-zone) + "Return the number of the week and the year TIME referes to. +Week is an integer from 1 to 52. Due to the way the first week +of the year is calculated a day in one year could actually be in +the last week of the previous or next year." + (let* ((year (year time)) + (start (beginning-of-first-week year time-zone)) + (days-from-start (truncate (- time start) (* 60 60 24))) + (weeks (truncate days-from-start 7)) + (week-number (mod weeks 52))) + (values (1+ week-number) + (cond ((< weeks 0) + (1- year)) + ((> weeks 51) + (1+ year)) + (t year))))) + +(defun week-day->string (day &optional sunday-first) + "Return the weekday string corresponding to DAY number." + (elt (if sunday-first + #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) + day)) + +(defconst +month-names+ #("January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December")) + +(defun month->string (month) + "Return the month string corresponding to MONTH number." + (elt +month-names+ (1- month))) + +(defun month-string->number (month) + (1+ (position month +month-names+ :test #'string-equal))) + +(defun print-time-span (span &optional stream) + "Print in English the time SPAN expressed in seconds." + (let* ((minute 60) + (hour (* minute 60)) + (day (* hour 24)) + (seconds span)) + (macrolet ((split (divisor) + `(when (>= seconds ,divisor) + (prog1 (truncate seconds ,divisor) + (setf seconds (mod seconds ,divisor)))))) + (let* ((days (split day)) + (hours (split hour)) + (minutes (split minute))) + (format stream "~{~A~^ ~}" (remove nil + (list + (when days + (format nil "~D day~:P" days)) + (when hours + (format nil "~D hour~:P" hours)) + (when minutes + (format nil "~D minute~:P" minutes)) + (when (or (> seconds 0) + (= span 0)) + (format nil "~D second~:P" seconds))))))))) + +(defun next-week-day (epoch week-day &optional time-zone) + "Return the universal time of the next WEEK-DAY starting from epoch." + (add-days (mod (- week-day (week-day epoch time-zone)) 7) + epoch)) + +(defun next-monday (epoch &optional time-zone) + "Return the universal time of the next Monday starting from +EPOCH." + (next-week-day epoch 0 time-zone)) + +(defun full-weeks-in-span (start end &optional time-zone) + "Return the number of full weeks in time span START to END. A +full week starts on Monday and ends on Sunday." + (be first-monday (next-monday start time-zone) + (truncate (- end first-monday) (* 7 24 60 60)))) + +(defconst +unix-lisp-time-difference+ + (encode-universal-time 0 0 0 1 1 1970 0) + "Time difference between Unix epoch and Common Lisp epoch. The +former is 1st January 1970, while the latter is the beginning of the +XX century.") + +(defun universal->unix-time (time) + (- time +unix-lisp-time-difference+)) + +(defun unix->universal-time (time) + (+ time +unix-lisp-time-difference+)) + +(defun get-unix-time () + (universal->unix-time (get-universal-time))) |