emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
* [PATCH] org-velocity and org-remember
@ 2010-11-03 23:22 Paul M. Rodriguez
  2010-11-04 21:53 ` Jeff Horn
  2010-11-15 10:23 ` [Accepted] " Carsten Dominik
  0 siblings, 2 replies; 3+ messages in thread
From: Paul M. Rodriguez @ 2010-11-03 23:22 UTC (permalink / raw)
  To: emacs-orgmode

[-- Attachment #1: Type: text/plain, Size: 214 bytes --]


This patch supports org-capture (with fallback to org-remember) for
org-velocity.  It also effects some internal changes, principally due to
the use of `Electric-command-loop' to replace an expedient equivalent.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: org-velocity.patch --]
[-- Type: text/x-diff, Size: 17509 bytes --]

diff --git a/contrib/lisp/org-velocity.el b/contrib/lisp/org-velocity.el
index 3e7453b..2a1f41b 100644
--- a/contrib/lisp/org-velocity.el
+++ b/contrib/lisp/org-velocity.el
@@ -4,7 +4,7 @@
 
 ;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
 ;; Created: 2010-05-05
-;; Version: 2.1
+;; Version: 2.2
 
 ;; This file is not part of GNU Emacs.
 
@@ -59,23 +59,23 @@
 ;; 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.
+;; choice to create a new heading named with the search.  Org-Velocity
+;; will use `org-capture' or `org-remember' if they are loaded,
+;; preferring `org-capture'.  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)
+;; (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)
+(require 'electric)
 (eval-when-compile (require 'cl))
 
 (defgroup org-velocity nil
@@ -99,18 +99,6 @@
   :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
@@ -124,17 +112,19 @@
 	  (const :tag "Match any word" any)
 	  (const :tag "Match all words" all)))
 
+(defcustom org-velocity-create-method 'capture
+  "Prefer `org-capture', `org-remember', or neither?"
+  :group 'org-velocity
+  :type '(choice
+	  (const :tag "Prefer capture > remember > default." capture)
+	  (const :tag "Prefer remember > default." remember)
+	  (const :tag "Edit in buffer." buffer)))
+
 (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))
@@ -142,6 +132,13 @@
   (name (substring-no-properties
 	 (org-get-heading))))
 
+(defconst org-velocity-index
+  (eval-when-compile
+   (nconc (number-sequence 49 57) 	;numbers
+	  (number-sequence 97 122)	;lowercase letters
+	  (number-sequence 65 90)))	;uppercase letters
+  "List of chars for indexing results.")
+
 (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
@@ -212,7 +209,12 @@ If there is no last heading, return nil."
       (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.")))
+    (set (make-local-variable 'header-line-format)
+	 (format "%s Use C-c C-c to finish."
+		 (abbreviate-file-name
+		  (buffer-file-name
+		   (marker-buffer
+		    (org-velocity-heading-marker heading))))))))
 
 (defun org-velocity-dismiss ()
   "Save current entry and close indirect buffer."
@@ -222,21 +224,14 @@ If there is no last heading, return nil."
 
 (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))
+  (insert (format "#%c " (nth (1- (line-number-at-pos))
+			      org-velocity-index)))
+  (let ((action (org-velocity-make-button-action heading)))
+   (insert-text-button
+    (org-velocity-heading-name heading)
+    'action action))
   (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."
@@ -244,14 +239,39 @@ If there is a REGION that will be inserted."
 	 (list (list
 		"Velocity entry"
 		?v
-		(let ((string "* %s\n\n%%?"))
-		  (if region
-		      (format (concat string "%s") heading region)
-		    (format string heading)))
+		(format "* %s\n\n%%?%s" heading (or region ""))
 		(org-velocity-use-file)
-		org-velocity-remember-method))))
+		'bottom))))
     (org-remember nil ?v)))
 
