lisp/org-habit.el

   1 ;;; org-habit.el --- The habit tracking code for Org-mode
   2
   3 ;; Copyright (C) 2009
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: John Wiegley <johnw at gnu dot org>
   7 ;; Keywords: outlines, hypermedia, calendar, wp
   8 ;; Homepage: http://orgmode.org
   9 ;; Version: 6.31trans
  10 ;;
  11 ;; This file is part of GNU Emacs.
  12 ;;
  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.
  17
  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.
  22
  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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 ;;
  27 ;;; Commentary:
  28
  29 ;; This file contains the habit tracking code for Org-mode
  30
  31 (require 'org)
  32 (require 'org-agenda)
  33 (eval-when-compile
  34   (require 'cl)
  35   (require 'calendar))
  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 time."
  67   :group 'org-habit
  68   :type 'boolean)
  69
  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."
  74   :group 'org-habit
  75   :group 'org-faces)
  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."
  80   :group 'org-habit
  81   :group 'org-faces)
  82
  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."
  87   :group 'org-habit
  88   :group 'org-faces)
  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."
  93   :group 'org-habit
  94   :group 'org-faces)
  95
  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."
 100   :group 'org-habit
 101   :group 'org-faces)
 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."
 106   :group 'org-habit
 107   :group 'org-faces)
 108
 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."
 113   :group 'org-habit
 114   :group 'org-faces)
 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."
 119   :group 'org-habit
 120   :group 'org-faces)
 121
 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."
 126   :group 'org-habit
 127   :group 'org-faces)
 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."
 132   :group 'org-habit
 133   :group 'org-faces)
 134
 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)))
 143
 144 (defun org-is-habit-p (&optional pom)
 145   (string= "habit" (org-entry-get (or pom (point)) "STYLE")))
 146
 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:
 150
 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
 156
 157 This list represents a \"habit\" for the rest of this module."
 158   (save-excursion
 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)
 166       (unless scheduled
 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))
 180               closed-dates))
 181       (list scheduled sr-days deadline dr-days closed-dates))))
 182
 183 (defsubst org-habit-scheduled (habit)
 184   (nth 0 habit))
 185 (defsubst org-habit-scheduled-repeat (habit)
 186   (nth 1 habit))
 187 (defsubst org-habit-deadline (habit)
 188   (nth 2 habit))
 189 (defsubst org-habit-deadline-repeat (habit)
 190   (nth 3 habit))
 191 (defsubst org-habit-done-dates (habit)
 192   (nth 4 habit))
 193
 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.
 198
 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))))
 218     (cond
 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))
 223      ((and deadline
 224            (time-less-p moment deadline))
 225       (if donep
 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)
 229          (if deadline
 230              (time-to-days deadline)
 231            (time-to-days scheduled-end)))
 232       (if donep
 233           '(org-habit-ready-face . org-habit-ready-future-face)
 234         '(org-habit-alert-face . org-habit-alert-future-face)))
 235      (t
 236       '(org-habit-overdue-face . org-habit-overdue-future-face)))))
 237
 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))
 242         (day starting)
 243         (current-days (time-to-days current))
 244         last-done-date
 245         (graph (make-string (1+ (- (time-to-days ending)
 246                                    (time-to-days starting))) ?\ ))
 247         (index 0))
 248     (if done-dates
 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)
 260                       (org-habit-get-faces
 261                        habit day (and in-the-past-p
 262                                       (time-add last-done-date
 263                                                 (days-to-time s-repeat)))
 264                        donep)))
 265              markedp face)
 266         (if donep
 267             (progn
 268               (aset graph index ?*)
 269               (setq last-done-date (car done-dates)
 270                     done-dates (cdr done-dates)
 271                     markedp t))
 272           (if todayp
 273               (aset graph index ?!)))
 274         (setq face (if (or in-the-past-p
 275                             todayp)
 276                         (car faces)
 277                       (cdr faces)))
 278         (if (and in-the-past-p
 279                  (not (eq face 'org-habit-overdue-face))
 280                  (not markedp))
 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))
 284             index (1+ index)))
 285     graph))
 286
 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))))
 292     (save-excursion
 293       (goto-char (if line (point-at-bol) (point-min)))
 294       (while (not (eobp))
 295         (let ((habit (get-text-property (point) 'org-habit-p)))
 296           (when habit
 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
 302                      habit
 303                      (time-subtract moment
 304                                     (days-to-time org-habit-preceding-days))
 305                      moment
 306                      (time-add moment
 307                                (days-to-time org-habit-following-days))))))
 308         (forward-line)))))
 309
 310 (defun org-habit-toggle-habits ()
 311   "Toggle display of habits in an agenda buffer."
 312   (interactive)
 313   (org-agenda-check-type t 'agenda)
 314   (setq org-habit-show-habits (not org-habit-show-habits))
 315   (org-agenda-redo)
 316   (org-agenda-set-mode-name)
 317   (message "Habits turned %s"
 318            (if org-habit-show-habits "on" "off")))
 319
 320 (org-defkey org-agenda-mode-map "K" 'org-habit-toggle-habits)
 321
 322 (provide 'org-habit)
 323
 324 ;; arch-tag:
 325
 326 ;;; org-habit.el ends here