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