From 617ccd1c2afe267f464a8b692db41c23329b6326 Mon Sep 17 00:00:00 2001
From: John Wiegley <johnw@newartisans.com>
Date: Mon, 19 Oct 2009 04:17:49 -0400
Subject: [PATCH 5/5] 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.
---
 doc/ChangeLog      |    5 +
 doc/org.texi       |   75 +++++++++++++++++-
 lisp/ChangeLog     |   11 +++
 lisp/org-agenda.el |   56 +++++++++++---
 lisp/org-habit.el  |  223 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 358 insertions(+), 12 deletions(-)
 create mode 100644 lisp/org-habit.el

diff --git a/doc/ChangeLog b/doc/ChangeLog
index 4ae3099..76fbd32 100644
--- a/doc/ChangeLog
+++ b/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'
diff --git a/doc/org.texi b/doc/org.texi
index b8e4eed..79606dc 100644
--- a/doc/org.texi
+++ b/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
 
@@ -231,7 +232,7 @@ Dates and Times
 * Creating timestamps::         Commands which insert timestamps
 * Deadlines and scheduling::    Planning your work
 * Clocking work time::          Tracking how long you spend on a task
-* Resolving idle time::         Resolving time if you've been idle
+* Resolving idle time::         
 * Effort estimates::            Planning work effort in advance
 * Relative timer::              Notes with a running timer
 
@@ -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::        
 @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,75 @@ 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,
+which are called ``habits''.  A habit has the followed properties:
+
+@enumerate
+@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
+It may also have a deadline set, 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 intervals.  If you get this wrong,
+Org will alert you to what you've set incorrectly in your habit.
+@item
+You must also have state logging on the @code{DONE} enabled, in order for
+historical data to be represented in the consistency graph.
+@end enumerate
+
+To give you an idea of what the above rules look like, here is 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 least every 4 days, and at most
+every 2 days.  Imagine today is the 15th, for the purposes of this example.
+This means the habit will first appear 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.  But what's really useful about habits is they are
+displayed along with a conistency graph, which shows how consistent you've
+been at getting task done in the past.  The graph shows every day that the
+task was done over the past five 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 on 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.
+
 @node Priorities, Breaking down tasks, Progress logging, TODO Items
 @section Priorities
 @cindex priorities
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 6810f7e..23bb298 100755
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,16 @@
 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
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 730250b..71353df 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -4215,7 +4215,7 @@ the documentation of `org-diary'."
 	 (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
-	 ee txt head face s todo-state upcomingp donep timestr)
+	 ee txt head face s todo-state upcomingp donep timestr habitp)
     (goto-char (point-min))
     (while (re-search-forward regexp nil t)
       (catch :skip
@@ -4239,6 +4239,7 @@ the documentation of `org-diary'."
 	    (save-excursion
 	      (setq todo-state (org-get-todo-state))
 	      (setq donep (member todo-state org-done-keywords))
+	      (setq habitp (org-is-habit-p))
 	      (if (and donep
 		       (or org-agenda-skip-deadline-if-done
 			   (not (= diff 0))))
@@ -4267,8 +4268,14 @@ the documentation of `org-diary'."
 				    diff date)
 				 (format (nth 1 org-agenda-deadline-leaders)
 					 diff)))
-			     head category tags
-			     (if (not (= diff 0)) nil timestr)))))
+			     (if habitp
+				 (if (> (length head) 20)
+				     (substring head 0 20)
+				   (format "%-20s" head))
+			       head)
+			     category tags
+			     (if (not (= diff 0)) nil timestr)
+			     nil nil habitp))))
 	      (when txt
 		(setq face (org-agenda-deadline-face dfrac wdays))
 		(org-add-props txt props
@@ -4282,6 +4289,17 @@ the documentation of `org-diary'."
 		  'date (if upcomingp date d2)
 		  'face (if donep 'org-agenda-done face)
 		  'undone-face face 'done-face 'org-agenda-done)
+		;; If this TODO is a habit, append the consistency graph to
+		;; the todo line.
+		(when habitp
+		  (setq txt (concat txt "  "
+				    (org-habit-build-graph
+				     (org-habit-parse-todo)
+				     (time-subtract (current-time)
+						    (days-to-time (* 5 7)))
+				     (current-time)
+				     (time-add (current-time)
+					       (days-to-time 7))))))
 		(push txt ee))))))
     (nreverse ee)))
 
