Merge branch 'master' of orgmode.org:org-mode
[org-mode.git] / lisp / org-habit.el
blob8465ba45a27a8f082d382a89553d09fedb09e8b7
1 ;;; org-habit.el --- The habit tracking code for Org-mode
3 ;; Copyright (C) 2009-2013 Free Software Foundation, Inc.
5 ;; Author: John Wiegley <johnw at gnu dot org>
6 ;; Keywords: outlines, hypermedia, calendar, wp
7 ;; Homepage: http://orgmode.org
8 ;;
9 ;; This file is part of GNU Emacs.
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.
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.
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25 ;;; Commentary:
27 ;; This file contains the habit tracking code for Org-mode
29 ;;; Code:
31 (require 'org)
32 (require 'org-agenda)
34 (eval-when-compile
35 (require 'cl))
37 (defgroup org-habit nil
38 "Options concerning habit tracking in Org-mode."
39 :tag "Org Habit"
40 :group 'org-progress)
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)
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)
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)
58 (defcustom org-habit-show-habits t
59 "If non-nil, show habits in agenda buffers."
60 :group 'org-habit
61 :type 'boolean)
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)
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)
76 (defcustom org-habit-today-glyph ?!
77 "Glyph character used to identify today."
78 :group 'org-habit
79 :version "24.1"
80 :type 'character)
82 (defcustom org-habit-completed-glyph ?*
83 "Glyph character used to show completed days on which a task was done."
84 :group 'org-habit
85 :version "24.1"
86 :type 'character)
88 (defface org-habit-clear-face
89 '((((background light)) (:background "#8270f9"))
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
95 '((((background light)) (:background "#d6e4fc"))
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)
101 (defface org-habit-ready-face
102 '((((background light)) (:background "#4df946"))
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
108 '((((background light)) (:background "#acfca9"))
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)
114 (defface org-habit-alert-face
115 '((((background light)) (:background "#f5f946"))
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
121 '((((background light)) (:background "#fafca9"))
122 (((background dark)) (:background "darkgoldenrod")))
123 "Face for days on which a task is due."
124 :group 'org-habit
125 :group 'org-faces)
127 (defface org-habit-overdue-face
128 '((((background light)) (:background "#f9372d"))
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
134 '((((background light)) (:background "#fc9590"))
135 (((background dark)) (:background "darkred")))
136 "Face for days on which a task is overdue."
137 :group 'org-habit
138 :group 'org-faces)
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)))
149 (defun org-is-habit-p (&optional pom)
150 "Is the task at POM or point a habit?"
151 (string= "habit" (org-entry-get (or pom (point)) "STYLE")))
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:
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
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))
169 (end (org-entry-end-position))
170 (habit-entry (org-no-properties (nth 4 (org-heading-components))))
171 closed-dates deadline dr-days sr-days)
172 (if scheduled
173 (setq scheduled (time-to-days scheduled))
174 (error "Habit %s has no scheduled date" habit-entry))
175 (unless scheduled-repeat
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))
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)
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))))
202 (list scheduled sr-days deadline dr-days closed-dates))))
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
211 (if (nth 3 habit)
212 (+ (org-habit-scheduled habit)
213 (1- (org-habit-scheduled-repeat habit)))
214 (org-habit-scheduled habit)))))
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))
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)
225 (now (if moment (time-to-days moment) (org-today)))
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))
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.
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)))
276 '(org-habit-overdue-face . org-habit-overdue-future-face)))))
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
312 (let ((done-time (time-add
313 starting
314 (days-to-time
315 (- start (time-to-days starting))))))
317 (aset graph index org-habit-completed-glyph)
318 (setq markedp t)
319 (put-text-property
320 index (1+ index) 'help-echo
321 (format-time-string (org-time-stamp-format) done-time) graph)
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
327 (aset graph index org-habit-today-glyph)))
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))
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
343 (buffer-invisibility-spec '(org-link))
344 (moment (time-subtract (current-time)
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)))
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))))
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)))
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")))
382 (org-defkey org-agenda-mode-map "K" 'org-habit-toggle-habits)
384 (provide 'org-habit)
386 ;;; org-habit.el ends here