r8970: time patch/tests from Marcus Pearce

diff --git a/base/package.lisp b/base/package.lisp
index e403fb6b7daefc5b89ed9981560260eb75867bcb..5eadf6583a26180bb5bf16a1c40ad2c81254b2fd 100644 (file)
--- a/base/package.lisp
+++ b/base/package.lisp
@@ -161,7 +161,9 @@
         #:duration-month
         #:duration-second
         #:duration-year
-        #:duration-reduce                
+        #:duration-reduce 
+        #:duration-timestring
+        #:extract-roman 
         #:format-duration
         #:format-time
         #:get-time
@@ -183,6 +185,7 @@
         #:month-name
         #:parse-date-time
         #:parse-timestring
+        #:parse-yearstring
         #:print-date
         #:roll
         #:roll-to

diff --git a/base/time.lisp b/base/time.lisp
index c4da0d2a5a70b70d0b47a8b383e55497ca7c0546..6891188a656769ba544cf47de8f34fa49645f6e0 100644 (file)
--- a/base/time.lisp
+++ b/base/time.lisp
@@ -84,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
@@ -134,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"
@@ -152,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))))
 
 
 ;; ------------------------------------------------------------
@@ -271,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."
@@ -279,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))
@@ -359,6 +374,7 @@ month, year, integer day-of-week"
 (defstruct interval
   (start nil)
   (end nil)
+  (name nil) 
   (contained nil)
   (type nil)
   (data nil))
@@ -435,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)
@@ -713,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)
@@ -765,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)
@@ -947,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 
@@ -1008,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
 

