aland/cl-dates
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Changed semantics of ymd->date

Browse source
This commit is contained in:
Sudhir Shenoy 2017-07-13 07:07:44 +09:00
parent 29bb69d1b5
commit 4c57a3c0d1
3 changed files with 21 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

33
dates.lisp
View file

@ -57,10 +57,10 @@ or a numeric offset in fractions of an hour e.g., +5.5"
(offset (zone-to-offset zone))) (offset (zone-to-offset zone)))
(- jdate (/ offset 24)))) (- jdate (/ offset 24))))
(defun date->ymd (date) (defun date->ymd (date &key (want-time nil))
"Returns 6 values corresponding to the given datetime- "Returns 6 values if :want-time is true: year, month, day, hour, minute, second.
year, month, day, hour, minute, second. Second may be a floating Second may be a floating point value but the first five are aways integers.
point value but the first five are aways integers" If :want-time is NIL, returns year, month and day as integers."
(let* ((jd (jday-number date)) (let* ((jd (jday-number date))
(e (floor (/ (- jd 1867216.25d0) 36524.25d0))) (e (floor (/ (- jd 1867216.25d0) 36524.25d0)))
(f (+ 1 jd e (- (floor (/ e 4))))) (f (+ 1 jd e (- (floor (/ e 4)))))
@ -70,20 +70,21 @@ point value but the first five are aways integers"
(j (floor (/ (- g i) 30.6001d0))) (j (floor (/ (- g i) 30.6001d0)))
(dd (- g i (floor (* j 30.6001d0)))) (dd (- g i (floor (* j 30.6001d0))))
(mm (- j (* 12 (floor (/ j 14))) 1)) (mm (- j (* 12 (floor (/ j 14))) 1))
(yy (+ h (floor (* 1/12 (- 14 mm))) -4716)) (yy (+ h (floor (* 1/12 (- 14 mm))) -4716)))
(day-frac (multiple-value-bind (day frac) (truncate date) (if want-time
(declare (ignore day)) (let ((day-frac (multiple-value-bind (day frac) (truncate date)
(if (>= frac 0.5d0) (declare (ignore day))
;; midnight to noon (if (>= frac 0.5d0)
(- frac 0.5d0) ;; midnight to noon
(+ frac 0.5d0))))) (- frac 0.5d0)
(multiple-value-bind (h m s) (day-fraction->hms day-frac) (+ frac 0.5d0)))))
(values yy mm dd h m s)))) (multiple-value-bind (h m s) (day-fraction->hms day-frac)
(values yy mm dd h m s)))
(values yy mm dd))))
(defun valid-date-p (yy mm dd) (defun valid-date-p (yy mm dd)
"Check that year, month and day form a valid calendar date" "Check that year, month and day form a valid calendar date"
(multiple-value-bind (y m d hr mn sc) (date->ymd (ymd->date yy mm dd)) (multiple-value-bind (y m d) (date->ymd (ymd->date yy mm dd))
(declare (ignore hr mn sc))
(and (= yy y) (= mm m) (= dd d)))) (and (= yy y) (= mm m) (= dd d))))
(defun valid-time-p (h m s) (defun valid-time-p (h m s)
@ -198,7 +199,7 @@ it returns year, month, day, hour, minute and second as 6 values"
(t (error "Invalid param which: ~a" which))))) (t (error "Invalid param which: ~a" which)))))
(setf date (apply-correction-factors yy date)) (setf date (apply-correction-factors yy date))
(if want-gregorian-date (if want-gregorian-date
(date->ymd date) (date->ymd date :want-time t)
date))) date)))
(defun cos-degrees (deg) (defun cos-degrees (deg)

4
parse-date.lisp
View file

@ -418,7 +418,7 @@
((setf tmp (str-to-relative-date token)) ((setf tmp (str-to-relative-date token))
(when (/= 0 num-date-comps) (when (/= 0 num-date-comps)
(return-from string->date nil)) (return-from string->date nil))
(multiple-value-bind (yy mm dd h m s) (date->ymd (+ reference-date tmp)) (multiple-value-bind (yy mm dd h m s) (date->ymd (+ reference-date tmp) :want-time t)
(setf (dt-yr res) yy (setf (dt-yr res) yy
(dt-mth res) mm (dt-mth res) mm
(dt-day res) dd (dt-day res) dd
@ -568,7 +568,7 @@
(when (dt-yr res) (when (dt-yr res)
(setf (dt-yr res) (make-four-digit-year (dt-yr res)))) (setf (dt-yr res) (make-four-digit-year (dt-yr res))))
;; copy all missing values from the reference date ;; copy all missing values from the reference date
(multiple-value-bind (yy mm dd h m s) (date->ymd reference-date) (multiple-value-bind (yy mm dd h m s) (date->ymd reference-date :want-time t)
(when-null-set res dt-yr yy) (when-null-set res dt-yr yy)
(when-null-set res dt-mth mm) (when-null-set res dt-mth mm)
(when-null-set res dt-day dd) (when-null-set res dt-day dd)

4
print-date.lisp
View file

@ -40,7 +40,7 @@ The :human format is the same as :iso-8601 except that the separators between da
time and timezone are spaces to make it more readable to the human eye." time and timezone are spaces to make it more readable to the human eye."
(let ((offset (zone-to-offset zone))) (let ((offset (zone-to-offset zone)))
(incf date (/ offset 24)) (incf date (/ offset 24))
(multiple-value-bind (yy mm dd h m s) (date->ymd date) (multiple-value-bind (yy mm dd h m s) (date->ymd date :want-time t)
(let ((year (format nil "~d" yy)) (let ((year (format nil "~d" yy))
(month (case format (month (case format
((:asctime :rfc-822 :rfc-850) (three-letter-month mm)) ((:asctime :rfc-822 :rfc-850) (three-letter-month mm))
@ -61,7 +61,7 @@ e.g., \"Thursday, 6 July 2017, 09:38:43.567 +0900\".
If :date-only is true, the time and timezone are omitted." If :date-only is true, the time and timezone are omitted."
(let ((offset (zone-to-offset zone))) (let ((offset (zone-to-offset zone)))
(incf date (/ offset 24)) (incf date (/ offset 24))
(multiple-value-bind (yy mm dd h m s) (date->ymd date) (multiple-value-bind (yy mm dd h m s) (date->ymd date :want-time t)
(if date-only (if date-only
(format nil "~a, ~d ~a ~d" (dow->string (day-of-week date)) (format nil "~a, ~d ~a ~d" (dow->string (day-of-week date))
dd (month->string mm) yy) dd (month->string mm) yy)