;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Time-stamp: <2008-12-01 21:46:40 madhu>
;;;   Touched: Sun Dec 25 14:11:18 2005 +0530 <enometh@meer.net>
;;;   Bugs-To: enometh@meer.net
;;;   Status: Experimental, Gratuitous.  Do not redistribute.
;;;   Copyright (C) 2005, 2008 Madhu. All rights reserved
;;;
(defpackage "DATE-TIME"
  (:use "CL")
  (:import-from #+pcl "PCL" #-pcl "CLOS" "SLOT-DEFINITION-NAME"
		"CLASS-DIRECT-SLOTS")
  (:export "DATE-TIME"
	   "UTIME"
	   "ENCODE-DATE-TIME"
	   "FIXED-DATE"
	   "*TZ*" "*YEAR*"
	   "WITH-DATE-TIME-SLOTS"
	   "DURATION"
	   "DATE-TIME+"
	   "PARSE-DATE-PARSE-ERROR"
	   "PARSE-DYNAMICAL-TIME"))
(in-package "DATE-TIME")

(defclass date-time () (second minute hour date month year time-zone))

(defmethod utime ((date-time date-time))
  (with-slots (second minute hour date month year time-zone) date-time
    (encode-universal-time second minute hour date month year time-zone)))

(defun encode-date-time (second minute hour date month year time-zone)
  (make-instance 'date-time :utime nil
		 :second second :minute minute :hour hour
		 :date date :month month :year year :time-zone time-zone))


;;; ----------------------------------------------------------------------
;;;
;;;
;;;

(defgeneric month-name (x)
  (:documentation "Return canonical full name of month as a string."))

(defgeneric month-number (x)
  (:documentation "Return an integer between 1 and 12."))

(defmethod month-name ((month integer))
  (check-type month (integer 1 12))
  (ecase month
    (1 "January") (2 "February") (3 "March") (4 "April")
    (5 "May")
    (6 "June") (7 "July") (8 "August") (9 "September")
    (10 "October") (11 "November") (12 "December")))

(defmethod month-number ((month integer))
  (check-type month (integer 1 12))
  month)

(defmethod month-number ((month-name string))
  (loop for (month-number string) in
	'((1 "January") (2 "February") (3 "March") (4 "April")
	  (5 "May")
	  (6 "June") (6 "July") (8 "August") (9 "September")
	  (10 "October") (11 "November") (12 "December")
	  (1 "Jan") (2 "Feb") (3 "Mar") (4 "Apr") (5 "May") (6 "Jun")
	  (7 "Jul") (8 "Aug") (9 "Sep") (10 "Oct") (11 "Nov")
	  (12 "Dec"))
	if (string-equal string month-name) return month-number
	finally (error "BEEP: ~S month not known." month-name)))

(defmethod month-number ((date-time date-time))
  (with-slots (month) date-time
    (check-type month (integer 1 12))
    month))


;;; ----------------------------------------------------------------------
;;;
;;;

(defun gregorian-leap-year (year)
  (and (= (mod year 4) 0)
       (not (member (mod year 400)
		    (list 100 200 300)))))

;; adapted from reingold. untested.
(defun fixed-from-gregorian (second minute hour day month year)
  "Returns the number of days elapsed since Sun Dec 31 1BC."
  (let ((date (+ 0		       ; Days before start of calendar
		 (* 365 (1- year))     ; Ordinary days since epoch
		 (floor (1- year) 4)   ; Julian leap days since epoch...
		 (-		       ; ...minus century years since epoch...
		  (floor (1- year) 100))
		 (floor		      ; ...plus years since epoch divisible...
		  (1- year) 400)      ; ...by 400.
		 (floor		      ; Days in prior months this year...
		  (- (* 367 month) 362)	; ...assuming 30-day Feb
		  12)
		 (if (<= month 2)	; Correct for 28- or 29-day Feb
		     0
		     (if (gregorian-leap-year year) -1 -2))
		 day))
	(frac (/ (+ second (* 60 minute) (* 3600 hour)) 86400)))
    (values (+ date frac) date)))

