Update copyright years again.

[org-mode.git] / contrib / lisp / org-choose.el

;;; org-choose.el --- decision management for org-mode

;; Copyright (C) 2009-2014 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)))

(provide 'org-choose)

;;; org-choose.el ends here