Start implementing a function to work with decoded time as durations

2 files changed, 169 insertions, 4 deletions

diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el
index 6e268baecc6..4fbb3c59476 100644
--- a/lisp/calendar/time-date.el
+++ b/lisp/calendar/time-date.el
@@ -36,6 +36,9 @@
 
 ;;; Code:
 
+(require 'cl-lib)
+(require 'subr-x)
+
 (defmacro with-decoded-time-value (varlist &rest body)
   "Decode a time value and bind it according to VARLIST, then eval BODY.
 
@@ -369,6 +372,114 @@ January 1st being 1."
             month (1+ month)))
     (list 0 0 0 ordinal month year nil nil nil)))
 
+(defun decoded-time-add (time delta)
+  "Add DELTA to TIME, both of which are `decoded-time' structures.
+TIME should represent a time, while DELTA should only have
+non-nil integers for the values that should be altered.
+
+For instance, if you want to \"add two months\" to TIME, then
+leave all other fields but the month field in DELTA nil, and make
+the month field 2.  The values in DELTA can be negative.
+
+If applying the delta leaves the time spec invalid, it is
+decreased to be valid (\"add one month\" to January 31st will
+yield a result of February 28th (or 29th, depending on the leap
+year status).
+
+Fields are added in a most to least significant order."
+  (let ((time (copy-sequence time))
+        seconds)
+    ;; Years are simple.
+    (when (decoded-time-year delta)
+      (cl-incf (decoded-time-year time) (decoded-time-year delta)))
+
+    ;; Months are pretty simple.
+    (when (decoded-time-month delta)
+      (let ((new (+ (decoded-time-month time) (decoded-time-month delta))))
+        (setf (decoded-time-month time) (mod new 12))
+        (cl-incf (decoded-time-year time) (/ new 12))))
+
+    ;; Adjust for month length.
+    (setf (decoded-time-day time)
+          (min (date-days-in-month (decoded-time-year time)
+                                   (decoded-time-month time))
+               (decoded-time-day time)))
+
+    ;; Days are iterative.
+    (when-let* ((days (decoded-time-day delta)))
+      (let ((increase (> days 0))
+            (days (abs days)))
+        (while (> days 0)
+          (decoded-time--alter-day time increase)
+          (cl-decf days))))
+
+    ;; Do the time part, which is pretty simple (except for leap
+    ;; seconds, I guess).
+    (setq seconds (+ (* (or (decoded-time-hour delta) 0) 3600)
+                     (* (or (decoded-time-minute delta) 0) 60)
+                     (or (decoded-time-second delta) 0)))
+    (cond
+     ((> seconds 0)
+      (decoded-time--alter-second time seconds t))
+     ((< seconds 0)
+      (decoded-time--alter-second time (abs seconds) nil)))
+
+    time))
+
+(defun decoded-time--alter-month (time increase)
+  (if increase
+      (progn
+        (cl-incf (decoded-time-month time))
+        (when (> (decoded-time-month time) 12)
+          (setf (decoded-time-month time) 1)
+          (cl-incf (decoded-time-year time))))
+    (cl-decf (decoded-time-month time))
+    (when (zerop (decoded-time-month time))
+      (setf (decoded-time-month time) 12)
+      (cl-decf (decoded-time-year time)))))
+
+(defun decoded-time--alter-day (time increase)
+  (if increase
+      (progn
+        (cl-incf (decoded-time-day time))
+        (when (> (decoded-time-day time)
+                 (date-days-in-month (decoded-time-year time)
+                                     (decoded-time-month time)))
+          (setf (decoded-time-day time) 1)
+          (decoded-time--alter-month time t)))
+    (cl-decf (decoded-time-day time))
+    (when (zerop (decoded-time-day time))
+      (decoded-time--alter-month time nil)
+      (setf (decoded-time-day time)
+            (date-days-in-month (decoded-time-year time)
+                                (decoded-time-month time))))))
+
+(defun decoded-time--alter-second (time seconds increase)
+  (let ((old (+ (* (or (decoded-time-hour time) 0) 3600)
+                (* (or (decoded-time-minute time) 0) 60)
+                (or (decoded-time-second time) 0))))
+
+    (if increase
+        (progn
+          (setq old (+ old seconds))
+          (setf (decoded-time-second time) (% old 60)
+                (decoded-time-minute time) (% (/ old 60) 60)
+                (decoded-time-hour time) (% (/ old 3600) 24))
+          ;; Hm...  DST...
+          (let ((days (/ old (* 60 60 24))))
+            (while (> days 0)
+              (decoded-time--alter-day time t)
+              (cl-decf days))))
+      (setq old (abs (- old seconds)))
+      (setf (decoded-time-second time) (% old 60)
+            (decoded-time-minute time) (% (/ old 60) 60)
+            (decoded-time-hour time) (% (/ old 3600) 24))
+      ;; Hm...  DST...
+      (let ((days (/ old (* 60 60 24))))
+        (while (> days 0)
+          (decoded-time--alter-day time nil)
+          (cl-decf days))))))
+
 (provide 'time-date)
 
 ;;; time-date.el ends here
diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el
index 803eaa1d80d..02df0cd8ad7 100644
--- a/test/lisp/calendar/time-date-tests.el
+++ b/test/lisp/calendar/time-date-tests.el
@@ -34,15 +34,69 @@
   (should-not (= (date-days-in-month 1900 3) 28)))
 
 (ert-deftest test-ordinal ()
-  (should (equal (time-ordinal-to-date 2008 271)
+  (should (equal (date-ordinal-to-time 2008 271)
                  '(0 0 0 27 9 2008 nil nil nil)))
-  (should (equal (time-ordinal-to-date 2008 1)
+  (should (equal (date-ordinal-to-time 2008 1)
                  '(0 0 0 1 1 2008 nil nil nil)))
-  (should (equal (time-ordinal-to-date 2008 32)
+  (should (equal (date-ordinal-to-time 2008 32)
                  '(0 0 0 1 2 2008 nil nil nil)))
-  (should (equal (time-ordinal-to-date 1981 095)
+  (should (equal (date-ordinal-to-time 1981 095)
                  '(0 0 0 5 4 1981 nil nil nil))))
 
+(cl-defmethod mdec (&key second minute hour
+                         day month year
+                         dst zone)
+  (list second minute hour day month year nil dst zone))
+
+(ert-deftest test-decoded-add ()
+  (let ((time '(12 15 16 8 7 2019 1 t 7200)))
+    (should (equal (decoded-time-add time (mdec :year 1))
+                   '(12 15 16 8 7 2020 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :year -2))
+                   '(12 15 16 8 7 2017 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :month 1))
+                   '(12 15 16 8 8 2019 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :month 10))
+                   '(12 15 16 8 5 2020 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :day 1))
+                   '(12 15 16 9 7 2019 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :day -1))
+                   '(12 15 16 7 7 2019 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :day 30))
+                   '(12 15 16 7 8 2019 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :day -365))
+                   '(12 15 16 8 7 2018 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :day 365))
+                   '(12 15 16 7 7 2020 1 t 7200)))
+
+    ;; 2020 is a leap year.
+    (should (equal (decoded-time-add time (mdec :day 366))
+                   '(12 15 16 8 7 2020 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :second 1))
+                   '(13 15 16 8 7 2019 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :second -1))
+                   '(11 15 16 8 7 2019 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :second 61))
+                   '(13 16 16 8 7 2019 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :hour 1 :minute 2 :second 3))
+                   '(15 17 17 8 7 2019 1 t 7200)))
+
+    (should (equal (decoded-time-add time (mdec :hour 24))
+                   '(12 15 16 9 7 2019 1 t 7200)))
+    ))
+
 (require 'ert)
 
 ;;; time-date-tests.el ends here