Source

hyperbole / wrolo-logic.el

Full commit
;;!emacs
;;
;; FILE:         wrolo-logic.el
;; SUMMARY:      Performs logical retrievals on rolo files
;; USAGE:        GNU Emacs Lisp Library
;; KEYWORDS:     hypermedia, matching
;;
;; AUTHOR:       Bob Weiner
;; ORG:          BeOpen.com
;;
;; ORIG-DATE:    13-Jun-89 at 22:57:33
;; LAST-MOD:     16-Jun-99 at 00:20:38 by Bob Weiner
;;
;; Copyright (C) 1989-1995, BeOpen.com and the Free Software Foundation, Inc.
;; See the "HY-COPY" file for license information.
;;
;; This file is part of Hyperbole.
;;
;; DESCRIPTION:  
;;
;;  INSTALLATION:
;;
;;   See also wrolo.el.  These functions are separated from wrolo.el since many
;;   users may never want or need them.  They can be automatically loaded when
;;   desired by adding the following to one of your Emacs init files:
;;
;;    (autoload 'rolo-fgrep-logical "wrolo-logic" "Rolo search with logical operators." t)
;;
;;  FEATURES:
;;
;;   1.  One command, `rolo-fgrep-logical' which prompts for a logical search
;;       expression string and displays any matching entries.  A sample expression
;;       might be:
;;        (and (or (not time card) (xor "french balloons" spanish)) teacher pet)
;;
;;       Either double quotes or parentheses may be used to group multiple
;;       words as a single argument.
;;
;;   2.  Logical `rolo-and', `rolo-or', `rolo-not', and `rolo-xor' rolo
;;       entry string filter functions. They take any number of string or
;;       boolean arguments and may be nested.  NOTE THAT THESE FUNCTIONS
;;       SHOULD NEVER BE CALLED DIRECTLY UNLESS THE FREE VARIABLES `start'
;;       and `end' ARE BOUND BEFOREHAND.
;;
;;   3.  Logical `rolo-r-and', `rolo-r-or', `rolo-r-not', and `rolo-r-xor'
;;       rolo entry regexp filter functions.  They take any number of string or
;;       boolean arguments and may be nested.  NOTE THAT THESE FUNCTIONS
;;       SHOULD NEVER BE CALLED DIRECTLY UNLESS THE FREE VARIABLES `start'
;;       and `end' ARE BOUND BEFOREHAND.
;;
;;  EXAMPLE PROGRAMMATIC USAGE:
;;
;;     (rolo-logic (rolo-and (rolo-not "Tool-And-Die") "secretary"))
;;
;;   would find all non-Tool-And-Die Corp. secretaries in your rolo.
;;
;;   The logical matching routines are not at all optimal, but then most
;;   rolo files are not terribly lengthy either.
;;
;; DESCRIP-END.

(require 'wrolo)

;;;###autoload
(defun rolo-fgrep-logical (expr)
  "Read and execute a rolo string search with prefix logical operators.
A complex example might be:
  (and (or (not time card) (xor (french balloons) spanish)) teacher pet)
which means:
  Match neither `time' nor `card'
    or
  Matches exactly one of `french balloons' or `spanish'
    and
  Matches `teacher' and `pet'.

Either double quotes or parentheses may be used to group multiple words as a
single argument."
  (interactive "sLogical rolo search: ")
  (setq expr (hypb:replace-match-string "\(or " expr "\(| " t))
  (setq expr (hypb:replace-match-string "\(xor " expr "\(@ " t))
  (setq expr (hypb:replace-match-string "\(not " expr "\(! " t))
  (setq expr (hypb:replace-match-string "\(and " expr "\(& " t))
  (setq expr (hypb:replace-match-string
	      "\"\\([^\"]*\\)\"" expr "{\\1}" nil))
  (setq expr (hypb:replace-match-string
	      "\(\\([^@|!&()][^()\"]*\\)\)" expr "{\\1}" nil))
  (let ((saved-expr expr))
    (while
	(not (equal
	      saved-expr
	      (setq expr (hypb:replace-match-string
			  "\\(\\s-\\)\\([^{}()\" \t\n\r]+\\)\\([^{}()]*[()]\\)"
			  expr "\\1\"\\2\"\\3" nil))))
      (setq saved-expr expr)))
  (setq expr (hypb:replace-match-string
	      "{\\([^{}]+\\)}" expr "\"\\1\"" nil))
  (setq expr (hypb:replace-match-string "\(| " expr "\(rolo-or " t))
  (setq expr (hypb:replace-match-string "\(@ " expr "\(rolo-xor " t))
  (setq expr (hypb:replace-match-string "\(! " expr "\(rolo-not " t))
  (setq expr (hypb:replace-match-string "\(& " expr "\(rolo-and " t))
  (setq expr (format "(rolo-logic (quote %s))" expr))
  (let ((total-matches (eval (read expr))))
    (if (interactive-p)
	(message "%s matching entr%s found in rolo."
		 (if (= total-matches 0) "No" total-matches)
		 (if (= total-matches 1) "y" "ies")))
    total-matches))

