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