Commit | Line | Data |
---|---|---|
8bfe682a CD |
1 | ;;; org-habit.el --- The habit tracking code for Org-mode |
2 | ||
114f9c96 | 3 | ;; Copyright (C) 2009, 2010 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 | |
86fbb8ca | 8 | ;; Version: 7.01 |
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)) | |
152 | (sr-days (org-habit-duration-to-days scheduled-repeat)) | |
153 | (end (org-entry-end-position)) | |
154 | (habit-entry (org-no-properties (nth 5 (org-heading-components)))) | |
155 | closed-dates deadline dr-days) | |
156 | (if scheduled | |
157 | (setq scheduled (time-to-days scheduled)) | |
158 | (error "Habit %s has no scheduled date" habit-entry)) | |
159 | (unless scheduled-repeat | |
160 | (error "Habit %s has no scheduled repeat period" habit-entry)) | |
161 | (unless (> sr-days 0) | |
162 | (error "Habit %s scheduled repeat period is less than 1d" habit-entry)) | |
163 | (when (string-match "/\\([0-9]+[dwmy]\\)" scheduled-repeat) | |
164 | (setq dr-days (org-habit-duration-to-days | |
165 | (match-string-no-properties 1 scheduled-repeat))) | |
166 | (if (<= dr-days sr-days) | |
167 | (error "Habit %s deadline repeat period is less than or equal to scheduled (%s)" | |
168 | habit-entry scheduled-repeat)) | |
169 | (setq deadline (+ scheduled (- dr-days sr-days)))) | |
170 | (org-back-to-heading t) | |
171 | (while (re-search-forward "- State \"DONE\".*\\[\\([^]]+\\)\\]" end t) | |
172 | (push (time-to-days | |
173 | (org-time-string-to-time (match-string-no-properties 1))) | |
174 | closed-dates)) | |
175 | (list scheduled sr-days deadline dr-days closed-dates)))) | |
176 | ||
177 | (defsubst org-habit-scheduled (habit) | |
178 | (nth 0 habit)) | |
179 | (defsubst org-habit-scheduled-repeat (habit) | |
180 | (nth 1 habit)) | |
181 | (defsubst org-habit-deadline (habit) | |
182 | (let ((deadline (nth 2 habit))) | |
183 | (or deadline | |
86fbb8ca CD |
184 | (if (nth 3 habit) |
185 | (+ (org-habit-scheduled habit) | |
186 | (1- (org-habit-scheduled-repeat habit))) | |
187 | (org-habit-scheduled habit))))) | |
8bfe682a CD |
188 | (defsubst org-habit-deadline-repeat (habit) |
189 | (or (nth 3 habit) | |
190 | (org-habit-scheduled-repeat habit))) | |
191 | (defsubst org-habit-done-dates (habit) | |
192 | (nth 4 habit)) | |
193 | ||
194 | (defsubst org-habit-get-priority (habit &optional moment) | |
195 | "Determine the relative priority of a habit. | |
196 | This must take into account not just urgency, but consistency as well." | |
197 | (let ((pri 1000) | |
198 | (now (time-to-days | |
199 | (or moment | |
200 | (time-subtract (current-time) | |
201 | (list 0 (* 3600 org-extend-today-until) 0))))) | |
202 | (scheduled (org-habit-scheduled habit)) | |
203 | (deadline (org-habit-deadline habit))) | |
204 | ;; add 10 for every day past the scheduled date, and subtract for every | |
205 | ;; day before it | |
206 | (setq pri (+ pri (* (- now scheduled) 10))) | |
207 | ;; add 50 if the deadline is today | |
208 | (if (and (/= scheduled deadline) | |
209 | (= now deadline)) | |
210 | (setq pri (+ pri 50))) | |
211 | ;; add 100 for every day beyond the deadline date, and subtract 10 for | |
212 | ;; every day before it | |
213 | (let ((slip (- now (1- deadline)))) | |
214 | (if (> slip 0) | |
215 | (setq pri (+ pri (* slip 100))) | |
216 | (setq pri (+ pri (* slip 10))))) | |
217 | pri)) | |
218 | ||
219 | (defun org-habit-get-faces (habit &optional now-days scheduled-days donep) | |
220 | "Return faces for HABIT relative to NOW-DAYS and SCHEDULED-DAYS. | |
221 | NOW-DAYS defaults to the current time's days-past-the-epoch if nil. | |
222 | SCHEDULED-DAYS defaults to the habit's actual scheduled days if nil. | |
223 | ||
224 | Habits are assigned colors on the following basis: | |
225 | Blue Task is before the scheduled date. | |
226 | Green Task is on or after scheduled date, but before the | |
227 | end of the schedule's repeat period. | |
228 | Yellow If the task has a deadline, then it is after schedule's | |
229 | repeat period, but before the deadline. | |
230 | Orange The task has reached the deadline day, or if there is | |
231 | no deadline, the end of the schedule's repeat period. | |
232 | Red The task has gone beyond the deadline day or the | |
233 | schedule's repeat period." | |
234 | (let* ((scheduled (or scheduled-days (org-habit-scheduled habit))) | |
235 | (s-repeat (org-habit-scheduled-repeat habit)) | |
236 | (scheduled-end (+ scheduled (1- s-repeat))) | |
237 | (d-repeat (org-habit-deadline-repeat habit)) | |
238 | (deadline (if scheduled-days | |
239 | (+ scheduled-days (- d-repeat s-repeat)) | |
240 | (org-habit-deadline habit))) | |
241 | (m-days (or now-days (time-to-days (current-time))))) | |
242 | (cond | |
243 | ((< m-days scheduled) | |
244 | '(org-habit-clear-face . org-habit-clear-future-face)) | |
245 | ((< m-days deadline) | |
246 | '(org-habit-ready-face . org-habit-ready-future-face)) | |
247 | ((= m-days deadline) | |
248 | (if donep | |
249 | '(org-habit-ready-face . org-habit-ready-future-face) | |
250 | '(org-habit-alert-face . org-habit-alert-future-face))) | |
251 | (t | |
252 | '(org-habit-overdue-face . org-habit-overdue-future-face))))) | |
253 | ||
254 | (defun org-habit-build-graph (habit starting current ending) | |
255 | "Build a graph for the given HABIT, from STARTING to ENDING. | |
256 | CURRENT gives the current time between STARTING and ENDING, for | |
257 | the purpose of drawing the graph. It need not be the actual | |
258 | current time." | |
259 | (let* ((done-dates (sort (org-habit-done-dates habit) '<)) | |
260 | (scheduled (org-habit-scheduled habit)) | |
261 | (s-repeat (org-habit-scheduled-repeat habit)) | |
262 | (start (time-to-days starting)) | |
263 | (now (time-to-days current)) | |
264 | (end (time-to-days ending)) | |
265 | (graph (make-string (1+ (- end start)) ?\ )) | |
266 | (index 0) | |
267 | last-done-date) | |
268 | (while (and done-dates (< (car done-dates) start)) | |
269 | (setq last-done-date (car done-dates) | |
270 | done-dates (cdr done-dates))) | |
271 | (while (< start end) | |
272 | (let* ((in-the-past-p (< start now)) | |
273 | (todayp (= start now)) | |
274 | (donep (and done-dates | |
275 | (= start (car done-dates)))) | |
276 | (faces (if (and in-the-past-p | |
277 | (not last-done-date) | |
278 | (not (< scheduled now))) | |
279 | '(org-habit-clear-face . org-habit-clear-future-face) | |
280 | (org-habit-get-faces | |
281 | habit start (and in-the-past-p | |
282 | (if last-done-date | |
283 | (+ last-done-date s-repeat) | |
284 | scheduled)) | |
285 | donep))) | |
286 | markedp face) | |
287 | (if donep | |
86fbb8ca CD |
288 | (let ((done-time (time-add |
289 | starting | |
290 | (days-to-time | |
291 | (- start (time-to-days starting)))))) | |
292 | ||
8bfe682a CD |
293 | (aset graph index ?*) |
294 | (setq markedp t) | |
86fbb8ca CD |
295 | (put-text-property |
296 | index (1+ index) 'help-echo | |
297 | (format-time-string (org-time-stamp-format) done-time) graph) | |
8bfe682a CD |
298 | (while (and done-dates |
299 | (= start (car done-dates))) | |
300 | (setq last-done-date (car done-dates) | |
301 | done-dates (cdr done-dates)))) | |
302 | (if todayp | |
303 | (aset graph index ?!))) | |
304 | (setq face (if (or in-the-past-p todayp) | |
305 | (car faces) | |
306 | (cdr faces))) | |
307 | (if (and in-the-past-p | |
308 | (not (eq face 'org-habit-overdue-face)) | |
309 | (not markedp)) | |
310 | (setq face (cdr faces))) | |
311 | (put-text-property index (1+ index) 'face face graph)) | |
312 | (setq start (1+ start) | |
313 | index (1+ index))) | |
314 | graph)) | |
315 | ||
316 | (defun org-habit-insert-consistency-graphs (&optional line) | |
317 | "Insert consistency graph for any habitual tasks." | |
318 | (let ((inhibit-read-only t) l c | |
ed21c5c8 | 319 | (buffer-invisibility-spec '(org-link)) |
8bfe682a CD |
320 | (moment (time-subtract (current-time) |
321 | (list 0 (* 3600 org-extend-today-until) 0)))) | |
322 | (save-excursion | |
323 | (goto-char (if line (point-at-bol) (point-min))) | |
324 | (while (not (eobp)) | |
325 | (let ((habit (get-text-property (point) 'org-habit-p))) | |
326 | (when habit | |
327 | (move-to-column org-habit-graph-column t) | |
328 | (delete-char (min (+ 1 org-habit-preceding-days | |
329 | org-habit-following-days) | |
330 | (- (line-end-position) (point)))) | |
331 | (insert (org-habit-build-graph | |
332 | habit | |
333 | (time-subtract moment | |
334 | (days-to-time org-habit-preceding-days)) | |
335 | moment | |
336 | (time-add moment | |
337 | (days-to-time org-habit-following-days)))))) | |
338 | (forward-line))))) | |
339 | ||
340 | (defun org-habit-toggle-habits () | |
341 | "Toggle display of habits in an agenda buffer." | |
342 | (interactive) | |
343 | (org-agenda-check-type t 'agenda) | |
344 | (setq org-habit-show-habits (not org-habit-show-habits)) | |
345 | (org-agenda-redo) | |
346 | (org-agenda-set-mode-name) | |
347 | (message "Habits turned %s" | |
348 | (if org-habit-show-habits "on" "off"))) | |
349 | ||
350 | (org-defkey org-agenda-mode-map "K" 'org-habit-toggle-habits) | |
351 | ||
352 | (provide 'org-habit) | |
353 | ||
354 | ;; arch-tag: 64e070d9-bd09-4917-bd44-44465f5ed348 | |
355 | ||
356 | ;;; org-habit.el ends here |