1 ;;; org-habit.el --- The habit tracking code for Org-mode
4 ;; Free Software Foundation, Inc.
6 ;; Author: John Wiegley <johnw at gnu dot org>
7 ;; Keywords: outlines, hypermedia, calendar, wp
8 ;; Homepage: http://orgmode.org
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
29 ;; This file contains the habit tracking code for Org-mode
37 (defgroup org-habit nil
38 "Options concerning habit tracking in Org-mode."
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."
48 (defcustom org-habit-preceding-days
21
49 "Number of days before today to appear in consistency graphs."
53 (defcustom org-habit-following-days
7
54 "Number of days after today to appear in consistency graphs."
58 (defcustom org-habit-show-habits t
59 "If non-nil, show habits in agenda buffers."
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 time."
70 (defface org-habit-clear-face
71 '((((background light
)) (:background
"slateblue"))
72 (((background dark
)) (:background
"blue")))
73 "Face for days on which a task shouldn't be done yet."
76 (defface org-habit-clear-future-face
77 '((((background light
)) (:background
"powderblue"))
78 (((background dark
)) (:background
"midnightblue")))
79 "Face for future days on which a task shouldn't be done yet."
83 (defface org-habit-ready-face
84 '((((background light
)) (:background
"green"))
85 (((background dark
)) (:background
"forestgreen")))
86 "Face for days on which a task should start to be done."
89 (defface org-habit-ready-future-face
90 '((((background light
)) (:background
"palegreen"))
91 (((background dark
)) (:background
"darkgreen")))
92 "Face for days on which a task should start to be done."
96 (defface org-habit-warning-face
97 '((((background light
)) (:background
"yellow"))
98 (((background dark
)) (:background
"gold")))
99 "Face for days on which a task ought to be done."
102 (defface org-habit-warning-future-face
103 '((((background light
)) (:background
"palegoldenrod"))
104 (((background dark
)) (:background
"darkgoldenrod")))
105 "Face for days on which a task ought be done."
109 (defface org-habit-alert-face
110 '((((background light
)) (:background
"yellow"))
111 (((background dark
)) (:background
"gold")))
112 "Face for days on which a task is due."
115 (defface org-habit-alert-future-face
116 '((((background light
)) (:background
"palegoldenrod"))
117 (((background dark
)) (:background
"darkgoldenrod")))
118 "Face for days on which a task is due."
122 (defface org-habit-overdue-face
123 '((((background light
)) (:background
"red"))
124 (((background dark
)) (:background
"firebrick")))
125 "Face for days on which a task is overdue."
128 (defface org-habit-overdue-future-face
129 '((((background light
)) (:background
"mistyrose"))
130 (((background dark
)) (:background
"darkred")))
131 "Face for days on which a task is overdue."
135 (defun org-habit-duration-to-days (ts)
136 (if (string-match "\\([0-9]+\\)\\([dwmy]\\)" ts
)
137 ;; lead time is specified.
138 (floor (* (string-to-number (match-string 1 ts
))
139 (cdr (assoc (match-string 2 ts
)
140 '(("d" .
1) ("w" .
7)
141 ("m" .
30.4) ("y" .
365.25))))))
142 (error "Invalid duration string: %s" ts
)))
144 (defun org-is-habit-p (&optional pom
)
145 (string= "habit" (org-entry-get (or pom
(point)) "STYLE")))
147 (defun org-habit-parse-todo (&optional pom
)
148 "Parse the TODO surrounding point for its habit-related data.
149 Returns a list with the following elements:
151 0: Scheduled date for the habit (may be in the past)
152 1: \".+\"-style repeater for the schedule, in days
153 2: Optional deadline (nil if not present)
154 3: If deadline, the repeater for the deadline, otherwise nil
155 4: A list of all the past dates this todo was mark closed
157 This list represents a \"habit\" for the rest of this module."
159 (if pom
(goto-char pom
))
160 (assert (org-is-habit-p (point)))
161 (let* ((scheduled (org-get-scheduled-time (point)))
162 (scheduled-repeat (org-get-repeat "SCHEDULED"))
163 (sr-days (org-habit-duration-to-days scheduled-repeat
))
164 (end (org-entry-end-position))
165 closed-dates deadline dr-days
)
167 (error "Habit has no scheduled date"))
168 (unless scheduled-repeat
169 (error "Habit has no scheduled repeat period"))
170 (when (string-match "/\\([0-9]+[dwmy]\\)" scheduled-repeat
)
171 (setq dr-days
(org-habit-duration-to-days
172 (match-string-no-properties 1 scheduled-repeat
)))
173 (if (<= dr-days sr-days
)
174 (error "Habit's deadline repeat period is less than or equal to scheduled"))
175 (setq deadline
(time-add scheduled
176 (days-to-time (- dr-days sr-days
)))))
177 (org-back-to-heading t
)
178 (while (re-search-forward "- State \"DONE\".*\\[\\([^]]+\\)\\]" end t
)
179 (push (org-time-string-to-time (match-string-no-properties 1))
181 (list scheduled sr-days deadline dr-days closed-dates
))))
183 (defsubst org-habit-scheduled
(habit)
185 (defsubst org-habit-scheduled-repeat
(habit)
187 (defsubst org-habit-deadline
(habit)
189 (defsubst org-habit-deadline-repeat
(habit)
191 (defsubst org-habit-done-dates
(habit)
194 (defun org-habit-get-faces (habit &optional moment scheduled-time donep
)
195 "Return faces for HABIT relative to MOMENT and SCHEDULED-TIME.
196 MOMENT defaults to the current time if it is nil.
197 SCHEDULED-TIME defaults to the habit's actual scheduled time if nil.
199 Habits are assigned colors on the following basis:
200 Blue Task is before the scheduled date.
201 Green Task is on or after scheduled date, but before the
202 end of the schedule's repeat period.
203 Yellow If the task has a deadline, then it is after schedule's
204 repeat period, but before the deadline.
205 Orange The task has reached the deadline day, or if there is
206 no deadline, the end of the schedule's repeat period.
207 Red The task has gone beyond the deadline day or the
208 schedule's repeat period."
209 (unless moment
(setq moment
(current-time)))
210 (let* ((scheduled (or scheduled-time
(org-habit-scheduled habit
)))
211 (s-repeat (org-habit-scheduled-repeat habit
))
212 (scheduled-end (time-add scheduled
(days-to-time s-repeat
)))
213 (d-repeat (org-habit-deadline-repeat habit
))
214 (deadline (if (and scheduled-time d-repeat
)
215 (time-add scheduled-time
216 (days-to-time (- d-repeat s-repeat
)))
217 (org-habit-deadline habit
))))
219 ((time-less-p moment scheduled
)
220 '(org-habit-clear-face . org-habit-clear-future-face
))
221 ((time-less-p moment scheduled-end
)
222 '(org-habit-ready-face . org-habit-ready-future-face
))
224 (time-less-p moment deadline
))
226 '(org-habit-ready-face . org-habit-ready-future-face
)
227 '(org-habit-warning-face . org-habit-warning-future-face
)))
228 ((= (time-to-days moment
)
230 (time-to-days deadline
)
231 (time-to-days scheduled-end
)))
233 '(org-habit-ready-face . org-habit-ready-future-face
)
234 '(org-habit-alert-face . org-habit-alert-future-face
)))
236 '(org-habit-overdue-face . org-habit-overdue-future-face
)))))
238 (defun org-habit-build-graph (habit &optional starting current ending
)
239 "Build a color graph for the given HABIT, from STARTING to ENDING."
240 (let ((done-dates (sort (org-habit-done-dates habit
) 'time-less-p
))
241 (s-repeat (org-habit-scheduled-repeat habit
))
243 (current-days (time-to-days current
))
245 (graph (make-string (1+ (- (time-to-days ending
)
246 (time-to-days starting
))) ?\
))
249 (while (time-less-p (car done-dates
) starting
)
250 (setq last-done-date
(car done-dates
)
251 done-dates
(cdr done-dates
))))
252 (while (time-less-p day ending
)
253 (let* ((now-days (time-to-days day
))
254 (in-the-past-p (< now-days current-days
))
255 (todayp (= now-days current-days
))
256 (donep (and done-dates
257 (= now-days
(time-to-days (car done-dates
)))))
258 (faces (if (and in-the-past-p
(not last-done-date
))
259 '(org-habit-clear-face . org-habit-clear-future-face
)
261 habit day
(and in-the-past-p
262 (time-add last-done-date
263 (days-to-time s-repeat
)))
268 (aset graph index ?
*)
269 (setq last-done-date
(car done-dates
)
270 done-dates
(cdr done-dates
)
273 (aset graph index ?
!)))
274 (setq face
(if (or in-the-past-p
278 (if (and in-the-past-p
279 (not (eq face
'org-habit-overdue-face
))
281 (setq face
(cdr faces
)))
282 (put-text-property index
(1+ index
) 'face face graph
))
283 (setq day
(time-add day
(days-to-time 1))
287 (defun org-habit-insert-consistency-graphs (&optional line
)
288 "Insert consistency graph for any habitual tasks."
289 (let ((inhibit-read-only t
) l c
290 (moment (time-subtract (current-time)
291 (list 0 (* 3600 org-extend-today-until
) 0))))
293 (goto-char (if line
(point-at-bol) (point-min)))
295 (let ((habit (get-text-property (point) 'org-habit-p
)))
297 (move-to-column org-habit-graph-column t
)
298 (delete-char (min (+ 1 org-habit-preceding-days
299 org-habit-following-days
)
300 (- (line-end-position) (point))))
301 (insert (org-habit-build-graph
303 (time-subtract moment
304 (days-to-time org-habit-preceding-days
))
307 (days-to-time org-habit-following-days
))))))
310 (defun org-habit-toggle-habits ()
311 "Toggle display of habits in an agenda buffer."
313 (org-agenda-check-type t
'agenda
)
314 (setq org-habit-show-habits
(not org-habit-show-habits
))
316 (org-agenda-set-mode-name)
317 (message "Habits turned %s"
318 (if org-habit-show-habits
"on" "off")))
320 (org-defkey org-agenda-mode-map
"K" 'org-habit-toggle-habits
)
326 ;;; org-habit.el ends here