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