;; reingold. Sun = 0
(defun weekday-from-gregorian (year month day)
  (mod (fixed-from-gregorian 0 0 0 day month year) 7))

;; adapted from reingold. untested.
(defun gregorian-from-fixed (fixed-date)
  "Returns muliple values. FIXED-DATE is the number of days elapsed since
12/31/1BC."
  (multiple-value-bind (date frac) (floor fixed-date)
    (let* ((gregorian-epoch 1)
	   (date1 (+ (1- gregorian-epoch) date 306))
	   (approx (floor (- date1 gregorian-epoch -2) 146097/400))
	   (start (+ gregorian-epoch	; start of next year
		     (* 365 approx)
		     (floor approx 4)
		     (- (floor approx 100))
		     (floor approx 400)))
	   (y (if (< date1 start) approx (1+ approx)))
	   (prior-days (- date (fixed-from-gregorian 0 0 0 1 3 (1- y))))
	   (month1 (mod (+ (floor (+ (* 5 prior-days) 155) 153) 2) 12))
	   (month (if (zerop month1) 12 month1))
	   (year (- y (floor (+ month 9) 12)))
	   (day (1+ (- date (fixed-from-gregorian 0 0 0 1 month year)))))
      (multiple-value-bind (hour minute1) (floor (* frac 86400) 3600)
	(multiple-value-bind (minute second) (floor minute1 60)
	  (values (floor second) minute hour day month year 0))))))

(defmethod fixed-date ((date-time date-time))
  "Returns the number of days elapsed since Sun Dec 31 1BC."
  (with-slots (second minute hour date month year time-zone) date-time
    (fixed-from-gregorian second minute (+ hour time-zone) date month year)))

(defun date-time-from-fixed (fixed-date)
  (multiple-value-call #'encode-date-time
    (gregorian-from-fixed fixed-date)))


;;; ----------------------------------------------------------------------
;;;
;;;
;;;

(defvar *tz* -11/2)			; current common lisp timezone

(defmethod initialize-instance :after ((obj date-time)
				       &key (utime (get-universal-time))
				       ;; override these
				       ((:second sec))
				       ((:minute min))
				       ((:hour hr))
				       ((:date dat))
				       ((:month mon))
				       ((:year yr))
				       ((:time-zone tz) *tz*)
				       &allow-other-keys)
  "Initialize a date-time object to the specified fields using common lisp
univeral time UTIME for defaults.  If UTIME is NIL, initialize with bogus
values."
  (with-slots (second minute hour date month year time-zone) obj
    (if utime
	(let (daylight-p day)
	  (multiple-value-setq (second minute hour date month year day
				       daylight-p time-zone)
	    (decode-universal-time utime tz))
	  (cond (time-zone
		 (when daylight-p (setq time-zone (1- time-zone))))
		(daylight-p (error "Can't handle daylight-p.")))
	  (assert (= (mod (1+ day) 7)
		     (weekday-from-gregorian year month date))))
	(multiple-value-setq (second minute hour date month year time-zone)
	  (values 0 0 0 1 1 1 tz)))
      (if sec (setq second sec))
      (if min (setq minute min))
      (if hr (setq hour hr))
      (if dat (setq date dat))
      (if yr (setq year yr))
      (when mon
	(setq month (month-number mon))))
    #+dbg
    (when utime
      (assert (= utime (utime obj))  nil "utime=~A objects utime=~A"
	      utime (utime obj))))

