org-habit.el (17526B)
1 ;;; org-habit.el --- The habit tracking code for Org -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2009-2024 Free Software Foundation, Inc. 4 5 ;; Author: John Wiegley <johnw at gnu dot org> 6 ;; Keywords: outlines, hypermedia, calendar, text 7 ;; URL: https://orgmode.org 8 ;; 9 ;; This file is part of GNU Emacs. 10 ;; 11 ;; GNU Emacs is free software: you can redistribute it and/or modify 12 ;; it under the terms of the GNU General Public License as published by 13 ;; the Free Software Foundation, either version 3 of the License, or 14 ;; (at your option) any later version. 15 16 ;; GNU Emacs is distributed in the hope that it will be useful, 17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 ;; GNU General Public License for more details. 20 21 ;; You should have received a copy of the GNU General Public License 22 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 ;; 25 ;;; Commentary: 26 27 ;; This file contains the habit tracking code for Org mode 28 29 ;;; Code: 30 31 (require 'org-macs) 32 (org-assert-version) 33 34 (require 'cl-lib) 35 (require 'org) 36 (require 'org-agenda) 37 38 (defgroup org-habit nil 39 "Options concerning habit tracking in Org mode." 40 :tag "Org Habit" 41 :group 'org-progress) 42 43 (defcustom org-habit-graph-column 40 44 "The absolute column at which to insert habit consistency graphs. 45 Note that consistency graphs will overwrite anything else in the buffer." 46 :group 'org-habit 47 :type 'integer) 48 49 (defcustom org-habit-preceding-days 21 50 "Number of days before today to appear in consistency graphs." 51 :group 'org-habit 52 :type 'integer) 53 54 (defcustom org-habit-following-days 7 55 "Number of days after today to appear in consistency graphs." 56 :group 'org-habit 57 :type 'integer) 58 59 (defcustom org-habit-show-habits t 60 "If non-nil, show habits in agenda buffers." 61 :group 'org-habit 62 :type 'boolean) 63 64 (defcustom org-habit-show-habits-only-for-today t 65 "If non-nil, only show habits on today's agenda, and not for future days. 66 Note that even when shown for future days, the graph is always 67 relative to the current effective date." 68 :group 'org-habit 69 :type 'boolean) 70 71 (defcustom org-habit-show-all-today nil 72 "If non-nil, show the consistency graph of all habits on 73 today's agenda, even if they are not scheduled." 74 :group 'org-habit 75 :type 'boolean) 76 77 (defcustom org-habit-today-glyph ?! 78 "Glyph character used to identify today." 79 :group 'org-habit 80 :version "24.1" 81 :type 'character) 82 83 (defcustom org-habit-completed-glyph ?* 84 "Glyph character used to show completed days on which a task was done." 85 :group 'org-habit 86 :version "24.1" 87 :type 'character) 88 89 (defcustom org-habit-show-done-always-green nil 90 "Non-nil means DONE days will always be green in the consistency graph. 91 It will be green even if it was done after the deadline." 92 :group 'org-habit 93 :type 'boolean) 94 95 (defcustom org-habit-scheduled-past-days nil 96 "Value to use instead of `org-scheduled-past-days', for habits only. 97 98 If nil, `org-scheduled-past-days' is used. 99 100 Setting this to say 10000 is a way to make habits always show up 101 as a reminder, even if you set `org-scheduled-past-days' to a 102 small value because you regard scheduled items as a way of 103 \"turning on\" TODO items on a particular date, rather than as a 104 means of creating calendar-based reminders." 105 :group 'org-habit 106 :type '(choice integer (const nil)) 107 :package-version '(Org . "9.3") 108 :safe (lambda (v) (or (integerp v) (null v)))) 109 110 (defface org-habit-clear-face 111 '((((background light)) (:background "#8270f9")) 112 (((background dark)) (:background "blue"))) 113 "Face for days on which a task shouldn't be done yet." 114 :group 'org-habit 115 :group 'org-faces) 116 (defface org-habit-clear-future-face 117 '((((background light)) (:background "#d6e4fc")) 118 (((background dark)) (:background "midnightblue"))) 119 "Face for future days on which a task shouldn't be done yet." 120 :group 'org-habit 121 :group 'org-faces) 122 123 (defface org-habit-ready-face 124 '((((background light)) (:background "#4df946")) 125 (((background dark)) (:background "forestgreen"))) 126 "Face for days on which a task should start to be done." 127 :group 'org-habit 128 :group 'org-faces) 129 (defface org-habit-ready-future-face 130 '((((background light)) (:background "#acfca9")) 131 (((background dark)) (:background "darkgreen"))) 132 "Face for days on which a task should start to be done." 133 :group 'org-habit 134 :group 'org-faces) 135 136 (defface org-habit-alert-face 137 '((((background light)) (:background "#f5f946")) 138 (((background dark)) (:background "gold"))) 139 "Face for days on which a task is due." 140 :group 'org-habit 141 :group 'org-faces) 142 (defface org-habit-alert-future-face 143 '((((background light)) (:background "#fafca9")) 144 (((background dark)) (:background "darkgoldenrod"))) 145 "Face for days on which a task is due." 146 :group 'org-habit 147 :group 'org-faces) 148 149 (defface org-habit-overdue-face 150 '((((background light)) (:background "#f9372d")) 151 (((background dark)) (:background "firebrick"))) 152 "Face for days on which a task is overdue." 153 :group 'org-habit 154 :group 'org-faces) 155 (defface org-habit-overdue-future-face 156 '((((background light)) (:background "#fc9590")) 157 (((background dark)) (:background "darkred"))) 158 "Face for days on which a task is overdue." 159 :group 'org-habit 160 :group 'org-faces) 161 162 (defun org-habit-duration-to-days (ts) 163 (if (string-match "\\([0-9]+\\)\\([dwmy]\\)" ts) 164 ;; lead time is specified. 165 (floor (* (string-to-number (match-string 1 ts)) 166 (cdr (assoc (match-string 2 ts) 167 '(("d" . 1) ("w" . 7) 168 ("m" . 30.4) ("y" . 365.25)))))) 169 (error "Invalid duration string: %s" ts))) 170 171 (defun org-is-habit-p (&optional epom) 172 "Is the task at EPOM or point a habit? 173 EPOM is an element, marker, or buffer position." 174 (string= "habit" (org-entry-get epom "STYLE" 'selective))) 175 176 (defun org-habit-parse-todo (&optional pom) 177 "Parse the TODO surrounding point for its habit-related data. 178 Returns a list with the following elements: 179 180 0: Scheduled date for the habit (may be in the past) 181 1: \".+\"-style repeater for the schedule, in days 182 2: Optional deadline (nil if not present) 183 3: If deadline, the repeater for the deadline, otherwise nil 184 4: A list of all the past dates this todo was mark closed 185 5: Repeater type as a string 186 187 This list represents a \"habit\" for the rest of this module." 188 (save-excursion 189 (if pom (goto-char pom)) 190 (cl-assert (org-is-habit-p (point))) 191 (let* ((scheduled (org-get-scheduled-time (point))) 192 (scheduled-repeat (org-get-repeat (org-entry-get (point) "SCHEDULED"))) 193 (end (org-entry-end-position)) 194 (habit-entry (org-no-properties (nth 4 (org-heading-components)))) 195 closed-dates deadline dr-days sr-days sr-type) 196 (if scheduled 197 (setq scheduled (time-to-days scheduled)) 198 (error "Habit %s has no scheduled date" habit-entry)) 199 (unless scheduled-repeat 200 (error 201 "Habit `%s' has no scheduled repeat period or has an incorrect one" 202 habit-entry)) 203 (setq sr-days (org-habit-duration-to-days scheduled-repeat) 204 sr-type (progn (string-match "[\\.+]?\\+" scheduled-repeat) 205 (match-string-no-properties 0 scheduled-repeat))) 206 (unless (> sr-days 0) 207 (error "Habit %s scheduled repeat period is less than 1d" habit-entry)) 208 (when (string-match "/\\([0-9]+[dwmy]\\)" scheduled-repeat) 209 (setq dr-days (org-habit-duration-to-days 210 (match-string-no-properties 1 scheduled-repeat))) 211 (if (<= dr-days sr-days) 212 (error "Habit %s deadline repeat period is less than or equal to scheduled (%s)" 213 habit-entry scheduled-repeat)) 214 (setq deadline (+ scheduled (- dr-days sr-days)))) 215 (org-back-to-heading t) 216 (let* ((maxdays (+ org-habit-preceding-days org-habit-following-days)) 217 (reversed org-log-states-order-reversed) 218 (search (if reversed 're-search-forward 're-search-backward)) 219 (limit (if reversed end (point))) 220 (count 0) 221 (re (format 222 "^[ \t]*-[ \t]+\\(?:State \"%s\".*%s%s\\)" 223 (regexp-opt org-done-keywords) 224 org-ts-regexp-inactive 225 (let ((value (cdr (assq 'done org-log-note-headings)))) 226 (if (not value) "" 227 (concat "\\|" 228 (org-replace-escapes 229 (regexp-quote value) 230 `(("%d" . ,org-ts-regexp-inactive) 231 ("%D" . ,org-ts-regexp) 232 ("%s" . "\"\\S-+\"") 233 ("%S" . "\"\\S-+\"") 234 ("%t" . ,org-ts-regexp-inactive) 235 ("%T" . ,org-ts-regexp) 236 ("%u" . ".*?") 237 ("%U" . ".*?"))))))))) 238 (unless reversed (goto-char end)) 239 (while (and (< count maxdays) (funcall search re limit t)) 240 (push (time-to-days 241 (org-time-string-to-time 242 (or (match-string-no-properties 1) 243 (match-string-no-properties 2)))) 244 closed-dates) 245 (setq count (1+ count)))) 246 (list scheduled sr-days deadline dr-days closed-dates sr-type)))) 247 248 (defsubst org-habit-scheduled (habit) 249 (nth 0 habit)) 250 (defsubst org-habit-scheduled-repeat (habit) 251 (nth 1 habit)) 252 (defsubst org-habit-deadline (habit) 253 (let ((deadline (nth 2 habit))) 254 (or deadline 255 (if (nth 3 habit) 256 (+ (org-habit-scheduled habit) 257 (1- (org-habit-scheduled-repeat habit))) 258 (org-habit-scheduled habit))))) 259 (defsubst org-habit-deadline-repeat (habit) 260 (or (nth 3 habit) 261 (org-habit-scheduled-repeat habit))) 262 (defsubst org-habit-done-dates (habit) 263 (nth 4 habit)) 264 (defsubst org-habit-repeat-type (habit) 265 (nth 5 habit)) 266 267 (defsubst org-habit-get-urgency (habit &optional moment) 268 "Determine the relative urgency of a habit. 269 This must take into account not just urgency, but consistency as well." 270 (let ((pri 1000) 271 (now (if moment (time-to-days moment) (org-today))) 272 (scheduled (org-habit-scheduled habit)) 273 (deadline (org-habit-deadline habit))) 274 ;; add 10 for every day past the scheduled date, and subtract for every 275 ;; day before it 276 (setq pri (+ pri (* (- now scheduled) 10))) 277 ;; add 50 if the deadline is today 278 (if (and (/= scheduled deadline) 279 (= now deadline)) 280 (setq pri (+ pri 50))) 281 ;; add 100 for every day beyond the deadline date, and subtract 10 for 282 ;; every day before it 283 (let ((slip (- now (1- deadline)))) 284 (if (> slip 0) 285 (setq pri (+ pri (* slip 100))) 286 (setq pri (+ pri (* slip 10))))) 287 pri)) 288 289 (defun org-habit-get-faces (habit &optional now-days scheduled-days donep) 290 "Return faces for HABIT relative to NOW-DAYS and SCHEDULED-DAYS. 291 NOW-DAYS defaults to the current time's days-past-the-epoch if nil. 292 SCHEDULED-DAYS defaults to the habit's actual scheduled days if nil. 293 294 Habits are assigned colors on the following basis: 295 Blue Task is before the scheduled date. 296 Green Task is on or after scheduled date, but before the 297 end of the schedule's repeat period. 298 Yellow If the task has a deadline, then it is after schedule's 299 repeat period, but before the deadline. 300 Orange The task has reached the deadline day, or if there is 301 no deadline, the end of the schedule's repeat period. 302 Red The task has gone beyond the deadline day or the 303 schedule's repeat period." 304 (let* ((scheduled (or scheduled-days (org-habit-scheduled habit))) 305 (s-repeat (org-habit-scheduled-repeat habit)) 306 (d-repeat (org-habit-deadline-repeat habit)) 307 (deadline (if scheduled-days 308 (+ scheduled-days (- d-repeat s-repeat)) 309 (org-habit-deadline habit))) 310 (m-days (or now-days (time-to-days nil)))) 311 (cond 312 ((< m-days scheduled) 313 '(org-habit-clear-face . org-habit-clear-future-face)) 314 ((< m-days deadline) 315 '(org-habit-ready-face . org-habit-ready-future-face)) 316 ((= m-days deadline) 317 (if donep 318 '(org-habit-ready-face . org-habit-ready-future-face) 319 '(org-habit-alert-face . org-habit-alert-future-face))) 320 ((and org-habit-show-done-always-green donep) 321 '(org-habit-ready-face . org-habit-ready-future-face)) 322 (t '(org-habit-overdue-face . org-habit-overdue-future-face))))) 323 324 (defun org-habit-build-graph (habit starting current ending) 325 "Build a graph for the given HABIT, from STARTING to ENDING. 326 CURRENT gives the current time between STARTING and ENDING, for 327 the purpose of drawing the graph. It need not be the actual 328 current time." 329 (let* ((all-done-dates (sort (org-habit-done-dates habit) #'<)) 330 (done-dates all-done-dates) 331 (scheduled (org-habit-scheduled habit)) 332 (s-repeat (org-habit-scheduled-repeat habit)) 333 (start (time-to-days starting)) 334 (now (time-to-days current)) 335 (end (time-to-days ending)) 336 (graph (make-string (1+ (- end start)) ?\s)) 337 (index 0) 338 last-done-date) 339 (while (and done-dates (< (car done-dates) start)) 340 (setq last-done-date (car done-dates) 341 done-dates (cdr done-dates))) 342 (while (< start end) 343 (let* ((in-the-past-p (< start now)) 344 (todayp (= start now)) 345 (donep (and done-dates (= start (car done-dates)))) 346 (faces 347 (if (and in-the-past-p 348 (not last-done-date) 349 (not (< scheduled now))) 350 (if (and all-done-dates (= (car all-done-dates) start)) 351 ;; This is the very first done of this habit. 352 '(org-habit-ready-face . org-habit-ready-future-face) 353 '(org-habit-clear-face . org-habit-clear-future-face)) 354 (org-habit-get-faces 355 habit start 356 (and in-the-past-p 357 last-done-date 358 ;; Compute scheduled time for habit at the time 359 ;; START was current. 360 (let ((type (org-habit-repeat-type habit))) 361 (cond 362 ;; At the last done date, use current 363 ;; scheduling in all cases. 364 ((null done-dates) scheduled) 365 ((equal type ".+") (+ last-done-date s-repeat)) 366 ((equal type "+") 367 ;; Since LAST-DONE-DATE, each done mark 368 ;; shifted scheduled date by S-REPEAT. 369 (- scheduled (* (length done-dates) s-repeat))) 370 (t 371 ;; Compute the scheduled time after the 372 ;; first repeat. This is the closest time 373 ;; past FIRST-DONE which can reach SCHEDULED 374 ;; by a number of S-REPEAT hops. 375 ;; 376 ;; Then, play TODO state change history from 377 ;; the beginning in order to find current 378 ;; scheduled time. 379 (let* ((first-done (car all-done-dates)) 380 (s (let ((shift (mod (- scheduled first-done) 381 s-repeat))) 382 (+ (if (= shift 0) s-repeat shift) 383 first-done)))) 384 (if (= first-done last-done-date) s 385 (catch :exit 386 (dolist (done (cdr all-done-dates) s) 387 ;; Each repeat shifts S by any 388 ;; number of S-REPEAT hops it takes 389 ;; to get past DONE, with a minimum 390 ;; of one hop. 391 (cl-incf s (* (1+ (/ (max (- done s) 0) 392 s-repeat)) 393 s-repeat)) 394 (when (= done last-done-date) 395 (throw :exit s)))))))))) 396 donep))) 397 markedp face) 398 (cond 399 (donep 400 (aset graph index org-habit-completed-glyph) 401 (setq markedp t) 402 (while (and done-dates (= start (car done-dates))) 403 (setq last-done-date (car done-dates)) 404 (setq done-dates (cdr done-dates)))) 405 (todayp 406 (aset graph index org-habit-today-glyph))) 407 (setq face (if (or in-the-past-p todayp) 408 (car faces) 409 (cdr faces))) 410 (when (and in-the-past-p 411 (not (eq face 'org-habit-overdue-face)) 412 (not markedp)) 413 (setq face (cdr faces))) 414 (put-text-property index (1+ index) 'face face graph) 415 (put-text-property index (1+ index) 416 'help-echo 417 (concat (format-time-string 418 (org-time-stamp-format) 419 (time-add starting (days-to-time (- start (time-to-days starting))))) 420 (if donep " DONE" "")) 421 graph)) 422 (setq start (1+ start) 423 index (1+ index))) 424 graph)) 425 426 (defun org-habit-insert-consistency-graphs (&optional line) 427 "Insert consistency graph for any habitual tasks." 428 (let ((inhibit-read-only t) 429 (buffer-invisibility-spec '(org-link)) 430 (moment (time-subtract nil (* 3600 org-extend-today-until)))) 431 (save-excursion 432 (goto-char (if line (line-beginning-position) (point-min))) 433 (while (not (eobp)) 434 (let ((habit (get-text-property (point) 'org-habit-p)) 435 (invisible-prop (get-text-property (point) 'invisible))) 436 (when habit 437 (move-to-column org-habit-graph-column t) 438 (delete-char (min (+ 1 org-habit-preceding-days 439 org-habit-following-days) 440 (- (line-end-position) (point)))) 441 (insert-before-markers 442 (org-habit-build-graph 443 habit 444 (time-subtract moment (days-to-time org-habit-preceding-days)) 445 moment 446 (time-add moment (days-to-time org-habit-following-days)))) 447 ;; Inherit invisible state of hidden entries. 448 (when invisible-prop 449 (put-text-property 450 (- (point) org-habit-graph-column) (point) 451 'invisible invisible-prop)))) 452 (forward-line))))) 453 454 (defun org-habit-toggle-habits () 455 "Toggle display of habits in an agenda buffer." 456 (interactive) 457 (org-agenda-check-type t 'agenda) 458 (setq org-habit-show-habits (not org-habit-show-habits)) 459 (org-agenda-redo) 460 (org-agenda-set-mode-name) 461 (message "Habits turned %s" 462 (if org-habit-show-habits "on" "off"))) 463 464 (defun org-habit-toggle-display-in-agenda (arg) 465 "Toggle display of habits in agenda. 466 With ARG toggle display of all vs. undone scheduled habits. 467 See `org-habit-show-all-today'." 468 (interactive "P") 469 (if (not arg) 470 (org-habit-toggle-habits) 471 (org-agenda-check-type t 'agenda) 472 (setq org-habit-show-all-today (not org-habit-show-all-today)) 473 (when org-habit-show-habits (org-agenda-redo)))) 474 475 (org-defkey org-agenda-mode-map "K" 'org-habit-toggle-display-in-agenda) 476 477 (provide 'org-habit) 478 479 ;;; org-habit.el ends here