colonelpanic/dotfiles
1
0
Fork 1
Code Issues Pull Requests Packages Projects Releases Wiki Activity

[org-window-habit] Rearrange stuff and minor fixes

Browse Source
This commit is contained in:
Ivan Malison 2023-09-11 22:58:51 -06:00
parent 2612f57652
commit 8f95590d18
1 changed files with 71 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

206
dotfiles/emacs.d/load.d/org-window-habit.el
View File

@ -1,4 +1,4 @@
(require 'eieio) (require 'eieio)
(require 'calendar) (require 'calendar)
(require 'org) (require 'org)
(require 'org-habit) (require 'org-habit)
@ -9,47 +9,61 @@
:group 'org-window-habit :group 'org-window-habit
:type 'integer) :type 'integer)
(defface org-window-habit-conformed-with-completion-face (defcustom org-window-habit-following-days 7
'((((background light)) (:background "#40778f")) "Number of days after today to appear in consistency graphs."
(((background dark)) (:background "#40778f")))
"Face for intervals for which the user was conforming only with their completion."
:group 'org-window-habit :group 'org-window-habit
:group 'org-faces) :type 'integer)
(defface org-window-habit-conforming-without-completion-face (defvar org-window-habit-graph-assessment-fn
'((((background light)) (:background "#40578f")) 'org-window-habit-default-graph-assessment-fn)
(((background dark)) (:background "#40578f")))
"Face for intervals for which the user is conforming without any completions."
:group 'org-window-habit
:group 'org-faces)
(defface org-window-habit-conforming-with-completion-face (define-minor-mode org-window-habit-mode
'((((background light)) (:background "#f5f946")) "Minor mode that replaces the normal org-habit functionality."
(((background dark)) (:background "gold"))) :lighter nil
"Face for currently ongoing interval where user is conforming with completion." :global t
:group 'org-window-habit :group 'org-window-habit
:group 'org-faces) :require 'org-window-habit)
(defface org-window-habit-okay-conforming-face (defvar org-window-habit-conforming-color "#0000FF")
'((((background light)) (:background "#FF00FF")) (defvar org-window-habit-not-conforming-color "#FF0000")
(((background dark)) (:background "#FF00FF"))) (defvar org-window-habit-required-completion-foreground-color "#000000")
"Face for interval in which the user is only okay conforming ." (defvar org-window-habit-non-required-completion-foreground-color "#FFFFFF")
:group 'org-window-habit (defvar org-window-habit-required-completion-today-foreground-color "#00FF00")
:group 'org-faces)
(defface org-window-habit-extreme-not-conforming-face (defun org-window-habit-create-face (bg-color foreground-color)
'((((background light)) (:background "#fc9590")) (let* ((bg-name (replace-regexp-in-string "#" "" bg-color))
(((background dark)) (:background "darkred"))) (fg-name (replace-regexp-in-string "#" "" foreground-color))
"Face for interval in which the user is not conforming by a large ." (face-name (intern (format "org-window-habit-face-bg-%s-fg-%s" bg-name fg-name))))
:group 'org-window-habit (if (facep face-name)
:group 'org-faces) face-name
(progn
(make-face face-name)
(set-face-attribute face-name nil :background bg-color :foreground foreground-color)
face-name))))
(defface org-window-habit-not-conforming-face (defcustom org-window-habit-completion-needed-today-glyph ?▂
'((((background light)) (:background "#f9372d")) "Glyph character used to show days on which a completion is expected."
(((background dark)) (:background "firebrick"))) :group 'org-habit
"Face for interval in which the user is not conforming." :version "24.1"
:group 'org-window-habit :type 'character)
:group 'org-faces)
(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)))
(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)))))
(defun org-window-habit-time-max (&rest args) (defun org-window-habit-time-max (&rest args)
"Return the maximum time value from ARGS." "Return the maximum time value from ARGS."
@ -216,6 +230,16 @@
(* space) (* space)
(regexp org-ts-regexp-inactive))) (regexp org-ts-regexp-inactive)))
(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))
(defun org-window-habit-default-aggregation-fn (collection) (defun org-window-habit-default-aggregation-fn (collection)
(cl-loop for el in collection minimize (car el))) (cl-loop for el in collection minimize (car el)))
@ -228,6 +252,7 @@
(assessment-decrement-plist :initarg :assessment-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) (aggregation-fn :initarg :aggregation-fn :initform 'org-window-habit-default-aggregation-fn)
(graph-assessment-fn :initarg :graph-assessment-fn :initform nil)
(start-time :initarg :start-time))) (start-time :initarg :start-time)))
(defclass org-window-habit-iterator () (defclass org-window-habit-iterator ()
@ -382,21 +407,6 @@
while (funcall comparison time testing-value) while (funcall comparison time testing-value)
finally return index)) 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))
(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))
@ -429,20 +439,6 @@
: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-advance-window
((window-habit org-window-habit) start-time end-time &key (direction 1))
(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)))))
(defcustom org-window-habit-following-days 7
"Number of days after today to appear in consistency graphs."
:group 'org-window-habit
:type 'integer)
(cl-defmethod org-window-habit-advance (cl-defmethod org-window-habit-advance
((iterator org-window-habit-iterator) &key (amount nil)) ((iterator org-window-habit-iterator) &key (amount nil))
(with-slots (window window-spec) iterator (with-slots (window window-spec) iterator
@ -510,8 +506,11 @@
(with-slots (with-slots
(assessment-decrement-plist window-specs reschedule-interval (assessment-decrement-plist window-specs reschedule-interval
max-repetitions-per-interval start-time aggregation-fn max-repetitions-per-interval start-time aggregation-fn
assessment-interval) assessment-interval graph-assessment-fn)
habit habit
(unless graph-assessment-fn
(setq graph-assessment-fn
org-window-habit-graph-assessment-fn))
(cl-destructuring-bind (actual-intervals actual-start-time) (cl-destructuring-bind (actual-intervals actual-start-time)
(cl-loop (cl-loop
with target-start-time = (org-window-habit-normalize-time-to-duration with target-start-time = (org-window-habit-normalize-time-to-duration
@ -533,8 +532,10 @@
collect collect
(org-window-habit-iterator-from-time (org-window-habit-iterator-from-time
window-spec actual-start-time)) window-spec actual-start-time))
for current-assessment-start = (oref (oref (car iterators) window) assessment-start-time) for current-assessment-start =
for current-assessment-end = (oref (oref (car iterators) window) assessment-end-time) (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) while (time-less-p current-assessment-end now)
for conforming-values-no-comp = for conforming-values-no-comp =
(cl-loop for iterator in iterators (cl-loop for iterator in iterators
@ -550,15 +551,9 @@
(cl-loop for iterator in iterators (cl-loop for iterator in iterators
collect (org-window-habit-get-conforming-value iterator)) collect (org-window-habit-get-conforming-value iterator))
for assessment-value = (funcall aggregation-fn conforming-values) 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
habit current-assessment-start current-assessment-end))
collect collect
(funcall (funcall
org-window-habit-graph-assessment-fn graph-assessment-fn
assessment-value-no-comp assessment-value-no-comp
assessment-value assessment-value
(org-window-habit-get-completion-count (org-window-habit-get-completion-count
@ -591,7 +586,7 @@
(funcall aggregation-fn with-completion-conforming-values)) (funcall aggregation-fn with-completion-conforming-values))
(current-assessment (current-assessment
(funcall (funcall
org-window-habit-graph-assessment-fn graph-assessment-fn
assessment-value assessment-value
with-completion-assessment-value with-completion-assessment-value
(org-window-habit-get-completion-count (org-window-habit-get-completion-count
@ -611,16 +606,9 @@
(put-text-property index (1+ index) 'face face graph))) (put-text-property index (1+ index) 'face face graph)))
graph)) graph))
(define-minor-mode org-window-habit-mode
"Minor mode that replaces the normal org-habit functionality."
:lighter nil
:global t
:group 'org-window-habit
:require 'org-window-habit)
(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-create-instance-from-heading-at-point)
(apply orig args))) (apply orig args)))
(advice-add 'org-habit-parse-todo (advice-add 'org-habit-parse-todo
@ -671,12 +659,6 @@
fill-completions-fn fill-completions-fn
interval-start-time interval-start-time
(- end-index start-index))) (- 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)
@ -712,49 +694,6 @@
do (org-window-habit-advance iterator)) do (org-window-habit-advance iterator))
finally return current-assessment-start))) finally return current-assessment-start)))
(defvar org-window-habit-face-fn 'org-window-habit-default-face-fn)
(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 (cl-defun org-window-habit-default-graph-assessment-fn
(without-completion-assessment-value (without-completion-assessment-value
with-completion-assessment-value with-completion-assessment-value
@ -802,9 +741,6 @@
(t ?\s)))) (t ?\s))))
(list character face))) (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