From faa5d9f559b59cc2bd328e95352b4b8152ea352c Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 12 Apr 2004 16:18:23 +0000 Subject: [PATCH] r8970: time patch/tests from Marcus Pearce --- base/package.lisp | 5 +- base/time.lisp | 102 ++++++++++++++------ clsql-tests.asd | 1 + tests/test-time.lisp | 216 +++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 293 insertions(+), 31 deletions(-) create mode 100644 tests/test-time.lisp diff --git a/base/package.lisp b/base/package.lisp index e403fb6..5eadf65 100644 --- 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 c4da0d2..6891188 100644 --- 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 eeca182..4fc94cf 100644 --- 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 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) + +)) -- 2.34.1