contrib/lisp/org-choose.el

   1 ;;;_ org-choose.el --- decision management for org-mode
   2
   3 ;;;_. Headers
   4 ;;;_ , License
   5 ;; Copyright (C) 2009  Tom Breton (Tehom)
   6
   7 ;; Author: Tom Breton (Tehom)
   8 ;; Keywords: outlines, convenience
   9
  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.
  14
  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.
  19
  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.
  24
  25 ;;;_ , Commentary:
  26
  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.
  29
  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)
  32
  33 ;;   * Setting up at least one set of TODO keywords with the
  34 ;;     interpretation "choose" by either:
  35
  36 ;;     * Using the file directive #+CHOOSE_TODO:
  37
  38 ;;       * For instance, "#+CHOOSE_TODO: NO(,-) MAYBE(,0) YES"
  39
  40 ;;     * Or by M-x customize-apropos org-todo-keywords
  41
  42 ;;   * Operating on single items with the TODO commands.
  43
  44 ;;     * Use C-S-right to change the keyword set.  Use this to change to
  45 ;;       the "choose" keyword set that you just defined.
  46
  47 ;;     * Use S-right to advance the TODO mark to the next setting.
  48
  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.
  52
  53 ;;     * Use S-left to demote TODO to the previous setting.
  54
  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.
  58
  59 ;;     * All the other TODO commands are available and behave essentially
  60 ;;       the normal way.
  61
  62
  63 ;;;_ , Requires
  64
  65 (require 'org)
  66 ;(eval-when-compile
  67 ;   (require 'cl))
  68 (require 'cl)
  69
  70 ;;;_. Body
  71 ;;;_ , The variables
  72
  73 (defstruct (org-choose-mark-data. (:type list))
  74    "The format of an entry in org-choose-mark-data.
  75 Indexes are 0-based or `nil'.
  76 "
  77    keyword
  78    bot-lower-range
  79    top-upper-range
  80    range-length
  81    static-default
  82    all-keywords)
  83
  84 (defvar org-choose-mark-data
  85    ()
  86    "Alist of information for choose marks.
  87
  88 Each entry is an `org-choose-mark-data.'" )
  89 (make-variable-buffer-local 'org-choose-mark-data)
  90 ;;;_ , For setup
  91 ;;;_  . org-choose-filter-one
  92
  93 (defun org-choose-filter-one (i)
  94    "Return a list of
  95  * a canonized version of the string
  96  * optionally one symbol"
  97
  98    (if
  99       (not
 100          (string-match "(.*)" i))
 101       (list i i)
 102       (let*
 103          (
 104             (end-text (match-beginning 0))
 105             (vanilla-text (substring i 0 end-text))
 106             ;;Get the parenthesized part.
 107             (match (match-string 0 i))
 108             ;;Remove the parentheses.
 109             (args (substring match 1 -1))
 110             ;;Split it
 111             (arglist
 112                (let
 113                   ((arglist-x (org-split-string args ",")))
 114                   ;;When string starts with "," `split-string' doesn't
 115                   ;;make a first arg, so in that case make one
 116                   ;;manually.
 117                   (if
 118                      (string-match "^," args)
 119                      (cons nil arglist-x)
 120                      arglist-x)))
 121             (decision-arg (second arglist))
 122             (type
 123                (cond
 124                   ((string= decision-arg "0")
 125                      'default-mark)
 126                   ((string= decision-arg "+")
 127                      'top-upper-range)
 128                   ((string= decision-arg "-")
 129                      'bot-lower-range)
 130                   (t nil)))
 131             (vanilla-arg (first arglist))
 132             (vanilla-mark
 133                (if vanilla-arg
 134                   (concat vanilla-text "("vanilla-arg")")
 135                   vanilla-text)))
 136          (if type
 137             (list vanilla-text vanilla-mark type)
 138             (list vanilla-text vanilla-mark)))))
 139
 140 ;;;_  . org-choose-setup-vars
 141 (defun org-choose-setup-vars (bot-lower-range top-upper-range
 142                                    static-default num-items all-mark-texts)
 143    "Add to org-choose-mark-data according to arguments"
 144
 145    (let*
 146       (
 147          (tail
 148             ;;If there's no bot-lower-range or no default, we don't
 149             ;;have ranges.
 150             (cdr
 151                (if (and static-default bot-lower-range)
 152                   (let*
 153                      (
 154                         ;;If there's no top-upper-range, use the last
 155                         ;;item.
 156                         (top-upper-range
 157                            (or top-upper-range (1- num-items)))
 158                         (lower-range-length
 159                            (1+ (- static-default bot-lower-range)))
 160                         (upper-range-length
 161                            (- top-upper-range static-default))
 162                         (range-length
 163                            (min upper-range-length lower-range-length)))
 164
 165
 166                      (make-org-choose-mark-data.
 167                         :keyword nil
 168                         :bot-lower-range bot-lower-range
 169                         :top-upper-range top-upper-range
 170                         :range-length    range-length
 171                         :static-default static-default
 172                         :all-keywords all-mark-texts))
 173
 174                   (make-org-choose-mark-data.
 175                      :keyword nil
 176                      :bot-lower-range nil
 177                      :top-upper-range nil
 178                      :range-length    nil
 179                      :static-default (or static-default 0)
 180                      :all-keywords all-mark-texts)))))
 181
 182       (dolist (text all-mark-texts)
 183          (pushnew (cons text tail)
 184             org-choose-mark-data
 185             :test
 186             #'(lambda (a b)
 187                  (equal (car a) (car b)))))))
 188
 189
 190
 191
 192 ;;;_  . org-choose-filter-tail
 193 (defun org-choose-filter-tail (raw)
 194    "Return a translation of RAW to vanilla and set appropriate
 195 buffer-local variables.
 196
 197 RAW is a list of strings representing the input text of a choose
 198 interpretation."
 199    (let
 200       ((vanilla-list nil)
 201          (all-mark-texts nil)
 202          (index 0)
 203          bot-lower-range top-upper-range range-length static-default)
 204       (dolist (i raw)
 205          (destructuring-bind
 206             (vanilla-text vanilla-mark &optional type)
 207             (org-choose-filter-one i)
 208             (cond
 209                ((eq type 'bot-lower-range)
 210                   (setq bot-lower-range index))
 211                ((eq type 'top-upper-range)
 212                   (setq top-upper-range index))
 213                ((eq type 'default-mark)
 214                   (setq static-default index)))
 215             (incf index)
 216             (push vanilla-text all-mark-texts)
 217             (push vanilla-mark vanilla-list)))
 218
 219       (org-choose-setup-vars bot-lower-range top-upper-range
 220          static-default index (reverse all-mark-texts))
 221       (nreverse vanilla-list)))
 222
 223 ;;;_  . org-choose-setup-filter
 224
 225 (defun org-choose-setup-filter (raw)
 226    "A setup filter for choose interpretations."
 227    (when (eq (car raw) 'choose)
 228       (cons
 229          'choose
 230          (org-choose-filter-tail (cdr raw)))))
 231
 232 ;;;_  . org-choose-conform-after-promotion
 233 (defun org-choose-conform-after-promotion (entry-pos keywords highest-ok-ix)
 234   "Conform the current item after another item was promoted"
 235
 236    (unless
 237       ;;Skip the entry that triggered this by skipping any entry with
 238       ;;the same starting position.  plist uses the start of the
 239       ;;header line as the position, but map no longer does, so we
 240       ;;have to go back to the heading.
 241       (=
 242          (save-excursion
 243             (org-back-to-heading)
 244             (point))
 245          entry-pos)
 246       (let
 247          ((ix
 248              (org-choose-get-entry-index keywords)))
 249          ;;If the index of the entry exceeds the highest allowable
 250          ;;index, change it to that.
 251          (when (and ix
 252                   (> ix highest-ok-ix))
 253             (org-todo
 254                (nth highest-ok-ix keywords))))))
 255 ;;;_  . org-choose-conform-after-demotion
 256 (defun org-choose-conform-after-demotion (entry-pos keywords
 257                                                raise-to-ix
 258                                                old-highest-ok-ix)
 259   "Conform the current item after another item was demoted."
 260
 261    (unless
 262       ;;Skip the entry that triggered this.
 263       (=
 264          (save-excursion
 265             (org-back-to-heading)
 266             (point))
 267          entry-pos)
 268       (let
 269          ((ix
 270              (org-choose-get-entry-index keywords)))
 271          ;;If the index of the entry was at or above the old allowable
 272          ;;position, change it to the new mirror position if there is
 273          ;;one.
 274          (when (and
 275                   ix
 276                   raise-to-ix
 277                   (>= ix old-highest-ok-ix))
 278             (org-todo
 279                (nth raise-to-ix keywords))))))
 280
 281 ;;;_ , org-choose-keep-sensible (the org-trigger-hook function)
 282 (defun org-choose-keep-sensible (change-plist)
 283   "Bring the other items back into a sensible state after an item's
 284 setting was changed."
 285    (let*
 286       (  (from (plist-get change-plist :from))
 287          (to (plist-get change-plist :to))
 288          (entry-pos
 289             (set-marker
 290                (make-marker)
 291                (plist-get change-plist :position)))
 292          (kwd-data
 293             (assoc to org-todo-kwd-alist)))
 294       (when
 295          (eq (nth 1 kwd-data) 'choose)
 296          (let*
 297             (
 298                (data
 299                   (assoc to org-choose-mark-data))
 300                (keywords
 301                   (org-choose-mark-data.-all-keywords data))
 302                (old-index
 303                   (org-choose-get-index-in-keywords
 304                      from
 305                      keywords))
 306                (new-index
 307                   (org-choose-get-index-in-keywords
 308                      to
 309                      keywords))
 310                (highest-ok-ix
 311                   (org-choose-highest-other-ok
 312                      new-index
 313                      data))
 314                (funcdata
 315                   (cond
 316                      ;;The entry doesn't participate in conformance,
 317                      ;;so give `nil' which does nothing.
 318                      ((not highest-ok-ix) nil)
 319                      ;;The entry was created or promoted
 320                      ((or
 321                          (not old-index)
 322                          (> new-index old-index))
 323                         (list
 324                            #'org-choose-conform-after-promotion
 325                            entry-pos keywords
 326                            highest-ok-ix))
 327                      (t ;;Otherwise the entry was demoted.
 328                         (let
 329                            (
 330                               (raise-to-ix
 331                                  (min
 332                                     highest-ok-ix
 333                                     (org-choose-mark-data.-static-default
 334                                        data)))
 335                               (old-highest-ok-ix
 336                                  (org-choose-highest-other-ok
 337                                     old-index
 338                                     data)))
 339
 340                            (list
 341                               #'org-choose-conform-after-demotion
 342                               entry-pos
 343                               keywords
 344                               raise-to-ix
 345                               old-highest-ok-ix))))))
 346
 347             (if funcdata
 348                ;;The funny-looking names are to make variable capture
 349                ;;unlikely.  (Poor-man's lexical bindings).
 350                (destructuring-bind (func-d473 . args-46k) funcdata
 351                   (let
 352                      ((map-over-entries
 353                          (org-choose-get-fn-map-group))
 354                         ;;We may call `org-todo', so let various hooks
 355                         ;;`nil' so we don't cause loops.
 356                         org-after-todo-state-change-hook
 357                         org-trigger-hook
 358                         org-blocker-hook
 359                         org-todo-get-default-hook
 360                         ;;Also let this alist `nil' so we don't log
 361                         ;;secondary transitions.
 362                         org-todo-log-states)
 363                      ;;Map over group
 364                      (funcall map-over-entries
 365                         #'(lambda ()
 366                              (apply func-d473 args-46k))))))))
 367
 368       ;;Remove the marker
 369       (set-marker entry-pos nil)))
 370
 371
 372
 373 ;;;_ , Getting the default mark
 374 ;;;_  . org-choose-get-index-in-keywords
 375 (defun org-choose-get-index-in-keywords (ix all-keywords)
 376   "Return the index of the current entry."
 377
 378    (if ix
 379       (position ix all-keywords
 380          :test #'equal)))
 381
 382 ;;;_  . org-choose-get-entry-index
 383 (defun org-choose-get-entry-index (all-keywords)
 384    "Return index of current entry."
 385
 386    (let*
 387       ((state (org-entry-get (point) "TODO")))
 388       (org-choose-get-index-in-keywords state all-keywords)))
 389
 390 ;;;_  . org-choose-get-fn-map-group
 391
 392 (defun org-choose-get-fn-map-group ()
 393    "Return a function to map over the group"
 394
 395    #'(lambda (fn)
 396        (require 'org-agenda) ;; `org-map-entries' seems to need it.
 397         (save-excursion
 398           (unless (org-up-heading-safe)
 399             (error "Choosing is only supported between siblings in a tree, not on top level"))
 400           (let
 401               ((level (org-reduced-level (org-outline-level))))
 402             (save-restriction
 403               (org-map-entries
 404                fn
 405                (format "LEVEL=%d" level)
 406                'tree))))))
 407
 408 ;;;_  . org-choose-get-highest-mark-index
 409
 410 (defun org-choose-get-highest-mark-index (keywords)
 411    "Get the index of the highest current mark in the group.
 412 If there is none, return 0"
 413
 414    (let*
 415       (
 416          ;;Func maps over applicable entries.
 417          (map-over-entries
 418             (org-choose-get-fn-map-group))
 419
 420          (indexes-list
 421             (remove nil
 422                (funcall map-over-entries
 423                   #'(lambda ()
 424                        (org-choose-get-entry-index keywords))))))
 425       (if
 426          indexes-list
 427          (apply #'max indexes-list)
 428          0)))
 429
 430
 431 ;;;_  . org-choose-highest-ok
 432
 433 (defun org-choose-highest-other-ok (ix data)
 434   "Return the highest index that any choose mark can sensibly have,
 435 given that another mark has index IX.
 436 DATA must be a `org-choose-mark-data.'."
 437
 438    (let
 439       (
 440          (bot-lower-range
 441             (org-choose-mark-data.-bot-lower-range data))
 442          (top-upper-range
 443             (org-choose-mark-data.-top-upper-range data))
 444          (range-length
 445             (org-choose-mark-data.-range-length data)))
 446       (when (and ix bot-lower-range)
 447          (let*
 448             ((delta
 449                 (- top-upper-range ix)))
 450             (unless
 451                (< range-length delta)
 452                (+ bot-lower-range delta))))))
 453
 454 ;;;_  . org-choose-get-default-mark-index
 455
 456 (defun org-choose-get-default-mark-index (data)
 457   "Return the index of the default mark in a choose interpretation.
 458
 459 DATA must be a `org-choose-mark-data.'."
 460
 461
 462    (or
 463       (let
 464          ((highest-mark-index
 465              (org-choose-get-highest-mark-index
 466                 (org-choose-mark-data.-all-keywords data))))
 467          (org-choose-highest-other-ok
 468             highest-mark-index data))
 469       (org-choose-mark-data.-static-default data)))
 470
 471
 472
 473 ;;;_  . org-choose-get-mark-N
 474 (defun org-choose-get-mark-N (n data)
 475    "Get the text of the nth mark in a choose interpretation."
 476
 477    (let*
 478       ((l (org-choose-mark-data.-all-keywords data)))
 479       (nth n l)))
 480
 481 ;;;_  . org-choose-get-default-mark
 482
 483 (defun org-choose-get-default-mark (new-mark old-mark)
 484    "Get the default mark IFF in a choose interpretation.
 485 NEW-MARK and OLD-MARK are the text of the new and old marks."
 486
 487    (let*
 488       (
 489          (old-kwd-data
 490             (assoc old-mark org-todo-kwd-alist))
 491          (new-kwd-data
 492             (assoc new-mark org-todo-kwd-alist))
 493          (becomes-choose
 494             (and
 495                (or
 496                   (not old-kwd-data)
 497                   (not
 498                      (eq (nth 1 old-kwd-data) 'choose)))
 499                (eq (nth 1 new-kwd-data) 'choose))))
 500       (when
 501          becomes-choose
 502          (let
 503             ((new-mark-data
 504                 (assoc new-mark org-choose-mark-data)))
 505             (if
 506                new-mark
 507                (org-choose-get-mark-N
 508                   (org-choose-get-default-mark-index
 509                      new-mark-data)
 510                   new-mark-data)
 511                (error "Somehow got an unrecognizable mark"))))))
 512
 513 ;;;_ , Setting it all up
 514
 515 (eval-after-load "org"
 516   '(progn
 517      (add-to-list 'org-todo-setup-filter-hook
 518                   #'org-choose-setup-filter)
 519      (add-to-list 'org-todo-get-default-hook
 520                   #'org-choose-get-default-mark)
 521      (add-to-list 'org-trigger-hook
 522                   #'org-choose-keep-sensible)
 523      (add-to-list 'org-todo-interpretation-widgets
 524                   '(:tag "Choose   (to record decisions)" choose)
 525                   'append)
 526      ))
 527
 528
 529 ;;;_. Footers
 530 ;;;_ , Provides
 531
 532 (provide 'org-choose)
 533
 534 ;;;_ * Local emacs vars.
 535 ;;;_  + Local variables:
 536 ;;;_  + End:
 537
 538 ;;;_ , End
 539 ;;; org-choose.el ends here