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