;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:clsql-base-sys)
+(in-package #:clsql-base)
;; ------------------------------------------------------------
;; Months
);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
(%make-wall-time :mjd (time-mjd time)
:second (time-second time)))
-(defun get-time ()
+(defun utime->time (utime)
"Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
(multiple-value-bind (second minute hour day mon year)
- (decode-universal-time (get-universal-time))
+ (decode-universal-time utime)
(make-time :year year :month mon :day day :hour hour :minute minute
:second second)))
+(defun get-time ()
+ "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
+ (utime->time (get-universal-time)))
+
(defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0)
(second 0))
(multiple-value-bind (minute-add second-60)
(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"
(values second minute hour day month year (mod (+ (time-mjd time) 3) 7)))))
;; duration specific
-(defun duration-reduce (duration precision)
+(defun duration-reduce (duration precision &optional round)
(ecase precision
(:second
(+ (duration-second duration)
- (* (duration-reduce duration :minute) 60)))
+ (* (duration-reduce duration :minute) 60)))
(:minute
- (+ (duration-minute duration)
- (* (duration-reduce duration :hour) 60)))
+ (+ (if round
+ (floor (duration-second duration) 30)
+ 0)
+ (duration-minute duration)
+ (* (duration-reduce duration :hour) 60)))
(:hour
- (+ (duration-hour duration)
- (* (duration-reduce duration :day) 24)))
+ (+ (if round
+ (floor (duration-minute duration) 30)
+ 0)
+ (duration-hour duration)
+ (* (duration-reduce duration :day) 24)))
(:day
- (duration-day duration))))
+ (+ (if round
+ (floor (duration-hour duration) 12)
+ 0)
+ (duration-day duration)))))
;; ------------------------------------------------------------
(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."
(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))
(defstruct interval
(start nil)
(end nil)
+ (name nil)
(contained nil)
(type nil)
(data nil))
(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)
(internal-separator " "))
"produces on stream the timestring corresponding to the wall-time
with the given options"
- (multiple-value-bind (second minute hour day month year dow)
- (decode-time time)
- (case format
- (:pretty
- (format stream "~A ~A, ~A ~D, ~D"
- (pretty-time hour minute)
- (day-name dow)
- (month-name month)
- day
- year))
- (:short-pretty
- (format stream "~A, ~D/~D/~D"
- (pretty-time hour minute)
- month day year))
- (:iso
- (let ((string (iso-timestring time)))
- (if stream
- (write-string string stream)
+ (let ((*print-circle* nil))
+ (multiple-value-bind (second minute hour day month year dow)
+ (decode-time time)
+ (case format
+ (:pretty
+ (format stream "~A ~A, ~A ~D, ~D"
+ (pretty-time hour minute)
+ (day-name dow)
+ (month-name month)
+ day
+ year))
+ (:short-pretty
+ (format stream "~A, ~D/~D/~D"
+ (pretty-time hour minute)
+ month day year))
+ (:iso
+ (let ((string (iso-timestring time)))
+ (if stream
+ (write-string string stream)
string)))
- (t
- (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D"
- year date-separator month date-separator day
- internal-separator hour time-separator minute time-separator
- second)))))
-
+ (t
+ (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D"
+ year date-separator month date-separator day
+ internal-separator hour time-separator minute time-separator
+ second))))))
+
(defun pretty-time (hour minute)
(cond
((eq hour 0)
(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)
(t
(values hours "AM"))))
+(defgeneric to-string (val &rest keys)
+ )
+
+(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)
(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))))
+
+(defun parse-integer-insensitively (string)
+ (let ((start (position-if #'digit-char-p string))
+ (end (position-if #'digit-char-p string :from-end t)))
+ (when (and start end)
+ (parse-integer (subseq string start (1+ end)) :junk-allowed t))))
+
+(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))
+ (let ((val (cdr (assoc (aref string x) *roman-digits*))))
+ (when (and val parse (< (car parse) val))
+ (push (- (pop parse)) parse))
+ (push val parse)))
+ (apply #'+ parse))
+
;; ------------------------------------------------------------
;; Parsing iso-8601 timestrings
(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
projects / clsql.git / blobdiff