[Emacs] Make org-window-habit repetitions work

This commit is contained in:
Ivan Malison 2023-08-29 03:09:35 -06:00
parent e25cb6d9e4
commit 6cf2d8eb61

View File

@ -12,12 +12,15 @@
max-time)) max-time))
(defun org-window-habit-negate-plist (plist) (defun org-window-habit-negate-plist (plist)
(org-window-habit-multiply-plist plist -1))
(defun org-window-habit-multiply-plist (plist factor)
(let (result) (let (result)
(while plist (while plist
(let ((key (pop plist)) (let ((key (pop plist))
(value (pop plist))) (value (pop plist)))
(push key result) (push key result)
(push (- value) result))) (push (* factor value) result)))
(nreverse result))) (nreverse result)))
(defun org-window-habit-duration-proportion (start-time end-time between-time) (defun org-window-habit-duration-proportion (start-time end-time between-time)
@ -174,7 +177,7 @@
(window-length (org-window-habit-string-duration-to-plist (window-length (org-window-habit-string-duration-to-plist
(org-entry-get nil "WINDOW_DURATION" "1d"))) (org-entry-get nil "WINDOW_DURATION" "1d")))
(assessment-interval (org-window-habit-string-duration-to-plist (assessment-interval (org-window-habit-string-duration-to-plist
(org-entry-get nil "ASSESMENT_INTERVAL" "1d"))) (org-entry-get nil "ASSESMENT_INTERVAL")))
(repetitions-required (string-to-number (repetitions-required (string-to-number
(or (org-entry-get nil "REPETITIONS_REQUIRED" t) "1"))) (or (org-entry-get nil "REPETITIONS_REQUIRED" t) "1")))
(okay-repetitions-required (string-to-number (okay-repetitions-required (string-to-number
@ -187,29 +190,80 @@
:done-times done-times-vector :done-times done-times-vector
:window-decrement-plist (org-window-habit-negate-plist assessment-interval))))) :window-decrement-plist (org-window-habit-negate-plist assessment-interval)))))
(cl-defun org-window-habit-find-array-forward
(array time &key (start-index nil) (comparison '<))
(setq start-index (or start-index 0))
(cl-loop for index from start-index to (length array)
while (and (< index (length array))
(funcall comparison time (aref array index)))
finally return index))
(cl-defun org-window-habit-find-array-backward
(array time &key (start-index nil) (comparison '<))
(setq start-index (or start-index (length array)))
(cl-loop for index downfrom start-index to 1
for testing-value = (aref array (- index 1))
while (funcall comparison time testing-value)
finally return index))
(defun time-less-or-equal-p (time1 time2)
(or (time-less-p time1 time2)
(time-equal-p time1 time2)))
(defun time-greater-p (time1 time2)
(time-less-p time2 time1))
(defun time-greater-or-equal-p (time1 time2)
(time-less-or-equal-p time2 time1))
(cl-defmethod org-window-habit-get-completion-window-indices (cl-defmethod org-window-habit-get-completion-window-indices
((habit org-window-habit) start-time end-time &key (start-index 0) (end-index 0)) ((habit org-window-habit) start-time end-time
&key (start-index nil) (end-index nil) (reverse nil))
(with-slots (done-times) habit (with-slots (done-times) habit
;; Adjust the start-index based on end-time (if (not reverse)
(while (and (>= start-index 0) (< start-index (length done-times)) (list
(not (time-less-p (aref done-times start-index) end-time))) ; exclusive of end-time ;; We use end-time and not start time because the array is in descending
(setq start-index (1+ start-index))) ;; order
(org-window-habit-find-array-forward
;; Adjust the end-index based on start-time done-times end-time
(let ((initial-end-index end-index)) ;; This actually makes this value exclusive because this function
(while (and (>= end-index 0) (< end-index (length done-times)) ;; will now pass over equal values
(and (time-less-p start-time (aref done-times end-index)) ; inclusive of start-time :comparison 'time-less-or-equal-p
(not (time-equal-p start-time (aref done-times end-index))))) :start-index start-index)
(setq end-index (1+ end-index))) ;; We use start-time to compute the end index because the list is in
;; descending order
(list start-index end-index)))) (org-window-habit-find-array-forward
done-times start-time
;; Again, this is counter-intuitive but using strict less here
;; actually makes this interval inclusive
:comparison 'time-less-p
:start-index end-index))
(list
;; We use end-time and not start time because the array is in descending
;; order
(org-window-habit-find-array-backward
done-times end-time
;; Here, because we are searching backwards, this actually does the more
;; intuitve thing of giving us an exclusive bound index.
:comparison 'time-greater-p
:start-index start-index)
;; We use start-time to compute the end index because the list is in
;; descending order
(org-window-habit-find-array-backward
done-times start-time
;; Here, because we are searching backwards, this actually does the more
;; intuitve thing of giving us an exclusive bound index.
:comparison 'time-greater-or-equal-p
:start-index end-index)))))
;; TODO avoid using current-time ;; TODO avoid using current-time
(cl-defmethod org-window-habit-get-windows (cl-defmethod org-window-habit-get-windows
((window-habit org-window-habit) &key (max-intervals nil)) ((window-habit org-window-habit) &key (max-intervals nil))
(with-slots (duration-plist done-times window-decrement-plist) window-habit (with-slots (duration-plist done-times window-decrement-plist) window-habit
(let* ((done-times-count (length done-times)) (let* ((done-times-count (length done-times))
(earliest-completion (aref done-times (- done-times-count 1)))) (earliest-completion (when (> done-times-count 0)
(aref done-times (- done-times-count 1)))))
(when earliest-completion
(cl-loop (cl-loop
with start-index = 0 with start-index = 0
with end-index = 0 with end-index = 0
@ -249,19 +303,22 @@
current-window-start current-window-start
window-decrement-plist)) window-decrement-plist))
when (not (time-less-p current-window-start last-start)) when (not (time-less-p current-window-start last-start))
do (error "The window start did not get smaller"))))) do (error "The window start did not get smaller"))))))
(cl-defmethod org-window-habit-advance-window (cl-defmethod org-window-habit-advance-window
((window-habit org-window-habit) start-time end-time end-index) ((window-habit org-window-habit) start-time end-time &key (direction 1))
(with-slots (duration-plist done-times window-decrement-plist) window-habit (with-slots (assessment-interval) window-habit
)) (let ((interval-movement-plist (org-window-habit-multiply-plist
assessment-interval direction)))
(list
(org-window-habit-keyed-duration-add-plist start-time interval-movement-plist)
(org-window-habit-keyed-duration-add-plist end-time interval-movement-plist)))))
(defvar org-window-habit-face-fn 'org-window-habit-default-face-fn) (defvar org-window-habit-face-fn 'org-window-habit-default-face-fn)
(defface org-window-habit-conformed-with-completion-face (defface org-window-habit-conformed-with-completion-face
'((((background light)) (:background "#4df946")) '((((background light)) (:background "#007F7F"))
(((background dark)) (:background "forestgreen"))) (((background dark)) (:background "cyan")))
"Face for intervals on which a the user was conforming with their completion but not without it." "Face for intervals on which a the user was conforming with their completion but not without it."
:group 'org-window-habit :group 'org-window-habit
:group 'org-faces) :group 'org-faces)
@ -276,7 +333,7 @@
(defface org-window-habit-conforming-with-completion-face (defface org-window-habit-conforming-with-completion-face
'((((background light)) (:background "#f5f946")) '((((background light)) (:background "#f5f946"))
(((background dark)) (:background "gold"))) (((background dark)) (:background "gold")))
"Face for currently ongoing interval for which the user will only be conforming with a completion" "Face for currently ongoing interval where user is conforming with completion."
:group 'org-window-habit :group 'org-window-habit
:group 'org-faces) :group 'org-faces)
@ -424,7 +481,61 @@
(advice-add 'org-habit-get-urgency (advice-add 'org-habit-get-urgency
:around 'org-window-habit-get-urgency-advice) :around 'org-window-habit-get-urgency-advice)
(defun org-window-habit-auto-repeat (done-word) (defun org-window-habit-show-time-string (time)
(format-time-string
"%Y-%m-%d %H:%M"
time))
(defun org-window-habit-get-next-required-interval-test ()
(mapcar
'org-window-habit-show-time-string
(org-window-habit-get-next-required-interval
(org-window-habit-create-instance-from-heading-at-point))))
(cl-defmethod org-window-habit-get-next-required-interval ((habit org-window-habit))
(cl-loop
with
(start-time effective-start
end-time last-start-index last-end-index ongoing) =
(car (org-window-habit-get-windows habit :max-intervals 1))
with last-end-time =
(org-window-habit-keyed-duration-add-plist
end-time
(oref habit window-decrement-plist))
for (start-index end-index) =
(org-window-habit-get-completion-window-indices
habit
start-time end-time
:start-index last-start-index
:end-index last-end-index
:reverse t)
for actual-completions = (- end-index start-index)
for expected-completions = actual-completions
for actual-start = (org-window-habit-time-max effective-start start-time)
for proportion = (org-window-habit-duration-proportion start-time end-time actual-start)
for required = (* proportion (oref habit repetitions-required))
until (< expected-completions required)
for (new-start-time new-end-time) =
(org-window-habit-advance-window habit start-time end-time)
do
(setq last-end-time end-time
start-time new-start-time
end-time new-end-time
last-start-index start-index
last-end-index end-index)
finally return (list last-end-time end-time)))
;; TODO: check for completion WITHIN the current interval
(defun org-window-habit-auto-repeat (&rest args)
(let* ((required-interval-start
(car (org-window-habit-get-next-required-interval
(org-window-habit-create-instance-from-heading-at-point))))
(repeat (org-get-repeat))
(deadline-time-string
(format-time-string (car org-timestamp-formats)
required-interval-start)))
(org-deadline nil deadline-time-string))
;; Always unschedule
(save-excursion (save-excursion
(let ((scheduled (org-entry-get (point) "SCHEDULED"))) (let ((scheduled (org-entry-get (point) "SCHEDULED")))
(when scheduled (when scheduled
@ -432,30 +543,12 @@
(defun org-window-habit-auto-repeat-maybe-advice (orig &rest args) (defun org-window-habit-auto-repeat-maybe-advice (orig &rest args)
(apply orig args) (apply orig args)
;; (if (and org-window-habit-mode (org-is-habit-p)) (when (and org-window-habit-mode (org-is-habit-p))
;; (apply 'org-window-habit-auto-repeat args) (apply 'org-window-habit-auto-repeat args)))
;; (apply orig args))
)
(advice-add 'org-auto-repeat-maybe (advice-add 'org-auto-repeat-maybe
:around 'org-window-habit-auto-repeat-maybe-advice) :around 'org-window-habit-auto-repeat-maybe-advice)
(advice-add 'org-element--property
:around 'org-window-habit-scheduled-deadline-hackery)
(defun org-window-habit-scheduled-deadline-hackery (orig property node &rest args)
(let ((actual-value (apply orig property node args))
(is-habit (string= "habit" (funcall orig :STYLE node))))
actual-value
;; (message "prop: %s, is-habit: %s" property is-habit)
;; (if (and org-window-habit-mode (string= "habit" (funcall orig :STYLE node)))
;; (cond
;; ((eq property :deadline) nil)
;; ((eq property :scheduled) (or actual-value (apply orig :deadline node args)))
;; (t actual-value))
;; actual-value)
))
(defun org-window-habit-insert-consistency-graphs (&optional line) (defun org-window-habit-insert-consistency-graphs (&optional line)
"Insert consistency graph for any habitual tasks." "Insert consistency graph for any habitual tasks."
(let ((inhibit-read-only t) (let ((inhibit-read-only t)