Commit | Line | Data |
---|---|---|
8bfe682a CD |
1 | ;;; org-habit.el --- The habit tracking code for Org-mode |
2 | ||
73b0cd50 | 3 | ;; Copyright (C) 2009-2011 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 | |
acedf35c | 8 | ;; Version: 7.4 |
8bfe682a CD |
9 | ;; |
10 | ;; This file is part of GNU Emacs. | |
11 | ;; | |
12 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
13 | ;; it under the terms of the GNU General Public License as published by | |
14 | ;; the Free Software Foundation, either version 3 of the License, or | |
15 | ;; (at your option) any later version. | |
16 | ||
17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
21 | ||
22 | ;; You should have received a copy of the GNU General Public License | |
23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
25 | ;; | |
26 | ;;; Commentary: | |
27 | ||
28 | ;; This file contains the habit tracking code for Org-mode | |
29 | ||
86fbb8ca CD |
30 | ;;; Code: |
31 | ||
8bfe682a CD |
32 | (require 'org) |
33 | (require 'org-agenda) | |
86fbb8ca | 34 | |
8bfe682a | 35 | (eval-when-compile |
86fbb8ca | 36 | (require 'cl)) |
8bfe682a CD |
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 | (defface org-habit-clear-face | |
ed21c5c8 | 72 | '((((background light)) (:background "#8270f9")) |
8bfe682a CD |
73 | (((background dark)) (:background "blue"))) |
74 | "Face for days on which a task shouldn't be done yet." | |
75 | :group 'org-habit | |
76 | :group 'org-faces) | |
77 | (defface org-habit-clear-future-face | |
ed21c5c8 | 78 | '((((background light)) (:background "#d6e4fc")) |
8bfe682a CD |
79 | (((background dark)) (:background "midnightblue"))) |
80 | "Face for future days on which a task shouldn't be done yet." | |
81 | :group 'org-habit | |
82 | :group 'org-faces) | |
83 | ||
84 | (defface org-habit-ready-face | |
ed21c5c8 | 85 | '((((background light)) (:background "#4df946")) |
8bfe682a CD |
86 | (((background dark)) (:background "forestgreen"))) |
87 | "Face for days on which a task should start to be done." | |
88 | :group 'org-habit | |
89 | :group 'org-faces) | |
90 | (defface org-habit-ready-future-face | |
ed21c5c8 | 91 | '((((background light)) (:background "#acfca9")) |
8bfe682a CD |
92 | (((background dark)) (:background "darkgreen"))) |
93 | "Face for days on which a task should start to be done." | |
94 | :group 'org-habit | |
95 | :group 'org-faces) | |
96 | ||
97 | (defface org-habit-alert-face | |
ed21c5c8 | 98 | '((((background light)) (:background "#f5f946")) |
8bfe682a CD |
99 | (((background dark)) (:background "gold"))) |
100 | "Face for days on which a task is due." | |
101 | :group 'org-habit | |
102 | :group 'org-faces) | |
103 | (defface org-habit-alert-future-face | |
ed21c5c8 | 104 | '((((background light)) (:background "#fafca9")) |
8bfe682a CD |
105 | (((background dark)) (:background "darkgoldenrod"))) |
106 | "Face for days on which a task is due." | |
107 | :group 'org-habit | |
108 | :group 'org-faces) | |
109 | ||
110 | (defface org-habit-overdue-face | |
ed21c5c8 | 111 | '((((background light)) (:background "#f9372d")) |
8bfe682a CD |
112 | (((background dark)) (:background "firebrick"))) |
113 | "Face for days on which a task is overdue." | |
114 | :group 'org-habit | |
115 | :group 'org-faces) | |
116 | (defface org-habit-overdue-future-face | |
ed21c5c8 | 117 | '((((background light)) (:background "#fc9590")) |
8bfe682a CD |
118 | (((background dark)) (:background "darkred"))) |
119 | "Face for days on which a task is overdue." | |
120 | :group 'org-habit | |
121 | :group 'org-faces) | |
122 | ||
123 | (defun org-habit-duration-to-days (ts) | |
124 | (if (string-match "\\([0-9]+\\)\\([dwmy]\\)" ts) | |
125 | ;; lead time is specified. | |
126 | (floor (* (string-to-number (match-string 1 ts)) | |
127 | (cdr (assoc (match-string 2 ts) | |
128 | '(("d" . 1) ("w" . 7) | |
129 | ("m" . 30.4) ("y" . 365.25)))))) | |
130 | (error "Invalid duration string: %s" ts))) | |
131 | ||
132 | (defun org-is-habit-p (&optional pom) | |
5dec9555 | 133 | "Is the task at POM or point a habit?" |
8bfe682a CD |
134 | (string= "habit" (org-entry-get (or pom (point)) "STYLE"))) |
135 | ||
136 | (defun org-habit-parse-todo (&optional pom) | |
137 | "Parse the TODO surrounding point for its habit-related data. | |
138 | Returns a list with the following elements: | |
139 | ||
140 | 0: Scheduled date for the habit (may be in the past) | |
141 | 1: \".+\"-style repeater for the schedule, in days | |
142 | 2: Optional deadline (nil if not present) | |
143 | 3: If deadline, the repeater for the deadline, otherwise nil | |
144 | 4: A list of all the past dates this todo was mark closed | |
145 | ||
146 | This list represents a \"habit\" for the rest of this module." | |
147 | (save-excursion | |
148 | (if pom (goto-char pom)) | |
149 | (assert (org-is-habit-p (point))) | |
150 | (let* ((scheduled (org-get-scheduled-time (point))) | |
151 | (scheduled-repeat (org-get-repeat org-scheduled-string)) | |
8bfe682a | 152 | (end (org-entry-end-position)) |
afe98dfa CD |
153 | (habit-entry (org-no-properties (nth 4 (org-heading-components)))) |
154 | closed-dates deadline dr-days sr-days) | |
8bfe682a CD |
155 | (if scheduled |
156 | (setq scheduled (time-to-days scheduled)) | |
157 | (error "Habit %s has no scheduled date" habit-entry)) | |
158 | (unless scheduled-repeat | |
afe98dfa CD |
159 | (error |
160 | "Habit '%s' has no scheduled repeat period or has an incorrect one" | |
161 | habit-entry)) | |
162 | (setq sr-days (org-habit-duration-to-days scheduled-repeat)) | |
8bfe682a CD |
163 | (unless (> sr-days 0) |
164 | (error "Habit %s scheduled repeat period is less than 1d" habit-entry)) | |
165 | (when (string-match "/\\([0-9]+[dwmy]\\)" scheduled-repeat) | |
166 | (setq dr-days (org-habit-duration-to-days | |
167 | (match-string-no-properties 1 scheduled-repeat))) | |
168 | (if (<= dr-days sr-days) | |
169 | (error "Habit %s deadline repeat period is less than or equal to scheduled (%s)" | |
170 | habit-entry scheduled-repeat)) | |
171 | (setq deadline (+ scheduled (- dr-days sr-days)))) | |
172 | (org-back-to-heading t) | |
173 | (while (re-search-forward "- State \"DONE\".*\\[\\([^]]+\\)\\]" end t) | |
174 | (push (time-to-days | |
175 | (org-time-string-to-time (match-string-no-properties 1))) | |
176 | closed-dates)) | |
177 | (list scheduled sr-days deadline dr-days closed-dates)))) | |
178 | ||
179 | (defsubst org-habit-scheduled (habit) | |
180 | (nth 0 habit)) | |
181 | (defsubst org-habit-scheduled-repeat (habit) | |
182 | (nth 1 habit)) | |
183 | (defsubst org-habit-deadline (habit) | |
184 | (let ((deadline (nth 2 habit))) | |
185 | (or deadline | |
86fbb8ca CD |
186 | (if (nth 3 habit) |
187 | (+ (org-habit-scheduled habit) | |
188 | (1- (org-habit-scheduled-repeat habit))) | |
189 | (org-habit-scheduled habit))))) | |
8bfe682a CD |
190 | (defsubst org-habit-deadline-repeat (habit) |
191 | (or (nth 3 habit) | |
192 | (org-habit-scheduled-repeat habit))) | |
193 | (defsubst org-habit-done-dates (habit) | |
194 | (nth 4 habit)) | |
195 | ||
196 | (defsubst org-habit-get-priority (habit &optional moment) | |
197 | "Determine the relative priority of a habit. | |
198 | This must take into account not just urgency, but consistency as well." | |
199 | (let ((pri 1000) | |
acedf35c | 200 | (now (if moment (time-to-days moment) (org-today))) |
8bfe682a CD |
201 | (scheduled (org-habit-scheduled habit)) |
202 | (deadline (org-habit-deadline habit))) | |
203 | ;; add 10 for every day past the scheduled date, and subtract for every | |
204 | ;; day before it | |
205 | (setq pri (+ pri (* (- now scheduled) 10))) | |
206 | ;; add 50 if the deadline is today | |
207 | (if (and (/= scheduled deadline) | |
208 | (= now deadline)) | |
209 | (setq pri (+ pri 50))) | |
210 | ;; add 100 for every day beyond the deadline date, and subtract 10 for | |
211 | ;; every day before it | |
212 | (let ((slip (- now (1- deadline)))) | |
213 | (if (> slip 0) | |
214 | (setq pri (+ pri (* slip 100))) | |
215 | (setq pri (+ pri (* slip 10))))) | |
216 | pri)) | |
217 | ||
218 | (defun org-habit-get-faces (habit &optional now-days scheduled-days donep) | |
219 | "Return faces for HABIT relative to NOW-DAYS and SCHEDULED-DAYS. | |
220 | NOW-DAYS defaults to the current time's days-past-the-epoch if nil. | |
221 | SCHEDULED-DAYS defaults to the habit's actual scheduled days if nil. | |
222 | ||
223 | Habits are assigned colors on the following basis: | |
224 | Blue Task is before the scheduled date. | |
225 | Green Task is on or after scheduled date, but before the | |
226 | end of the schedule's repeat period. | |
227 | Yellow If the task has a deadline, then it is after schedule's | |
228 | repeat period, but before the deadline. | |
229 | Orange The task has reached the deadline day, or if there is | |
230 | no deadline, the end of the schedule's repeat period. | |
231 | Red The task has gone beyond the deadline day or the | |
232 | schedule's repeat period." | |
233 | (let* ((scheduled (or scheduled-days (org-habit-scheduled habit))) | |
234 | (s-repeat (org-habit-scheduled-repeat habit)) | |
235 | (scheduled-end (+ scheduled (1- s-repeat))) | |
236 | (d-repeat (org-habit-deadline-repeat habit)) | |
237 | (deadline (if scheduled-days | |
238 | (+ scheduled-days (- d-repeat s-repeat)) | |
239 | (org-habit-deadline habit))) | |
240 | (m-days (or now-days (time-to-days (current-time))))) | |
241 | (cond | |
242 | ((< m-days scheduled) | |
243 | '(org-habit-clear-face . org-habit-clear-future-face)) | |
244 | ((< m-days deadline) | |
245 | '(org-habit-ready-face . org-habit-ready-future-face)) | |
246 | ((= m-days deadline) | |
247 | (if donep | |
248 | '(org-habit-ready-face . org-habit-ready-future-face) | |
249 | '(org-habit-alert-face . org-habit-alert-future-face))) | |
250 | (t | |
251 | '(org-habit-overdue-face . org-habit-overdue-future-face))))) | |
252 | ||
253 | (defun org-habit-build-graph (habit starting current ending) | |
254 | "Build a graph for the given HABIT, from STARTING to ENDING. | |
255 | CURRENT gives the current time between STARTING and ENDING, for | |
256 | the purpose of drawing the graph. It need not be the actual | |
257 | current time." | |
258 | (let* ((done-dates (sort (org-habit-done-dates habit) '<)) | |
259 | (scheduled (org-habit-scheduled habit)) | |
260 | (s-repeat (org-habit-scheduled-repeat habit)) | |
261 | (start (time-to-days starting)) | |
262 | (now (time-to-days current)) | |
263 | (end (time-to-days ending)) | |
264 | (graph (make-string (1+ (- end start)) ?\ )) | |
265 | (index 0) | |
266 | last-done-date) | |
267 | (while (and done-dates (< (car done-dates) start)) | |
268 | (setq last-done-date (car done-dates) | |
269 | done-dates (cdr done-dates))) | |
270 | (while (< start end) | |
271 | (let* ((in-the-past-p (< start now)) | |
272 | (todayp (= start now)) | |
273 | (donep (and done-dates | |
274 | (= start (car done-dates)))) | |
275 | (faces (if (and in-the-past-p | |
276 | (not last-done-date) | |
277 | (not (< scheduled now))) | |
278 | '(org-habit-clear-face . org-habit-clear-future-face) | |
279 | (org-habit-get-faces | |
280 | habit start (and in-the-past-p | |
281 | (if last-done-date | |
282 | (+ last-done-date s-repeat) | |
283 | scheduled)) | |
284 | donep))) | |
285 | markedp face) | |
286 | (if donep | |
86fbb8ca CD |
287 | (let ((done-time (time-add |
288 | starting | |
289 | (days-to-time | |
290 | (- start (time-to-days starting)))))) | |
291 | ||
8bfe682a CD |
292 | (aset graph index ?*) |
293 | (setq markedp t) | |
86fbb8ca CD |
294 | (put-text-property |
295 | index (1+ index) 'help-echo | |
296 | (format-time-string (org-time-stamp-format) done-time) graph) | |
8bfe682a CD |
297 | (while (and done-dates |
298 | (= start (car done-dates))) | |
299 | (setq last-done-date (car done-dates) | |
300 | done-dates (cdr done-dates)))) | |
301 | (if todayp | |
302 | (aset graph index ?!))) | |
303 | (setq face (if (or in-the-past-p todayp) | |
304 | (car faces) | |
305 | (cdr faces))) | |
306 | (if (and in-the-past-p | |
307 | (not (eq face 'org-habit-overdue-face)) | |
308 | (not markedp)) | |
309 | (setq face (cdr faces))) | |
310 | (put-text-property index (1+ index) 'face face graph)) | |
311 | (setq start (1+ start) | |
312 | index (1+ index))) | |
313 | graph)) | |
314 | ||
315 | (defun org-habit-insert-consistency-graphs (&optional line) | |
316 | "Insert consistency graph for any habitual tasks." | |
317 | (let ((inhibit-read-only t) l c | |
ed21c5c8 | 318 | (buffer-invisibility-spec '(org-link)) |
8bfe682a CD |
319 | (moment (time-subtract (current-time) |
320 | (list 0 (* 3600 org-extend-today-until) 0)))) | |
321 | (save-excursion | |
322 | (goto-char (if line (point-at-bol) (point-min))) | |
323 | (while (not (eobp)) | |
324 | (let ((habit (get-text-property (point) 'org-habit-p))) | |
325 | (when habit | |
326 | (move-to-column org-habit-graph-column t) | |
327 | (delete-char (min (+ 1 org-habit-preceding-days | |
328 | org-habit-following-days) | |
329 | (- (line-end-position) (point)))) | |
330 | (insert (org-habit-build-graph | |
331 | habit | |
332 | (time-subtract moment | |
333 | (days-to-time org-habit-preceding-days)) | |
334 | moment | |
335 | (time-add moment | |
336 | (days-to-time org-habit-following-days)))))) | |
337 | (forward-line))))) | |
338 | ||
339 | (defun org-habit-toggle-habits () | |
340 | "Toggle display of habits in an agenda buffer." | |
341 | (interactive) | |
342 | (org-agenda-check-type t 'agenda) | |
343 | (setq org-habit-show-habits (not org-habit-show-habits)) | |
344 | (org-agenda-redo) | |
345 | (org-agenda-set-mode-name) | |
346 | (message "Habits turned %s" | |
347 | (if org-habit-show-habits "on" "off"))) | |
348 | ||
349 | (org-defkey org-agenda-mode-map "K" 'org-habit-toggle-habits) | |
350 | ||
351 | (provide 'org-habit) | |
352 | ||
8bfe682a CD |
353 | |
354 | ;;; org-habit.el ends here |