replacing cl concatenate with concat

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

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

;;;_. Headers
;;;_ , License
;; Copyright (C) 2009-2012 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)
     ))


;;;_. Footers
;;;_ , Provides

(provide 'org-choose)

;;;_ * Local emacs vars.
;;;_  + Local variables:
;;;_  + End:

;;;_ , End

;;; org-choose.el ends here