X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=base%2Ftime.lisp;h=6891188a656769ba544cf47de8f34fa49645f6e0;hb=faa5d9f559b59cc2bd328e95352b4b8152ea352c;hp=75034cff21236ddf7cf6ad334cb45034f79422bd;hpb=ce0e343835a040406678dff74a62d1b0cb56f317;p=clsql.git diff --git a/base/time.lisp b/base/time.lisp index 75034cf..6891188 100644 --- a/base/time.lisp +++ b/base/time.lisp @@ -1,24 +1,22 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; $Id: $ -;;;; ====================================================================== +;;;; ************************************************************************* ;;;; -;;;; Description ========================================================== -;;;; ====================================================================== +;;;; $Id$ ;;;; ;;;; A variety of structures and function for creating and ;;;; manipulating dates, times, durations and intervals for -;;;; CLSQL-USQL. +;;;; CLSQL. ;;;; ;;;; This file was originally part of ODCL and is Copyright (c) 2002 - ;;;; 2003 onShore Development, Inc. ;;;; -;;;; ====================================================================== - +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* (in-package #:clsql-base-sys) - ;; ------------------------------------------------------------ ;; Months @@ -86,6 +84,13 @@ );eval-when +(defun duration-timestring (duration) + (let ((second (duration-second duration)) + (minute (duration-minute duration)) + (hour (duration-hour duration)) + (day (duration-day duration))) + (format nil "P~dD~dH~dM~dS" day hour minute second))) + ;; ------------------------------------------------------------ ;; Constructors @@ -136,9 +141,9 @@ (values hour minute second)))) (defun time-ymd (time) - (destructuring-bind (minute day year) + (destructuring-bind (month day year) (mjd-to-gregorian (time-mjd time)) - (values year minute day))) + (values year month day))) (defun time-dow (time) "Return the 0 indexed Day of the week starting with Sunday" @@ -154,19 +159,27 @@ month, year, integer day-of-week" (values second minute hour day month year (mod (+ (time-mjd time) 3) 7))))) ;; duration specific -(defun duration-reduce (duration precision) - (ecase precision - (:second - (+ (duration-second duration) - (* (duration-reduce duration :minute) 60))) - (:minute - (+ (duration-minute duration) - (* (duration-reduce duration :hour) 60))) - (:hour - (+ (duration-hour duration) - (* (duration-reduce duration :day) 24))) - (:day - (duration-day duration)))) +(defun duration-reduce (duration precision &optional round) + (:second + (+ (duration-second duration) + (* (duration-reduce duration :minute) 60))) + (:minute + (+ (if round + (floor (duration-second duration) 30) + 0) + (duration-minute duration) + (* (duration-reduce duration :hour) 60))) + (:hour + (+ (if round + (floor (duration-minute duration) 30) + 0) + (duration-hour duration) + (* (duration-reduce duration :day) 24))) + (:day + (+ (if round + (floor (duration-hour duration) 12) + 0) + (duration-day duration)))) ;; ------------------------------------------------------------ @@ -273,7 +286,7 @@ month, year, integer day-of-week" (result number)) ((null nlist) (return result)) (declare (list nlist)) - (if (%time> (car nlist) result) (setq result (car nlist))))) + (if (%time> (car nlist) result) (setf result (car nlist))))) (defun time-min (number &rest more-numbers) "Returns the least of its arguments." @@ -281,7 +294,7 @@ month, year, integer day-of-week" (result number)) ((null nlist) (return result)) (declare (list nlist)) - (if (%time< (car nlist) result) (setq result (car nlist))))) + (if (%time< (car nlist) result) (setf result (car nlist))))) (defun time-compare (time-a time-b) (let ((mjd-a (time-mjd time-a)) @@ -361,6 +374,7 @@ month, year, integer day-of-week" (defstruct interval (start nil) (end nil) + (name nil) (contained nil) (type nil) (data nil)) @@ -437,16 +451,14 @@ month, year, integer day-of-week" (defun interval-match (list time) "Return the index of the first interval in list containing time" ;; this depends on ordering of intervals! - (dotimes (x (length list)) - (let ((elt (nth x list))) - (when (and (time<= (interval-start elt) time) - (time< time (interval-end elt))) - (return-from interval-match x)) - (when (time< time (interval-start elt)) - (return-from interval-match nil))))) - + (let ((list (sort-interval-list list))) + (dotimes (x (length list)) + (let ((elt (nth x list))) + (when (and (time<= (interval-start elt) time) + (time< time (interval-end elt))) + (return-from interval-match x)))))) + (defun interval-clear (list time) - ;(cmsg "List = ~s" list) (dotimes (x (length list)) (let ((elt (nth x list))) (when (and (time<= (interval-start elt) time) @@ -715,10 +727,10 @@ with the given options" (defun current-year () (third (mjd-to-gregorian (time-mjd (get-time))))) -(defun current-day () +(defun current-month () (second (mjd-to-gregorian (time-mjd (get-time))))) -(defun current-month () +(defun current-day () (first (mjd-to-gregorian (time-mjd (get-time))))) (defun parse-date-time (string) @@ -767,6 +779,11 @@ with the given options" (t (values hours "AM")))) +(defmethod to-string ((time wall-time) &rest keys) + (destructuring-bind (&key (style :daytime) &allow-other-keys) + keys + (print-date time style))) + (defun print-date (time &optional (style :daytime)) (multiple-value-bind (second minute hour day month year dow) (decode-time time) @@ -949,11 +966,34 @@ rules" (let ((doy (+ day (* 31 (1- month))))) (declare (type fixnum doy)) (when (< 2 month) - (setq doy (- doy (floor (+ 23 (* 4 month)) 10))) + (setf doy (- doy (floor (+ 23 (* 4 month)) 10))) (when (leap-year? year) (incf doy))) doy)) +(defun parse-yearstring (string) + (let ((year (or (parse-integer-insensitively string) + (extract-roman string)))) + (when (and year (< 1500 year 2500)) + (make-time :year year)))) + +(defvar *roman-digits* + '((#\M . 1000) + (#\D . 500) + (#\C . 100) + (#\L . 50) + (#\X . 10) + (#\V . 5) + (#\I . 1))) + +(defun extract-roman (string &aux parse) + (dotimes (x (length string)) + (when-bind (val (get-alist (aref string x) *roman-digits*)) + (when (and parse (< (car parse) val)) + (push (- (pop parse)) parse)) + (push val parse))) + (apply #'+ parse)) + ;; ------------------------------------------------------------ ;; Parsing iso-8601 timestrings @@ -1010,7 +1050,7 @@ formatted date string." (t (return-from parse (make-duration :day days :hour hours :minute minutes :second secs)))) - (setq index next-index)))))) + (setf index next-index)))))) ;; e.g. 2000-11-11 00:00:00-06