(%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)
;; duration specific
(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))))
+ (ecase precision
+ (: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)))))
;; ------------------------------------------------------------
(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)
(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
(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)
(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))
+ (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))