(defun rolo-logic (sexp &optional in-bufs count-only include-sub-entries
			no-sub-entries-out)
  "Apply SEXP to all entries in optional IN-BUFS, display entries where SEXP is non-nil.
If IN-BUFS is nil, `rolo-file-list' is used.  If optional COUNT-ONLY is
non-nil, don't display entries, return count of matching entries only.  If
optional INCLUDE-SUB-ENTRIES flag is non-nil, SEXP will be applied across all
sub-entries at once.  Default is to apply SEXP to each entry and sub-entry
separately.  Entries are displayed with all of their sub-entries unless
INCLUDE-SUB-ENTRIES is nil and optional NO-SUB-ENTRIES-OUT flag is non-nil.
SEXP should use the free variables `start' and `end' which contain the limits
of the region on which it should operate.  Returns number of evaluations of
SEXP that return non-nil."
  (let ((obuf (current-buffer))
	(display-buf (if count-only
			 nil
		       (prog1 (set-buffer (get-buffer-create rolo-display-buffer))
			 (setq buffer-read-only nil)
			 (erase-buffer)))))
    (let ((result
	    (mapcar
	     (function
	      (lambda (in-bufs)
		 (rolo-map-logic sexp in-bufs count-only include-sub-entries
				 no-sub-entries-out)))
	      (cond ((null in-bufs) rolo-file-list)
		    ((listp in-bufs) in-bufs)
		    ((list in-bufs))))))
      (let ((total-matches (apply '+ result)))
	(if (or count-only (= total-matches 0))
	    nil
	  (rolo-display-matches display-buf))
	total-matches))))

(defun rolo-map-logic (sexp rolo-buf &optional count-only
			    include-sub-entries no-sub-entries-out)
  "Apply SEXP to all entries in ROLO-BUF, write to buffer entries where SEXP is non-nil.
If optional COUNT-ONLY is non-nil, don't display entries, return count of
matching entries only.  If optional INCLUDE-SUB-ENTRIES flag is non-nil, SEXP
will be applied across all sub-entries at once.  Default is to apply SEXP to
each entry and sub-entry separately.  Entries are displayed with all of their
sub-entries unless INCLUDE-SUB-ENTRIES is nil and optional NO-SUB-ENTRIES-OUT
flag is non-nil.  SEXP should use the free variables `start' and `end' which
contain the limits of the region on which it should operate.  Returns number
of applications of SEXP that return non-nil."
  (if (or (bufferp rolo-buf)
	  (if (file-exists-p rolo-buf)
	      (setq rolo-buf (find-file-noselect rolo-buf t))))
      (let* ((display-buf (set-buffer (get-buffer-create rolo-display-buffer)))
	     (buffer-read-only))
	(let ((hdr-pos) (num-found 0))
	  (set-buffer rolo-buf)
	  (save-excursion
	    (save-restriction
	      (widen)
	      (goto-char 1)
	      ;; Ensure no entries in outline mode are hidden.
	      ;; Uses `show-all' function from outline.el.
	      (if (search-forward "\C-m" nil t)
		  (show-all))
	      (if (re-search-forward rolo-hdr-regexp nil t 2)
		  (progn (forward-line)
			 (setq hdr-pos (cons (point-min) (point)))))
	      (let* ((start)
		     (end)
		     (end-entry-hdr)
		     (curr-entry-level))
		(while (re-search-forward rolo-entry-regexp nil t)
		  (setq start (save-excursion (beginning-of-line) (point))
			next-entry-exists nil
			end-entry-hdr (point)
			curr-entry-level (buffer-substring start end-entry-hdr)
			end (rolo-to-entry-end include-sub-entries curr-entry-level))
		  (let ((result (eval sexp)))
		    (or count-only 
			(and result (= num-found 0) hdr-pos
			     (let* ((src (or (buffer-file-name rolo-buf)
					     rolo-buf))
				    (src-line
				     (format
				      (concat (if (boundp 'hbut:source-prefix)
						  hbut:source-prefix
						"@loc> ")
					      "%s")
				      (prin1-to-string src))))
			       (set-buffer display-buf)
			       (goto-char (point-max))
			       (if hdr-pos
				   (progn
				     (insert-buffer-substring
				      rolo-buf (car hdr-pos) (cdr hdr-pos))
				     (insert src-line "\n\n"))
				 (insert (format rolo-hdr-format src-line)))
			       (set-buffer rolo-buf))))
		    (if result
			(progn (goto-char end)
			       (setq num-found (1+ num-found)
				     end (if (or include-sub-entries
						 no-sub-entries-out)
					     end
					   (goto-char (rolo-to-entry-end
						       t curr-entry-level))))
			       (or count-only
				   (append-to-buffer display-buf start end)))
		      (goto-char end-entry-hdr)))))))
	  (rolo-kill-buffer rolo-buf)
	  num-found))
    0))

;;
;; INTERNAL FUNCTIONS.
;;

;; Do NOT call the following functions directly.
;; Send them as parts of an expression to `rolo-logic'.

(defun rolo-not (&rest pat-list)
  "Logical <not> rolo entry filter.  PAT-LIST is a list of pattern elements.
Each element may be t, nil, or a string."
  (let ((pat))
    (while (and pat-list
		(or (not (setq pat (car pat-list)))
		    (and (not (eq pat t))
			 (goto-char start)
			 (not (search-forward pat end t)))))
      (setq pat-list (cdr pat-list)))
    (if pat-list nil t)))

(defun rolo-or (&rest pat-list)
  "Logical <or> rolo entry filter.  PAT-LIST is a list of pattern elements.
Each element may be t, nil, or a string."
  (if (memq t pat-list)
      t
    (let ((pat))
      (while (and pat-list
		  (or (not (setq pat (car pat-list)))
		      (and (not (eq pat t))
			   (goto-char start)
			   (not (search-forward pat end t)))))
	(setq pat-list (cdr pat-list)))
      (if pat-list t nil))))

(defun rolo-xor (&rest pat-list)
  "Logical <xor> rolo entry filter.  PAT-LIST is a list of pattern elements.
Each element may be t, nil, or a string."
  (let ((pat)
	(matches 0))
    (while (and pat-list
		(or (not (setq pat (car pat-list)))
		    (and (or (eq pat t)
			     (not (goto-char start))
			     (search-forward pat end t))
			 (setq matches (1+ matches)))
		    t)
		(< matches 2))
      (setq pat-list (cdr pat-list)))
    (= matches 1)))

(defun rolo-and (&rest pat-list)
  "Logical <and> rolo entry filter.  PAT-LIST is a list of pattern elements.
Each element may be t, nil, or a string."
  (if (memq nil pat-list)
      nil
    (let ((pat))
      (while (and pat-list
		  (setq pat (car pat-list))
		  (or (eq pat t)
		      (not (goto-char start))
		      (search-forward pat end t)))
	(setq pat-list (cdr pat-list)))
      (if pat-list nil t))))

;; Work with regular expression patterns rather than strings

(defun rolo-r-not (&rest pat-list)
  "Logical <not> rolo entry filter.  PAT-LIST is a list of pattern elements.
Each element may be t, nil, or a string."
  (let ((pat))
    (while (and pat-list
		(or (not (setq pat (car pat-list)))
		    (and (not (eq pat t))
			 (goto-char start)
			 (not (re-search-forward pat end t)))))
      (setq pat-list (cdr pat-list)))
    (if pat-list nil t)))

(defun rolo-r-or (&rest pat-list)
  "Logical <or> rolo entry filter.  PAT-LIST is a list of pattern elements.
Each element may be t, nil, or a string."
  (if (memq t pat-list)
      t
    (let ((pat))
      (while (and pat-list
		  (or (not (setq pat (car pat-list)))
		      (and (not (eq pat t))
			   (goto-char start)
			   (not (re-search-forward pat end t)))))
	(setq pat-list (cdr pat-list)))
      (if pat-list t nil))))

(defun rolo-r-xor (&rest pat-list)
  "Logical <xor> rolo entry filter.  PAT-LIST is a list of pattern elements.
Each element may be t, nil, or a string."
  (let ((pat)
	(matches 0))
    (while (and pat-list
		(or (not (setq pat (car pat-list)))
		    (and (or (eq pat t)
			     (not (goto-char start))
			     (re-search-forward pat end t))
			 (setq matches (1+ matches)))
		    t)
		(< matches 2))
      (setq pat-list (cdr pat-list)))
    (= matches 1)))

(defun rolo-r-and (&rest pat-list)
  "Logical <and> rolo entry filter.  PAT-LIST is a list of pattern elements.
Each element may be t, nil, or a string."
  (if (memq nil pat-list)
      nil
    (let ((pat))
      (while (and pat-list
		  (setq pat (car pat-list))
		  (or (eq pat t)
		      (not (goto-char start))
		      (re-search-forward pat end t)))
	(setq pat-list (cdr pat-list)))
      (if pat-list nil t))))

(provide 'wrolo-logic)