org-choose.el 14 KB

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