Added support for habit consistency tracking

org-habit.el: New file, which implements code to build a "habit
consistency graph".

org-agenda.el (org-agenda-get-deadlines)
(org-agenda-get-scheduled): Display consistency graphs when outputting
habits into the agenda.  The graphs are always relative to the current
time.

(org-format-agenda-item): Added new parameter `habitp', which indicates
whether we are formatting a habit or not.  Do not display "extra"
leading information if habitp is true.

Makefile

@@ -77,6 +77,7 @@ LISPF      = 	org.el			\
 		org-feed.el		\
 		org-footnote.el		\
 		org-gnus.el		\
+		org-habit.el		\
 		org-html.el		\
 		org-icalendar.el	\
 		org-id.el		\

doc/ChangeLog

@@ -1,3 +1,8 @@
+2009-10-19  John Wiegley  <johnw@newartisans.com>
+
+	* org.texi (Tracking your habits): Added a new section in the
+	manual about how to track habits.
+
 2009-10-18  Carsten Dominik  <carsten.dominik@gmail.com>
 
 	* org.texi (Pushing to MobileOrg): Mention that `org-directory'

doc/org.texi

@@ -198,6 +198,7 @@ Progress logging
 
 * Closing items::               When was this entry marked DONE?
 * Tracking TODO state changes::  When did the status change?
+* Tracking your habits::        How consistent have you been?
 
 Tags
 
@@ -3524,6 +3525,7 @@ work time}.
 @menu
 * Closing items::               When was this entry marked DONE?
 * Tracking TODO state changes::  When did the status change?
+* Tracking your habits::        How consistent have you been?
 @end menu
 
 @node Closing items, Tracking TODO state changes, Progress logging, Progress logging
@@ -3558,7 +3560,7 @@ In the timeline (@pxref{Timeline}) and in the agenda
 display the TODO items with a @samp{CLOSED} timestamp on each day,
 giving you an overview of what has been done.
 
-@node Tracking TODO state changes,  , Closing items, Progress logging
+@node Tracking TODO state changes, Tracking your habits, Closing items, Progress logging
 @subsection Tracking TODO state changes
 @cindex drawer, for state change recording
 
@@ -3635,6 +3637,103 @@ settings like @code{TODO(!)}.  For example
   :END:
 @end example
 
