[org-window-habit] Support multiple window specifications
This commit is contained in:
parent
35ec61575d
commit
abf779fc42
@ -4,6 +4,11 @@
|
|||||||
(require 'org-habit)
|
(require 'org-habit)
|
||||||
(require 'cl-lib)
|
(require 'cl-lib)
|
||||||
|
|
||||||
|
(defcustom org-window-habit-preceding-intervals 30
|
||||||
|
"Number of days before today to appear in consistency graphs."
|
||||||
|
:group 'org-window-habit
|
||||||
|
:type 'integer)
|
||||||
|
|
||||||
(defface org-window-habit-conformed-with-completion-face
|
(defface org-window-habit-conformed-with-completion-face
|
||||||
'((((background light)) (:background "#40778f"))
|
'((((background light)) (:background "#40778f"))
|
||||||
(((background dark)) (:background "#40778f")))
|
(((background dark)) (:background "#40778f")))
|
||||||
@ -132,8 +137,8 @@
|
|||||||
(t (list :days read-value))))))
|
(t (list :days read-value))))))
|
||||||
|
|
||||||
(defun org-window-habit-normalize-time-to-duration
|
(defun org-window-habit-normalize-time-to-duration
|
||||||
(time-value &optional duration-plist alignment-time)
|
(time-value duration-plist)
|
||||||
(let* ((alignment-decoded (decode-time (or alignment-time time-value)))
|
(let* ((alignment-decoded (decode-time time-value))
|
||||||
(year (nth 5 alignment-decoded))
|
(year (nth 5 alignment-decoded))
|
||||||
(month (nth 4 alignment-decoded))
|
(month (nth 4 alignment-decoded))
|
||||||
(day (nth 3 alignment-decoded))
|
(day (nth 3 alignment-decoded))
|
||||||
@ -211,15 +216,77 @@
|
|||||||
(* space)
|
(* space)
|
||||||
(regexp org-ts-regexp-inactive)))
|
(regexp org-ts-regexp-inactive)))
|
||||||
|
|
||||||
|
(defun org-window-habit-default-aggregation-fn (collection)
|
||||||
|
(cl-loop for el in collection minimize (car el)))
|
||||||
|
|
||||||
(defclass org-window-habit ()
|
(defclass org-window-habit ()
|
||||||
((duration-plist :initarg :duration-plist :initform '(:days 1))
|
((window-specs :initarg :window-specs :initform nil)
|
||||||
(assessment-interval :initarg :assessment-interval :initform '(:days 1))
|
(assessment-interval :initarg :assessment-interval :initform '(:days 1))
|
||||||
(reschedule-interval :initarg :reschedule-interval :initform '(:days 1))
|
(reschedule-interval :initarg :reschedule-interval :initform '(:days 1))
|
||||||
(repetitions-required :initarg :repetitions-required :initform 1)
|
(reschedule-threshold :initarg :reschedule-threshold :initform 1.0)
|
||||||
(okay-repetitions-required :initarg :okay-repetitions-required :initform 1)
|
|
||||||
(done-times :initarg :done-times :initform nil)
|
(done-times :initarg :done-times :initform nil)
|
||||||
(window-decrement-plist :initarg :window-decrement-plist :initform nil)
|
(assessment-decrement-plist :initarg :assessment-decrement-plist :initform nil)
|
||||||
(max-repetitions-per-interval :initarg :max-repetitions-per-interval :initform 1)))
|
(max-repetitions-per-interval :initarg :max-repetitions-per-interval :initform 1)
|
||||||
|
(aggregation-fn :initarg :aggregation-fn :initform 'org-window-habit-default-aggregation-fn)
|
||||||
|
(start-time :initarg :start-time)))
|
||||||
|
|
||||||
|
(defclass org-window-habit-iterator ()
|
||||||
|
((window-spec :initarg :window-spec)
|
||||||
|
(window :initarg :window)
|
||||||
|
(start-index :initarg :start-index)
|
||||||
|
(end-index :initarg :end-index)))
|
||||||
|
|
||||||
|
(defclass org-window-habit-window-spec ()
|
||||||
|
((duration-plist :initarg :duration :initform '(:days 1))
|
||||||
|
(target-repetitions :initarg :repetitions :initform 1)
|
||||||
|
(conforming-value :initarg :value :initform 1.0)
|
||||||
|
(find-window :initarg :find-window :initform nil)
|
||||||
|
(habit :initarg :habit)))
|
||||||
|
|
||||||
|
(defclass org-window-habit-assessment-window ()
|
||||||
|
((assessment-start-time :initarg :assessment-start-time)
|
||||||
|
(assessment-end-time :initarg :assessment-end-time)
|
||||||
|
(start-time :initarg :start-time)
|
||||||
|
(end-time :initarg :end-time)))
|
||||||
|
|
||||||
|
(defun org-window-habit-get-window-where-time-in-last-assessment (spec time)
|
||||||
|
(let* ((habit (oref spec habit))
|
||||||
|
(assessment-plist
|
||||||
|
(oref habit assessment-interval))
|
||||||
|
(assessment-start
|
||||||
|
(org-window-habit-normalize-time-to-duration
|
||||||
|
time assessment-plist))
|
||||||
|
(assessment-end
|
||||||
|
(org-window-habit-keyed-duration-add-plist
|
||||||
|
assessment-start
|
||||||
|
assessment-plist))
|
||||||
|
(window-start
|
||||||
|
(org-window-habit-keyed-duration-add-plist
|
||||||
|
assessment-end
|
||||||
|
(org-window-habit-negate-plist (oref spec duration-plist)))))
|
||||||
|
(make-instance
|
||||||
|
'org-window-habit-assessment-window
|
||||||
|
:assessment-start-time assessment-start
|
||||||
|
:assessment-end-time assessment-end
|
||||||
|
:start-time window-start
|
||||||
|
:end-time assessment-end)))
|
||||||
|
|
||||||
|
(cl-defmethod org-window-habit-get-assessment-window
|
||||||
|
((spec org-window-habit-window-spec) time)
|
||||||
|
(funcall (or (oref spec find-window)
|
||||||
|
'org-window-habit-get-window-where-time-in-last-assessment)
|
||||||
|
spec time))
|
||||||
|
|
||||||
|
(cl-defun org-window-habit-iterator-from-time (window-spec &optional time)
|
||||||
|
(setq time (or time (current-time)))
|
||||||
|
(let* ((iterator
|
||||||
|
(make-instance 'org-window-habit-iterator
|
||||||
|
:window-spec window-spec
|
||||||
|
:window (org-window-habit-get-assessment-window window-spec time)
|
||||||
|
:start-index 0
|
||||||
|
:end-index 0)))
|
||||||
|
(org-window-habit-adjust-iterator-indicies iterator)
|
||||||
|
iterator))
|
||||||
|
|
||||||
(defun org-window-habit-create-instance-from-heading-at-point ()
|
(defun org-window-habit-create-instance-from-heading-at-point ()
|
||||||
"Construct an org-window-habit instance from the current org entry."
|
"Construct an org-window-habit instance from the current org entry."
|
||||||
@ -229,41 +296,75 @@
|
|||||||
if (member (nth 0 state-change-info) org-done-keywords)
|
if (member (nth 0 state-change-info) org-done-keywords)
|
||||||
collect (nth 2 state-change-info)))
|
collect (nth 2 state-change-info)))
|
||||||
(done-times-vector (vconcat done-times))
|
(done-times-vector (vconcat done-times))
|
||||||
(window-length
|
|
||||||
(org-window-habit-string-duration-to-plist
|
|
||||||
(org-entry-get nil "WINDOW_DURATION" "1d") :default '(:days 1)))
|
|
||||||
(assessment-interval
|
(assessment-interval
|
||||||
(org-window-habit-string-duration-to-plist
|
(org-window-habit-string-duration-to-plist
|
||||||
(org-entry-get nil "ASSESMENT_INTERVAL") :default '(:days 1)))
|
(org-entry-get nil "ASSESSMENT_INTERVAL") :default '(:days 1)))
|
||||||
(reschedule-interval
|
(reschedule-interval
|
||||||
(org-window-habit-string-duration-to-plist
|
(org-window-habit-string-duration-to-plist
|
||||||
(org-entry-get nil "RESCHEDULE_INTERVAL")))
|
(org-entry-get nil "RESCHEDULE_INTERVAL")))
|
||||||
|
(max-repetitions-per-interval
|
||||||
|
(string-to-number
|
||||||
|
(or (org-entry-get nil "MAX_REPETITIONS_PER_INTERVAL" t) "1"))))
|
||||||
|
(make-instance 'org-window-habit
|
||||||
|
:start-time nil
|
||||||
|
:window-specs (or
|
||||||
|
(org-window-habit-create-specs)
|
||||||
|
(org-window-habit-create-specs-from-perfect-okay))
|
||||||
|
:assessment-interval assessment-interval
|
||||||
|
:reschedule-interval reschedule-interval
|
||||||
|
:done-times done-times-vector
|
||||||
|
:max-repetitions-per-interval max-repetitions-per-interval))))
|
||||||
|
|
||||||
|
(defun org-window-habit-create-specs ()
|
||||||
|
(let ((spec-text (org-entry-get nil "WINDOW_SPECS" t)))
|
||||||
|
(when spec-text
|
||||||
|
(cl-loop for args in (car (read-from-string spec-text))
|
||||||
|
collect (apply 'make-instance 'org-window-habit-window-spec args)))))
|
||||||
|
|
||||||
|
(defun org-window-habit-create-specs-from-perfect-okay ()
|
||||||
|
(let*
|
||||||
|
((window-length
|
||||||
|
(org-window-habit-string-duration-to-plist
|
||||||
|
(org-entry-get nil "WINDOW_DURATION" "1d") :default '(:days 1)))
|
||||||
(repetitions-required
|
(repetitions-required
|
||||||
(string-to-number
|
(string-to-number
|
||||||
(or (org-entry-get nil "REPETITIONS_REQUIRED" t) "1")))
|
(or (org-entry-get nil "REPETITIONS_REQUIRED" t) "1")))
|
||||||
(okay-repetitions-required
|
(okay-repetitions-required
|
||||||
(string-to-number
|
(string-to-number
|
||||||
(or (org-entry-get nil "OKAY_REPETITIONS_REQUIRED" t) "1")))
|
(or (org-entry-get nil "OKAY_REPETITIONS_REQUIRED" t) "1"))))
|
||||||
(max-repetitions-per-interval
|
(list
|
||||||
(string-to-number
|
(make-instance
|
||||||
(or (org-entry-get nil "MAX_REPETITIONS_PER_INTERVAL" t) "1"))))
|
'org-window-habit-window-spec
|
||||||
(make-instance 'org-window-habit
|
:duration window-length
|
||||||
:duration-plist window-length
|
:repetitions repetitions-required
|
||||||
:assessment-interval assessment-interval
|
:value 1.0)
|
||||||
:reschedule-interval reschedule-interval
|
(make-instance
|
||||||
:repetitions-required repetitions-required
|
'org-window-habit-window-spec
|
||||||
:okay-repetitions-required okay-repetitions-required
|
:duration window-length
|
||||||
:done-times done-times-vector
|
:repetitions okay-repetitions-required
|
||||||
:max-repetitions-per-interval max-repetitions-per-interval))))
|
:value .5))))
|
||||||
|
|
||||||
|
(cl-defmethod org-window-habit-earliest-completion ((habit org-window-habit))
|
||||||
|
(with-slots (done-times) habit
|
||||||
|
(let ((done-times-count (length done-times)))
|
||||||
|
(when (> done-times-count 0)
|
||||||
|
(aref done-times (- done-times-count 1))))))
|
||||||
|
|
||||||
(cl-defmethod initialize-instance :after ((habit org-window-habit) &rest _args)
|
(cl-defmethod initialize-instance :after ((habit org-window-habit) &rest _args)
|
||||||
(when (null (oref habit assessment-interval))
|
(when (null (oref habit assessment-interval))
|
||||||
(oset habit assessment-interval (oref habit duration-plist)))
|
(oset habit assessment-interval (oref habit duration-plist)))
|
||||||
(when (null (oref habit reschedule-interval))
|
(when (null (oref habit reschedule-interval))
|
||||||
(oset habit reschedule-interval (oref habit assessment-interval)))
|
(oset habit reschedule-interval (oref habit assessment-interval)))
|
||||||
(when (null (oref habit window-decrement-plist))
|
(when (null (oref habit assessment-decrement-plist))
|
||||||
(oset habit window-decrement-plist
|
(oset habit assessment-decrement-plist
|
||||||
(org-window-habit-negate-plist (oref habit assessment-interval)))))
|
(org-window-habit-negate-plist (oref habit assessment-interval))))
|
||||||
|
(when (null (oref habit start-time))
|
||||||
|
(oset habit start-time
|
||||||
|
(org-window-habit-normalize-time-to-duration
|
||||||
|
(org-window-habit-earliest-completion habit)
|
||||||
|
(oref habit assessment-interval))))
|
||||||
|
(cl-loop for window-spec in (oref habit window-specs)
|
||||||
|
do (oset window-spec habit habit)))
|
||||||
|
|
||||||
(cl-defun org-window-habit-find-array-forward
|
(cl-defun org-window-habit-find-array-forward
|
||||||
(array time &key (start-index nil) (comparison '<))
|
(array time &key (start-index nil) (comparison '<))
|
||||||
@ -291,6 +392,11 @@
|
|||||||
(defun time-greater-or-equal-p (time1 time2)
|
(defun time-greater-or-equal-p (time1 time2)
|
||||||
(time-less-or-equal-p time2 time1))
|
(time-less-or-equal-p time2 time1))
|
||||||
|
|
||||||
|
(defun test-org-window-habit-get-completion-window-indices (start-time end-time)
|
||||||
|
(interactive)
|
||||||
|
(org-window-habit-get-completion-window-indices
|
||||||
|
(org-window-habit-create-instance-from-heading-at-point) start-time end-time))
|
||||||
|
|
||||||
(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
|
((habit org-window-habit) start-time end-time
|
||||||
&key (start-index nil) (end-index nil) (reverse nil))
|
&key (start-index nil) (end-index nil) (reverse nil))
|
||||||
@ -301,83 +407,28 @@
|
|||||||
;; order
|
;; order
|
||||||
(org-window-habit-find-array-forward
|
(org-window-habit-find-array-forward
|
||||||
done-times end-time
|
done-times end-time
|
||||||
;; This actually makes this value exclusive because this function
|
:comparison 'time-less-p
|
||||||
;; will now pass over equal values
|
|
||||||
:comparison 'time-less-or-equal-p
|
|
||||||
:start-index start-index)
|
:start-index start-index)
|
||||||
;; We use start-time to compute the end index because the list is in
|
;; We use start-time to compute the end index because the list is in
|
||||||
;; descending order
|
;; descending order
|
||||||
(org-window-habit-find-array-forward
|
(org-window-habit-find-array-forward
|
||||||
done-times start-time
|
done-times start-time
|
||||||
;; Again, this is counter-intuitive but using strict less here
|
:comparison 'time-less-or-equal-p
|
||||||
;; actually makes this interval inclusive
|
|
||||||
:comparison 'time-less-p
|
|
||||||
:start-index end-index))
|
:start-index end-index))
|
||||||
(list
|
(list
|
||||||
;; We use end-time and not start time because the array is in descending
|
;; We use end-time and not start time because the array is in descending
|
||||||
;; order
|
;; order
|
||||||
(org-window-habit-find-array-backward
|
(org-window-habit-find-array-backward
|
||||||
done-times end-time
|
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
|
:comparison 'time-greater-p
|
||||||
:start-index start-index)
|
:start-index start-index)
|
||||||
;; We use start-time to compute the end index because the list is in
|
;; We use start-time to compute the end index because the list is in
|
||||||
;; descending order
|
;; descending order
|
||||||
(org-window-habit-find-array-backward
|
(org-window-habit-find-array-backward
|
||||||
done-times start-time
|
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
|
:comparison 'time-greater-or-equal-p
|
||||||
:start-index end-index)))))
|
:start-index end-index)))))
|
||||||
|
|
||||||
(cl-defmethod org-window-habit-get-windows
|
|
||||||
((window-habit org-window-habit) &key (max-intervals nil))
|
|
||||||
(with-slots (duration-plist done-times window-decrement-plist) window-habit
|
|
||||||
(let* ((done-times-count (length done-times))
|
|
||||||
(earliest-completion (when (> done-times-count 0)
|
|
||||||
(aref done-times (- done-times-count 1)))))
|
|
||||||
(when earliest-completion
|
|
||||||
(cl-loop
|
|
||||||
with start-index = 0
|
|
||||||
with end-index = 0
|
|
||||||
with interval-ongoing = t
|
|
||||||
with current-window-start =
|
|
||||||
(org-window-habit-normalize-time-to-duration (current-time) duration-plist)
|
|
||||||
for current-window-end =
|
|
||||||
(org-window-habit-keyed-duration-add-plist current-window-start duration-plist)
|
|
||||||
for (new-start-index new-end-index) =
|
|
||||||
(org-window-habit-get-completion-window-indices
|
|
||||||
window-habit current-window-start current-window-end
|
|
||||||
:start-index start-index :end-index (or end-index 0))
|
|
||||||
for last-start = current-window-start
|
|
||||||
do
|
|
||||||
(setq start-index new-start-index
|
|
||||||
end-index new-end-index)
|
|
||||||
when (>= start-index done-times-count)
|
|
||||||
return windows
|
|
||||||
for effective-start =
|
|
||||||
(if (time-less-p earliest-completion current-window-start)
|
|
||||||
current-window-start
|
|
||||||
(org-window-habit-time-max
|
|
||||||
current-window-start
|
|
||||||
(org-window-habit-find-aligned-bounding-time
|
|
||||||
earliest-completion window-decrement-plist current-window-end)))
|
|
||||||
collect
|
|
||||||
(list current-window-start effective-start current-window-end
|
|
||||||
start-index end-index interval-ongoing)
|
|
||||||
into windows
|
|
||||||
do (setq interval-ongoing nil)
|
|
||||||
when (and max-intervals (>= (length windows) max-intervals))
|
|
||||||
return windows
|
|
||||||
do
|
|
||||||
(setq current-window-start
|
|
||||||
(org-window-habit-keyed-duration-add-plist
|
|
||||||
current-window-start
|
|
||||||
window-decrement-plist))
|
|
||||||
when (not (time-less-p current-window-start last-start))
|
|
||||||
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 &key (direction 1))
|
((window-habit org-window-habit) start-time end-time &key (direction 1))
|
||||||
(with-slots (assessment-interval) window-habit
|
(with-slots (assessment-interval) window-habit
|
||||||
@ -387,87 +438,168 @@
|
|||||||
(org-window-habit-keyed-duration-add-plist start-time interval-movement-plist)
|
(org-window-habit-keyed-duration-add-plist start-time interval-movement-plist)
|
||||||
(org-window-habit-keyed-duration-add-plist end-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)
|
|
||||||
|
|
||||||
(cl-defun org-window-habit-default-face-fn
|
|
||||||
(perfect-repetitions-required
|
|
||||||
okay-repetitions-required
|
|
||||||
completions-without-interval
|
|
||||||
completions-in-interval
|
|
||||||
interval-ongoing &key
|
|
||||||
(completions-per-interval 1))
|
|
||||||
(cond
|
|
||||||
((>= completions-without-interval perfect-repetitions-required)
|
|
||||||
'org-window-habit-conforming-without-completion-face)
|
|
||||||
((>= (+ completions-without-interval completions-in-interval) perfect-repetitions-required)
|
|
||||||
'org-window-habit-conformed-with-completion-face)
|
|
||||||
((and interval-ongoing
|
|
||||||
(>= (+ completions-without-interval completions-per-interval)
|
|
||||||
perfect-repetitions-required))
|
|
||||||
'org-window-habit-conforming-with-completion-face)
|
|
||||||
((>= (+ completions-without-interval completions-in-interval)
|
|
||||||
okay-repetitions-required)
|
|
||||||
'org-window-habit-okay-conforming-face)
|
|
||||||
(t 'org-window-habit-not-conforming-face)))
|
|
||||||
|
|
||||||
(defcustom org-window-habit-preceding-intervals 21
|
|
||||||
"Number of days before today to appear in consistency graphs."
|
|
||||||
:group 'org-window-habit
|
|
||||||
:type 'integer)
|
|
||||||
|
|
||||||
(defcustom org-window-habit-following-days 7
|
(defcustom org-window-habit-following-days 7
|
||||||
"Number of days after today to appear in consistency graphs."
|
"Number of days after today to appear in consistency graphs."
|
||||||
:group 'org-window-habit
|
:group 'org-window-habit
|
||||||
:type 'integer)
|
:type 'integer)
|
||||||
|
|
||||||
(cl-defmethod org-window-habit-build-graph ((habit org-window-habit))
|
(cl-defmethod org-window-habit-advance
|
||||||
(with-slots
|
((iterator org-window-habit-iterator) &key (amount nil))
|
||||||
(duration-plist repetitions-required okay-repetitions-required window-decrement-plist)
|
(with-slots (window window-spec) iterator
|
||||||
habit
|
(unless amount
|
||||||
(let* ((past-and-present-windows
|
(setq amount (oref (oref window-spec habit) assessment-interval)))
|
||||||
(nreverse (org-window-habit-get-windows
|
(let*
|
||||||
habit :max-intervals org-window-habit-preceding-intervals)))
|
((new-start-time (org-window-habit-keyed-duration-add-plist
|
||||||
(filler-count (- org-window-habit-preceding-intervals
|
(oref window assessment-start-time)
|
||||||
(length past-and-present-windows))))
|
amount))
|
||||||
(nconc
|
(window-moved-backward
|
||||||
(cl-loop for i from 0 to filler-count
|
(time-less-p new-start-time (oref window assessment-start-time)))
|
||||||
collect (list ?\s 'org-window-habit-conforming-without-completion-face))
|
(new-window (org-window-habit-get-assessment-window window-spec new-start-time)))
|
||||||
(cl-loop
|
(oset iterator window new-window)
|
||||||
for (start-time actual-start-time end-time start-index end-index interval-ongoing)
|
(org-window-habit-adjust-iterator-indicies
|
||||||
in past-and-present-windows
|
iterator (not window-moved-backward)))))
|
||||||
for duration-proportion =
|
|
||||||
(org-window-habit-duration-proportion
|
(cl-defmethod org-window-habit-effective-start ((iterator org-window-habit-iterator))
|
||||||
start-time end-time actual-start-time)
|
(org-window-habit-time-max (oref (oref iterator window) start-time)
|
||||||
for scaled-repetitions-required =
|
(oref (oref (oref iterator window-spec) habit) start-time)))
|
||||||
(* duration-proportion repetitions-required)
|
|
||||||
for scaled-okay-repetitions-required =
|
(cl-defmethod org-window-habit-adjust-iterator-indicies
|
||||||
(* duration-proportion okay-repetitions-required)
|
((iterator org-window-habit-iterator)
|
||||||
for interval-start-time =
|
&optional window-moved-forward)
|
||||||
(org-window-habit-keyed-duration-add-plist
|
(with-slots (window start-index end-index window-spec) iterator
|
||||||
end-time window-decrement-plist)
|
(cl-destructuring-bind (new-start-index new-end-index)
|
||||||
for (interval-start-index interval-end-index) =
|
|
||||||
(org-window-habit-get-completion-window-indices
|
(org-window-habit-get-completion-window-indices
|
||||||
habit interval-start-time end-time
|
(oref window-spec habit)
|
||||||
:start-index start-index :end-index start-index)
|
(oref window start-time) (oref window end-time)
|
||||||
for strict-completions =
|
:start-index start-index
|
||||||
|
:end-index end-index
|
||||||
|
:reverse window-moved-forward)
|
||||||
|
(oset iterator start-index new-start-index)
|
||||||
|
(oset iterator end-index new-end-index))))
|
||||||
|
|
||||||
|
(cl-defmethod org-window-habit-conforming-ratio
|
||||||
|
((iterator org-window-habit-iterator) &rest args)
|
||||||
|
(with-slots (window-spec window start-index) iterator
|
||||||
|
(min
|
||||||
|
1.0
|
||||||
|
(/
|
||||||
|
(apply 'org-window-habit-get-completion-count
|
||||||
|
(oref window-spec habit)
|
||||||
|
(oref window start-time)
|
||||||
|
(oref window end-time)
|
||||||
|
:start-index start-index
|
||||||
|
args)
|
||||||
|
(* (org-window-habit-actual-window-scale iterator)
|
||||||
|
(oref window-spec target-repetitions))))))
|
||||||
|
|
||||||
|
(cl-defmethod org-window-habit-actual-window-scale
|
||||||
|
((iterator org-window-habit-iterator))
|
||||||
|
(with-slots (window) iterator
|
||||||
|
(org-window-habit-duration-proportion
|
||||||
|
(oref window start-time) (oref window end-time)
|
||||||
|
(org-window-habit-effective-start iterator))))
|
||||||
|
|
||||||
|
(cl-defmethod org-window-habit-get-conforming-value
|
||||||
|
((iterator org-window-habit-iterator) &rest args)
|
||||||
|
(with-slots (window-spec) iterator
|
||||||
|
(list (apply 'org-window-habit-conforming-ratio iterator args)
|
||||||
|
(oref window-spec conforming-value))))
|
||||||
|
|
||||||
|
(cl-defmethod org-window-habit-build-graph ((habit org-window-habit) &optional now)
|
||||||
|
(setq now (or now (current-time)))
|
||||||
|
(with-slots
|
||||||
|
(assessment-decrement-plist window-specs reschedule-interval
|
||||||
|
max-repetitions-per-interval start-time aggregation-fn
|
||||||
|
assessment-interval)
|
||||||
|
habit
|
||||||
|
(cl-destructuring-bind (actual-intervals actual-start-time)
|
||||||
|
(cl-loop
|
||||||
|
with target-start-time = (org-window-habit-normalize-time-to-duration
|
||||||
|
now assessment-interval)
|
||||||
|
for i from 0 to org-window-habit-preceding-intervals
|
||||||
|
while (time-less-p start-time target-start-time)
|
||||||
|
do
|
||||||
|
(setq target-start-time
|
||||||
|
(org-window-habit-keyed-duration-add-plist
|
||||||
|
target-start-time
|
||||||
|
assessment-decrement-plist))
|
||||||
|
finally return (list i target-start-time))
|
||||||
|
(nconc
|
||||||
|
(cl-loop for i from 0 to (- org-window-habit-preceding-intervals actual-intervals)
|
||||||
|
collect (list ?\s 'default))
|
||||||
|
(cl-loop
|
||||||
|
with iterators =
|
||||||
|
(cl-loop for window-spec in window-specs
|
||||||
|
collect
|
||||||
|
(org-window-habit-iterator-from-time
|
||||||
|
window-spec actual-start-time))
|
||||||
|
for current-assessment-start = (oref (oref (car iterators) window) assessment-start-time)
|
||||||
|
for current-assessment-end = (oref (oref (car iterators) window) assessment-end-time)
|
||||||
|
while (time-less-p current-assessment-end now)
|
||||||
|
for conforming-values-no-comp =
|
||||||
|
(cl-loop for iterator in iterators
|
||||||
|
collect (org-window-habit-get-conforming-value
|
||||||
|
iterator
|
||||||
|
:fill-completions-fn
|
||||||
|
(lambda (time actual-completions)
|
||||||
|
(if (time-equal-p current-assessment-start time)
|
||||||
|
0
|
||||||
|
actual-completions))))
|
||||||
|
for assessment-value-no-comp = (or (funcall aggregation-fn conforming-values) 0.0)
|
||||||
|
for conforming-values =
|
||||||
|
(cl-loop for iterator in iterators
|
||||||
|
collect (org-window-habit-get-conforming-value iterator))
|
||||||
|
for assessment-value = (funcall aggregation-fn conforming-values)
|
||||||
|
do
|
||||||
|
(message "%s %s %s"
|
||||||
|
(org-window-habit-time-to-string current-assessment-start)
|
||||||
|
(org-window-habit-time-to-string current-assessment-end)
|
||||||
(org-window-habit-get-completion-count
|
(org-window-habit-get-completion-count
|
||||||
habit start-time end-time :start-index start-index)
|
habit current-assessment-start current-assessment-end))
|
||||||
for total-completions = (- end-index start-index)
|
collect
|
||||||
for completions-in-interval = (- interval-end-index interval-start-index)
|
(funcall
|
||||||
for completions-outside-interval = (- total-completions completions-in-interval)
|
org-window-habit-graph-assessment-fn
|
||||||
for face =
|
assessment-value-no-comp
|
||||||
(funcall org-window-habit-face-fn
|
assessment-value
|
||||||
scaled-repetitions-required
|
(org-window-habit-get-completion-count
|
||||||
scaled-okay-repetitions-required
|
habit current-assessment-start current-assessment-end)
|
||||||
completions-outside-interval
|
'past
|
||||||
completions-in-interval
|
habit
|
||||||
interval-ongoing)
|
(oref (car iterators) window))
|
||||||
for character =
|
into past-assessments
|
||||||
(cond
|
do
|
||||||
((>= completions-in-interval 1) org-habit-completed-glyph)
|
(cl-loop for iterator in iterators
|
||||||
(interval-ongoing org-habit-today-glyph)
|
do (org-window-habit-advance iterator))
|
||||||
(t ?\s))
|
finally
|
||||||
collect (list character face))))))
|
return
|
||||||
|
(let*
|
||||||
|
((current-assessment-start (oref (oref (car iterators) window) assessment-start-time))
|
||||||
|
(current-assessment-end (oref (oref (car iterators) window) assessment-end-time))
|
||||||
|
(conforming-values (cl-loop for iterator in iterators collect
|
||||||
|
(org-window-habit-get-conforming-value iterator)))
|
||||||
|
(assessment-value (funcall aggregation-fn conforming-values))
|
||||||
|
(with-completion-conforming-values
|
||||||
|
(cl-loop for iterator in iterators
|
||||||
|
collect (org-window-habit-get-conforming-value
|
||||||
|
iterator
|
||||||
|
:fill-completions-fn
|
||||||
|
(lambda (time actual-completions)
|
||||||
|
(if (time-equal-p current-assessment-start time)
|
||||||
|
(+ actual-completions max-repetitions-per-interval)
|
||||||
|
actual-completions)))))
|
||||||
|
(with-completion-assessment-value
|
||||||
|
(funcall aggregation-fn with-completion-conforming-values))
|
||||||
|
(current-assessment
|
||||||
|
(funcall
|
||||||
|
org-window-habit-graph-assessment-fn
|
||||||
|
assessment-value
|
||||||
|
with-completion-assessment-value
|
||||||
|
(org-window-habit-get-completion-count
|
||||||
|
habit current-assessment-start current-assessment-end)
|
||||||
|
'present
|
||||||
|
habit
|
||||||
|
(oref (car iterators) window))))
|
||||||
|
(nconc past-assessments (list current-assessment))))))))
|
||||||
|
|
||||||
(defun org-window-habit-make-graph-string (graph-info)
|
(defun org-window-habit-make-graph-string (graph-info)
|
||||||
(let ((graph (make-string (length graph-info) ?\s)))
|
(let ((graph (make-string (length graph-info) ?\s)))
|
||||||
@ -486,9 +618,6 @@
|
|||||||
:group 'org-window-habit
|
:group 'org-window-habit
|
||||||
:require 'org-window-habit)
|
:require 'org-window-habit)
|
||||||
|
|
||||||
(defun org-window-habit-parse-todo ()
|
|
||||||
(org-window-habit-create-instance-from-heading-at-point))
|
|
||||||
|
|
||||||
(defun org-window-habit-parse-todo-advice (orig &rest args)
|
(defun org-window-habit-parse-todo-advice (orig &rest args)
|
||||||
(if org-window-habit-mode
|
(if org-window-habit-mode
|
||||||
(org-window-habit-parse-todo)
|
(org-window-habit-parse-todo)
|
||||||
@ -513,19 +642,14 @@
|
|||||||
(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-show-time-string (time)
|
(defun org-window-habit-time-to-string (time)
|
||||||
(format-time-string
|
(format-time-string
|
||||||
"%Y-%m-%d %H:%M"
|
"%Y-%m-%d %H:%M"
|
||||||
time))
|
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-completion-count
|
(cl-defmethod org-window-habit-get-completion-count
|
||||||
((habit org-window-habit) start-time end-time &key (start-index 0))
|
((habit org-window-habit) start-time end-time &key (start-index 0)
|
||||||
|
(fill-completions-fn (lambda (time actual-completions) actual-completions)))
|
||||||
(cl-loop
|
(cl-loop
|
||||||
with next-start-index = start-index
|
with next-start-index = start-index
|
||||||
with interval-end-time = end-time
|
with interval-end-time = end-time
|
||||||
@ -535,72 +659,157 @@
|
|||||||
(org-window-habit-time-max
|
(org-window-habit-time-max
|
||||||
start-time
|
start-time
|
||||||
(org-window-habit-keyed-duration-add-plist
|
(org-window-habit-keyed-duration-add-plist
|
||||||
interval-end-time (oref habit window-decrement-plist)))
|
interval-end-time (oref habit assessment-decrement-plist)))
|
||||||
for (start-index end-index) =
|
for (start-index end-index) =
|
||||||
(org-window-habit-get-completion-window-indices
|
(org-window-habit-get-completion-window-indices
|
||||||
habit interval-start-time interval-end-time
|
habit interval-start-time interval-end-time
|
||||||
:start-index next-start-index
|
:start-index next-start-index
|
||||||
:end-index next-start-index)
|
:end-index next-start-index)
|
||||||
for completions-within-interval =
|
for completions-within-interval =
|
||||||
(min (oref habit max-repetitions-per-interval) (- end-index start-index))
|
(min (oref habit max-repetitions-per-interval)
|
||||||
|
(funcall
|
||||||
|
fill-completions-fn
|
||||||
|
interval-start-time
|
||||||
|
(- end-index start-index)))
|
||||||
|
do
|
||||||
|
(message "%s %s %s %s"
|
||||||
|
(org-window-habit-time-to-string interval-start-time)
|
||||||
|
(org-window-habit-time-to-string interval-end-time)
|
||||||
|
start-index
|
||||||
|
end-index)
|
||||||
sum completions-within-interval
|
sum completions-within-interval
|
||||||
do (setq next-start-index end-index
|
do (setq next-start-index end-index
|
||||||
interval-end-time interval-start-time)
|
interval-end-time interval-start-time)
|
||||||
while (time-less-p start-time interval-start-time)))
|
while (time-less-p start-time interval-start-time)))
|
||||||
|
|
||||||
(cl-defmethod org-window-habit-get-next-required-interval ((habit org-window-habit))
|
(cl-defmethod org-window-habit-get-next-required-interval
|
||||||
(cl-loop
|
((habit org-window-habit) &optional now) (setq now (or now (current-time)))
|
||||||
with
|
(with-slots
|
||||||
(start-time effective-start
|
(window-specs reschedule-interval reschedule-threshold assessment-interval
|
||||||
end-time last-start-index last-end-index ongoing) =
|
aggregation-fn done-times)
|
||||||
(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))
|
|
||||||
with reschedule-decrement-plist =
|
|
||||||
(org-window-habit-negate-plist (oref habit reschedule-interval))
|
|
||||||
for (start-index end-index) =
|
|
||||||
(org-window-habit-get-completion-window-indices
|
|
||||||
habit
|
habit
|
||||||
start-time end-time
|
(cl-loop
|
||||||
:start-index last-start-index
|
with start-time =
|
||||||
:end-index last-end-index
|
(org-window-habit-normalize-time-to-duration
|
||||||
:reverse t)
|
(org-window-habit-time-max
|
||||||
for actual-completions =
|
now
|
||||||
(org-window-habit-get-completion-count
|
(org-window-habit-keyed-duration-add-plist (aref done-times 0)
|
||||||
habit start-time end-time :start-index start-index)
|
reschedule-interval))
|
||||||
for expected-completions = actual-completions
|
assessment-interval)
|
||||||
for actual-start = (org-window-habit-time-max effective-start start-time)
|
with iterators =
|
||||||
for proportion =
|
(cl-loop for window-spec in window-specs
|
||||||
(org-window-habit-duration-proportion start-time end-time actual-start)
|
collect
|
||||||
for required = (* proportion (oref habit repetitions-required))
|
(org-window-habit-iterator-from-time window-spec start-time))
|
||||||
for reschedule-start-time =
|
for current-assessment-start = (oref (oref (car iterators) window) assessment-start-time)
|
||||||
(org-window-habit-keyed-duration-add-plist
|
for current-assessment-end = (oref (oref (car iterators) window) assessment-end-time)
|
||||||
end-time reschedule-decrement-plist)
|
for conforming-values =
|
||||||
for (reschedule-start-index reschedule-end-index) =
|
(cl-loop for iterator in iterators
|
||||||
(org-window-habit-get-completion-window-indices
|
collect (org-window-habit-get-conforming-value iterator))
|
||||||
habit reschedule-start-time end-time
|
for assessment-value = (funcall aggregation-fn conforming-values)
|
||||||
:start-index start-index
|
until (< assessment-value reschedule-threshold)
|
||||||
:end-index end-index
|
|
||||||
:reverse t)
|
|
||||||
for interval-has-completion = (not (eq reschedule-start-index reschedule-end-index))
|
|
||||||
until (and (not interval-has-completion) (< expected-completions required))
|
|
||||||
for (new-start-time new-end-time) =
|
|
||||||
(org-window-habit-advance-window habit start-time end-time)
|
|
||||||
do
|
do
|
||||||
(setq last-end-time end-time
|
(cl-loop for iterator in iterators
|
||||||
start-time new-start-time
|
do (org-window-habit-advance iterator))
|
||||||
end-time new-end-time
|
finally return current-assessment-start)))
|
||||||
last-start-index start-index
|
|
||||||
last-end-index end-index)
|
(defvar org-window-habit-face-fn 'org-window-habit-default-face-fn)
|
||||||
finally return (list last-end-time end-time)))
|
|
||||||
|
(defun org-window-habit-lerp-color (color1 color2 proportion)
|
||||||
|
(let ((r1 (string-to-number (substring color1 1 3) 16))
|
||||||
|
(g1 (string-to-number (substring color1 3 5) 16))
|
||||||
|
(b1 (string-to-number (substring color1 5 7) 16))
|
||||||
|
(r2 (string-to-number (substring color2 1 3) 16))
|
||||||
|
(g2 (string-to-number (substring color2 3 5) 16))
|
||||||
|
(b2 (string-to-number (substring color2 5 7) 16)))
|
||||||
|
(format "#%02x%02x%02x"
|
||||||
|
(round (+ (* (- r2 r1) proportion) r1))
|
||||||
|
(round (+ (* (- g2 g1) proportion) g1))
|
||||||
|
(round (+ (* (- b2 b1) proportion) b1)))))
|
||||||
|
|
||||||
|
(defvar org-window-habit-conforming-color "#0000FF")
|
||||||
|
(defvar org-window-habit-not-conforming-color "#FF0000")
|
||||||
|
(defvar org-window-habit-required-completion-foreground-color "#000000")
|
||||||
|
(defvar org-window-habit-non-required-completion-foreground-color "#FFFFFF")
|
||||||
|
(defvar org-window-habit-required-completion-today-foreground-color "#00FF00")
|
||||||
|
|
||||||
|
(defun org-window-habit-create-face (bg-color foreground-color)
|
||||||
|
(let* ((bg-name (replace-regexp-in-string "#" "" bg-color))
|
||||||
|
(fg-name (replace-regexp-in-string "#" "" foreground-color))
|
||||||
|
(face-name (intern (format "org-window-habit-face-bg-%s-fg-%s" bg-name fg-name))))
|
||||||
|
(if (facep face-name)
|
||||||
|
face-name
|
||||||
|
(progn
|
||||||
|
(make-face face-name)
|
||||||
|
(set-face-attribute face-name nil :background bg-color :foreground foreground-color)
|
||||||
|
face-name))))
|
||||||
|
|
||||||
|
(defcustom org-window-habit-completion-needed-today-glyph ?▂
|
||||||
|
"Glyph character used to show days on which a completion is expected."
|
||||||
|
:group 'org-habit
|
||||||
|
:version "24.1"
|
||||||
|
:type 'character)
|
||||||
|
|
||||||
|
(defvar org-window-habit-non-conforming-scale .8)
|
||||||
|
|
||||||
|
(defun org-window-habit-rescale-assessment-value (value)
|
||||||
|
(if (>= value 1.0) value
|
||||||
|
(* org-window-habit-non-conforming-scale value)))
|
||||||
|
|
||||||
|
(cl-defun org-window-habit-default-graph-assessment-fn
|
||||||
|
(without-completion-assessment-value
|
||||||
|
with-completion-assessment-value
|
||||||
|
completions-in-interval
|
||||||
|
current-interval-time-type
|
||||||
|
habit
|
||||||
|
window)
|
||||||
|
(let* ((with-completion-color
|
||||||
|
(org-window-habit-lerp-color
|
||||||
|
org-window-habit-not-conforming-color
|
||||||
|
org-window-habit-conforming-color
|
||||||
|
(org-window-habit-rescale-assessment-value
|
||||||
|
with-completion-assessment-value)))
|
||||||
|
(without-completion-color
|
||||||
|
(org-window-habit-lerp-color
|
||||||
|
org-window-habit-not-conforming-color
|
||||||
|
org-window-habit-conforming-color
|
||||||
|
(org-window-habit-rescale-assessment-value
|
||||||
|
without-completion-assessment-value)))
|
||||||
|
(completion-today-matters
|
||||||
|
(< without-completion-assessment-value with-completion-assessment-value))
|
||||||
|
(interval-is-present (eq current-interval-time-type 'present))
|
||||||
|
(completion-expected-today
|
||||||
|
(and interval-is-present
|
||||||
|
(time-less-p
|
||||||
|
(org-window-habit-get-next-required-interval habit)
|
||||||
|
(oref window assessment-end-time))))
|
||||||
|
(bg-color
|
||||||
|
(if completion-expected-today
|
||||||
|
without-completion-color
|
||||||
|
with-completion-color))
|
||||||
|
(fg-color
|
||||||
|
(cond
|
||||||
|
(completion-expected-today
|
||||||
|
with-completion-color)
|
||||||
|
(completion-today-matters
|
||||||
|
org-window-habit-required-completion-foreground-color)
|
||||||
|
(t org-window-habit-non-required-completion-foreground-color)))
|
||||||
|
(face (org-window-habit-create-face bg-color fg-color))
|
||||||
|
(character
|
||||||
|
(cond
|
||||||
|
((> completions-in-interval 0) org-habit-completed-glyph)
|
||||||
|
(completion-expected-today
|
||||||
|
org-window-habit-completion-needed-today-glyph)
|
||||||
|
(t ?\s))))
|
||||||
|
(list character face)))
|
||||||
|
|
||||||
|
(defvar org-window-habit-graph-assessment-fn
|
||||||
|
'org-window-habit-default-graph-assessment-fn)
|
||||||
|
|
||||||
(defun org-window-habit-auto-repeat (&rest args)
|
(defun org-window-habit-auto-repeat (&rest args)
|
||||||
(interactive)
|
(interactive)
|
||||||
(let* ((required-interval-start
|
(let* ((required-interval-start
|
||||||
(car (org-window-habit-get-next-required-interval
|
(org-window-habit-get-next-required-interval
|
||||||
(org-window-habit-create-instance-from-heading-at-point))))
|
(org-window-habit-create-instance-from-heading-at-point)))
|
||||||
(repeat (org-get-repeat))
|
(repeat (org-get-repeat))
|
||||||
(target-time-string
|
(target-time-string
|
||||||
(format-time-string (car org-timestamp-formats)
|
(format-time-string (car org-timestamp-formats)
|
||||||
|
Loading…
Reference in New Issue
Block a user