Install Paul Rodriguez' org-velocity.el

* contrib/lisp/org-velocity.el: New file.
* contrib/README: List org-velocity.el
* lisp/org.el (org-modules): Add entry for org-velocity

3 files changed, 472 insertions, 1 deletions

diff --git a/contrib/README b/contrib/README
index f8fe423..3cb076d 100644
--- a/contrib/README
+++ b/contrib/README
@@ -43,6 +43,7 @@ org-special-blocks.el    --- Turn blocks into LaTeX envs and HTML divs
 orgtbl-sqlinsert.el      --- Convert Org-mode tables to SQL insertions
 org-toc.el 	         --- Table of contents for Org-mode buffer
 org-track.el             --- Keep up with Org development
+org-velocity.el          --- something like Notational Velocity for Org
 
 
 
diff --git a/contrib/lisp/org-velocity.el b/contrib/lisp/org-velocity.el
new file mode 100644
index 0000000..3e7453b
--- /dev/null
+++ b/contrib/lisp/org-velocity.el
@@ -0,0 +1,469 @@
+;;; org-velocity.el --- something like Notational Velocity for Org.
+
+;; Copyright (C) 2010 Paul M. Rodriguez
+
+;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
+;; Created: 2010-05-05
+;; Version: 2.1
+
+;; This file is not part of GNU Emacs.
+
+;; This program 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 version 2.
+
+;; This program 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.
+
+;; For a copy of the GNU General Public License, search the Internet,
+;; or write to the Free Software Foundation, Inc., 59 Temple Place,
+;; Suite 330, Boston, MA 02111-1307 USA
+
+;;; Commentary:
+;; Org-Velocity.el implements an interface for Org inspired by the
+;; minimalist notetaking program Notational Velocity.  The idea is to
+;; allow you to maintain, amass and access brief notes on many
+;; subjects with minimal fuss.
+
+;; It can be used in two ways: to store and access notes from any
+;; buffer a universal bucket file; or as a method for navigating any
+;; Org file.
+
+;; The name of the bucket-file (`org-velocity-bucket') and whether to
+;; always use it (`org-velocity-always-use-bucket-file') are set
+;; through Customize.  If the bucket file is set but not always to be
+;; used, then calling Org-Velocity outside of Org-mode uses the bucket
+;; file; calling it in Org mode uses the current buffer.  If no bucket
+;; file is set then Org-Velocity only works when called from Org.
+;; Even if the bucket file is always to be used, calling
+;; `org-velocity-read' with an argument will use the current file.
+
+;; The interface, unlike its inspiration, is not incremental.
+;; Org-Velocity prompts for search terms in the usual way; if the user
+;; has customized `org-velocity-use-completion', completion is offered
+;; on the headings in the target file.  If the search multiple times
+;; in the target file, a buffer containing a buttonized list of the
+;; headings where it occurs is displayed.  Results beyond what can be
+;; indexed are discarded.  After clicking on a heading, or typing a
+;; character associated with it, the user is taken to the heading.
+;; (Typing 0 forces a new heading to be created.)  If
+;; `org-velocity-edit-indirectly' is so set, the heading and its
+;; subtree are displayed in an indirect buffer.  Otherwise the user is
+;; simply taken to the proper buffer and position.
+
+;; If the user simply hits RET at the prompt, without making a choice,
+;; then the search is restored for editing.  A blank search quits.
+;; This method of selection is obviously not as slick as the original,
+;; but probably more useful for a keyboard-driven interface.
+
+;; If the search does not occur in the file the user is offered a
+;; choice to create a new heading named with the search.  When
+;; org-remember is loaded, or the user customizes
+;; `org-velocity-use-remember', then org-remember is used to insert
+;; the new heading.  Otherwise the user is simply taken to a new
+;; heading at the end of the file.
+
+;; Thanks to Richard Riley, Carsten Dominik, and Bastien Guerry for
+;; their suggestions.
+
+;;; Usage:
+;;; (require 'org-velocity)
+;;; (setq org-velocity-bucket (concat org-directory "/bucket.org"))
+;;; (global-set-key (kbd "C-c v") 'org-velocity-read)
+
+;;; Code:
+(require 'org)
+(require 'button)
+(eval-when-compile (require 'cl))
+
+(defgroup org-velocity nil
+  "Notational Velocity-style interface for Org."
+  :tag "Org-Velocity"
+  :group 'outlines
+  :group 'hypermedia)
+
+(defcustom org-velocity-bucket ""
+  "Where is the bucket file?"
+  :group 'org-velocity
+  :type 'file)
+
+(defcustom org-velocity-always-use-bucket nil
+  "Use bucket file even when called from an Org buffer?"
+  :group 'org-velocity
+  :type 'boolean)
+
+(defcustom org-velocity-use-completion nil
+  "Complete on heading names?"
+  :group 'org-velocity
+  :type 'boolean)
+
+(defcustom org-velocity-use-remember (featurep 'org-remember)
+  "Use Org-remember or just visit the file?"
+  :group 'org-velocity
+  :type 'boolean)
+
+(defcustom org-velocity-remember-method 'bottom
+  "Where in files should `org-remember' record new entries?"
+  :group 'org-velocity
+  :type '(choice (const :tag "Add at bottom" bottom)
+		 (const :tag "Add at top" top)
+		 (const :tag "Use date tree" date-tree)))
+
+(defcustom org-velocity-edit-indirectly t
+  "Edit entries in an indirect buffer or just visit the file?"
+  :group 'org-velocity
+  :type 'boolean)
+
+(defcustom org-velocity-search-method 'phrase
+  "Match on whole phrase, any word, or all words?"
+  :group 'org-velocity
+  :type '(choice
+	  (const :tag "Match whole phrase" phrase)
+	  (const :tag "Match any word" any)
+	  (const :tag "Match all words" all)))
+
+(defcustom org-velocity-allow-regexps nil
+  "Allow searches to use regular expressions?"
+  :group 'org-velocity
+  :type 'boolean)
+
+(defvar org-velocity-index
+  (nconc (number-sequence 49 57) 	;numbers
+	 (number-sequence 97 122)	;lowercase letters
+	 (number-sequence 65 90))	;uppercase letters
+  "List of chars for indexing results.")
+
+(defstruct (org-velocity-heading
+	    (:constructor org-velocity-make-heading)
+	    (:type list))
+  (marker (point-marker))
+  (name (substring-no-properties
+	 (org-get-heading))))
+
+(defun org-velocity-use-file ()
+  "Return the proper file for Org-Velocity to search.
+If `org-velocity-always-use-bucket' is t, use bucket file; complain
+if missing.  Otherwise if this is an Org file, use it."
+  (let ((org-velocity-bucket
+	 (and org-velocity-bucket (expand-file-name org-velocity-bucket))))
+    (if org-velocity-always-use-bucket
+	(or org-velocity-bucket (error "Bucket required but not defined"))
+      (if (and (eq major-mode 'org-mode)
+	       (buffer-file-name))
+	  (buffer-file-name)
+	(or org-velocity-bucket
+	    (error "No bucket and not an Org file"))))))
+
+(defsubst org-velocity-display-buffer ()
+  "Return the proper buffer for Org-Velocity to display in."
+  (get-buffer-create "*Velocity headings*"))
+
+(defsubst org-velocity-bucket-buffer ()
+  "Return proper buffer for bucket operations."
+  (find-file-noselect (org-velocity-use-file)))
+
+(defun org-velocity-quote (search)
+  "Quote SEARCH as a regexp if `org-velocity-allow-regexps' is non-nil.
+Acts like `regexp-quote' on a string, `regexp-opt' on a list."
+  (if org-velocity-allow-regexps
+      search
+    (if (listp search)
+	(regexp-opt search)
+      (regexp-quote search))))
+
+(defun org-velocity-nearest-heading (position)
+  "Return last heading at POSITION.
+If there is no last heading, return nil."
+  (save-excursion
+    (goto-char position)
+    (unless (org-before-first-heading-p)
+      (org-back-to-heading)
+      (org-velocity-make-heading))))
+
+(defun org-velocity-make-button-action (heading)
+  "Return a form to visit HEADING."
+  `(lambda (button)
+    (run-hooks 'mouse-leave-buffer-hook) ;turn off temporary modes
+    (if org-velocity-edit-indirectly
+	(org-velocity-edit-entry ',heading)
+      (progn
+	(message "%s" ,(org-velocity-heading-name heading))
+	(switch-to-buffer (marker-buffer
+			   ,(org-velocity-heading-marker heading)))
+	(goto-char (marker-position
+		    ,(org-velocity-heading-marker heading)))))))
+
+(defun org-velocity-edit-entry (heading)
+  "Edit entry at HEADING in an indirect buffer."
+  (let ((buffer (make-indirect-buffer
+		 (marker-buffer (org-velocity-heading-marker heading))
+		 (generate-new-buffer-name
+		  (org-velocity-heading-name heading)))))
+    (with-current-buffer buffer
+      (let ((org-inhibit-startup t))
+	(org-mode))
+      (goto-char (marker-position (org-velocity-heading-marker heading)))
+      (narrow-to-region (point)
+			(save-excursion
+			  (org-end-of-subtree)
+			  (point)))
+      (goto-char (point-min))
+      (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
+    (pop-to-buffer buffer)
+    (message "%s" "Use C-c C-c to save changes.")))
+
+(defun org-velocity-dismiss ()
+  "Save current entry and close indirect buffer."
+  (progn
+    (save-buffer)
+    (kill-buffer)))
+
+(defun org-velocity-buttonize (heading)
+  "Insert HEADING as a text button."
+  (insert (format "#%c " (nth (1- (line-number-at-pos)) org-velocity-index)))
+  (insert-text-button
+   (org-velocity-heading-name heading)
+   'action (org-velocity-make-button-action heading))
+  (newline))
+
+(defun org-velocity-insert-heading (heading)
+  "Add a new heading named HEADING."
+  (with-current-buffer (org-velocity-bucket-buffer)
+    (goto-char (point-max))
+    (newline)
+    (org-insert-heading) (insert heading)
+    (newline)
+    (goto-char (point-max))))
+
+(defun org-velocity-remember (heading &optional region)
+  "Use `org-remember' to record a note to HEADING.
+If there is a REGION that will be inserted."
+  (let ((org-remember-templates
+	 (list (list
+		"Velocity entry"
+		?v
+		(let ((string "* %s\n\n%%?"))
+		  (if region
+		      (format (concat string "%s") heading region)
+		    (format string heading)))
+		(org-velocity-use-file)
+		org-velocity-remember-method))))
+    (org-remember nil ?v)))
+
+(defun org-velocity-all-search (search)
+  "Return entries containing all words in SEARCH."
+  (when (file-exists-p (org-velocity-use-file))
+   (save-excursion
+     (delq nil
+	   (let ((keywords
+		  (mapcar 'org-velocity-quote
+			  (split-string search)))
+		 (case-fold-search t))
+	     (apply 'nconc
+		    (org-map-entries
+		     (lambda ()
+		       (let ((limit (save-excursion (org-end-of-subtree)
+						    (point))))
+			 (catch 'fail
+			   (mapcar
+			    (lambda (word)
+			      (or (save-excursion
+				    (and (re-search-forward word limit t)
+					 (org-velocity-nearest-heading
+					  (match-beginning 0))))
+				  (throw 'fail nil)))
+			    keywords)))))))))))
+
+(defun org-velocity-generic-search (search)
+  "Return entries containing SEARCH."
+  (save-excursion
+    (delq nil
+	  (nreverse
+	   (let (matches (case-fold-search t))
+	     (goto-char (point-min))
+	     (while (re-search-forward search
+				       (point-max) t)
+	       (push (org-velocity-nearest-heading (match-beginning 0))
+		     matches)
+	       (outline-next-heading))
+	     matches)))))
+
+(defsubst org-velocity-phrase-search (search)
+  "Return entries containing SEARCH as a phrase."
+  (org-velocity-generic-search (org-velocity-quote search)))
+
+(defsubst org-velocity-any-search (search)
+  "Return entries containing any word in SEARCH."
+  (org-velocity-generic-search (org-velocity-quote (split-string search))))
+
+(defun org-velocity-present (headings)
+  "Buttonize HEADINGS in `org-velocity-display-buffer'."
+  (and (listp headings) (delete-dups headings))
+  (let ((cdr (nthcdr 
+	      (1- (length org-velocity-index))
+	      headings)))
+    (and (consp cdr) (setcdr cdr nil)))
+  (with-current-buffer (org-velocity-display-buffer)
+    (mapc
+     'org-velocity-buttonize
+     headings)
+    (goto-char (point-min))))
+
+(defun org-velocity-new (search &optional ask)
+  "Create new heading named SEARCH.
+If ASK is non-nil, ask first."
+  (if (or (null ask)
+	  (y-or-n-p "No match found, create? "))
+      ;; if there's a region, we want to insert it
+      (let ((region (if (use-region-p)
+			(buffer-substring
+			 (region-beginning)
+			 (region-end)))))
+	(if org-velocity-use-remember
+	    (org-velocity-remember search region)
+	  (progn
+	    (org-velocity-insert-heading search)
+	    (switch-to-buffer (org-velocity-bucket-buffer))
+	    (when region (insert region))))
+	(when region (message "%s" "Inserted region"))
+	search)))
+
+(defun org-velocity-engine (search)
+  "Display a list of headings where SEARCH occurs."
+  (with-current-buffer (org-velocity-display-buffer) (erase-buffer))
+  (unless (string-equal "" search);exit on empty string
+    (case
+	(with-current-buffer (org-velocity-bucket-buffer)
+	  (save-excursion
+	    (let ((matches
+		   (case org-velocity-search-method
+		     ('phrase (org-velocity-phrase-search search))
+		     ('any    (org-velocity-any-search search))
+		     ('all    (org-velocity-all-search search)))))
+	      (org-velocity-present matches)
+	      (cond ((zerop (length matches)) 'new)
+		    ((= (length matches) 1)   'follow)
+		    ((> (length matches) 1)   'prompt)))))
+      ('prompt (progn
+		 (display-buffer (org-velocity-display-buffer))
+		 (case (org-velocity-follow-hint)
+		   ('edit (org-velocity-read nil search))
+		   ('new (org-velocity-new search)))))
+      ('new (unless (org-velocity-new search t)
+	      (org-velocity-read nil search)))
+      ('follow (if (y-or-n-p "One match, follow? ")
+		   (progn
+		     (set-buffer (org-velocity-display-buffer))
+		     (goto-char (point-min))
+		     (button-activate (next-button (point))))
+		 (org-velocity-read nil search))))))
+
+(defun org-velocity-list-position (elt list)	
+  "Return first position of ELT in LIST"
+  (let ((copy (copy-list list)))
+    (1- 
+     (length
+      (progn 
+	(setcdr (member elt copy) nil)
+	copy)))))
+
+(defun org-velocity-activate-button (char)
+  "Go to button on line number associated with CHAR in `org-velocity-index'."
+  (goto-char (point-min))
+  (forward-line (org-velocity-list-position char org-velocity-index))
+  (goto-char
+   (button-start
+    (next-button (point))))
+  (message "%s" (button-label (button-at (point))))
+  (button-activate (button-at (point))))
+
+(defun org-velocity-follow-hint ()
+  "Prompt for index of button."
+  (let ((hint
+	 (read-key
+	  "Follow (0 for new note, RET to edit search, TAB to scroll): ")))
+    (cond
+     ;; quit?
+     ((or (eq hint 7)			;C-g
+	  (eq hint 27))			;ESC
+      (keyboard-quit))
+     ;; zero?
+     ((eq hint 48)
+      'new)
+     ;; return?
+     ((or (eq hint 13)			;\r
+	  (eq hint 10))			;\n
+      'edit)
+     ;; tab?
+     ((eq hint 9)
+      (let ((other-window-scroll-buffer 
+	     (org-velocity-display-buffer)))
+	(scroll-other-window))
+      (org-velocity-follow-hint))
+     ;; click?
+     ((mouse-event-p hint)
+      (mouse-set-point hint)
+      (if (button-at (point))
+	  (push-button (point))
+	(org-velocity-follow-hint)))
+     ;; unhandled char?
+     ((not (memq hint org-velocity-index))
+      (org-velocity-follow-hint))
+     ;; index beyond results?
+     ((> (org-velocity-list-position hint org-velocity-index)
+	 (with-current-buffer (org-velocity-display-buffer)
+	   (1- (count-lines (point-min) (point-max)))))
+      (org-velocity-follow-hint))
+     ;; follow hint
+     (t (set-buffer (org-velocity-display-buffer))
+	(org-velocity-activate-button hint)))))
+
+(defun org-velocity-read-string (prompt &optional initial-input)
+  "Read string using `read-string', with PROMPT followed by INITIAL-INPUT."
+  ;; The use of initial inputs to the minibuffer is deprecated (see
+  ;; `read-from-minibuffer', but in this case it is the user-friendly
+  ;; thing to do.
+  (let ((minibuffer-setup-hook minibuffer-setup-hook))
+    (add-hook 'minibuffer-setup-hook (lambda ()
+				       (and initial-input (insert initial-input))
+				       (goto-char (point-max))))
+    (if (and org-velocity-use-completion
+	     ;; map-entries complains for nonexistent files
+	     (file-exists-p (org-velocity-use-file)))
+	(completing-read
+	 prompt
+	 (with-current-buffer (org-velocity-bucket-buffer)
+	  (org-map-entries
+	   (lambda ()
+	     (substring-no-properties
+	      (org-get-heading))))))
+	(read-string prompt))))
+
+(defun org-velocity-read (arg &optional search)
+  "Read a search string SEARCH for Org-Velocity interface.
+This means that a buffer will display all headings where SEARCH
+occurs, where one can be selected by a mouse click or by typing
+its index.  If SEARCH does not occur, then a new heading may be
+created named SEARCH.
+
+If `org-velocity-bucket' is defined and
+`org-velocity-always-use-bucket' is non-nil, then the bucket file
+will be used; otherwise, this will work when called in any Org
+file.  Calling with ARG forces current file."
+  (interactive "P")
+  (let ((org-velocity-always-use-bucket
+	 (if arg nil org-velocity-always-use-bucket)))
+    ;; complain if inappropriate
+    (assert (org-velocity-use-file))
+    (unwind-protect
+	(org-velocity-engine
+	 (org-velocity-read-string "Velocity search: " search))
+      (progn
+	(kill-buffer (org-velocity-display-buffer))
+	(delete-other-windows)))))
+
+(provide 'org-velocity)
+
+;;; org-velocity.el ends here
diff --git a/lisp/org.el b/lisp/org.el
index 2ad7ce1..e2bf727 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -295,6 +295,7 @@ to add the symbol `xyz', and the package must have a call to
 	(const :tag "   wl:                Links to Wanderlust folders/messages" org-wl)
 	(const :tag "   w3m:               Special cut/paste from w3m to Org-mode." org-w3m)
 	(const :tag "   mouse:             Additional mouse support" org-mouse)
+	(const :tag "   TaskJuggler:       Export tasks to a TaskJuggler project" org-taskjuggler)
 
 	(const :tag "C  annotate-file:     Annotate a file with org syntax" org-annotate-file)
 	(const :tag "C  bookmark:          Org-mode links to bookmarks" org-bookmark)
@@ -328,7 +329,7 @@ to add the symbol `xyz', and the package must have a call to
 	(const :tag "C  sqlinsert:         Convert Org-mode tables to SQL insertions" orgtbl-sqlinsert)
 	(const :tag "C  toc:               Table of contents for Org-mode buffer" org-toc)
 	(const :tag "C  track:             Keep up with Org-mode development" org-track)
-	(const :tag "C  TaskJuggler:       Export tasks to a TaskJuggler project" org-taskjuggler)
+	(const :tag "C  velocity           Something like Notational Velocity for Org" org-velocity)
 	(repeat :tag "External packages" :inline t (symbol :tag "Package"))))
 
 (defcustom org-support-shift-select nil