+@node Tracking your habits,  , Tracking TODO state changes, Progress logging
+@subsection Tracking your habits
+@cindex habits
+
+Org has the ability to track the consistency of a special category of TODOs,
+called ``habits''.  A habit has the following properties:
+
+@enumerate
+@item
+The habit is a TODO, with a TODO keyword that represents an open state.
+@item
+The property @code{STYLE} is set to the value @code{habit}.
+@item
+The TODO has a scheduled date, with a @code{.+} style repeat interval.
+@item
+The TODO may also have a deadline, as long as it also has a @code{.+} style
+repeat interval and it starts a number of days after the scheduled date equal
+to the difference between the repeat interval lengths@footnote{Note that if
+you don't set this right, Org will alert you as to what's incorrect about the
+habit definition.}.
+@item
+You must also have state logging for the @code{DONE} state enabled, in order
+for historical data to be represented in the consistency graph.  If it's not
+enabled it's not an error, but the consistency graphs will be largely
+meaningless.
+@end enumerate
+
+To give you an idea of what the above rules look like in action, here's an
+actual habit with some history:
+
+@example
+** TODO Shave
+   SCHEDULED: <2009-10-17 Sat .+2d> DEADLINE: <2009-10-19 Mon .+4d>
+   - State "DONE"       from "TODO"       [2009-10-15 Thu]
+   - State "DONE"       from "TODO"       [2009-10-12 Mon]
+   - State "DONE"       from "TODO"       [2009-10-10 Sat]
+   - State "DONE"       from "TODO"       [2009-10-04 Sun]
+   - State "DONE"       from "TODO"       [2009-10-02 Fri]
+   - State "DONE"       from "TODO"       [2009-09-29 Tue]
+   - State "DONE"       from "TODO"       [2009-09-25 Fri]
+   - State "DONE"       from "TODO"       [2009-09-19 Sat]
+   - State "DONE"       from "TODO"       [2009-09-16 Wed]
+   - State "DONE"       from "TODO"       [2009-09-12 Sat]
+   :PROPERTIES:
+   :STYLE:    habit
+   :LAST_REPEAT: [2009-10-19 Mon 00:36]
+   :END:
+@end example
+
+What this habit says is: I want to shave at most every 2 days (given by the
+@code{SCHEDULED} date and repeat interval) at least every 4 days (given by
+the @code{DEADLINE} date and repeat interval).  If today is the 15th, then
+the habit first appears in the agenda on Oct 17, after the minimum of 2 days
+has elapsed, and will appear overdue on Oct 19, after four days have elapsed.
+
+What's really useful about habits is that they are displayed along with a
+conistency graph, to show how consistent you've been at getting that task
+done in the past.  This graph shows every day that the task was done over the
+past three weeks, with colors for each day.  The colors used are:
+
+@table @code
+@item Blue
+If the task wasn't to be done yet on that day.
+@item Green
+If the task could have been done on that day.
+@item Yellow
+If the task was going to be overdue the next day.
+@item Red
+If the task was overdue on that day.
+@end table
+
+In addition to coloring each day, the day is also marked with an asterix if
+the task was actually done that day, and an exclamation mark to show where
+the current day falls in the graph.
+
+There are several configuration variables that can be used to change the way
+habits are displayed in the agenda.
+
+@table @code
+@item org-habit-graph-column
+The buffer column at which the consistency graph should be drawn.  This will
+overwite any text in that column, so it's a good idea to keep your habits'
+titles brief and to the point.
+@item org-habit-preceding-days
+The amount of history, in days before today, to appear in consistency graphs.
+@item org-habit-following-days
+The number of days after today that will appear in consistency graphs.
+@item org-habit-show-habits-only-for-today
+If non-nil, only show habits in today's agenda view.  This is set to true by
+default.
+@end table
+
+Lastly, pressing @kbd{K} in the agenda buffer will cause habits to
+temporarily be disabled and they won't appear at all.  Press @kbd{K} again to
+bring them back.  They are also subject to tag filtering, if you have habits
+which should only be done in certain contexts, for example.
+
 @node Priorities, Breaking down tasks, Progress logging, TODO Items
 @section Priorities
 @cindex priorities

lisp/ChangeLog

@@ -1,3 +1,8 @@
+2009-10-20  John Wiegley  <johnw@newartisans.com>
+
+	* org-agenda.el (org-finalize-agenda): Draw habit consistency
+	graphs after everything else in the buffer has been setup.
+
 2009-10-19  Carsten Dominik  <carsten.dominik@gmail.com>
 
 	* org-mobile.el (org-mobile-apply): Count success and failure.
@@ -15,6 +20,17 @@
 
 2009-10-19  John Wiegley  <johnw@newartisans.com>
 
+	* org-habit.el: New file, which implements code to build a "habit
+	consistency graph".
+
+	* org-agenda.el (org-agenda-get-deadlines)
+	(org-agenda-get-scheduled): Display consistency graphs when
+	outputting habits into the agenda.  The graphs are always relative
+	to the current time.
+	(org-format-agenda-item): Added new parameter `habitp', which
+	indicates whether we are formatting a habit or not.  Do not
+	display "extra" leading information if habitp is true.
+
 	* org.el (org-repeat-re): Improved regexp to include .+ and ++
 	leaders for repeat strings.
 	(org-get-repeat): Now takes a string parameter `tagline', so the

lisp/org-agenda.el

@@ -201,6 +201,7 @@ you can \"misuse\" it to also add other text to the header.  However,
     (const priority-up) (const priority-down)
     (const todo-state-up) (const todo-state-down)
     (const effort-up) (const effort-down)
+    (const habit-up) (const habit-down)
     (const user-defined-up) (const user-defined-down))
   "Sorting choices.")
 