(defun time-zone (rational)
  (assert (<= -24 rational 24))
  (assert (zerop (nth-value 1 (round (* 3600 rational)))))
  (format nil "~C~2,'0D~2,'0D" (if (plusp rational) #\- #\+)
	  (abs (truncate rational))
	  (truncate (* 60 (mod rational 1)))))

(defmethod print-object ((obj date-time) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (with-slots  (second minute hour date month year time-zone) obj
      (format stream
	      "\"~A ~A ~2,' D ~2,'0D:~2,'0D:~2,'0D ~A ~4D\""
	      (ecase (weekday-from-gregorian year month date)
		(0 "Sun") (1 "Mon") (2 "Tue") (3 "Wed") (4 "Thu")
		(5 "Fri") (6 "Sat"))
	      (ecase month
		(1 "Jan") (2 "Feb") (3 "Mar") (4 "Apr") (5 "May") (6 "Jun")
		(7 "Jul") (8 "Aug") (9 "Sep") (10 "Oct") (11 "Nov")
		(12 "Dec"))
	      date hour minute second
	      (case time-zone
		(-11/2 "IST")
		(0 "GMT")
		(t (time-zone time-zone)))
	      year))))

(defun cmp-date-time (a b)
  (< (utime a) (utime b)))

(defmacro with-date-time-slots ((&rest slot-names) date-time &body body)
  "Make DATE-TIME slotnames available in YOUR package!"
  (let* ((direct-slot-names
	  (mapcar #'slot-definition-name
		  (class-direct-slots (find-class 'DATE-TIME:date-time))))
	 (var (gensym)))
    `(let* ((,var ,date-time)
	    ,@(loop for slot-name in slot-names
		    for other = (find slot-name direct-slot-names
				      :test #'string= :key #'symbol-name)
		    unless other
		    do (error "Slot ~A not found in ~A~&." slot-name
			      direct-slot-names)
		    else collect
		    (list slot-name `(slot-value ,var ',other))))
       ,@body)))


;;; ----------------------------------------------------------------------
;;;
;;; DAYS-IN-MONTH
;;;

(defvar *year*
  (let ((x (make-instance 'date-time)))
    (with-slots (year) x
      year))
  "Current year.")

(defun days-in-month (thing &optional (year *year*))
  (assert (not (<= 0 year 99)))
  (ecase (month-number thing)
    (1 31)				; jan
    (2 (if (gregorian-leap-year year) 29 28))
    (3 31)				; mar
    (4 30)				; apr
    (5 31)				; may
    (6 30)				; jun
    (7 31)				; jul
    (8 31)				; aug
    (9 30)				; sep
    (10 31)				; oct
    (11 30)				; nov
    (12 31)				; dec
    ))


;;; ----------------------------------------------------------------------
;;;
;;; DURATIONS AND PERIODS
;;;

(defclass duration ()
  ((seconds :initform 0 :initarg :seconds :type (integer 0))
   (minutes :initform 0 :initarg :minutes :type (integer 0))
   (hours :initform 0 :initarg :hours :type (integer 0))
   (days :initform 0 :initarg :days :type (integer 0))
   (months :initform 0 :initarg :months :type (integer 0))
   (years :initform 0 :initarg :years :type (integer 0))
   (signum :initform 1 :initarg :signum :type (integer -1 1))))

(defmethod print-object ((obj duration) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (with-slots  (seconds minutes hours days months years signum) obj
      (ignore-errors
	(format stream "~@[~A~]~@[~AY~]~@[~AM~]~@[~AD~]~@[~Ah~]~@[~Am~]~@[~As~]"
		(unless (plusp signum) "-")
		(unless (zerop years) years)     (unless (zerop months) months)
		(unless (zerop days) days)       (unless (zerop hours) hours)
		(unless (zerop minutes) minutes) (unless (zerop seconds) seconds))))))

(defun date-time-add-days (date-time days1)
  (date-time-from-fixed (+ (fixed-date date-time) days1)))

(defun date-time-add-months (date-time months1)
  (with-slots (second minute hour date month year time-zone) date-time
    (multiple-value-bind (years2 months2) (floor (+ months1 month) 12)
      (encode-date-time second minute hour date (if (zerop months2) 12 months2)
			(+ year years2) time-zone))))

(defun date-time-add-years (date-time years1)
  (with-slots (second minute hour date month year time-zone) date-time
    (encode-date-time second minute hour date month (+ year years1) time-zone)))

(defvar *date-time-decomposition-strategy*
  :count-years-first)

(defun date-time-add-duration (date-time duration &optional
			       (strategy *date-time-decomposition-strategy*)
			       (minusp (minusp (slot-value duration 'signum))))
  (with-slots (years months days hours minutes seconds signum) duration
    (let ((days1 (+ days (/ (+ seconds (* 60 minutes) (* 3600 hours)) 86400))))
      (ecase strategy
	(:count-years-first
	 (date-time-add-days
	  (date-time-add-months
	   (date-time-add-years date-time (if minusp (- years) years))
	   (if minusp (- months) months))
	  (if minusp (- days1) days1)))
	(:count-days-first
	 (date-time-add-years
	  (date-time-add-months
	   (date-time-add-days date-time (if minusp (- days1) days1))
	   (if minusp (- months) months))
	  (if minusp (- years) years)))))))

(defmethod date-time+ ((date-time date-time) (duration duration)
		       &optional (strategy *date-time-decomposition-strategy*))
  (date-time-add-duration date-time duration strategy))

(defmethod date-time+ ((duration duration) (date-time date-time)
		       &optional (strategy *date-time-decomposition-strategy*))
  (date-time-add-duration date-time duration strategy))

(defmethod date-time- ((date-time date-time) (duration duration)
		       &optional (strategy *date-time-decomposition-strategy*))
  (date-time-add-duration date-time duration strategy
			  (plusp (slot-value duration 'signum))))

(defmethod date-time- ((duration duration) (date-time date-time)
		       &optional (strategy *date-time-decomposition-strategy*))
  (date-time-add-duration date-time duration strategy
			  (plusp (slot-value duration 'signum))))

;; NOT SYMMETRIC. ALWAYS MORE ACCURATE THAN USER SPECIFIED TIMEPERIODS.
(defmethod date-time- ((date-time date-time) (date-time2 date-time)
		       &optional (strategy *date-time-decomposition-strategy*))
  (declare (ignore strategy))
  (let ((diff (- (fixed-date date-time) (fixed-date date-time2))))
    (multiple-value-bind (days frac) (floor diff)
      (multiple-value-bind (hour minute1) (floor (* frac 86400) 3600)
	(multiple-value-bind (minute second) (floor minute1 60)
	  (make-instance 'duration :seconds (floor second)
			 :minutes minute :hours hour
			 :days (abs days) :signum (signum days)))))))

;;; ----------------------------------------------------------------------
;;;
;;; Support symbol months.
;;;

(defvar *month-symbols*
  '(January February March April May June July August September October
    November December))

(defun month-symbol-p (symbol)		;precedent: digit-char-p
  "Returns index in *MONTH-SYMBOLS* if found."
  (position-if
   (lambda (month-symbol)
     (or (eq month-symbol symbol)
	 (let ((home-package (find-package "DATE-TIME")))
	   (unless (eq (symbol-package symbol) home-package)
	     (eq (find-symbol (symbol-name symbol) home-package)
		 month-symbol)))
	 (let ((string (string symbol)))
	   (when (= (length string) 3)
	     (let ((ret (mismatch string (string month-symbol) :test #'equalp)))
	       (or (null ret) (not (zerop ret))))))))
   *month-symbols*))

(deftype month-symbol ()
  `(and symbol (satisfies month-symbol-p)))

(defmethod month-number ((month symbol))
  (let ((p (month-symbol-p month)))
    (if p (1+ p) (error "BEEP: ~S month not known." month))))


;;; ----------------------------------------------------------------------
;;;
;;; Support parsing dates in astronomical convention.
;;;

(define-condition parse-date-parse-error (parse-error)
  ((stream :initarg :stream :reader parse-date-parse-error-stream)
   (message :initarg :message :reader parse-date-parse-error-message)
   (offending-position :initarg :offending-position :reader
		       parse-date-parse-error-data))
  (:report (lambda (condition stream)
	     (princ (parse-date-parse-error-message condition) stream))))

(defun parse-year (string &optional eof-error-p eof-value &key (start 0)
		   end preserve-whitespace &aux *read-eval*)
  (multiple-value-bind (year position)
      (read-from-string string eof-error-p eof-value
			:start start :end end :preserve-whitespace
			preserve-whitespace)
    (unless (and position (numberp year))
      (error 'parse-date-parse-error
	     :message "Parsing year"
	     :offending-position start))
    (values year position)))

(defun parse-month (string &optional eof-error-p eof-value &key
		    (start 0) end preserve-whitespace &aux *read-eval*)
  (multiple-value-bind (month position)
      (read-from-string string eof-error-p eof-value
			:start start :end end :preserve-whitespace
			preserve-whitespace)
    (unless (and position (typep month 'month-symbol))
      (error 'parse-date-parse-error
	     :message "Parsing month"
	     :offending-position start))
    (values month position)))

(defun parse-date (string &optional eof-error-p eof-value &key (start 0)
		   end preserve-whitespace &aux *read-eval*)
  (multiple-value-bind (date position)
      (read-from-string string eof-error-p eof-value
			:start start :end end :preserve-whitespace
			preserve-whitespace)
    (unless (and position (numberp date))
      (error 'parse-date-parse-error
	     :message "Parsing date"
	     :offending-position start))
    (values date position)))

(defun whitespacep (c) (case c ((#\Space #\Tab) T)))

(defun parse-non-white-string (string &optional eof-error-p eof-value
			       &key (start 0) end
			       preserve-whitespace)
  (when preserve-whitespace (warn "TODO"))
  (let* ((real-start (position-if-not 'whitespacep string
				      :start start
				      :end end)))
    (when real-start
      (let ((real-end (or (position-if 'whitespacep string
				       :start real-start
				       :end end)
			  end)))
	(return-from parse-non-white-string
	  (values
	   (subseq string real-start real-end)
	   (or real-end (length string))))))
    (if eof-error-p
	(with-input-from-string (stream string) ; oh shit!
	  (error 'end-of-file :stream stream))
	eof-value)))

(defun parse-time-as-string (string &optional eof-error-p eof-value
			     &key (start 0) end preserve-whitespace)
  (parse-non-white-string string eof-error-p eof-value
			  :start start :end end
			  :preserve-whitespace preserve-whitespace))

(defun parse-zone (string &optional eof-error-p eof-value &key
		   (start 0) end preserve-whitespace &aux *read-eval*)
  "Read the LAST thunk of string as a zone-symbol." ; XXX
  (let ((real-start (let ((real-end (position-if-not 'whitespacep string
						     :start start
						     :end end
						     :from-end t)))
		      (position-if 'whitespacep string
				   :start start
				   :end (or real-end end)
				   :from-end t))))
    (multiple-value-bind (zone-symbol position)
	(read-from-string string eof-error-p eof-value
			  :start (or real-start start)
			  :preserve-whitespace preserve-whitespace
			  :end end)
      (unless (and position (symbolp zone-symbol))
	(error 'parse-date-parse-error
	       :message "Parsing zone"
	       :offending-position start))
      (values zone-symbol position))))

(defun parse-timestring (string &key (start 0) end &aux *read-eval*)
  "Following old general astronmical convention, superior symbols are placed
immediately above (ahead of) the decimal point, not after the last decimal."
  (let ((hour 0) (minute 0) (second 0) chars-seen)
    (flet ((go-bail () (return-from parse-timestring
			 (values hour minute second))))
      (let ((hend (position-if (lambda (c) (case c ((#\h #\H) T)))
			       string
			       :start start
			       :end end)))
	(when hend
	  (setq chars-seen 'hour)
	  (multiple-value-bind (value pos)
	      (parse-integer string :start start :end hend)
	    (assert (= pos hend))
	    (setq hour value)
	    (if (>= (1+ hend) (or end (length string)))
		(go-bail))
	    (setq start (1+ hend)))))
      (let ((mend (position-if (lambda (c) (case c ((#\m #\M) T)))
			       string :start start
			       :end end)))
	(when mend
	  (setq chars-seen 'minute)
	  (multiple-value-bind (value pos)
	      (parse-integer string :start start :end mend)
	    (assert (= pos mend))
	    (setq minute value)
	    (if (>= (1+ mend) (or end (length string)))
		(go-bail))
	    (setq start (1+ mend)))))
      (let ((send (position-if (lambda (c) (case c ((#\s #\S) T)))
			       string
			       :start start
			       :end end)))
	(when send
	  (setq chars-seen 'second)
	  (multiple-value-bind (value pos)
	      (parse-integer string :start start :end send)
	    (assert (= pos send))
	    (setq second value)
	    (if (>= (1+ send) (or end (length string)))
		(go-bail))
	    (setq start (1+ send)))))
      (when chars-seen
	(multiple-value-bind (value pos)
	    (read-from-string string nil nil :start start :end end)
	  (when value
	    #+dbg
	    (warn "~A" value)
	    (assert (numberp value))
	    (assert (< 0 value 1))
	    (unless (= pos (length string))
	      (warn "parse-timestring: Junk at end of string"))
	    (ecase chars-seen
	      (hour (incf hour value))
	      (minute (incf minute value))
	      (second (incf second value)))))
	(go-bail))
      #+dbg
      (warn "~a"
	     (list 'read-from-string  string nil nil :start start :end end))
      (multiple-value-bind (value pos)
	  (read-from-string  string nil nil :start start :end end)
	(when value
	  (assert (numberp value))
	  (unless (= pos (length string))
	    (warn "Parse-timestring: Junk at end of string"))
	  (setq hour value)
	  (go-bail)))
      (error "No time-markers in time string ~A." string))))

(defun parse-dynamical-time (string &key (start 0) end
			     ((:package *package*) #.*package*))
  (multiple-value-bind (year pos)
      (parse-year string t nil  :start start :end end)
    (multiple-value-bind (month pos)
	(parse-month string t nil :start pos :end end)
      (multiple-value-bind (date pos)
	  (parse-date string t nil :start pos :end end)
	(let (next-string pos2 (hour 0) (minute 0) (second 0) (zone 0))
	  (tagbody
	     (multiple-value-setq (next-string pos2) ; XXX time optional
	       (parse-non-white-string string nil nil :start pos))
	     (unless next-string (go bail))
	     (cond ((digit-char-p (char next-string 0))
		    (multiple-value-setq (hour minute second)
		      (parse-timestring next-string))
		    (multiple-value-setq (zone pos2)
		      (parse-zone string nil nil :start (or pos2 pos)
				  :end end)))
		   (t #+dbg
		      (warn "Treating ~A as a timezone!" next-string)
		      (multiple-value-setq (zone pos2)
			(parse-zone string nil nil :start pos :end end))))
	     #+dbg
	     (when pos2
	       (unless (>= pos2 (or end (length string)))
		 (warn "Junk at end of string: ~A ~A" string
		       (subseq string pos2))))
	   bail
	     (return-from parse-dynamical-time
	       (values SECOND MINUTE HOUR DATE (1+ (position month *month-symbols*))
		       YEAR (if (eq zone 'ut) 0 zone)))))))))

;;;
;;;
;;;
(defun date-time-from-dt-string (string)
  "STRING should be in UT zone."
  (multiple-value-call #'encode-date-time (parse-dynamical-time string)))


;;; JUNK AT EOF
#||
(setq $now (make-instance 'date-time :utime 0))
(utime $now)
(setq $now (make-instance 'date-time))
(setq $now (make-instance 'date-time :hour 10 :month "Feb" :year 2000))
(days-in-month $now)			;29
(days-in-month "April" 2005)		;30

(setq $x (make-instance 'date-time :utime 3213456525))
;;=>  "Mon Oct 31 00:18:45 IST 2001"
(setq $f (fixed-date $x))		; => 280622893/384
(floor $f)				; => 730788, 301/384
(setq $y (date-time-from-fixed $f))
(user::date :utime			; => "Tue Oct 30 18:48:45 2001 +0000"
	    (let ((x (multiple-value-list (gregorian-from-fixed $f))))
	      ;;=> (13/16 0 7 30 10 2001)
	      (multiple-value-call 'encode-universal-time
		(values-list x)))
	    :tz 0
	    :stream nil)

(check-type 'november month-symbol)
(check-type :nov month-symbol)
(check-type :nov month-symbol)
(days-in-month 'feb 2005)		;28
(month-symbol-p 'november)		;10
(month-number :January)			;1

(identity $x)				;=> "Mon Oct 31 00:18:45 IST 2001"
(date-time+ $x (make-instance 'duration :days 33))
;;=> "Mon Dec  2 18:48:45 IST 2001"
(date-time+ $x (make-instance 'duration :days 365))
;;=> "Wed Oct 30 18:48:45 IST 2002"
(setq $now (make-instance 'date-time))
(date-time-add-months $now -12)
(date-time-add-months $now 1)
(date-time-add-years $now 10)
(setq $a (make-instance 'date-time :year 2003 :date 10 :month 2
			:hour 0 :minute 0 :second 0 :time-zone 0))
(- (fixed-date $b) (fixed-date $a))	; 385
(setq $d1 (make-instance 'duration :years 1 :days 20))
(date-time- (date-time+ $a $d1) $d1)
(setq $b (make-instance 'date-time :year 2004 :date 1 :month 3
			:hour 0 :minute 0 :second 0
			:time-zone 0))
(date-time- $b $a)
(date-time+ $a (make-instance 'duration :years 1 :days 20) :count-years-first)
(date-time+ $a (make-instance 'duration :years 1 :days 20) :count-days-first)
(setq $d2 (make-instance 'duration :years 1 :days 21))

(progn
(make-package "TREAP")
(defvar TREAP::*predicate-for-comparing-treap-nodes* #'cmp-date-time)
(user::lc "home:cl/treap"))
(setq $t
      (make-instance 'treap:treap :predicate-for-comparison #'cmp-date-time))
(loop for rpm-package across rpmtar::$pkglist
      for install-time = (slot-value rpm-package 'rpmtags:INSTALLTIME)
      for date-time = (make-instance 'date-time :utime
				     (+ user::+unix-epoch+ install-time))
      collect  (push rpm-package (treap:gettreap date-time $t)))
(treap::treap-length $t)
(let ((i 0)) (treap::maptreap (lambda (k v) (incf i (length v))) $t) i)
(length rpmtar::$pkglist)
(setq $lo (make-instance 'date-time :month 1 :day 10
			 :hour 0 :minute 0 :second 0))
(setq $hi (make-instance 'date-time :month 2 :day 10
			 :hour 0 :minute 0 :second 0))
;;;
(defun %collect-events-in-range (treap lo hi)
  "The keys of TREAP are DATE-TIME objects. Values are a list of events that
occured at that instant."
  (declare (type date-time hi lo))
  (let (ret vals (lo (utime lo)) (hi (utime hi)))
    (unless (< lo hi)  (rotatef lo hi))
    (treap::maptreap (lambda (k v)
		      (when (< lo (utime k) hi)
			(push k ret)
			(setq vals (append vals v)))) treap)
    (values ret vals)))
;;;
(length (%collect-events-in-range $t $lo $hi))

(parse-dynamical-time "1992 November 30 10h32m TD")
;; => 0, 32, 10, 30, 11, 1992, TD
(setq $sd "1992 November 8 4h21m TD")
(parse-dynamical-time $sd)
;; => 0, 21, 4, 8, 11, 1992, TD
(multiple-value-list (parse-dynamical-time "1992 November 8 4h21m TD"))
;; => (0 21 4 8 11 1992 TD)
(parse-time-as-string "   0h23m0s ");;=> "0h23m0s", 10
(parse-timestring "23h48m.23") ;=> 23, 48.23, 0
(parse-timestring "23h48m23s") ;=> 23, 48, 23
(parse-timestring "23h48m23s.3") ;=> 23, 48, 23.3
(parse-time-as-string " " nil nil)
(parse-zone "IST " t nil )
(parse-zone "1993   UT " nil nil :start 4) ;=> UT,10
(parse-non-white-string "  FOO bar  "t nil) ;=> "FOO", 5
(parse-dynamical-time "1923 October 3 34h3s.45")
;;=> 3.45, 0, 34, 3, 10, 1923, NIL
(setq $x "1858 November 17 0h UT")
(parse-dynamical-time $x)
;;=> 0, 0, 0, 17, 11, 1858, 0
(parse-zone $x) ;;=> UT,22
(parse-dynamical-time "1858 November 17 0h53m  ")
(multiple-value-call 'encode-universal-time
  (parse-dynamical-time "1958 November 17 4h53m UT")) ;1857963180
(date-time-from-dt-string "1858 November 17 4h53m UT")
||#