+(defun org-velocity-capture (heading &optional region)
+  "Use `org-capture' to record a note to HEADING.
+If there is a REGION that will be inserted."
+  (let ((org-capture-templates
+	 (list `("v"
+		 "Velocity entry"
+		 entry
+		 (file ,(org-velocity-use-file))
+		 ,(format "* %s\n\n%%?%s" heading (or region ""))))))
+    (if (fboundp 'org-capture) ;; quiet compiler
+     (org-capture nil "v"))))
+
+(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-create-heading (search region)
+  "Add and visit a new heading named SEARCH.
+If REGION is non-nil insert as the contents of the heading."
+  (org-velocity-insert-heading search)
+  (switch-to-buffer (org-velocity-bucket-buffer))
+  (when region (insert region)))
+
 (defun org-velocity-all-search (search)
   "Return entries containing all words in SEARCH."
   (when (file-exists-p (org-velocity-use-file))
@@ -261,20 +281,16 @@ If there is a REGION that will be inserted."
 		  (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)))))))))))
+	     (org-map-entries
+	      (lambda ()
+		(if (loop with limit = (save-excursion
+					 (org-end-of-subtree)
+					 (point))
+			  for word in keywords
+			  always (save-excursion
+				   (re-search-forward word limit t)))
+		    (org-velocity-nearest-heading
+		     (match-beginning 0))))))))))
 
 (defun org-velocity-generic-search (search)
   "Return entries containing SEARCH."
@@ -301,7 +317,7 @@ If there is a REGION that will be inserted."
 (defun org-velocity-present (headings)
   "Buttonize HEADINGS in `org-velocity-display-buffer'."
   (and (listp headings) (delete-dups headings))
-  (let ((cdr (nthcdr 
+  (let ((cdr (nthcdr
 	      (1- (length org-velocity-index))
 	      headings)))
     (and (consp cdr) (setcdr cdr nil)))
@@ -311,7 +327,24 @@ If there is a REGION that will be inserted."
      headings)
     (goto-char (point-min))))
 
-(defun org-velocity-new (search &optional ask)
+(defun org-velocity-create-1 (search region)
+  "Create a new heading named SEARCH.
+If REGION is non-nil insert as contents of new heading.
+The possible methods are `org-velocity-capture',
+`org-velocity-remember', or `org-velocity-create-heading', in
+that order.  Which is preferred is determined by
+`org-velocity-create-method'."
+  (funcall
+   (ecase org-velocity-create-method
+     (capture (or (and (featurep 'org-capture) 'org-velocity-capture)
+		  (and (featurep 'org-remember) 'org-velocity-remember)
+		  'org-velocity-create-heading))
+     (remember (or (and (featurep 'org-remember) 'org-velocity-remember)
+		   'org-velocity-create-heading))
+     (buffer 'org-velocity-create-heading))
+   search region))
+
+(defun org-velocity-create (search &optional ask)
   "Create new heading named SEARCH.
 If ASK is non-nil, ask first."
   (if (or (null ask)
@@ -321,37 +354,45 @@ If ASK is non-nil, ask first."
 			(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))))
+	(with-current-buffer (org-velocity-bucket-buffer)
+	 (org-velocity-create-1 search region))
 	(when region (message "%s" "Inserted region"))
 	search)))
 
+(defun org-velocity-get-matches (search)
+  "Return matches for SEARCH in current bucket.
+Use method specified by `org-velocity-search-method'."
+  (with-current-buffer (org-velocity-bucket-buffer)
+   (case org-velocity-search-method
+     ('phrase (org-velocity-phrase-search search))
+     ('any    (org-velocity-any-search search))
+     ('all    (org-velocity-all-search 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
+  (with-current-buffer (org-velocity-display-buffer)
+    (erase-buffer)
+    (setq cursor-type nil))
+  (unless (or
+	   (not (stringp search))
+	   (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)))))
+	    (let ((matches (org-velocity-get-matches 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)
+		 (Electric-pop-up-window (org-velocity-display-buffer))
+		 (let ((hint (org-velocity-electric-follow-hint)))
+		   (if hint
+		       (case hint
+			 (edit (org-velocity-read nil search))
+			 (new (org-velocity-create search))
+			 (otherwise (org-velocity-activate-button hint)))))))
+      ('new (unless (org-velocity-create search t)
 	      (org-velocity-read nil search)))
       ('follow (if (y-or-n-p "One match, follow? ")
 		   (progn
@@ -360,86 +401,104 @@ If ASK is non-nil, ask first."
 		     (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-position (item list)
+  "Return first position of ITEM in LIST."
+  (loop for elt in list
+	for i from 0
+	if (equal elt item)
+	return i))
 
 (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))
+  (forward-line (org-velocity-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)
+(defun org-velocity-electric-undefined ()
+  "Complain about an undefined key."
+  (interactive)
+  (message "%s"
+	   (substitute-command-keys
+	    "\\[org-velocity-electric-new] for new entry, \\[org-velocity-electric-edit] to edit search, \\[scroll-up] to scroll."))
+  (sit-for 4))
+
+(defun org-velocity-electric-follow (ev)
+  "Follow a hint indexed by keyboard event EV."
+  (interactive (list last-command-event))
+  (if (not (> (org-velocity-position ev org-velocity-index)
 	   (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)))))
+      (throw 'org-velocity-select ev)
+    (call-interactively 'org-velocity-electric-undefined)))
+
+(defun org-velocity-electric-click (ev)
+  "Follow hint indexed by a mouse event EV."
+  (interactive "e")
+  (throw 'org-velocity-select
+	 (nth (1- (count-lines
+		   (point-min)
+		   (posn-point (event-start ev))))
+	      org-velocity-index)))
+
+(defun org-velocity-electric-edit ()
+  "Edit the search string."
+  (interactive)
+  (throw 'org-velocity-select 'edit))
+
+(defun org-velocity-electric-new ()
+  "Force a new entry."
+  (interactive)
+  (throw 'org-velocity-select 'new))
+
+(defvar org-velocity-electric-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map [t] 'org-velocity-electric-undefined)    (loop for c in org-velocity-index
+	  do (define-key map (char-to-string c) 'org-velocity-electric-follow))
+    (define-key map "0" 'org-velocity-electric-new)
+    (define-key map [tab] 'scroll-up)
+    (define-key map [return] 'org-velocity-electric-edit)
+    (define-key map [mouse-1] 'org-velocity-electric-click)
+    (define-key map [mouse-2] 'org-velocity-electric-click)
+    (define-key map [escape escape escape] 'keyboard-quit)
+    (define-key map "\C-h" 'help-command)
+    map))
+
+(defun org-velocity-electric-follow-hint ()
+  "Read index of button electrically."
+  (with-current-buffer (org-velocity-display-buffer)
+    (use-local-map org-velocity-electric-map)
+    (catch 'org-velocity-select
+      (Electric-command-loop 'org-velocity-select
+			     "Follow: "))))
+
+(defun org-velocity-read-with-completion (prompt)
+  "Like `completing-read' on entries with PROMPT.
+Use `minibuffer-local-filename-completion-map'."
+  (let ((minibuffer-local-completion-map
+	 minibuffer-local-filename-completion-map))
+    (completing-read
+     prompt
+     (mapcar 'substring-no-properties
+	     (org-map-entries 'org-get-heading)))))
 
 (defun org-velocity-read-string (prompt &optional initial-input)
-  "Read string using `read-string', with PROMPT followed by INITIAL-INPUT."
+  "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
+  ;; `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))))
+  (minibuffer-with-setup-hook
+      (lexical-let ((initial-input initial-input))
+	(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))))
+	(org-velocity-read-with-completion prompt)
+      (read-string prompt))))
 
 (defun org-velocity-read (arg &optional search)
   "Read a search string SEARCH for Org-Velocity interface.
@@ -465,5 +524,4 @@ file.  Calling with ARG forces current file."
 	(delete-other-windows)))))
 
 (provide 'org-velocity)
-
 ;;; org-velocity.el ends here

[-- Attachment #3: Type: text/plain, Size: 201 bytes --]

_______________________________________________
Emacs-orgmode mailing list
Please use `Reply All' to send replies to the list.
Emacs-orgmode@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-orgmode

^ permalink raw reply related	[flat|nested] 3+ messages in thread

* Re: [PATCH] org-velocity and org-remember
  2010-11-03 23:22 [PATCH] org-velocity and org-remember Paul M. Rodriguez
@ 2010-11-04 21:53 ` Jeff Horn
  2010-11-15 10:23 ` [Accepted] " Carsten Dominik
  1 sibling, 0 replies; 3+ messages in thread
From: Jeff Horn @ 2010-11-04 21:53 UTC (permalink / raw)
  To: Paul M. Rodriguez; +Cc: emacs-orgmode

Thanks for taking care of this, Paul. The patch works fine on my end.
I seem to remember an option for inserting the note with a date tree.
Has something changed or am I confusing org-velocity options with
another set of options?

Can I get org-velocity to automatically insert a timestamp, perhaps by
giving it a default capture template to use?

Jeff

On Wed, Nov 3, 2010 at 7:22 PM, Paul M. Rodriguez
<paulmrodriguez@gmail.com> wrote:
>
> This patch supports org-capture (with fallback to org-remember) for
> org-velocity.  It also effects some internal changes, principally due to
> the use of `Electric-command-loop' to replace an expedient equivalent.
>
>
> _______________________________________________
> Emacs-orgmode mailing list
> Please use `Reply All' to send replies to the list.
> Emacs-orgmode@gnu.org
> http://lists.gnu.org/mailman/listinfo/emacs-orgmode
>
>



-- 
Jeffrey Horn
Graduate Lecturer and PhD Student in Economics
George Mason University

(704) 271-4797
jhorn@gmu.edu
jrhorn424@gmail.com

http://www.failuretorefrain.com/jeff/

^ permalink raw reply	[flat|nested] 3+ messages in thread

* [Accepted] org-velocity and org-remember
  2010-11-03 23:22 [PATCH] org-velocity and org-remember Paul M. Rodriguez
  2010-11-04 21:53 ` Jeff Horn
@ 2010-11-15 10:23 ` Carsten Dominik
  1 sibling, 0 replies; 3+ messages in thread
From: Carsten Dominik @ 2010-11-15 10:23 UTC (permalink / raw)
  To: emacs-orgmode

Patch 362 (http://patchwork.newartisans.com/patch/362/) is now "Accepted".

Maintainer comment: none

This relates to the following submission:

http://mid.gmane.org/%3C87mxpqc7rr.fsf%40gmail.com%3E

Here is the original message containing the patch:

> Content-Type: text/plain; charset="utf-8"
> MIME-Version: 1.0
> Content-Transfer-Encoding: 7bit
> Subject: [Orgmode] org-velocity and org-remember
> Date: Thu, 04 Nov 2010 04:22:16 -0000
> From: Paul M. Rodriguez <paulmrodriguez@gmail.com>
> X-Patchwork-Id: 362
> Message-Id: <87mxpqc7rr.fsf@gmail.com>
> To: emacs-orgmode@gnu.org
> 
> This patch supports org-capture (with fallback to org-remember) for
> org-velocity.  It also effects some internal changes, principally due to
> the use of `Electric-command-loop' to replace an expedient equivalent.
> 
> 
> diff --git a/contrib/lisp/org-velocity.el b/contrib/lisp/org-velocity.el
> index 3e7453b..2a1f41b 100644
> --- a/contrib/lisp/org-velocity.el
> +++ b/contrib/lisp/org-velocity.el
> @@ -4,7 +4,7 @@
>  
>  ;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
>  ;; Created: 2010-05-05
> -;; Version: 2.1
> +;; Version: 2.2
>  
>  ;; This file is not part of GNU Emacs.
>  
> @@ -59,23 +59,23 @@
>  ;; 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.
> +;; choice to create a new heading named with the search.  Org-Velocity
> +;; will use `org-capture' or `org-remember' if they are loaded,
> +;; preferring `org-capture'.  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)
> +;; (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)
> +(require 'electric)
>  (eval-when-compile (require 'cl))
>  
>  (defgroup org-velocity nil
> @@ -99,18 +99,6 @@
>    :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
> @@ -124,17 +112,19 @@
>  	  (const :tag "Match any word" any)
>  	  (const :tag "Match all words" all)))
>  
> +(defcustom org-velocity-create-method 'capture
> +  "Prefer `org-capture', `org-remember', or neither?"
> +  :group 'org-velocity
> +  :type '(choice
> +	  (const :tag "Prefer capture > remember > default." capture)
> +	  (const :tag "Prefer remember > default." remember)
> +	  (const :tag "Edit in buffer." buffer)))
> +
>  (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))
> @@ -142,6 +132,13 @@
>    (name (substring-no-properties
>  	 (org-get-heading))))
>  
> +(defconst org-velocity-index
> +  (eval-when-compile
> +   (nconc (number-sequence 49 57) 	;numbers
> +	  (number-sequence 97 122)	;lowercase letters
> +	  (number-sequence 65 90)))	;uppercase letters
> +  "List of chars for indexing results.")
> +
>  (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
> @@ -212,7 +209,12 @@ If there is no last heading, return nil."
>        (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.")))
> +    (set (make-local-variable 'header-line-format)
> +	 (format "%s Use C-c C-c to finish."
> +		 (abbreviate-file-name
> +		  (buffer-file-name
> +		   (marker-buffer
> +		    (org-velocity-heading-marker heading))))))))
>  
>  (defun org-velocity-dismiss ()
>    "Save current entry and close indirect buffer."
> @@ -222,21 +224,14 @@ If there is no last heading, return nil."
>  
>  (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))
> +  (insert (format "#%c " (nth (1- (line-number-at-pos))
> +			      org-velocity-index)))
> +  (let ((action (org-velocity-make-button-action heading)))
> +   (insert-text-button
> +    (org-velocity-heading-name heading)
> +    'action action))
>    (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."
> @@ -244,14 +239,39 @@ If there is a REGION that will be inserted."
>  	 (list (list
>  		"Velocity entry"
>  		?v
> -		(let ((string "* %s\n\n%%?"))
> -		  (if region
> -		      (format (concat string "%s") heading region)
> -		    (format string heading)))
> +		(format "* %s\n\n%%?%s" heading (or region ""))
>  		(org-velocity-use-file)
> -		org-velocity-remember-method))))
> +		'bottom))))
>      (org-remember nil ?v)))
>  
> +(defun org-velocity-capture (heading &optional region)
> +  "Use `org-capture' to record a note to HEADING.
> +If there is a REGION that will be inserted."
> +  (let ((org-capture-templates
> +	 (list `("v"
> +		 "Velocity entry"
> +		 entry
> +		 (file ,(org-velocity-use-file))
> +		 ,(format "* %s\n\n%%?%s" heading (or region ""))))))
> +    (if (fboundp 'org-capture) ;; quiet compiler
> +     (org-capture nil "v"))))
> +
> +(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-create-heading (search region)
> +  "Add and visit a new heading named SEARCH.
> +If REGION is non-nil insert as the contents of the heading."
> +  (org-velocity-insert-heading search)
> +  (switch-to-buffer (org-velocity-bucket-buffer))
> +  (when region (insert region)))
> +
>  (defun org-velocity-all-search (search)
>    "Return entries containing all words in SEARCH."
>    (when (file-exists-p (org-velocity-use-file))
> @@ -261,20 +281,16 @@ If there is a REGION that will be inserted."
>  		  (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)))))))))))
> +	     (org-map-entries
> +	      (lambda ()
> +		(if (loop with limit = (save-excursion
> +					 (org-end-of-subtree)
> +					 (point))
> +			  for word in keywords
> +			  always (save-excursion
> +				   (re-search-forward word limit t)))
> +		    (org-velocity-nearest-heading
> +		     (match-beginning 0))))))))))
>  
>  (defun org-velocity-generic-search (search)
>    "Return entries containing SEARCH."
> @@ -301,7 +317,7 @@ If there is a REGION that will be inserted."
>  (defun org-velocity-present (headings)
>    "Buttonize HEADINGS in `org-velocity-display-buffer'."
>    (and (listp headings) (delete-dups headings))
> -  (let ((cdr (nthcdr 
> +  (let ((cdr (nthcdr
>  	      (1- (length org-velocity-index))
>  	      headings)))
>      (and (consp cdr) (setcdr cdr nil)))
> @@ -311,7 +327,24 @@ If there is a REGION that will be inserted."
>       headings)
>      (goto-char (point-min))))
>  
> -(defun org-velocity-new (search &optional ask)
> +(defun org-velocity-create-1 (search region)
> +  "Create a new heading named SEARCH.
> +If REGION is non-nil insert as contents of new heading.
> +The possible methods are `org-velocity-capture',
> +`org-velocity-remember', or `org-velocity-create-heading', in
> +that order.  Which is preferred is determined by
> +`org-velocity-create-method'."
> +  (funcall
> +   (ecase org-velocity-create-method
> +     (capture (or (and (featurep 'org-capture) 'org-velocity-capture)
> +		  (and (featurep 'org-remember) 'org-velocity-remember)
> +		  'org-velocity-create-heading))
> +     (remember (or (and (featurep 'org-remember) 'org-velocity-remember)
> +		   'org-velocity-create-heading))
> +     (buffer 'org-velocity-create-heading))
> +   search region))
> +
> +(defun org-velocity-create (search &optional ask)
>    "Create new heading named SEARCH.
>  If ASK is non-nil, ask first."
>    (if (or (null ask)
> @@ -321,37 +354,45 @@ If ASK is non-nil, ask first."
>  			(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))))
> +	(with-current-buffer (org-velocity-bucket-buffer)
> +	 (org-velocity-create-1 search region))
>  	(when region (message "%s" "Inserted region"))
>  	search)))
>  
> +(defun org-velocity-get-matches (search)
> +  "Return matches for SEARCH in current bucket.
> +Use method specified by `org-velocity-search-method'."
> +  (with-current-buffer (org-velocity-bucket-buffer)
> +   (case org-velocity-search-method
> +     ('phrase (org-velocity-phrase-search search))
> +     ('any    (org-velocity-any-search search))
> +     ('all    (org-velocity-all-search 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
> +  (with-current-buffer (org-velocity-display-buffer)
> +    (erase-buffer)
> +    (setq cursor-type nil))
> +  (unless (or
> +	   (not (stringp search))
> +	   (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)))))
> +	    (let ((matches (org-velocity-get-matches 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)
> +		 (Electric-pop-up-window (org-velocity-display-buffer))
> +		 (let ((hint (org-velocity-electric-follow-hint)))
> +		   (if hint
> +		       (case hint
> +			 (edit (org-velocity-read nil search))
> +			 (new (org-velocity-create search))
> +			 (otherwise (org-velocity-activate-button hint)))))))
> +      ('new (unless (org-velocity-create search t)
>  	      (org-velocity-read nil search)))
>        ('follow (if (y-or-n-p "One match, follow? ")
>  		   (progn
> @@ -360,86 +401,104 @@ If ASK is non-nil, ask first."
>  		     (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-position (item list)
> +  "Return first position of ITEM in LIST."
> +  (loop for elt in list
> +	for i from 0
> +	if (equal elt item)
> +	return i))
>  
>  (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))
> +  (forward-line (org-velocity-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)
> +(defun org-velocity-electric-undefined ()
> +  "Complain about an undefined key."
> +  (interactive)
> +  (message "%s"
> +	   (substitute-command-keys
> +	    "\\[org-velocity-electric-new] for new entry, \\[org-velocity-electric-edit] to edit search, \\[scroll-up] to scroll."))
> +  (sit-for 4))
> +
> +(defun org-velocity-electric-follow (ev)
> +  "Follow a hint indexed by keyboard event EV."
> +  (interactive (list last-command-event))
> +  (if (not (> (org-velocity-position ev org-velocity-index)
>  	   (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)))))
> +      (throw 'org-velocity-select ev)
> +    (call-interactively 'org-velocity-electric-undefined)))
> +
> +(defun org-velocity-electric-click (ev)
> +  "Follow hint indexed by a mouse event EV."
> +  (interactive "e")
> +  (throw 'org-velocity-select
> +	 (nth (1- (count-lines
> +		   (point-min)
> +		   (posn-point (event-start ev))))
> +	      org-velocity-index)))
> +
> +(defun org-velocity-electric-edit ()
> +  "Edit the search string."
> +  (interactive)
> +  (throw 'org-velocity-select 'edit))
> +
> +(defun org-velocity-electric-new ()
> +  "Force a new entry."
> +  (interactive)
> +  (throw 'org-velocity-select 'new))
> +
> +(defvar org-velocity-electric-map
> +  (let ((map (make-sparse-keymap)))
> +    (define-key map [t] 'org-velocity-electric-undefined)    (loop for c in org-velocity-index
> +	  do (define-key map (char-to-string c) 'org-velocity-electric-follow))
> +    (define-key map "0" 'org-velocity-electric-new)
> +    (define-key map [tab] 'scroll-up)
> +    (define-key map [return] 'org-velocity-electric-edit)
> +    (define-key map [mouse-1] 'org-velocity-electric-click)
> +    (define-key map [mouse-2] 'org-velocity-electric-click)
> +    (define-key map [escape escape escape] 'keyboard-quit)
> +    (define-key map "\C-h" 'help-command)
> +    map))
> +
> +(defun org-velocity-electric-follow-hint ()
> +  "Read index of button electrically."
> +  (with-current-buffer (org-velocity-display-buffer)
> +    (use-local-map org-velocity-electric-map)
> +    (catch 'org-velocity-select
> +      (Electric-command-loop 'org-velocity-select
> +			     "Follow: "))))
> +
> +(defun org-velocity-read-with-completion (prompt)
> +  "Like `completing-read' on entries with PROMPT.
> +Use `minibuffer-local-filename-completion-map'."
> +  (let ((minibuffer-local-completion-map
> +	 minibuffer-local-filename-completion-map))
> +    (completing-read
> +     prompt
> +     (mapcar 'substring-no-properties
> +	     (org-map-entries 'org-get-heading)))))
>  
>  (defun org-velocity-read-string (prompt &optional initial-input)
> -  "Read string using `read-string', with PROMPT followed by INITIAL-INPUT."
> +  "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
> +  ;; `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))))
> +  (minibuffer-with-setup-hook
> +      (lexical-let ((initial-input initial-input))
> +	(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))))
> +	(org-velocity-read-with-completion prompt)
> +      (read-string prompt))))
>  
>  (defun org-velocity-read (arg &optional search)
>    "Read a search string SEARCH for Org-Velocity interface.
> @@ -465,5 +524,4 @@ file.  Calling with ARG forces current file."
>  	(delete-other-windows)))))
>  
>  (provide 'org-velocity)
> -
>  ;;; org-velocity.el ends here
> 

^ permalink raw reply	[flat|nested] 3+ messages in thread

end of thread, other threads:[~2010-11-15 10:23 UTC | newest]

Thread overview: 3+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2010-11-03 23:22 [PATCH] org-velocity and org-remember Paul M. Rodriguez
2010-11-04 21:53 ` Jeff Horn
2010-11-15 10:23 ` [Accepted] " Carsten Dominik

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).