@@ -950,9 +951,9 @@ a grid line."
   :group 'org-agenda)
 
 (defcustom org-agenda-sorting-strategy
-  '((agenda time-up        priority-down category-keep)
-    (todo   priority-down  category-keep)
-    (tags   priority-down  category-keep)
+  '((agenda habit-down time-up priority-down category-keep)
+    (todo   priority-down category-keep)
+    (tags   priority-down category-keep)
     (search category-keep))
   "Sorting structure for the agenda items of a single day.
 This is a list of symbols which will be used in sequence to determine
@@ -975,6 +976,8 @@ effort-up          Sort numerically by estimated effort, high effort last.
 effort-down        Sort numerically by estimated effort, high effort first.
 user-defined-up    Sort according to `org-agenda-cmp-user-defined', high last.
 user-defined-down  Sort according to `org-agenda-cmp-user-defined', high first.
+habit-up           Put entries that are habits first
+habit-down         Put entries that are habits last
 
 The different possibilities will be tried in sequence, and testing stops
 if one comparison returns a \"not-equal\".  For example, the default
@@ -2600,6 +2603,8 @@ bind it in the options section.")
       (when org-agenda-entry-text-mode
 	(org-agenda-entry-text-hide)
 	(org-agenda-entry-text-show))
+      (if (functionp 'org-habit-insert-consistency-graphs)
+	  (org-habit-insert-consistency-graphs))
       (run-hooks 'org-finalize-agenda-hook)
       (setq org-agenda-type (org-get-at-bol 'org-agenda-type))
       (when (get 'org-agenda-filter :preset-filter)
@@ -4214,7 +4219,7 @@ the documentation of `org-diary'."
 	 (regexp org-deadline-time-regexp)
 	 (todayp (org-agenda-todayp date)) ; DATE bound by calendar
 	 (d1 (calendar-absolute-from-gregorian date))  ; DATE bound by calendar
-	 d2 diff dfrac wdays pos pos1 category tags
+	 d2 diff dfrac wdays pos pos1 category tags habitp
 	 ee txt head face s todo-state upcomingp donep timestr)
     (goto-char (point-min))
     (while (re-search-forward regexp nil t)
@@ -4227,15 +4232,22 @@ the documentation of `org-diary'."
 		  (match-string 1) d1 'past
 		  org-agenda-repeating-timestamp-show-all)
 	      diff (- d2 d1)
+	      ;; Never show habits as deadline entries, only as scheduled
+	      ;; entries.  The habit code already requires that every habit
+	      ;; have a scheduled date if it has a deadline, and that the
+	      ;; scheduled date is prior to the deadline.
+	      habitp (and (functionp 'org-is-habit-p)
+			  (org-is-habit-p))
 	      wdays (org-get-wdays s)
 	      dfrac (/ (* 1.0 (- wdays diff)) (max wdays 1))
 	      upcomingp (and todayp (> diff 0)))
 	;; When to show a deadline in the calendar:
 	;; If the expiration is within wdays warning time.
 	;; Past-due deadlines are only shown on the current date
-	(if (or (and (<= diff wdays)
-		     (and todayp (not org-agenda-only-exact-dates)))
-		(= diff 0))
+	(if (and (or (and (<= diff wdays)
+			  (and todayp (not org-agenda-only-exact-dates)))
+		     (= diff 0))
+		 (not habitp))
 	    (save-excursion
 	      (setq todo-state (org-get-todo-state))
 	      (setq donep (member todo-state org-done-keywords))
@@ -4311,11 +4323,11 @@ FRACTION is what fraction of the head-warning time has passed."
 	 mm
 	 (deadline-position-alist
 	  (mapcar (lambda (a) (and (setq mm (get-text-property
-					     0 'org-hd-marker a))
-				   (cons (marker-position mm) a)))
+					0 'org-hd-marker a))
+			      (cons (marker-position mm) a)))
 		  deadline-results))
 	 d2 diff pos pos1 category tags donep
-	 ee txt head pastschedp todo-state face timestr s)
+	 ee txt head pastschedp todo-state face timestr s habitp)
     (goto-char (point-min))
     (while (re-search-forward regexp nil t)
       (catch :skip
@@ -4330,60 +4342,69 @@ FRACTION is what fraction of the head-warning time has passed."
 	(setq pastschedp (and todayp (< diff 0)))
 	;; When to show a scheduled item in the calendar:
 	;; If it is on or past the date.
-	(if (or (and (< diff 0)
-		     (< (abs diff) org-scheduled-past-days)
-		     (and todayp (not org-agenda-only-exact-dates)))
-		(= diff 0))
-	    (save-excursion
-	      (setq todo-state (org-get-todo-state))
-	      (setq donep (member todo-state org-done-keywords))
-	      (if (and donep
-		       (or org-agenda-skip-scheduled-if-done
-			   (not (= diff 0))))
-		  (setq txt nil)
-		(setq category (org-get-category))
-		(if (not (re-search-backward "^\\*+[ \t]+" nil t))
-		    (setq txt org-agenda-no-heading-message)
-		  (goto-char (match-end 0))
-		  (setq pos1 (match-beginning 0))
+	(when (or (and (< diff 0)
+		       (< (abs diff) org-scheduled-past-days)
+		       (and todayp (not org-agenda-only-exact-dates)))
+		  (= diff 0))
+	  (save-excursion
+	    (setq todo-state (org-get-todo-state))
+	    (setq donep (member todo-state org-done-keywords))
+	    (setq habitp (and (functionp 'org-is-habit-p)
+			      (org-is-habit-p)))
+	    (if (and donep
+		     (or habitp org-agenda-skip-scheduled-if-done
+			 (not (= diff 0))))
+		(setq txt nil)
+	      (setq category (org-get-category))
+	      (if (not (re-search-backward "^\\*+[ \t]+" nil t))
+		  (setq txt org-agenda-no-heading-message)
+		(goto-char (match-end 0))
+		(setq pos1 (match-beginning 0))
+		(if habitp
+		    (if (or (not org-habit-show-habits)
+			    (and (not todayp)
+				 org-habit-show-habits-only-for-today))
+			(throw :skip nil))
 		  (if (and
 		       (or (eq t org-agenda-skip-scheduled-if-deadline-is-shown)
 			   (and org-agenda-skip-scheduled-if-deadline-is-shown
 				pastschedp))
 		       (setq mm (assoc pos1 deadline-position-alist)))
-		      (throw :skip nil))
-		  (setq tags (org-get-tags-at))
-		  (setq head (buffer-substring-no-properties
-			      (point)
-			      (progn (skip-chars-forward "^\r\n") (point))))
-		  (if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
-		      (setq timestr
-			    (concat (substring s (match-beginning 1)) " "))
-		    (setq timestr 'time))
-		  (setq txt (org-format-agenda-item
-			     (if (= diff 0)
-				 (car org-agenda-scheduled-leaders)
-			       (format (nth 1 org-agenda-scheduled-leaders)
-				       (- 1 diff)))
-			     head category tags
-			     (if (not (= diff 0)) nil timestr)))))
-	      (when txt
-		(setq face
-		      (cond
-		       (pastschedp 'org-scheduled-previously)
-		       (todayp 'org-scheduled-today)
-		       (t 'org-scheduled)))
-		(org-add-props txt props
-		  'undone-face face
-		  'face (if donep 'org-agenda-done face)
-		  'org-marker (org-agenda-new-marker pos)
-		  'org-hd-marker (org-agenda-new-marker pos1)
-		  'type (if pastschedp "past-scheduled" "scheduled")
-		  'date (if pastschedp d2 date)
-		  'priority (+ 94 (- 5 diff) (org-get-priority txt))
-		  'org-category category
-		  'todo-state todo-state)
-		(push txt ee))))))
+		      (throw :skip nil)))
+		(setq tags (org-get-tags-at))
+		(setq head (buffer-substring-no-properties
+			    (point)
+			    (progn (skip-chars-forward "^\r\n") (point))))
+		(if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
+		    (setq timestr
+			  (concat (substring s (match-beginning 1)) " "))
+		  (setq timestr 'time))
+		(setq txt (org-format-agenda-item
+			   (if (= diff 0)
+			       (car org-agenda-scheduled-leaders)
+			     (format (nth 1 org-agenda-scheduled-leaders)
+				     (- 1 diff)))
+			   head category tags
+			   (if (not (= diff 0)) nil timestr)
+			   nil nil habitp))))
+	    (when txt
+	      (setq face
+		    (cond
+		     (pastschedp 'org-scheduled-previously)
+		     (todayp 'org-scheduled-today)
+		     (t 'org-scheduled)))
+	      (org-add-props txt props
+		'undone-face face
+		'face (if donep 'org-agenda-done face)
+		'org-marker (org-agenda-new-marker pos)
+		'org-hd-marker (org-agenda-new-marker pos1)
+		'type (if pastschedp "past-scheduled" "scheduled")
+		'date (if pastschedp d2 date)
+		'priority (+ 94 (- 5 diff) (org-get-priority txt))
+		'org-category category
+		'org-habit-p (and habitp (org-habit-parse-todo))
+		'todo-state todo-state)
+	      (push txt ee))))))
     (nreverse ee)))
 
 (defun org-agenda-get-blocks ()
@@ -4462,7 +4483,7 @@ The flag is set if the currently compiled format contains a `%e'.")
   "Used by `org-compile-prefix-format' to remember the category field widh.")
 
 (defun org-format-agenda-item (extra txt &optional category tags dotime
-				     noprefix remove-re)
+				     noprefix remove-re habitp)
   "Format TXT to be inserted into the agenda buffer.
 In particular, it adds the prefix and corresponding text properties.  EXTRA
 must be a string and replaces the `%s' specifier in the prefix format.
@@ -4575,7 +4596,7 @@ Any match of REMOVE-RE will be removed from TXT."
 	(setq time (cond (s2 (concat s1 "-" s2))
 			 (s1 (concat s1 "......"))
 			 (t ""))
-	      extra (or extra "")
+	      extra (or (and (not habitp) extra) "")
 	      category (if (symbolp category) (symbol-name category) category)
 	      thecategory (copy-sequence category))
 	(if (string-match org-bracket-link-regexp category)
@@ -4858,6 +4879,14 @@ HH:MM."
 	  ((< tb ta) +1)
 	  (t nil))))
 
+(defsubst org-cmp-habit-p (a b)
+  "Compare the todo states of strings A and B."
+  (let ((ha (get-text-property 1 'org-habit-p a))
+	(hb (get-text-property 1 'org-habit-p b)))
+    (cond ((and ha (not hb)) -1)
+	  ((and (not ha) hb) +1)
+	  (t nil))))
+
 (defun org-entries-lessp (a b)
   "Predicate for sorting agenda entries."
   ;; The following variables will be used when the form is evaluated.
@@ -4875,6 +4904,8 @@ HH:MM."
 	 (tag-down (if tag-up (- tag-up) nil))
 	 (todo-state-up (org-cmp-todo-state a b))
 	 (todo-state-down (if todo-state-up (- todo-state-up) nil))
+	 (habit-up (org-cmp-habit-p a b))
+	 (habit-down (if habit-up (- habit-up) nil))
 	 user-defined-up user-defined-down)
     (if (and org-agenda-cmp-user-defined
 	     (functionp org-agenda-cmp-user-defined))

lisp/org-habit.el

@@ -0,0 +1,333 @@
+;;; org-habit.el --- The habit tracking code for Org-mode
+
+;; Copyright (C) 2009
+;;   Free Software Foundation, Inc.
+
+;; Author: John Wiegley <johnw at gnu dot org>
+;; Keywords: outlines, hypermedia, calendar, wp
+;; Homepage: http://orgmode.org
+;; Version: 6.31trans
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+
+;; This file contains the habit tracking code for Org-mode
+
+(require 'org)
+(require 'org-agenda)
+(eval-when-compile
+  (require 'cl)
+  (require 'calendar))
+
+(defgroup org-habit nil
+  "Options concerning habit tracking in Org-mode."
+  :tag "Org Habit"
+  :group 'org-progress)
+
+(defcustom org-habit-graph-column 40
+  "The absolute column at which to insert habit consistency graphs.
+Note that consistency graphs will overwrite anything else in the buffer."
+  :group 'org-habit
+  :type 'integer)
+
+(defcustom org-habit-preceding-days 21
+  "Number of days before today to appear in consistency graphs."
+  :group 'org-habit
+  :type 'integer)
+
+(defcustom org-habit-following-days 7
+  "Number of days after today to appear in consistency graphs."
+  :group 'org-habit
+  :type 'integer)
+
+(defcustom org-habit-show-habits t
+  "If non-nil, show habits in agenda buffers."
+  :group 'org-habit
+  :type 'boolean)
+
+(defcustom org-habit-show-habits-only-for-today t
+  "If non-nil, only show habits on today's agenda, and not for future days.
+Note that even when shown for future days, the graph is always
+relative to the current effective time."
+  :group 'org-habit
+  :type 'boolean)
+
+(defcustom org-habit-clear-color "slateblue"
+  "Color for days on which a task shouldn't be done yet."
+  :group 'org-habit
+  :group 'org-faces
+  :type 'color)
+(defcustom org-habit-clear-future-color "powderblue"
+  "Color for future days on which a task shouldn't be done yet."
+  :group 'org-habit
+  :group 'org-faces
+  :type 'color)
+
+(defcustom org-habit-ready-color "green"
+  "Color for days on which a task should start to be done."
+  :group 'org-habit
+  :group 'org-faces
+  :type 'color)
+(defcustom org-habit-ready-future-color "palegreen"
+  "Color for days on which a task should start to be done."
+  :group 'org-habit
+  :group 'org-faces
+  :type 'color)
+
+(defcustom org-habit-warning-color "yellow"
+  "Color for days on which a task ought to be done."
+  :group 'org-habit
+  :group 'org-faces
+  :type 'color)
+(defcustom org-habit-warning-future-color "palegoldenrod"
+  "Color for days on which a task ought be done."
+  :group 'org-habit
+  :group 'org-faces
+  :type 'color)
+
+(defcustom org-habit-alert-color "yellow"
+  "Color for days on which a task is due."
+  :group 'org-habit
+  :group 'org-faces
+  :type 'color)
+(defcustom org-habit-alert-future-color "palegoldenrod"
+  "Color for days on which a task is due."
+  :group 'org-habit
+  :group 'org-faces
+  :type 'color)
+
+(defcustom org-habit-overdue-color "red"
+  "Color for days on which a task is overdue."
+  :group 'org-habit
+  :group 'org-faces
+  :type 'color)
+(defcustom org-habit-overdue-future-color "mistyrose"
+  "Color for days on which a task is overdue."
+  :group 'org-habit
+  :group 'org-faces
+  :type 'color)
+
+(defun org-habit-duration-to-days (ts)
+  (if (string-match "\\([0-9]+\\)\\([dwmy]\\)\\'" ts)
+      ;; lead time is specified.
+      (floor (* (string-to-number (match-string 1 ts))
+		(cdr (assoc (match-string 2 ts)
+			    '(("d" . 1)    ("w" . 7)
+			      ("m" . 30.4) ("y" . 365.25))))))
+    (error "Invalid duration string: %s" ts)))
+
+(defun org-is-habit-p (&optional pom)
+  (string= "habit" (org-entry-get (or pom (point)) "STYLE")))
+
+(defun org-habit-parse-todo (&optional pom)
+  "Parse the TODO surrounding point for its habit-related data.
+Returns a list with the following elements:
+
+  0: Scheduled date for the habit (may be in the past)
+  1: \".+\"-style repeater for the schedule, in days
+  2: Optional deadline (nil if not present)
+  3: If deadline, the repeater for the deadline, otherwise nil
+  4: A list of all the past dates this todo was mark closed
+
+This list represents a \"habit\" for the rest of this module."
+  (save-excursion
+    (if pom (goto-char pom))
+    (assert (org-is-habit-p (point)))
+    (let ((scheduled (org-get-scheduled-time (point)))
+	  (scheduled-repeat (org-get-repeat "SCHEDULED"))
+	  (deadline (org-get-deadline-time (point)))
+	  (deadline-repeat (org-get-repeat "DEADLINE")))
+      (unless scheduled
+	(error "Habit has no scheduled date"))
+      (unless scheduled-repeat
+	(error "Habit has no scheduled repeat period"))
+      (unless (string-match "\\`\\.\\+[0-9]+" scheduled-repeat)
+	(error "Habit's scheduled repeat period does not match `.+[0-9]*'"))
+      (if (and deadline (not deadline-repeat))
+	  (error "Habit has a deadline, but no deadline repeat period"))
+      (if (and deadline
+	       (not (string-match "\\`\\.\\+[0-9]+" scheduled-repeat))) 
+	  (error "Habit's deadline repeat period does not match `.+[0-9]*'"))
+      (let ((sr-days (org-habit-duration-to-days scheduled-repeat))
+	    (dr-days (and deadline-repeat
+			  (org-habit-duration-to-days deadline-repeat))))
+	(when (and scheduled deadline)
+	  (cond
+	   ((time-less-p deadline scheduled)
+	    (error "Habit's deadline date is before the scheduled date"))
+	   ((< dr-days sr-days)
+	    (error "Habit's deadline repeat period is less than scheduled"))
+	   ((/= (- (time-to-days deadline)
+		   (time-to-days scheduled))
+		(- dr-days sr-days))
+	    (error "Habit's deadline and scheduled period lengths are off"))))
+	(let ((end (org-entry-end-position))
+	      closed-dates)
+	  (org-back-to-heading t)
+	  (while (re-search-forward "- State \"DONE\".*\\[\\([^]]+\\)\\]" end t)
+	    (push (org-time-string-to-time (match-string-no-properties 1))
+		  closed-dates))
+	  (list scheduled sr-days deadline dr-days closed-dates))))))
+
+(defsubst org-habit-scheduled (habit)
+  (nth 0 habit))
+(defsubst org-habit-scheduled-repeat (habit)
+  (nth 1 habit))
+(defsubst org-habit-deadline (habit)
+  (nth 2 habit))
+(defsubst org-habit-deadline-repeat (habit)
+  (nth 3 habit))
+(defsubst org-habit-done-dates (habit)
+  (nth 4 habit))
+
+(defun org-habit-get-colors (habit &optional moment scheduled-time donep)
+  "Return faces for HABIT relative to MOMENT and SCHEDULED-TIME.
+MOMENT defaults to the current time if it is nil.
+SCHEDULED-TIME defaults to the habit's actual scheduled time if nil.
+
+Habits are assigned colors on the following basis:
+  Blue      Task is before the scheduled date.
+  Green     Task is on or after scheduled date, but before the
+            end of the schedule's repeat period.
+  Yellow    If the task has a deadline, then it is after schedule's
+            repeat period, but before the deadline.
+  Orange    The task has reached the deadline day, or if there is
+            no deadline, the end of the schedule's repeat period.
+  Red       The task has gone beyond the deadline day or the
+            schedule's repeat period."
+  (unless moment (setq moment (current-time)))
+  (let* ((scheduled (or scheduled-time (org-habit-scheduled habit)))
+	 (s-repeat (org-habit-scheduled-repeat habit))
+	 (scheduled-end (time-add scheduled (days-to-time s-repeat)))
+	 (d-repeat (org-habit-deadline-repeat habit))
+	 (deadline (if scheduled-time
+		       (time-add scheduled-time
+				 (days-to-time (- d-repeat s-repeat)))
+		     (org-habit-deadline habit))))
+    (cond
+     ((time-less-p moment scheduled)
+      (cons org-habit-clear-color org-habit-clear-future-color))
+     ((time-less-p moment scheduled-end)
+      (cons org-habit-ready-color org-habit-ready-future-color))
+     ((and deadline
+	   (time-less-p moment deadline))
+      (if donep
+	  (cons org-habit-ready-color org-habit-ready-future-color)
+	(cons org-habit-warning-color org-habit-warning-future-color)))
+     ((= (time-to-days moment)
+	 (if deadline
+	     (time-to-days deadline)
+	   (time-to-days scheduled-end)))
+      (if donep
+	  (cons org-habit-ready-color org-habit-ready-future-color)
+	(cons org-habit-alert-color org-habit-alert-future-color)))
+     (t
+      (cons org-habit-overdue-color org-habit-overdue-future-color)))))
+
+(defun org-habit-build-graph (habit &optional starting current ending)
+  "Build a color graph for the given HABIT, from STARTING to ENDING."
+  (let ((done-dates (sort (org-habit-done-dates habit) 'time-less-p))
+	(s-repeat (org-habit-scheduled-repeat habit))
+	(day starting)
+	(current-days (time-to-days current))
+	last-done-date
+	(graph (make-string (1+ (- (time-to-days ending)
+				   (time-to-days starting))) ?\ ))
+	(index 0))
+    (if done-dates
+	(while (time-less-p (car done-dates) starting)
+	  (setq last-done-date (car done-dates)
+		done-dates (cdr done-dates))))
+    (while (time-less-p day ending)
+      (let* ((now-days (time-to-days day))
+	     (in-the-past-p (< now-days current-days))
+	     (todayp (= now-days current-days))
+	     (donep (and done-dates
+			 (= now-days (time-to-days (car done-dates)))))
+	     (colors (if (and in-the-past-p (not last-done-date))
+			 (cons org-habit-clear-color
+			       org-habit-clear-future-color)
+		       (org-habit-get-colors
+			habit day
+			(and in-the-past-p
+			     (time-add last-done-date
+				       (days-to-time s-repeat)))
+			donep)))
+	     markedp color)
+	(if donep
+	    (progn
+	      (aset graph index ?*)
+	      (setq last-done-date (car done-dates)
+		    done-dates (cdr done-dates)
+		    markedp t))
+	  (if todayp
+	      (aset graph index ?!)))
+	(setq color (if (or in-the-past-p
+			    todayp)
+			(car colors)
+		      (cdr colors)))
+	(if (and in-the-past-p
+		 (not (string= color org-habit-overdue-color))
+		 (not markedp))
+	    (setq color (cdr colors)))
+	(put-text-property index (1+ index)
+			   'face (list :background color) graph))
+      (setq day (time-add day (days-to-time 1))
+	    index (1+ index)))
+    graph))
+
+(defun org-habit-insert-consistency-graphs (&optional line)
+  "Insert consistency graph for any habitual tasks."
+  (let ((inhibit-read-only t) l c
+	(moment (time-subtract (current-time)
+			       (list 0 (* 3600 org-extend-today-until) 0))))
+    (save-excursion
+      (goto-char (if line (point-at-bol) (point-min)))
+      (while (not (eobp))
+	(let ((habit (get-text-property (point) 'org-habit-p)))
+	  (when habit
+	    (move-to-column org-habit-graph-column t)
+	    (delete-char (min (+ 1 org-habit-preceding-days
+				 org-habit-following-days)
+			      (- (line-end-position) (point))))
+	    (insert (org-habit-build-graph
+		     habit
+		     (time-subtract moment
+				    (days-to-time org-habit-preceding-days))
+		     moment
+		     (time-add moment
+			       (days-to-time org-habit-following-days))))))
+	(forward-line)))))
+
+(defun org-habit-toggle-habits ()
+  "Toggle display of habits in an agenda buffer."
+  (interactive)
+  (org-agenda-check-type t 'agenda)
+  (setq org-habit-show-habits (not org-habit-show-habits))
+  (org-agenda-redo)
+  (org-agenda-set-mode-name)
+  (message "Habits turned %s"
+	   (if org-habit-show-habits "on" "off")))
+
+(org-defkey org-agenda-mode-map "K" 'org-habit-toggle-habits)
+
+(provide 'org-habit)
+
+;; arch-tag: 
+
+;;; org-habit.el ends here

lisp/org.el

@@ -188,6 +188,7 @@ to add the symbol `xyz', and the package must have a call to
 	(const :tag "   id:                Global IDs for identifying entries" org-id)
 	(const :tag "   info:              Links to Info nodes" org-info)
 	(const :tag "   jsinfo:            Set up Sebastian Rose's JavaScript org-info.js" org-jsinfo)
+	(const :tag "   habit:             Track your consistency with habits" org-habit)
 	(const :tag "   inlinetask:        Tasks independent of outline hierarchy" org-inlinetask)
 	(const :tag "   irc:               Links to IRC/ERC chat sessions" org-irc)
 	(const :tag "   mac-message:       Links to messages in Apple Mail" org-mac-message)