org-mode-mirror/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