diff --git a/clsql-tests.asd b/clsql-tests.asd
index eeca1825ae674746d1c1f1eba265c4555cb33aa0..4fc94cfad70e09617b46740c6d3dea0db2aee9a7 100644 (file)
--- a/clsql-tests.asd
+++ b/clsql-tests.asd
@@ -32,6 +32,7 @@
              :components ((:file "package")
                           (:file "utils")
                           (:file "test-init")
+                          (:file "test-time")
                           (:file "test-basic")
                           (:file "test-connection")
                           (:file "test-fddl")

diff --git a/tests/test-time.lisp b/tests/test-time.lisp
new file mode 100644 (file)
index 0000000..f04daac
--- /dev/null
+++ b/tests/test-time.lisp
@@ -0,0 +1,216 @@
+;;; -*- Mode: Lisp -*-
+;;; $Id: test-time.lisp,v 1.10 2004/03/08 18:00:53 jesse Exp $
+;;;
+;;; Copyright (c) 2000, 2001 onShore Development, Inc.
+;;;
+;;; Test time functions (time.lisp)
+
+(in-package #:clsql-tests)
+
+(setq *rt-time* 
+      '(
+
+;; relations of intervals
+(deftest :time/1
+    (let* ((time-1 (clsql-base:parse-timestring "2002-01-01 10:00:00"))
+          (time-2 (clsql-base:parse-timestring "2002-01-01 11:00:00"))
+          (time-3 (clsql-base:parse-timestring "2002-01-01 12:00:00"))
+          (time-4 (clsql-base:parse-timestring "2002-01-01 13:00:00"))
+          (interval-1 (clsql-base:make-interval :start time-1 :end time-2))
+          (interval-2 (clsql-base:make-interval :start time-2 :end time-3))
+          (interval-3 (clsql-base:make-interval :start time-3 :end time-4))
+          (interval-4 (clsql-base:make-interval :start time-1 :end time-3))
+          (interval-5 (clsql-base:make-interval :start time-2 :end time-4))
+          (interval-6 (clsql-base:make-interval :start time-1 :end time-4)))
+      (flet ((my-assert (number relation i1 i2)
+              (declare (ignore number))
+              (let ((found-relation (clsql-base:interval-relation i1 i2)))
+                (equal relation found-relation))))
+       (and 
+        (my-assert 1 :contains interval-1 interval-1)
+        (my-assert 2 :precedes interval-1 interval-2)
+        (my-assert 3 :precedes interval-1 interval-3)
+        (my-assert 4 :contained interval-1 interval-4)
+        (my-assert 5 :precedes interval-1 interval-5)
+        (my-assert 6 :contained interval-1 interval-6)
+        (my-assert 7 :follows interval-2 interval-1)
+        (my-assert 8 :contains interval-2 interval-2)
+        (my-assert 9 :precedes interval-2 interval-3)
+        (my-assert 10 :contained interval-2 interval-4)
+        (my-assert 11 :contained interval-2 interval-5)
+        (my-assert 12 :contained interval-2 interval-6)
+        (my-assert 13 :follows interval-3 interval-1)
+        (my-assert 14 :follows interval-3 interval-2)
+        (my-assert 15 :contains interval-3 interval-3)
+        (my-assert 16 :follows interval-3 interval-4)
+        (my-assert 17 :contained interval-3 interval-5)
+        (my-assert 18 :contained interval-3 interval-6)
+        (my-assert 19 :contains interval-4 interval-1)
+        (my-assert 20 :contains interval-4 interval-2)
+        (my-assert 21 :precedes interval-4 interval-3)
+        (my-assert 22 :contains interval-4 interval-4)
+        (my-assert 23 :overlaps interval-4 interval-5)
+        (my-assert 24 :contained interval-4 interval-6)
+        (my-assert 25 :follows interval-5 interval-1)
+        (my-assert 26 :contains interval-5 interval-2)
+        (my-assert 27 :contains interval-5 interval-3)
+        (my-assert 28 :overlaps interval-5 interval-4)
+        (my-assert 29 :contains interval-5 interval-5)
+        (my-assert 30 :contained interval-5 interval-6)
+        (my-assert 31 :contains interval-6 interval-1)
+        (my-assert 32 :contains interval-6 interval-2)
+        (my-assert 33 :contains interval-6 interval-3)
+        (my-assert 34 :contains interval-6 interval-4)
+        (my-assert 35 :contains interval-6 interval-5)
+        (my-assert 36 :contains interval-6 interval-6))))
+  t)
+
+;; adjacent intervals in list
+(deftest :time/2
+  (let* ((interval-list nil)
+         (time-1 (clsql-base:parse-timestring "2002-01-01 10:00:00"))
+         (time-3 (clsql-base:parse-timestring "2002-01-01 12:00:00"))
+         (time-4 (clsql-base:parse-timestring "2002-01-01 13:00:00")))
+    (setf interval-list 
+         (clsql-base:interval-push interval-list (clsql-base:make-interval :start time-1 :end time-3
+                                                     :type :open)))
+    (setf interval-list 
+         (clsql-base:interval-push interval-list (clsql-base:make-interval :start time-3 :end time-4
+                                                     :type :open)))
+    (clsql-base:interval-relation (car interval-list) (cadr interval-list)))
+  :precedes)
+
+;; nested intervals in list
+(deftest :time/3
+    (let* ((interval-list nil)
+          (time-1 (clsql-base:parse-timestring "2002-01-01 10:00:00"))
+          (time-2 (clsql-base:parse-timestring "2002-01-01 11:00:00"))
+          (time-3 (clsql-base:parse-timestring "2002-01-01 12:00:00"))
+          (time-4 (clsql-base:parse-timestring "2002-01-01 13:00:00")))
+      (setf interval-list 
+           (clsql-base:interval-push interval-list (clsql-base:make-interval :start time-1 
+                                                       :end time-4 
+                                                       :type :open)))
+      (setf interval-list 
+           (clsql-base:interval-push interval-list (clsql-base:make-interval :start time-2 
+                                                       :end time-3 
+                                                       :type :closed)))
+      (let* ((interval (car interval-list))
+            (interval-contained 
+             (when interval (car (clsql-base:interval-contained interval)))))
+       (when (and interval interval-contained)
+         (and (clsql-base:time= (clsql-base:interval-start interval) time-1)
+              (clsql-base:time= (clsql-base:interval-end interval) time-4)
+              (eq (clsql-base:interval-type interval) :open)
+              (clsql-base:time= (clsql-base:interval-start interval-contained) time-2)
+              (clsql-base:time= (clsql-base:interval-end interval-contained) time-3)
+              (eq (clsql-base:interval-type interval-contained) :closed)))))
+  t)
+
+;; interval-edit - nonoverlapping
+(deftest :time/4
+    (let* ((interval-list nil)
+          (time-1 (clsql-base:parse-timestring "2002-01-01 10:00:00"))
+          (time-2 (clsql-base:parse-timestring "2002-01-01 11:00:00"))
+          (time-3 (clsql-base:parse-timestring "2002-01-01 12:00:00"))
+          (time-4 (clsql-base:parse-timestring "2002-01-01 13:00:00")))
+      (setf interval-list (clsql-base:interval-push interval-list (clsql-base:make-interval :start time-1 :end time-2 :type :open)))
+      (setf interval-list (clsql-base:interval-push interval-list (clsql-base:make-interval :start time-3 :end time-4 :type :closed)))
+      (setf interval-list (clsql-base:interval-edit interval-list time-1 time-1 time-3))
+      ;; should be time-3 not time-2 
+      (clsql-base:time= (clsql-base:interval-end (car interval-list)) time-3))
+  t)
+
+;; interval-edit - overlapping
+(deftest :time/5
+    (let* ((interval-list nil)
+          (time-1 (clsql-base:parse-timestring "2002-01-01 10:00:00"))
+          (time-2 (clsql-base:parse-timestring "2002-01-01 11:00:00"))
+          (time-3 (clsql-base:parse-timestring "2002-01-01 12:00:00"))
+          (time-4 (clsql-base:parse-timestring "2002-01-01 13:00:00")))
+      (setf interval-list (clsql-base:interval-push interval-list (clsql-base:make-interval :start time-1 :end time-2 :type :open)))
+      (setf interval-list (clsql-base:interval-push interval-list (clsql-base:make-interval :start time-2 :end time-4 :type :closed)))
+      (let ((pass t))
+       (handler-case 
+           (progn 
+             (setf interval-list 
+                   (clsql-base:interval-edit interval-list time-1 time-1 time-3))
+             (setf pass nil))
+         (error nil))
+       pass))
+  t)
+
+;; interval-edit - nested intervals in list
+(deftest :time/6
+    (let* ((interval-list nil)
+          (time-1 (clsql-base:parse-timestring "2002-01-01 10:00:00"))
+          (time-2 (clsql-base:parse-timestring "2002-01-01 11:00:00"))
+          (time-3 (clsql-base:parse-timestring "2002-01-01 12:00:00"))
+          (time-4 (clsql-base:parse-timestring "2002-01-01 13:00:00"))
+          (time-5 (clsql-base:parse-timestring "2002-01-01 14:00:00"))
+          (time-6 (clsql-base:parse-timestring "2002-01-01 15:00:00")))
+      (setf interval-list (clsql-base:interval-push interval-list (clsql-base:make-interval :start time-1 :end time-6 :type :open)))
+      (setf interval-list (clsql-base:interval-push interval-list (clsql-base:make-interval :start time-2 :end time-3 :type :closed)))
+      (setf interval-list (clsql-base:interval-push interval-list (clsql-base:make-interval :start time-4 :end time-5 :type :closed)))
+      (setf interval-list (clsql-base:interval-edit interval-list time-1 time-1 time-4))
+      ;; should be time-4 not time-6 
+      (clsql-base:time= (clsql-base:interval-end (car interval-list)) time-4))
+  t)
+  
+;; Test the boundaries of Local Time with granularity of 1 year
+(deftest :time/7
+    (let ((sec-in-year (* 60 60 24 365))
+         (year (clsql-base:time-element (clsql-base:make-time) :year)))
+      (dotimes (n 50 n)
+       (let ((date (clsql-base:make-time :second (* n sec-in-year))))
+         (unless (= (+ year n)
+                    (clsql-base:time-element date :year))
+           (return n)))))
+  50)
+
+;; Test db-timestring
+(deftest :time/9
+    (flet ((grab-year (dbstring)
+            (parse-integer (subseq dbstring 1 5))))
+      (let ((second-in-year (* 60 60 24 365)))
+       (dotimes (n 2000 n)
+         (let* ((second (* -1 n second-in-year))
+                (date (clsql-base:make-time :year 2525 :second second)))
+           (unless
+                (= (grab-year (clsql-base:db-timestring date))
+                   (clsql-base:time-element date :year))
+             (return n))))))
+  2000)
+
+;; Conversion between MJD and Gregorian
+(deftest :time/10
+    (dotimes (base 10000 base)
+      (unless (= (apply #'clsql-base:gregorian-to-mjd (clsql-base:mjd-to-gregorian base))
+                base)
+       (return base)))
+  10000)
+  
+;; Clsql-Base:Roll by minutes: +90
+(deftest :time/11
+    (let ((now (clsql-base:get-time)))
+      (clsql-base:time= (clsql-base:time+ now (clsql-base:make-duration :minute 90))
+            (clsql-base:roll now :minute 90)))
+  t)
+
+;;Clsql-Base:Roll by minutes: +900
+(deftest :time/12
+    (let ((now (clsql-base:get-time)))
+      (clsql-base:time= (clsql-base:time+ now (clsql-base:make-duration :minute 900))
+            (clsql-base:roll now :minute 900)))
+  t)
+
+
+;; Clsql-Base:Roll by minutes: +900
+(deftest :time/13
+    (let* ((now (clsql-base:get-time))
+          (add-time (clsql-base:time+ now (clsql-base:make-duration :minute 9000)))
+          (roll-time (clsql-base:roll now :minute 9000)))
+      (clsql-base:time= add-time roll-time))
+  t)
+
+))