;;;_ org-choose.el --- decision management for org-mode
;;;_. Headers
;;;_ , License
;; Copyright (C) 2009 Tom Breton (Tehom)
;; 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