summaryrefslogtreecommitdiff
path: root/contrib/lisp/org-choose.el
diff options
context:
space:
mode:
authorS├ębastien Delafond <sdelafond@gmail.com>2014-07-13 13:35:01 +0200
committerS├ębastien Delafond <sdelafond@gmail.com>2014-07-13 13:35:01 +0200
commit7697fa4daf3ec84f85711a84035d8f0224afd4e3 (patch)
tree24d0f1d2a9751ca8c063409fd2ab71478b296efb /contrib/lisp/org-choose.el
Imported Upstream version 7.9.2
Diffstat (limited to 'contrib/lisp/org-choose.el')
-rw-r--r--contrib/lisp/org-choose.el542
1 files changed, 542 insertions, 0 deletions
diff --git a/contrib/lisp/org-choose.el b/contrib/lisp/org-choose.el
new file mode 100644
index 0000000..3513fe9
--- /dev/null
+++ b/contrib/lisp/org-choose.el
@@ -0,0 +1,542 @@
+;;;_ org-choose.el --- decision management for org-mode
+
+;;;_. Headers
+;;;_ , License
+;; Copyright (C) 2009-2012 Tom Breton (Tehom)
+
+;; This file is not part of GNU Emacs.
+
+;; Author: Tom Breton (Tehom)
+;; Keywords: outlines, convenience
+
+;; 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:
+
+; This is code to support decision management. It lets you treat a
+; group of sibling items in org-mode as alternatives in a decision.
+
+; There are no user commands in this file. You use it by:
+; * Loading it (manually or by M-x customize-apropos org-modules)
+
+;; * Setting up at least one set of TODO keywords with the
+;; interpretation "choose" by either:
+
+;; * Using the file directive #+CHOOSE_TODO:
+
+;; * For instance, "#+CHOOSE_TODO: NO(,-) MAYBE(,0) YES"
+
+;; * Or by M-x customize-apropos org-todo-keywords
+
+;; * Operating on single items with the TODO commands.
+
+;; * Use C-S-right to change the keyword set. Use this to change to
+;; the "choose" keyword set that you just defined.
+
+;; * Use S-right to advance the TODO mark to the next setting.
+
+;; For "choose", that means you like this alternative more than
+;; before. Other alternatives will be automatically demoted to
+;; keep your settings consistent.
+
+;; * Use S-left to demote TODO to the previous setting.
+
+;; For "choose", that means you don't like this alternative as much
+;; as before. Other alternatives will be automatically promoted,
+;; if this item was all that was keeping them down.
+
+;; * All the other TODO commands are available and behave essentially
+;; the normal way.
+
+
+;;;_ , Requires
+
+(require 'org)
+;(eval-when-compile
+; (require 'cl))
+(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 (org-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)
+ "Conform the current item after another item was promoted"
+
+ (unless
+ ;;Skip the entry that triggered this by skipping any entry with
+ ;;the same starting position. plist uses the start of the
+ ;;header line as the position, but map no longer does, so we
+ ;;have to go back to the heading.
+ (=
+ (save-excursion
+ (org-back-to-heading)
+ (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)
+ "Conform the current item after another item was demoted."
+
+ (unless
+ ;;Skip the entry that triggered this.
+ (=
+ (save-excursion
+ (org-back-to-heading)
+ (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 org-trigger-hook function)
+(defun org-choose-keep-sensible (change-plist)
+ "Bring the other items back into a sensible state after an item's
+setting was changed."
+ (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 the index of the 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)
+ (require 'org-agenda) ;; `org-map-entries' seems to need it.
+ (save-excursion
+ (unless (org-up-heading-safe)
+ (error "Choosing is only supported between siblings in a tree, not on top level"))
+ (let
+ ((level (org-reduced-level (org-outline-level))))
+ (save-restriction
+ (org-map-entries
+ fn
+ (format "LEVEL=%d" level)
+ '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)
+ "Return the highest index that any choose mark can sensibly have,
+given that another mark has index IX.
+DATA must be a `org-choose-mark-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)
+ "Return the index of the default mark in a choose interpretation.
+
+DATA must be a `org-choose-mark-data.'."
+
+
+ (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)
+ 'append)
+ ))
+
+
+;;;_. Footers
+;;;_ , Provides
+
+(provide 'org-choose)
+
+;;;_ * Local emacs vars.
+;;;_ + Local variables:
+;;;_ + End:
+
+;;;_ , End
+
+;;; org-choose.el ends here