lisp/org-table.el: fix table alignment
[org-mode/org-tableheadings.git] / contrib / lisp / org-choose.el
blobc1006d095a1a5c58aac6937a50bf36bb2226c4a7
1 ;;; org-choose.el --- decision management for org-mode
3 ;; Copyright (C) 2009-2014 Tom Breton (Tehom)
5 ;; This file is not part of GNU Emacs.
7 ;; Author: Tom Breton (Tehom)
8 ;; Keywords: outlines, convenience
10 ;; This file is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
15 ;; This file is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
25 ;;; Commentary:
27 ;; This is code to support decision management. It lets you treat a
28 ;; group of sibling items in org-mode as alternatives in a decision.
30 ;; There are no user commands in this file. You use it by:
31 ;; * Loading it (manually or by M-x customize-apropos org-modules)
33 ;; * Setting up at least one set of TODO keywords with the
34 ;; interpretation "choose" by either:
36 ;; * Using the file directive #+CHOOSE_TODO:
38 ;; * For instance, "#+CHOOSE_TODO: NO(,-) MAYBE(,0) YES"
40 ;; * Or by M-x customize-apropos org-todo-keywords
42 ;; * Operating on single items with the TODO commands.
44 ;; * Use C-S-right to change the keyword set. Use this to change to
45 ;; the "choose" keyword set that you just defined.
47 ;; * Use S-right to advance the TODO mark to the next setting.
49 ;; For "choose", that means you like this alternative more than
50 ;; before. Other alternatives will be automatically demoted to
51 ;; keep your settings consistent.
53 ;; * Use S-left to demote TODO to the previous setting.
55 ;; For "choose", that means you don't like this alternative as much
56 ;; as before. Other alternatives will be automatically promoted,
57 ;; if this item was all that was keeping them down.
59 ;; * All the other TODO commands are available and behave essentially
60 ;; the normal way.
62 ;;; Requires
64 (require 'org)
65 ;(eval-when-compile
66 ; (require 'cl))
67 (require 'cl)
69 ;;; Body
70 ;;; The variables
72 (defstruct (org-choose-mark-data. (:type list))
73 "The format of an entry in org-choose-mark-data.
74 Indexes are 0-based or `nil'.
76 keyword
77 bot-lower-range
78 top-upper-range
79 range-length
80 static-default
81 all-keywords)
83 (defvar org-choose-mark-data
85 "Alist of information for choose marks.
87 Each entry is an `org-choose-mark-data.'" )
88 (make-variable-buffer-local 'org-choose-mark-data)
89 ;;;_ , For setup
90 ;;;_ . org-choose-filter-one
92 (defun org-choose-filter-one (i)
93 "Return a list of
94 * a canonized version of the string
95 * optionally one symbol"
97 (if
98 (not
99 (string-match "(.*)" i))
100 (list i i)
101 (let*
103 (end-text (match-beginning 0))
104 (vanilla-text (substring i 0 end-text))
105 ;;Get the parenthesized part.
106 (match (match-string 0 i))
107 ;;Remove the parentheses.
108 (args (substring match 1 -1))
109 ;;Split it
110 (arglist
111 (let
112 ((arglist-x (org-split-string args ",")))
113 ;;When string starts with "," `split-string' doesn't
114 ;;make a first arg, so in that case make one
115 ;;manually.
117 (string-match "^," args)
118 (cons nil arglist-x)
119 arglist-x)))
120 (decision-arg (second arglist))
121 (type
122 (cond
123 ((string= decision-arg "0")
124 'default-mark)
125 ((string= decision-arg "+")
126 'top-upper-range)
127 ((string= decision-arg "-")
128 'bot-lower-range)
129 (t nil)))
130 (vanilla-arg (first arglist))
131 (vanilla-mark
132 (if vanilla-arg
133 (concat vanilla-text "("vanilla-arg")")
134 vanilla-text)))
135 (if type
136 (list vanilla-text vanilla-mark type)
137 (list vanilla-text vanilla-mark)))))
139 ;;;_ . org-choose-setup-vars
140 (defun org-choose-setup-vars (bot-lower-range top-upper-range
141 static-default num-items all-mark-texts)
142 "Add to org-choose-mark-data according to arguments"
143 (let*
144 ((tail
145 ;;If there's no bot-lower-range or no default, we don't
146 ;;have ranges.
147 (cdr
148 (if (and static-default bot-lower-range)
149 (let*
150 ;;If there's no top-upper-range, use the last
151 ;;item.
152 ((top-upper-range
153 (or top-upper-range (1- num-items)))
154 (lower-range-length
155 (1+ (- static-default bot-lower-range)))
156 (upper-range-length
157 (- top-upper-range static-default))
158 (range-length
159 (min upper-range-length lower-range-length)))
160 (make-org-choose-mark-data.
161 :keyword nil
162 :bot-lower-range bot-lower-range
163 :top-upper-range top-upper-range
164 :range-length range-length
165 :static-default static-default
166 :all-keywords all-mark-texts))
167 (make-org-choose-mark-data.
168 :keyword nil
169 :bot-lower-range nil
170 :top-upper-range nil
171 :range-length nil
172 :static-default (or static-default 0)
173 :all-keywords all-mark-texts)))))
174 (dolist (text all-mark-texts)
175 (pushnew (cons text tail)
176 org-choose-mark-data
177 :test
178 #'(lambda (a b)
179 (equal (car a) (car b)))))))
181 ;;; org-choose-filter-tail
182 (defun org-choose-filter-tail (raw)
183 "Return a translation of RAW to vanilla and set appropriate
184 buffer-local variables.
186 RAW is a list of strings representing the input text of a choose
187 interpretation."
188 (let
189 ((vanilla-list nil)
190 (all-mark-texts nil)
191 (index 0)
192 bot-lower-range top-upper-range range-length static-default)
193 (dolist (i raw)
194 (destructuring-bind
195 (vanilla-text vanilla-mark &optional type)
196 (org-choose-filter-one i)
197 (cond
198 ((eq type 'bot-lower-range)
199 (setq bot-lower-range index))
200 ((eq type 'top-upper-range)
201 (setq top-upper-range index))
202 ((eq type 'default-mark)
203 (setq static-default index)))
204 (incf index)
205 (push vanilla-text all-mark-texts)
206 (push vanilla-mark vanilla-list)))
208 (org-choose-setup-vars bot-lower-range top-upper-range
209 static-default index (reverse all-mark-texts))
210 (nreverse vanilla-list)))
212 ;;; org-choose-setup-filter
214 (defun org-choose-setup-filter (raw)
215 "A setup filter for choose interpretations."
216 (when (eq (car raw) 'choose)
217 (cons
218 'choose
219 (org-choose-filter-tail (cdr raw)))))
221 ;;; org-choose-conform-after-promotion
222 (defun org-choose-conform-after-promotion (entry-pos keywords highest-ok-ix)
223 "Conform the current item after another item was promoted"
224 (unless
225 ;;Skip the entry that triggered this by skipping any entry with
226 ;;the same starting position. plist uses the start of the
227 ;;header line as the position, but map no longer does, so we
228 ;;have to go back to the heading.
230 (save-excursion
231 (org-back-to-heading)
232 (point))
233 entry-pos)
234 (let
235 ((ix
236 (org-choose-get-entry-index keywords)))
237 ;;If the index of the entry exceeds the highest allowable
238 ;;index, change it to that.
239 (when (and ix
240 (> ix highest-ok-ix))
241 (org-todo
242 (nth highest-ok-ix keywords))))))
243 ;;;_ . org-choose-conform-after-demotion
244 (defun org-choose-conform-after-demotion (entry-pos keywords
245 raise-to-ix
246 old-highest-ok-ix)
247 "Conform the current item after another item was demoted."
248 (unless
249 ;;Skip the entry that triggered this.
251 (save-excursion
252 (org-back-to-heading)
253 (point))
254 entry-pos)
255 (let
256 ((ix
257 (org-choose-get-entry-index keywords)))
258 ;;If the index of the entry was at or above the old allowable
259 ;;position, change it to the new mirror position if there is
260 ;;one.
261 (when (and
263 raise-to-ix
264 (>= ix old-highest-ok-ix))
265 (org-todo
266 (nth raise-to-ix keywords))))))
268 ;;; org-choose-keep-sensible (the org-trigger-hook function)
269 (defun org-choose-keep-sensible (change-plist)
270 "Bring the other items back into a sensible state after an item's
271 setting was changed."
272 (let*
273 ( (from (plist-get change-plist :from))
274 (to (plist-get change-plist :to))
275 (entry-pos
276 (set-marker
277 (make-marker)
278 (plist-get change-plist :position)))
279 (kwd-data
280 (assoc to org-todo-kwd-alist)))
281 (when
282 (eq (nth 1 kwd-data) 'choose)
283 (let*
285 (data
286 (assoc to org-choose-mark-data))
287 (keywords
288 (org-choose-mark-data.-all-keywords data))
289 (old-index
290 (org-choose-get-index-in-keywords
291 from
292 keywords))
293 (new-index
294 (org-choose-get-index-in-keywords
296 keywords))
297 (highest-ok-ix
298 (org-choose-highest-other-ok
299 new-index
300 data))
301 (funcdata
302 (cond
303 ;;The entry doesn't participate in conformance,
304 ;;so give `nil' which does nothing.
305 ((not highest-ok-ix) nil)
306 ;;The entry was created or promoted
307 ((or
308 (not old-index)
309 (> new-index old-index))
310 (list
311 #'org-choose-conform-after-promotion
312 entry-pos keywords
313 highest-ok-ix))
314 (t ;;Otherwise the entry was demoted.
315 (let
317 (raise-to-ix
318 (min
319 highest-ok-ix
320 (org-choose-mark-data.-static-default
321 data)))
322 (old-highest-ok-ix
323 (org-choose-highest-other-ok
324 old-index
325 data)))
326 (list
327 #'org-choose-conform-after-demotion
328 entry-pos
329 keywords
330 raise-to-ix
331 old-highest-ok-ix))))))
332 (if funcdata
333 ;;The funny-looking names are to make variable capture
334 ;;unlikely. (Poor-man's lexical bindings).
335 (destructuring-bind (func-d473 . args-46k) funcdata
336 (let
337 ((map-over-entries
338 (org-choose-get-fn-map-group))
339 ;;We may call `org-todo', so let various hooks
340 ;;`nil' so we don't cause loops.
341 org-after-todo-state-change-hook
342 org-trigger-hook
343 org-blocker-hook
344 org-todo-get-default-hook
345 ;;Also let this alist `nil' so we don't log
346 ;;secondary transitions.
347 org-todo-log-states)
348 ;;Map over group
349 (funcall map-over-entries
350 #'(lambda ()
351 (apply func-d473 args-46k))))))))
352 ;;Remove the marker
353 (set-marker entry-pos nil)))
355 ;;; Getting the default mark
356 ;;; org-choose-get-index-in-keywords
357 (defun org-choose-get-index-in-keywords (ix all-keywords)
358 "Return the index of the current entry."
359 (if ix
360 (position ix all-keywords
361 :test #'equal)))
363 ;;; org-choose-get-entry-index
364 (defun org-choose-get-entry-index (all-keywords)
365 "Return index of current entry."
366 (let*
367 ((state (org-entry-get (point) "TODO")))
368 (org-choose-get-index-in-keywords state all-keywords)))
370 ;;; org-choose-get-fn-map-group
372 (defun org-choose-get-fn-map-group ()
373 "Return a function to map over the group"
374 #'(lambda (fn)
375 (require 'org-agenda) ;; `org-map-entries' seems to need it.
376 (save-excursion
377 (unless (org-up-heading-safe)
378 (error "Choosing is only supported between siblings in a tree, not on top level"))
379 (let
380 ((level (org-reduced-level (org-outline-level))))
381 (save-restriction
382 (org-map-entries
384 (format "LEVEL=%d" level)
385 'tree))))))
387 ;;; org-choose-get-highest-mark-index
389 (defun org-choose-get-highest-mark-index (keywords)
390 "Get the index of the highest current mark in the group.
391 If there is none, return 0"
392 (let*
393 ;;Func maps over applicable entries.
394 ((map-over-entries
395 (org-choose-get-fn-map-group))
396 (indexes-list
397 (remove nil
398 (funcall map-over-entries
399 #'(lambda ()
400 (org-choose-get-entry-index keywords))))))
402 indexes-list
403 (apply #'max indexes-list)
404 0)))
406 ;;; org-choose-highest-ok
408 (defun org-choose-highest-other-ok (ix data)
409 "Return the highest index that any choose mark can sensibly have,
410 given that another mark has index IX.
411 DATA must be a `org-choose-mark-data.'."
412 (let
413 ((bot-lower-range
414 (org-choose-mark-data.-bot-lower-range data))
415 (top-upper-range
416 (org-choose-mark-data.-top-upper-range data))
417 (range-length
418 (org-choose-mark-data.-range-length data)))
419 (when (and ix bot-lower-range)
420 (let*
421 ((delta
422 (- top-upper-range ix)))
423 (unless
424 (< range-length delta)
425 (+ bot-lower-range delta))))))
427 ;;; org-choose-get-default-mark-index
429 (defun org-choose-get-default-mark-index (data)
430 "Return the index of the default mark in a choose interpretation.
432 DATA must be a `org-choose-mark-data.'."
434 (let
435 ((highest-mark-index
436 (org-choose-get-highest-mark-index
437 (org-choose-mark-data.-all-keywords data))))
438 (org-choose-highest-other-ok
439 highest-mark-index data))
440 (org-choose-mark-data.-static-default data)))
442 ;;; org-choose-get-mark-N
443 (defun org-choose-get-mark-N (n data)
444 "Get the text of the nth mark in a choose interpretation."
446 (let*
447 ((l (org-choose-mark-data.-all-keywords data)))
448 (nth n l)))
450 ;;; org-choose-get-default-mark
452 (defun org-choose-get-default-mark (new-mark old-mark)
453 "Get the default mark IFF in a choose interpretation.
454 NEW-MARK and OLD-MARK are the text of the new and old marks."
455 (let*
456 ((old-kwd-data
457 (assoc old-mark org-todo-kwd-alist))
458 (new-kwd-data
459 (assoc new-mark org-todo-kwd-alist))
460 (becomes-choose
461 (and
463 (not old-kwd-data)
464 (not
465 (eq (nth 1 old-kwd-data) 'choose)))
466 (eq (nth 1 new-kwd-data) 'choose))))
467 (when
468 becomes-choose
469 (let
470 ((new-mark-data
471 (assoc new-mark org-choose-mark-data)))
473 new-mark
474 (org-choose-get-mark-N
475 (org-choose-get-default-mark-index
476 new-mark-data)
477 new-mark-data)
478 (error "Somehow got an unrecognizable mark"))))))
480 ;;; Setting it all up
482 (eval-after-load "org"
483 '(progn
484 (add-to-list 'org-todo-setup-filter-hook
485 #'org-choose-setup-filter)
486 (add-to-list 'org-todo-get-default-hook
487 #'org-choose-get-default-mark)
488 (add-to-list 'org-trigger-hook
489 #'org-choose-keep-sensible)
490 (add-to-list 'org-todo-interpretation-widgets
491 '(:tag "Choose (to record decisions)" choose)
492 'append)))
494 (provide 'org-choose)
496 ;;; org-choose.el ends here