543 lines
14 KiB
EmacsLisp
543 lines
14 KiB
EmacsLisp
;;;_ 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
|