Add Tom Breton's org-choose.el as a contributed package

3 files changed, 569 insertions, 33 deletions

diff --git a/contrib/README b/contrib/README
index 27d0f2c..2715a1e 100644
--- a/contrib/README
+++ b/contrib/README
@@ -14,6 +14,7 @@ org-annotate-file.el     --- Annotate a file with org syntax
 org-annotation-helper.el --- Call remember directly from Firefox/Opera
 org-bookmark.el          --- Links to bookmarks
 org-browser-url.el       --- Store links to webpages directly from Firefox/Opera
+org-choose.el            --- Use TODO keywords to mark decision states
 org-depend.el            --- TODO dependencies for Org-mode
 org-elisp-symbol.el      --- Org links to emacs-lisp symbols
 org-eval.el              --- The <lisp> tag, adapted from Muse
diff --git a/contrib/lisp/org-choose.el b/contrib/lisp/org-choose.el
new file mode 100644
index 0000000..62af352
--- /dev/null
+++ b/contrib/lisp/org-choose.el
@@ -0,0 +1,487 @@
+;;;_ org-choose.el --- decision management for org-mode
+
+;;;_. Headers
+;;;_ , License
+;; Copyright (C) 2009  Tom Breton (Tehom)
+
+;; Author: Tom Breton (Tehom)
+;; Keywords: 
+
+;; This file 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 2, or (at your option)
+;; any later version.
+
+;; This file 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; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;;_ , Commentary:
+
+;; 
+
+
+;;;_ , Requires
+
+(require 'org)
+(eval-when-compile
+   (require 'cl))
+
+;;;_. Body
+;;;_ , The variables
+
+(defstruct (org-choose-mark-data. (:type list))
+   "The format of an entry in org-choose-mark-data.
+Indexes are 0-based or `nil'.
+"
+   keyword
+   bot-lower-range
+   top-upper-range
+   range-length
+   static-default
+   all-keywords)
+
+(defvar org-choose-mark-data 
+   ()
+   "Alist of information for choose marks.
+
+Each entry is an `org-choose-mark-data.'" )
+(make-variable-buffer-local 'org-choose-mark-data)
+;;;_ , For setup
+;;;_  . org-choose-filter-one
+
+(defun org-choose-filter-one (i)
+   "Return a list of
+ * a canonized version of the string
+ * optionally one symbol"
+
+   (if
+      (not
+	 (string-match "(.*)" i))
+      (list i i)
+      (let* 
+	 (
+	    (end-text (match-beginning 0))
+	    (vanilla-text (substring i 0 end-text))
+	    ;;Get the parenthesized part.
+	    (match (match-string 0 i))
+	    ;;Remove the parentheses.
+	    (args (substring match 1 -1))
+	    ;;Split it
+	    (arglist
+	       (let
+		  ((arglist-x (split-string args ",")))
+		  ;;When string starts with "," `split-string' doesn't
+		  ;;make a first arg, so in that case make one
+		  ;;manually.
+		  (if 
+		     (string-match "^," args)
+		     (cons nil arglist-x)
+		     arglist-x)))
+	    (decision-arg (second arglist))
+	    (type
+	       (cond
+		  ((string= decision-arg "0")
+		     'default-mark)
+		  ((string= decision-arg "+")
+		     'top-upper-range)
+		  ((string= decision-arg "-")
+		     'bot-lower-range)
+		  (t nil)))
+	    (vanilla-arg (first arglist))
+	    (vanilla-mark
+	       (if vanilla-arg
+		  (concat vanilla-text "("vanilla-arg")")
+		  vanilla-text)))
+	 (if type
+	    (list vanilla-text vanilla-mark type)
+	    (list vanilla-text vanilla-mark)))))
+
+;;;_  . org-choose-setup-vars
+(defun org-choose-setup-vars (bot-lower-range top-upper-range
+				   static-default num-items all-mark-texts)
+   "Add to org-choose-mark-data according to arguments"
+
+   (let*
+      (
+	 (tail
+	    ;;If there's no bot-lower-range or no default, we don't
+	    ;;have ranges.
+	    (cdr
+	       (if (and static-default bot-lower-range)
+		  (let*
+		     (
+			;;If there's no top-upper-range, use the last
+			;;item.
+			(top-upper-range
+			   (or top-upper-range (1- num-items)))
+			(lower-range-length 
+			   (1+ (- static-default bot-lower-range)))
+			(upper-range-length 
+			   (- top-upper-range static-default))
+			(range-length 
+			   (min upper-range-length lower-range-length)))
+
+
+		     (make-org-choose-mark-data.
+			:keyword nil
+			:bot-lower-range bot-lower-range
+			:top-upper-range top-upper-range
+			:range-length    range-length
+			:static-default static-default
+			:all-keywords all-mark-texts))
+
+		  (make-org-choose-mark-data.
+		     :keyword nil
+		     :bot-lower-range nil
+		     :top-upper-range nil
+		     :range-length    nil
+		     :static-default (or static-default 0)
+		     :all-keywords all-mark-texts)))))
+
+      (dolist (text all-mark-texts)
+	 (pushnew (cons text tail)
+	    org-choose-mark-data
+	    :test
+	    #'(lambda (a b)
+		 (equal (car a) (car b)))))))
+
+
+
+
+;;;_  . org-choose-filter-tail
+(defun org-choose-filter-tail (raw)
+   "Return a translation of RAW to vanilla and set appropriate
+buffer-local variables. 
+
+RAW is a list of strings representing the input text of a choose
+interpretation."
+   (let
+      ((vanilla-list nil)
+	 (all-mark-texts nil)
+	 (index 0)
+	 bot-lower-range top-upper-range range-length static-default)
+      (dolist (i raw)
+	 (destructuring-bind
+	    (vanilla-text vanilla-mark &optional type)
+	    (org-choose-filter-one i)
+	    (cond
+	       ((eq type 'bot-lower-range)
+		  (setq bot-lower-range index))
+	       ((eq type 'top-upper-range)
+		  (setq top-upper-range index))
+	       ((eq type 'default-mark)
+		  (setq static-default index)))
+	    (incf index)
+	    (push vanilla-text all-mark-texts)
+	    (push vanilla-mark vanilla-list)))
+
+      (org-choose-setup-vars bot-lower-range top-upper-range
+	 static-default index (reverse all-mark-texts)) 
+      (nreverse vanilla-list)))
+
+;;;_  . org-choose-setup-filter
+
+(defun org-choose-setup-filter (raw)
+   "A setup filter for choose interpretations."
+   (when (eq (car raw) 'choose)
+      (cons
+	 'choose
+	 (org-choose-filter-tail (cdr raw)))))
+
+;;;_  . org-choose-conform-after-promotion
+(defun org-choose-conform-after-promotion (entry-pos keywords highest-ok-ix)
+   ""
+   
+   (unless
+      ;;Skip the entry that triggered this by skipping any entry with
+      ;;the same starting position.  Both map and plist use the start
+      ;;of the header line as the position, so we can just compare
+      ;;them with `='
+      (= (point) entry-pos)
+      (let
+	 ((ix
+	     (org-choose-get-entry-index keywords)))
+	 ;;If the index of the entry exceeds the highest allowable
+	 ;;index, change it to that.
+	 (when (and ix 
+		  (> ix highest-ok-ix))
+	    (org-todo 
+	       (nth highest-ok-ix keywords))))))
+;;;_  . org-choose-conform-after-demotion
+(defun org-choose-conform-after-demotion (entry-pos keywords
+					       raise-to-ix
+					       old-highest-ok-ix) 
+   ""
+   (unless
+      ;;Skip the entry that triggered this.
+      (= (point) entry-pos)
+      (let
+	 ((ix
+	     (org-choose-get-entry-index keywords)))
+	 ;;If the index of the entry was at or above the old allowable
+	 ;;position, change it to the new mirror position if there is
+	 ;;one.
+	 (when (and 
+		  ix 
+		  raise-to-ix
+		  (>= ix old-highest-ok-ix))
+	    (org-todo 
+	       (nth raise-to-ix keywords))))))
+
+;;;_ , org-choose-keep-sensible (the trigger-hook function)
+(defun org-choose-keep-sensible (change-plist)
+   ""
+
+   (let*
+      (  (from (plist-get change-plist :from))
+	 (to (plist-get change-plist :to))
+	 (entry-pos 
+	    (set-marker
+	       (make-marker)
+	       (plist-get change-plist :position)))
+	 (kwd-data
+	    (assoc to org-todo-kwd-alist)))
+      (when
+	 (eq (nth 1 kwd-data) 'choose)
+	 (let*
+	    (
+	       (data
+		  (assoc to org-choose-mark-data))
+	       (keywords
+		  (org-choose-mark-data.-all-keywords data))
+	       (old-index
+		  (org-choose-get-index-in-keywords
+		     from 
+		     keywords))
+	       (new-index
+		  (org-choose-get-index-in-keywords
+		     to 
+		     keywords))
+	       (highest-ok-ix
+		  (org-choose-highest-other-ok
+		     new-index
+		     data))
+	       (funcdata
+		  (cond
+		     ;;The entry doesn't participate in conformance,
+		     ;;so give `nil' which does nothing.
+		     ((not highest-ok-ix) nil)
+		     ;;The entry was created or promoted
+		     ((or
+			 (not old-index)
+			 (> new-index old-index))
+			(list
+			   #'org-choose-conform-after-promotion
+			   entry-pos keywords 
+			   highest-ok-ix))
+		     (t	;;Otherwise the entry was demoted.
+			(let
+			   (
+			      (raise-to-ix
+				 (min
+				    highest-ok-ix
+				    (org-choose-mark-data.-static-default
+				       data)))
+			      (old-highest-ok-ix
+				 (org-choose-highest-other-ok
+				    old-index
+				    data)))
+			   
+			   (list
+			      #'org-choose-conform-after-demotion 
+			      entry-pos 
+			      keywords
+			      raise-to-ix
+			      old-highest-ok-ix))))))
+	    
+	    (if funcdata
+	       ;;The funny-looking names are to make variable capture
+	       ;;unlikely.  (Poor-man's lexical bindings).
+	       (destructuring-bind (func-d473 . args-46k) funcdata
+		  (let
+		     ((map-over-entries
+			 (org-choose-get-fn-map-group))
+			;;We may call `org-todo', so let various hooks
+			;;`nil' so we don't cause loops.
+			org-after-todo-state-change-hook
+			org-trigger-hook 
+			org-blocker-hook 
+			org-todo-get-default-hook
+			;;Also let this alist `nil' so we don't log
+			;;secondary transitions.
+			org-todo-log-states)
+		     ;;Map over group
+		     (funcall map-over-entries
+			#'(lambda ()
+			     (apply func-d473 args-46k))))))))
+      
+      ;;Remove the marker
+      (set-marker entry-pos nil)))
+
+
+
+;;;_ , Getting the default mark
+;;;_  . org-choose-get-index-in-keywords
+(defun org-choose-get-index-in-keywords (ix all-keywords)
+   "Return index of current entry."
+   (if ix
+      (position ix all-keywords
+	 :test #'equal)))
+
+;;;_  . org-choose-get-entry-index
+(defun org-choose-get-entry-index (all-keywords)
+   "Return index of current entry."
+
+   (let*
+      ((state (org-entry-get (point) "TODO")))
+      (org-choose-get-index-in-keywords state all-keywords)))
+
+;;;_  . org-choose-get-fn-map-group
+
+(defun org-choose-get-fn-map-group ()
+   "Return a function to map over the group"
+   
+   #'(lambda (fn)
+	(save-excursion
+	   (outline-up-heading-all 1)
+	   (save-restriction
+	      (org-map-entries fn nil 'tree)))))
+
+;;;_  . org-choose-get-highest-mark-index
+
+(defun org-choose-get-highest-mark-index (keywords)
+   "Get the index of the highest current mark in the group.
+If there is none, return 0"
+
+   (let*
+      (
+	 ;;Func maps over applicable entries.
+	 (map-over-entries
+	    (org-choose-get-fn-map-group))
+	 
+	 (indexes-list
+	    (remove nil
+	       (funcall map-over-entries 
+		  #'(lambda ()
+		       (org-choose-get-entry-index keywords))))))
+      (if
+	 indexes-list
+	 (apply #'max indexes-list)
+	 0)))
+
+
+;;;_  . org-choose-highest-ok
+
+(defun org-choose-highest-other-ok (ix data)
+   ""
+
+   (let
+      (		
+	 (bot-lower-range
+	    (org-choose-mark-data.-bot-lower-range data))
+	 (top-upper-range
+	    (org-choose-mark-data.-top-upper-range data))
+	 (range-length
+	    (org-choose-mark-data.-range-length data)))
+      (when (and ix bot-lower-range)
+	 (let*
+	    ((delta
+		(- top-upper-range ix)))
+	    (unless
+	       (< range-length delta)
+	       (+ bot-lower-range delta))))))
+
+;;;_  . org-choose-get-default-mark-index
+
+(defun org-choose-get-default-mark-index (data) 
+   "Get the index of the default mark in a choose interpretation.
+
+Args are in the same order as the fields of
+`org-choose-mark-data.' and have the same meaning."
+
+   (or
+      (let
+	 ((highest-mark-index
+	     (org-choose-get-highest-mark-index
+		(org-choose-mark-data.-all-keywords data))))
+	 (org-choose-highest-other-ok
+	    highest-mark-index data))
+      (org-choose-mark-data.-static-default data)))
+
+
+
+;;;_  . org-choose-get-mark-N
+(defun org-choose-get-mark-N (n data)
+   "Get the text of the nth mark in a choose interpretation."
+   
+   (let*
+      ((l (org-choose-mark-data.-all-keywords data)))
+      (nth n l)))
+
+;;;_  . org-choose-get-default-mark
+
+(defun org-choose-get-default-mark (new-mark old-mark)
+   "Get the default mark IFF in a choose interpretation.
+NEW-MARK and OLD-MARK are the text of the new and old marks."
+
+   (let*
+      (
+	 (old-kwd-data
+	    (assoc old-mark org-todo-kwd-alist))
+	 (new-kwd-data
+	    (assoc new-mark org-todo-kwd-alist))
+	 (becomes-choose
+	    (and
+	       (or
+		  (not old-kwd-data)
+		  (not
+		     (eq (nth 1 old-kwd-data) 'choose)))
+	       (eq (nth 1 new-kwd-data) 'choose))))
+      (when
+	 becomes-choose
+	 (let
+	    ((new-mark-data
+		(assoc new-mark org-choose-mark-data)))
+	    (if
+	       new-mark
+	       (org-choose-get-mark-N
+		  (org-choose-get-default-mark-index
+		     new-mark-data)
+		  new-mark-data)
+	       (error "Somehow got an unrecognizable mark"))))))
+
+;;;_ , Setting it all up
+
+(eval-after-load 'org
+  '(progn
+     (add-to-list 'org-todo-setup-filter-hook
+		  #'org-choose-setup-filter) 
+     (add-to-list 'org-todo-get-default-hook
+		  #'org-choose-get-default-mark) 
+     (add-to-list 'org-trigger-hook
+		  #'org-choose-keep-sensible)
+     (add-to-list 'org-todo-interpretation-widgets
+		  '(:tag "Choose   (to record decisions)" choose))
+; CD      (add-to-list 'org-todo-normal-interpretations 'choose))
+   ))
+
+
+
+;;;_. Footers
+;;;_ , Provides
+
+(provide 'org-choose)
+
+;;;_ * Local emacs vars.
+;;;_  + Local variables:
+;;;_  + End:
+
+;;;_ , End
+;;; org-choose.el ends here
diff --git a/lisp/org.el b/lisp/org.el
index 82db6fc..21aa09a 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -181,6 +181,7 @@ to add the symbol `xyz', and the package must have a call to
 	(const :tag "C  annotation-helper: Call Remember directly from Browser" org-annotation-helper)
 	(const :tag "C  bookmark:          Org links to bookmarks" org-bookmark)
 	(const :tag "C  browser-url:       Store link, directly from Browser" org-browser-url)
+	(const :tag "C  choose:            Use TODO keywords to mark decisions states" org-choose)
 	(const :tag "C  depend:            TODO dependencies for Org-mode" org-depend)
 	(const :tag "C  elisp-symbol:      Org links to emacs-lisp symbols" org-elisp-symbol)
 	(const :tag "C  eval:              Include command output as text" org-eval)
@@ -1483,6 +1484,14 @@ fast, while still showing the whole path to the entry."
   :tag "Org Progress"
   :group 'org-time)
 
+(defvar org-todo-interpretation-widgets
+  '(
+    (:tag "Sequence (cycling hits every state)" sequence)
+    (:tag "Type     (cycling directly to DONE)" type))
+  "The available interpretation symbols for customizing
+ `org-todo-keywords'.
+ Interested libraries should add to this list.")
+
 (defcustom org-todo-keywords '((sequence "TODO" "DONE"))
   "List of TODO entry keyword sequences and their interpretation.
 \\<org-mode-map>This is a list of sequences.
@@ -1532,8 +1541,18 @@ taken from the (otherwise obsolete) variable `org-todo-interpretation'."
 		  (cons
 		   (choice
 		    :tag "Interpretation"
-		    (const :tag "Sequence (cycling hits every state)" sequence)
-		    (const :tag "Type     (cycling directly to DONE)" type))
+		    ;;Quick and dirty way to see
+		    ;;`org-todo-interpretations'.  This takes the
+		    ;;place of item arguments
+		    :convert-widget
+		    (lambda (widget)
+		      (widget-put widget 
+				  :args (mapcar 
+					 #'(lambda (x)
+					     (widget-convert 
+					      (cons 'const x)))
+					 org-todo-interpretation-widgets))
+		      widget))
 		   (repeat
 		    (string :tag "Keyword"))))))
 
@@ -3174,7 +3193,7 @@ means to push this value onto the list in the variable.")
     (org-set-local 'org-file-properties nil)
     (org-set-local 'org-file-tags nil)
     (let ((re (org-make-options-regexp
-	       '("CATEGORY" "SEQ_TODO" "TYP_TODO" "TODO" "COLUMNS"
+	       '("CATEGORY" "SEQ_TODO" "TYP_TODO" "TODO" "CHOOSE_TODO" "COLUMNS"
 		 "STARTUP" "ARCHIVE" "FILETAGS" "TAGS" "LINK" "PRIORITIES"
 		 "CONSTANTS" "PROPERTY" "DRAWERS" "SETUPFILE")))
 	  (splitre "[ \t]+")
@@ -3201,6 +3220,8 @@ means to push this value onto the list in the variable.")
 	      (push (cons 'sequence (org-split-string value splitre)) kwds))
 	     ((equal key "TYP_TODO")
 	      (push (cons 'type (org-split-string value splitre)) kwds))
+ 	     ((equal key "CHOOSE_TODO")
+ 	      (push (cons 'choose (org-split-string value splitre)) kwds))
 	     ((equal key "TAGS")
 	      (setq tags (append tags (org-split-string value splitre))))
 	     ((equal key "COLUMNS")
@@ -3282,28 +3303,32 @@ means to push this value onto the list in the variable.")
       (setq kwds (nreverse kwds))
       (let (inter kws kw)
 	(while (setq kws (pop kwds))
-	  (setq inter (pop kws) sep (member "|" kws)
-		kws0 (delete "|" (copy-sequence kws))
-		kwsa nil
-		kws1 (mapcar
-		      (lambda (x)
-			;;                     1              2
-			(if (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?.*?)\\)?$" x)
-			    (progn
-			      (setq kw (match-string 1 x)
-				    key (and (match-end 2) (match-string 2 x))
-				    log (org-extract-log-state-settings x))
-			      (push (cons kw (and key (string-to-char key))) kwsa)
-			      (and log (push log org-todo-log-states))
-			      kw)
-			  (error "Invalid TODO keyword %s" x)))
-		      kws0)
-		kwsa (if kwsa (append '((:startgroup))
-				      (nreverse kwsa)
-				      '((:endgroup))))
-		hw (car kws1)
-		dws (if sep (org-remove-keyword-keys (cdr sep)) (last kws1))
-		tail (list inter hw (car dws) (org-last dws)))
+ 	  (let ((kws (or
+		      (run-hook-with-args-until-success
+ 		       'org-todo-setup-filter-hook kws) 
+		      kws)))
+	    (setq inter (pop kws) sep (member "|" kws)
+		  kws0 (delete "|" (copy-sequence kws))
+		  kwsa nil
+		  kws1 (mapcar
+			(lambda (x)
+			  ;;                     1              2
+			  (if (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?.*?)\\)?$" x)
+			      (progn
+				(setq kw (match-string 1 x)
+				      key (and (match-end 2) (match-string 2 x))
+				      log (org-extract-log-state-settings x))
+				(push (cons kw (and key (string-to-char key))) kwsa)
+				(and log (push log org-todo-log-states))
+				kw)
+			    (error "Invalid TODO keyword %s" x)))
+			kws0)
+		  kwsa (if kwsa (append '((:startgroup))
+					(nreverse kwsa)
+					'((:endgroup))))
+		  hw (car kws1)
+		  dws (if sep (org-remove-keyword-keys (cdr sep)) (last kws1))
+		  tail (list inter hw (car dws) (org-last dws))))
 	  (add-to-list 'org-todo-heads hw 'append)
 	  (push kws1 org-todo-sets)
 	  (setq org-done-keywords (append org-done-keywords dws nil))
@@ -5126,11 +5151,19 @@ state (TODO by default).  Also with prefix arg, force first state."
       (org-back-to-heading)
       (outline-previous-heading)
       (looking-at org-todo-line-regexp))
-    (if (or arg
-	    (not (match-beginning 2))
-	    (member (match-string 2) org-done-keywords))
-	(insert (car org-todo-keywords-1) " ")
-      (insert (match-string 2) " "))
+    (let*
+        ((new-mark-x
+	  (if (or arg
+		  (not (match-beginning 2))
+		  (member (match-string 2) org-done-keywords))
+ 	      (car org-todo-keywords-1)
+	    (match-string 2)))
+	 (new-mark
+	  (or
+	   (run-hook-with-args-until-success
+	    'org-todo-get-default-hook new-mark-x nil)
+	   new-mark-x)))
+      (insert new-mark " "))
     (when org-provide-todo-statistics
       (org-update-parent-todo-statistics))))
 
@@ -8357,6 +8390,18 @@ this is nil.")
 	      (push (nth 2 e) rtn)))
 	  rtn)))))
 
+(defvar org-todo-setup-filter-hook nil 
+  "Hook for functions that pre-filter todo specs.
+
+Each function takes a todo spec and returns either `nil' or the spec
+transformed into canonical form." )
+ 
+(defvar org-todo-get-default-hook nil
+  "Hook for functions that get a default item for todo.
+ 
+Each function takes arguments (NEW-MARK OLD-MARK) and returns either
+`nil' or a string to be used for the todo mark." )
+
 (defvar org-agenda-headline-snapshot-before-repeat)
 (defun org-todo (&optional arg)
   "Change the TODO state of an item.
@@ -8462,15 +8507,18 @@ For calling through lisp, arg is also interpreted in the following way:
 		       ((null member) (or head (car org-todo-keywords-1)))
 		       ((equal this final-done-word) nil) ;; -> make empty
 		       ((null tail) nil) ;; -> first entry
-		       ((eq interpret 'sequence)
-			(car tail))
 		       ((memq interpret '(type priority))
 			(if (eq this-command last-command)
 			    (car tail)
 			  (if (> (length tail) 0)
 			      (or done-word (car org-done-keywords))
 			    nil)))
-		       (t nil)))
+		       (t
+			(car tail))))
+	       (state (or 
+ 		       (run-hook-with-args-until-success
+			'org-todo-get-default-hook state last-state) 
+ 		       state))
 	       (next (if state (concat " " state " ") " "))
 	       (change-plist (list :type 'todo-state-change :from this :to state
 				   :position startpos))