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