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 | |
5dec9555 | 8 | ;; Version: 6.33x |
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 | ||
30 | (require 'org) | |
31 | (require 'org-agenda) | |
32 | (eval-when-compile | |
33 | (require 'cl) | |
34 | (require 'calendar)) | |
35 | ||
36 | (defgroup org-habit nil | |
37 | "Options concerning habit tracking in Org-mode." | |
38 | :tag "Org Habit" | |
39 | :group 'org-progress) | |
40 | ||
41 | (defcustom org-habit-graph-column 40 | |
42 | "The absolute column at which to insert habit consistency graphs. | |
43 | Note that consistency graphs will overwrite anything else in the buffer." | |
44 | :group 'org-habit | |
45 | :type 'integer) | |
46 | ||
47 | (defcustom org-habit-preceding-days 21 | |
48 | "Number of days before today to appear in consistency graphs." | |
49 | :group 'org-habit | |
50 | :type 'integer) | |
51 | ||
52 | (defcustom org-habit-following-days 7 | |
53 | "Number of days after today to appear in consistency graphs." | |
54 | :group 'org-habit | |
55 | :type 'integer) | |
56 | ||
57 | (defcustom org-habit-show-habits t | |
58 | "If non-nil, show habits in agenda buffers." | |
59 | :group 'org-habit | |
60 | :type 'boolean) | |
61 | ||
62 | (defcustom org-habit-show-habits-only-for-today t | |
63 | "If non-nil, only show habits on today's agenda, and not for future days. | |
64 | Note that even when shown for future days, the graph is always | |
65 | relative to the current effective date." | |
66 | :group 'org-habit | |
67 | :type 'boolean) | |
68 | ||
69 | (defface org-habit-clear-face | |
70 | '((((background light)) (:background "slateblue")) | |
71 | (((background dark)) (:background "blue"))) | |
72 | "Face for days on which a task shouldn't be done yet." | |
73 | :group 'org-habit | |
74 | :group 'org-faces) | |
75 | (defface org-habit-clear-future-face | |
76 | '((((background light)) (:background "powderblue")) | |
77 | (((background dark)) (:background "midnightblue"))) | |
78 | "Face for future days on which a task shouldn't be done yet." | |
79 | :group 'org-habit | |
80 | :group 'org-faces) | |
81 | ||
82 | (defface org-habit-ready-face | |
83 | '((((background light)) (:background "green")) | |
84 | (((background dark)) (:background "forestgreen"))) | |
85 | "Face for days on which a task should start to be done." | |
86 | :group 'org-habit | |
87 | :group 'org-faces) | |
88 | (defface org-habit-ready-future-face | |
89 | '((((background light)) (:background "palegreen")) | |
90 | (((background dark)) (:background "darkgreen"))) | |
91 | "Face for days on which a task should start to be done." | |
92 | :group 'org-habit | |
93 | :group 'org-faces) | |
94 | ||
95 | (defface org-habit-alert-face | |
96 | '((((background light)) (:background "yellow")) | |
97 | (((background dark)) (:background "gold"))) | |
98 | "Face for days on which a task is due." | |
99 | :group 'org-habit | |
100 | :group 'org-faces) | |
101 | (defface org-habit-alert-future-face | |
102 | '((((background light)) (:background "palegoldenrod")) | |
103 | (((background dark)) (:background "darkgoldenrod"))) | |
104 | "Face for days on which a task is due." | |
105 | :group 'org-habit | |
106 | :group 'org-faces) | |
107 | ||
108 | (defface org-habit-overdue-face | |
109 | '((((background light)) (:background "red")) | |
110 | (((background dark)) (:background "firebrick"))) | |
111 | "Face for days on which a task is overdue." | |
112 | :group 'org-habit | |
113 | :group 'org-faces) | |
114 | (defface org-habit-overdue-future-face | |
115 | '((((background light)) (:background "mistyrose")) | |
116 | (((background dark)) (:background "darkred"))) | |
117 | "Face for days on which a task is overdue." | |
118 | :group 'org-habit | |
119 | :group 'org-faces) | |
120 | ||
121 | (defun org-habit-duration-to-days (ts) | |
122 | (if (string-match "\\([0-9]+\\)\\([dwmy]\\)" ts) | |
123 | ;; lead time is specified. | |
124 | (floor (* (string-to-number (match-string 1 ts)) | |
125 | (cdr (assoc (match-string 2 ts) | |
126 | '(("d" . 1) ("w" . 7) | |
127 | ("m" . 30.4) ("y" . 365.25)))))) | |
128 | (error "Invalid duration string: %s" ts))) | |
129 | ||
130 | (defun org-is-habit-p (&optional pom) | |
5dec9555 | 131 | "Is the task at POM or point a habit?" |
8bfe682a CD |
132 | (string= "habit" (org-entry-get (or pom (point)) "STYLE"))) |
133 | ||
134 | (defun org-habit-parse-todo (&optional pom) | |
135 | "Parse the TODO surrounding point for its habit-related data. | |
136 | Returns a list with the following elements: | |
137 | ||
138 | 0: Scheduled date for the habit (may be in the past) | |
139 | 1: \".+\"-style repeater for the schedule, in days | |
140 | 2: Optional deadline (nil if not present) | |
141 | 3: If deadline, the repeater for the deadline, otherwise nil | |
142 | 4: A list of all the past dates this todo was mark closed | |
143 | ||
144 | This list represents a \"habit\" for the rest of this module." | |
145 | (save-excursion | |
146 | (if pom (goto-char pom)) | |
147 | (assert (org-is-habit-p (point))) | |
148 | (let* ((scheduled (org-get-scheduled-time (point))) | |
149 | (scheduled-repeat (org-get-repeat org-scheduled-string)) | |
150 | (sr-days (org-habit-duration-to-days scheduled-repeat)) | |
151 | (end (org-entry-end-position)) | |
152 | (habit-entry (org-no-properties (nth 5 (org-heading-components)))) | |
153 | closed-dates deadline dr-days) | |
154 | (if scheduled | |
155 | (setq scheduled (time-to-days scheduled)) | |
156 | (error "Habit %s has no scheduled date" habit-entry)) | |
157 | (unless scheduled-repeat | |
158 | (error "Habit %s has no scheduled repeat period" habit-entry)) | |
159 | (unless (> sr-days 0) | |
160 | (error "Habit %s scheduled repeat period is less than 1d" habit-entry)) | |
161 | (when (string-match "/\\([0-9]+[dwmy]\\)" scheduled-repeat) | |
162 | (setq dr-days (org-habit-duration-to-days | |
163 | (match-string-no-properties 1 scheduled-repeat))) | |
164 | (if (<= dr-days sr-days) | |
165 | (error "Habit %s deadline repeat period is less than or equal to scheduled (%s)" | |
166 | habit-entry scheduled-repeat)) | |
167 | (setq deadline (+ scheduled (- dr-days sr-days)))) | |
168 | (org-back-to-heading t) | |
169 | (while (re-search-forward "- State \"DONE\".*\\[\\([^]]+\\)\\]" end t) | |
170 | (push (time-to-days | |
171 | (org-time-string-to-time (match-string-no-properties 1))) | |
172 | closed-dates)) | |
173 | (list scheduled sr-days deadline dr-days closed-dates)))) | |
174 | ||
175 | (defsubst org-habit-scheduled (habit) | |
176 | (nth 0 habit)) | |
177 | (defsubst org-habit-scheduled-repeat (habit) | |
178 | (nth 1 habit)) | |
179 | (defsubst org-habit-deadline (habit) | |
180 | (let ((deadline (nth 2 habit))) | |
181 | (or deadline | |
182 | (+ (org-habit-scheduled habit) | |
183 | (1- (org-habit-scheduled-repeat habit)))))) | |
184 | (defsubst org-habit-deadline-repeat (habit) | |
185 | (or (nth 3 habit) | |
186 | (org-habit-scheduled-repeat habit))) | |
187 | (defsubst org-habit-done-dates (habit) | |
188 | (nth 4 habit)) | |
189 | ||
190 | (defsubst org-habit-get-priority (habit &optional moment) | |
191 | "Determine the relative priority of a habit. | |
192 | This must take into account not just urgency, but consistency as well." | |
193 | (let ((pri 1000) | |
194 | (now (time-to-days | |
195 | (or moment | |
196 | (time-subtract (current-time) | |
197 | (list 0 (* 3600 org-extend-today-until) 0))))) | |
198 | (scheduled (org-habit-scheduled habit)) | |
199 | (deadline (org-habit-deadline habit))) | |
200 | ;; add 10 for every day past the scheduled date, and subtract for every | |
201 | ;; day before it | |
202 | (setq pri (+ pri (* (- now scheduled) 10))) | |
203 | ;; add 50 if the deadline is today | |
204 | (if (and (/= scheduled deadline) | |
205 | (= now deadline)) | |
206 | (setq pri (+ pri 50))) | |
207 | ;; add 100 for every day beyond the deadline date, and subtract 10 for | |
208 | ;; every day before it | |
209 | (let ((slip (- now (1- deadline)))) | |
210 | (if (> slip 0) | |
211 | (setq pri (+ pri (* slip 100))) | |
212 | (setq pri (+ pri (* slip 10))))) | |
213 | pri)) | |
214 | ||
215 | (defun org-habit-get-faces (habit &optional now-days scheduled-days donep) | |
216 | "Return faces for HABIT relative to NOW-DAYS and SCHEDULED-DAYS. | |
217 | NOW-DAYS defaults to the current time's days-past-the-epoch if nil. | |
218 | SCHEDULED-DAYS defaults to the habit's actual scheduled days if nil. | |
219 | ||
220 | Habits are assigned colors on the following basis: | |
221 | Blue Task is before the scheduled date. | |
222 | Green Task is on or after scheduled date, but before the | |
223 | end of the schedule's repeat period. | |
224 | Yellow If the task has a deadline, then it is after schedule's | |
225 | repeat period, but before the deadline. | |
226 | Orange The task has reached the deadline day, or if there is | |
227 | no deadline, the end of the schedule's repeat period. | |
228 | Red The task has gone beyond the deadline day or the | |
229 | schedule's repeat period." | |
230 | (let* ((scheduled (or scheduled-days (org-habit-scheduled habit))) | |
231 | (s-repeat (org-habit-scheduled-repeat habit)) | |
232 | (scheduled-end (+ scheduled (1- s-repeat))) | |
233 | (d-repeat (org-habit-deadline-repeat habit)) | |
234 | (deadline (if scheduled-days | |
235 | (+ scheduled-days (- d-repeat s-repeat)) | |
236 | (org-habit-deadline habit))) | |
237 | (m-days (or now-days (time-to-days (current-time))))) | |
238 | (cond | |
239 | ((< m-days scheduled) | |
240 | '(org-habit-clear-face . org-habit-clear-future-face)) | |
241 | ((< m-days deadline) | |
242 | '(org-habit-ready-face . org-habit-ready-future-face)) | |
243 | ((= m-days deadline) | |
244 | (if donep | |
245 | '(org-habit-ready-face . org-habit-ready-future-face) | |
246 | '(org-habit-alert-face . org-habit-alert-future-face))) | |
247 | (t | |
248 | '(org-habit-overdue-face . org-habit-overdue-future-face))))) | |
249 | ||
250 | (defun org-habit-build-graph (habit starting current ending) | |
251 | "Build a graph for the given HABIT, from STARTING to ENDING. | |
252 | CURRENT gives the current time between STARTING and ENDING, for | |
253 | the purpose of drawing the graph. It need not be the actual | |
254 | current time." | |
255 | (let* ((done-dates (sort (org-habit-done-dates habit) '<)) | |
256 | (scheduled (org-habit-scheduled habit)) | |
257 | (s-repeat (org-habit-scheduled-repeat habit)) | |
258 | (start (time-to-days starting)) | |
259 | (now (time-to-days current)) | |
260 | (end (time-to-days ending)) | |
261 | (graph (make-string (1+ (- end start)) ?\ )) | |
262 | (index 0) | |
263 | last-done-date) | |
264 | (while (and done-dates (< (car done-dates) start)) | |
265 | (setq last-done-date (car done-dates) | |
266 | done-dates (cdr done-dates))) | |
267 | (while (< start end) | |
268 | (let* ((in-the-past-p (< start now)) | |
269 | (todayp (= start now)) | |
270 | (donep (and done-dates | |
271 | (= start (car done-dates)))) | |
272 | (faces (if (and in-the-past-p | |
273 | (not last-done-date) | |
274 | (not (< scheduled now))) | |
275 | '(org-habit-clear-face . org-habit-clear-future-face) | |
276 | (org-habit-get-faces | |
277 | habit start (and in-the-past-p | |
278 | (if last-done-date | |
279 | (+ last-done-date s-repeat) | |
280 | scheduled)) | |
281 | donep))) | |
282 | markedp face) | |
283 | (if donep | |
284 | (progn | |
285 | (aset graph index ?*) | |
286 | (setq markedp t) | |
287 | (while (and done-dates | |
288 | (= start (car done-dates))) | |
289 | (setq last-done-date (car done-dates) | |
290 | done-dates (cdr done-dates)))) | |
291 | (if todayp | |
292 | (aset graph index ?!))) | |
293 | (setq face (if (or in-the-past-p todayp) | |
294 | (car faces) | |
295 | (cdr faces))) | |
296 | (if (and in-the-past-p | |
297 | (not (eq face 'org-habit-overdue-face)) | |
298 | (not markedp)) | |
299 | (setq face (cdr faces))) | |
300 | (put-text-property index (1+ index) 'face face graph)) | |
301 | (setq start (1+ start) | |
302 | index (1+ index))) | |
303 | graph)) | |
304 | ||
305 | (defun org-habit-insert-consistency-graphs (&optional line) | |
306 | "Insert consistency graph for any habitual tasks." | |
307 | (let ((inhibit-read-only t) l c | |
308 | (moment (time-subtract (current-time) | |
309 | (list 0 (* 3600 org-extend-today-until) 0)))) | |
310 | (save-excursion | |
311 | (goto-char (if line (point-at-bol) (point-min))) | |
312 | (while (not (eobp)) | |
313 | (let ((habit (get-text-property (point) 'org-habit-p))) | |
314 | (when habit | |
315 | (move-to-column org-habit-graph-column t) | |
316 | (delete-char (min (+ 1 org-habit-preceding-days | |
317 | org-habit-following-days) | |
318 | (- (line-end-position) (point)))) | |
319 | (insert (org-habit-build-graph | |
320 | habit | |
321 | (time-subtract moment | |
322 | (days-to-time org-habit-preceding-days)) | |
323 | moment | |
324 | (time-add moment | |
325 | (days-to-time org-habit-following-days)))))) | |
326 | (forward-line))))) | |
327 | ||
328 | (defun org-habit-toggle-habits () | |
329 | "Toggle display of habits in an agenda buffer." | |
330 | (interactive) | |
331 | (org-agenda-check-type t 'agenda) | |
332 | (setq org-habit-show-habits (not org-habit-show-habits)) | |
333 | (org-agenda-redo) | |
334 | (org-agenda-set-mode-name) | |
335 | (message "Habits turned %s" | |
336 | (if org-habit-show-habits "on" "off"))) | |
337 | ||
338 | (org-defkey org-agenda-mode-map "K" 'org-habit-toggle-habits) | |
339 | ||
340 | (provide 'org-habit) | |
341 | ||
342 | ;; arch-tag: 64e070d9-bd09-4917-bd44-44465f5ed348 | |
343 | ||
344 | ;;; org-habit.el ends here |