update packages
This commit is contained in:
496
lisp/org-contrib/org-choose.el
Normal file
496
lisp/org-contrib/org-choose.el
Normal file
@@ -0,0 +1,496 @@
|
||||
;;; org-choose.el --- decision management for org-mode
|
||||
|
||||
;; Copyright (C) 2009-2014, 2021 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 3, 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)))
|
||||
|
||||
(provide 'org-choose)
|
||||
|
||||
;;; org-choose.el ends here
|
||||
Reference in New Issue
Block a user