X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=base%2Ftime.lisp;h=0b70f2c6f28b9610f7b7ac9875b38dfa72da3f4a;hp=381a77d2bb8b553c88191bba636b4cbdb296bd9c;hb=9bbed78051e80e6ab76ae47834136035602bbbf1;hpb=e06ca99080d17083dcfcf3f148de4a8796773e78

diff --git a/base/time.lisp b/base/time.lisp
index 381a77d..0b70f2c 100644
--- a/base/time.lisp
+++ b/base/time.lisp
@@ -1,10 +1,7 @@
 ;;;; -*- 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
@@ -13,11 +10,12 @@
 ;;;; This file was originally part of ODCL and is Copyright (c) 2002 -
 ;;;; 2003 onShore Development, Inc.
 ;;;;
-;;;; ======================================================================
-
-
-(in-package #:clsql-base-sys)
+;;;; 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)
 
 ;; ------------------------------------------------------------
 ;; 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
@@ -104,13 +109,17 @@
   (%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)
@@ -136,9 +145,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 +163,28 @@ 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)
+(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)))))
 
 
 ;; ------------------------------------------------------------
@@ -273,7 +291,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 +299,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 +379,7 @@ month, year, integer day-of-week"
 (defstruct interval
   (start nil)
   (end nil)
+  (name nil) 
   (contained nil)
   (type nil)
   (data nil))
@@ -437,16 +456,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)
@@ -667,31 +684,32 @@ TIME2."
                     (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)
@@ -715,10 +733,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 +785,14 @@ with the given options"
         (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)
@@ -949,11 +975,40 @@ 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))))
+
+(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 
@@ -1010,7 +1065,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