Added support for "habit tracking"

* Added support for "habit tracking"
@ 2009-10-19  8:26 John Wiegley
  2009-10-19  8:28 ` John Wiegley
                   ` (3 more replies)
  0 siblings, 4 replies; 33+ messages in thread
From: John Wiegley @ 2009-10-19  8:26 UTC (permalink / raw)
  To: Org-mode Mode

[-- Attachment #1: Type: text/plain, Size: 1393 bytes --]

There are really two kinds of TODOs on people's lists:

   1. Those whose importance is that they get done.
   2. Those whose importance is that they are done consistently.

I think most married people will know what I mean.  If you wash the  
dishes once after not having done it all month, you're not likely to  
win much applause.  But if you mow the lawn every month like  
clockwork, it's the regularity that does it.

Tracking habits isn't suited to a regular task manager, however.  You  
can see that the task needs to be done in your agenda, but you don't  
know if it's a task that sorely needs attention because you've been  
neglecting it, or if you've really been on the ball and don't _have_  
to do it today.

In the commercial world there is an app to address this kind of task  
called Sciral Consistency (http://sciral.com/consistency/).  I've been  
using it for about a year, and it's fantastic for making sure I keep  
up on my everyday duties, both at work and at home.

Well, I've implemented the functionality of Sciral for Org.  It works  
just as described on the Sciral webpage, complete with colorful graphs  
that appear to the right of the task name in the agenda buffer.  The  
graph even follows the same coloring algorithm as Sciral.

To test out this new feature, apply the attached patches and read the  
new manual section on "Tracking your habits".

John


[-- Attachment #2: 0001-Improvement-to-org-repeat-re.patch --]
[-- Type: application/octet-stream, Size: 1466 bytes --]

From 49cbd5355a8d76fe64cbad8785807f1166097096 Mon Sep 17 00:00:00 2001
From: John Wiegley <johnw@newartisans.com>
Date: Mon, 19 Oct 2009 03:58:45 -0400
Subject: [PATCH 1/5] Improvement to `org-repeat-re'

(org-repeat-re): Improved regexp to include .+ and ++ leaders for repeat
strings.
---
 lisp/ChangeLog |    5 +++++
 lisp/org.el    |    2 +-
 2 files changed, 6 insertions(+), 1 deletions(-)

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index c437305..efb6466 100755
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,10 @@
 2009-10-19  John Wiegley  <johnw@newartisans.com>
 
+	* org.el (org-repeat-re): Improved regexp to include .+ and ++
+	leaders for repeat strings.
+
+2009-10-19  John Wiegley  <johnw@newartisans.com>
+
 	* org-agenda.el (org-agenda-auto-exclude-function): New
 	customization variable for allowing the user to create an "auto
 	exclusion" filter for doing context-aware auto tag filtering.
diff --git a/lisp/org.el b/lisp/org.el
index 5b254d1..182234e 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -474,7 +474,7 @@ An entry can be toggled between QUOTE and normal with
   :type 'string)
 
 (defconst org-repeat-re
-  "<[0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9] [^>\n]*\\([.+]?\\+[0-9]+[dwmy]\\)"
+  "<[0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9] [^>\n]*\\([.+]+?\\+[0-9]+[dwmy]\\)"
   "Regular expression for specifying repeated events.
 After a match, group 1 contains the repeat expression.")
 
-- 
1.6.5


[-- Attachment #3: 0002-Added-tagline-parameter-to-org-get-repeat.patch --]
[-- Type: application/octet-stream, Size: 1790 bytes --]

From f604a7ecec7295cfbe4dd38519d38e16b51d9080 Mon Sep 17 00:00:00 2001
From: John Wiegley <johnw@newartisans.com>
Date: Mon, 19 Oct 2009 03:59:42 -0400
Subject: [PATCH 2/5] Added tagline parameter to `org-get-repeat'

(org-get-repeat): Now takes a string parameter `tagline', so the caller
can obtain the SCHEDULED repeat, or the DEADLINE repeat.
---
 lisp/ChangeLog |    2 ++
 lisp/org.el    |   10 ++++++----
 2 files changed, 8 insertions(+), 4 deletions(-)

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index efb6466..a5f8b7f 100755
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -2,6 +2,8 @@
 
 	* 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
+	caller can obtain the SCHEDULED repeat, or the DEADLINE repeat.
 
 2009-10-19  John Wiegley  <johnw@newartisans.com>
 
diff --git a/lisp/org.el b/lisp/org.el
index 182234e..2b202d8 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -10047,14 +10047,16 @@ Returns the new TODO keyword, or nil if no state change should occur."
 	     (throw 'exit t)))
       nil)))
 
-(defun org-get-repeat ()
+(defun org-get-repeat (&optional tagline)
   "Check if there is a deadline/schedule with repeater in this entry."
   (save-match-data
     (save-excursion
       (org-back-to-heading t)
-      (if (re-search-forward
-	   org-repeat-re (save-excursion (outline-next-heading) (point)) t)
-	  (match-string 1)))))
+      (and (re-search-forward (if tagline
+				  (concat tagline ":[^:]+" org-repeat-re)
+				org-repeat-re)
+			      (org-entry-end-position) t)
+	   (match-string-no-properties 1)))))
 
 (defvar org-last-changed-timestamp)
 (defvar org-last-inserted-timestamp)
-- 
1.6.5


[-- Attachment #4: 0003-Set-day-of-week-in-result-from-org-parse-time-string.patch --]
[-- Type: application/octet-stream, Size: 1716 bytes --]

From be58bd294b741a50474c276e8d719f731973257b Mon Sep 17 00:00:00 2001
From: John Wiegley <johnw@newartisans.com>
Date: Mon, 19 Oct 2009 04:00:35 -0400
Subject: [PATCH 3/5] Set day-of-week in result from `org-parse-time-string'

(org-parse-time-string): Set the day-of-week field after parsing a time,
since this information is always in the time string.
---
 lisp/ChangeLog |    2 ++
 lisp/org.el    |    9 ++++++++-
 2 files changed, 10 insertions(+), 1 deletions(-)

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index a5f8b7f..6810f7e 100755
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -4,6 +4,8 @@
 	leaders for repeat strings.
 	(org-get-repeat): Now takes a string parameter `tagline', so the
 	caller can obtain the SCHEDULED repeat, or the DEADLINE repeat.
+	(org-parse-time-string): Set the day-of-week field after parsing a
+	time, since this information is always in the time string.
 
 2009-10-19  John Wiegley  <johnw@newartisans.com>
 
diff --git a/lisp/org.el b/lisp/org.el
index 2b202d8..eb45eea 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -13457,7 +13457,14 @@ hour and minute fields will be nil if not given."
 	    (string-to-number (match-string 4 s))
 	    (string-to-number (match-string 3 s))
 	    (string-to-number (match-string 2 s))
-	    nil nil nil)
+	    (let ((dow (match-string 5 s)))
+	      (cond ((string= dow "Sun") 0)
+		    ((string= dow "Mon") 1)
+		    ((string= dow "Tue") 2)
+		    ((string= dow "Wed") 3)
+		    ((string= dow "Thu") 4)
+		    ((string= dow "Fri") 5)
+		    ((string= dow "Sat") 6))) nil nil)
     (error "Not a standard Org-mode time string: %s" s)))
 
 (defun org-timestamp-up (&optional arg)
-- 
1.6.5


[-- Attachment #5: 0004-Added-some-missing-text-to-the-manual.patch --]
[-- Type: application/octet-stream, Size: 890 bytes --]

From 3c0dfce39f4467b6fda19e1d3dfb9b675b214c37 Mon Sep 17 00:00:00 2001
From: John Wiegley <johnw@newartisans.com>
Date: Mon, 19 Oct 2009 04:04:07 -0400
Subject: [PATCH 4/5] Added some missing text to the manual

---
 doc/org.texi |    2 +-
 1 files changed, 1 insertions(+), 1 deletions(-)

diff --git a/doc/org.texi b/doc/org.texi
index 5ae6575..b8e4eed 100644
--- a/doc/org.texi
+++ b/doc/org.texi
@@ -231,7 +231,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 idle time::         Resolving time if you've been idle
 * Effort estimates::            Planning work effort in advance
 * Relative timer::              Notes with a running timer
 
-- 
1.6.5


[-- Attachment #6: 0005-Added-support-for-habit-consistency-tracking.patch --]
[-- Type: application/octet-stream, Size: 21254 bytes --]

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


[-- Attachment #7: Type: text/plain, Size: 204 bytes --]

_______________________________________________
Emacs-orgmode mailing list
Remember: use `Reply All' to send replies to the list.
Emacs-orgmode@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-orgmode

^ permalink raw reply related	[flat|nested] 33+ messages in thread