@@ -4311,11 +4329,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
@@ -4337,6 +4355,7 @@ FRACTION is what fraction of the head-warning time has passed."
 	    (save-excursion
 	      (setq todo-state (org-get-todo-state))
 	      (setq donep (member todo-state org-done-keywords))
+	      (setq habitp (org-is-habit-p))
 	      (if (and donep
 		       (or org-agenda-skip-scheduled-if-done
 			   (not (= diff 0))))
@@ -4365,8 +4384,14 @@ FRACTION is what fraction of the head-warning time has passed."
 				 (car org-agenda-scheduled-leaders)
 			       (format (nth 1 org-agenda-scheduled-leaders)
 				       (- 1 diff)))
-			     head category tags
-			     (if (not (= diff 0)) nil timestr)))))
+			     (if habitp
+				 (if (> (length head) 20)
+				     (substring head 0 20)
+				   (format "%-20s" head))
+			       head)
+			     category tags
+			     (if (not (= diff 0)) nil timestr)
+			     nil nil habitp))))
 	      (when txt
 		(setq face
 		      (cond
@@ -4383,6 +4408,17 @@ FRACTION is what fraction of the head-warning time has passed."
 		  'priority (+ 94 (- 5 diff) (org-get-priority txt))
 		  'org-category category
 		  'todo-state todo-state)
+		;; If this TODO is a habit, append the consistency graph to
+		;; the todo line.
+		(when habitp
+		  (setq txt (concat txt "  "
+				    (org-habit-build-graph
+				     (org-habit-parse-todo)
+				     (time-subtract (current-time)
+						    (days-to-time (* 5 7)))
+				     (current-time)
+				     (time-add (current-time)
+					       (days-to-time 7))))))
 		(push txt ee))))))
     (nreverse ee)))
 
@@ -4462,7 +4498,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 +4611,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)
diff --git a/lisp/org-habit.el b/lisp/org-habit.el
new file mode 100644
index 0000000..a3face5
--- /dev/null
+++ b/lisp/org-habit.el
@@ -0,0 +1,223 @@
+;;; 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)
+(eval-when-compile
+  (require 'cl)
+  (require 'calendar))
+
+(defgroup org-habit nil
+  "Options concerning habit tracking in Org-mode."
+  :tag "Org Habit"
+  :group 'org-progress)
+
+(defvar org-habit-clear-color "slateblue")
+(defvar org-habit-clear-future-color "powderblue")
+
+(defvar org-habit-ready-color "green")
+(defvar org-habit-ready-future-color "palegreen")
+
+(defvar org-habit-warning-color "yellow")
+(defvar org-habit-warning-future-color "palegoldenrod")
+
+(defvar org-habit-alert-color "yellow")
+(defvar org-habit-alert-future-color "palegoldenrod")
+
+(defvar org-habit-overdue-color "red")
+(defvar org-habit-overdue-future-color "mistyrose")
+
+(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 (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)
+  "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))
+      (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)))
+      (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."
+  (message "Build graph starting: %s" (format-time-string "%c" starting))
+  (message "Build graph current:  %s" (format-time-string "%c" current))
+  (message "Build graph ending:   %s" (format-time-string "%c" 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 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))
+	     (today-p (= now-days current-days))
+	     (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))))))
+	     markedp color)
+	(if today-p
+	    (aset graph index ?!)
+	  (when (and done-dates
+		     (= now-days (time-to-days (car done-dates))))
+	    (aset graph index ?*)
+	    (setq last-done-date (car done-dates)
+		  done-dates (cdr done-dates)
+		  markedp t)))
+	(setq color (if (or in-the-past-p
+			    today-p)
+			(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))
+
+(provide 'org-habit)
+
+;; arch-tag: 
+
+;;; org-habit.el ends here
-- 
1.6.5

