;;; hyrolo-logic.el --- Logic functions for GNU Hyperbole Rolo files  -*- lexical-binding: t; -*-
;;
;; Author:       Bob Weiner
;;
;; Orig-Date:    13-Jun-89 at 22:57:33
;; Last-Mod:     10-Apr-22 at 09:53:39 by Bob Weiner
;;
;; Copyright (C) 1989-2021  Free Software Foundation, Inc.
;; See the "HY-COPY" file for license information.
;;
;; This file is part of GNU Hyperbole.
;;
;;; Commentary:
;;
;;  INSTALLATION:
;;
;;   See also hyrolo.el.  These functions are separated from hyrolo.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 'hyrolo-fgrep-logical "hyrolo-logic" "Rolo search with logical operators." t)
;;
;;  FEATURES:
;;
;;   1.  One command, `hyrolo-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)
;;
;;       By default, only sub-entries with matches are shown, not entire
;;       hierarchies of entries, for more intuitive results.  Use a prefix argument
;;
;;       Either double quotes or parentheses may be used to group multiple
;;       words as a single argument.
;;
;;   2.  Logical `hyrolo-and', `hyrolo-or', `hyrolo-not', and `hyrolo-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 `hyrolo-r-and', `hyrolo-r-or', `hyrolo-r-not', and `hyrolo-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:
;;
;;     (hyrolo-logic (hyrolo-and (hyrolo-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, so results are often
;;   displayed quickly.

;;; Code:
;;; ************************************************************************
;;; Other required Elisp libraries
;;; ************************************************************************

(require 'hyrolo)

;; Quiet byte compiler warnings for these free variables.
(eval-when-compile
  (defvar next-entry-exists nil))

;;; ************************************************************************
;;; Public functions
;;; ************************************************************************

;;;###autoload
(defun hyrolo-fgrep-logical (expr &optional count-only include-sub-entries no-sub-entries-out)
  "Display rolo entries matching EXPR, a string, which may contain prefix logical operators.
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.

A complex example of EXPR might be:
  (and (or (not time card) (xor (and french balloons) spanish)) teacher pet)
which means:
  Match neither `time' nor `card'
    or
  Match exactly one of `french balloons' or `spanish'
    and
  Match `teacher' and `pet'.

Either double quotes or parentheses may be used to group multiple words as a
single argument."
  (interactive "sLogical rolo search: \nP\nP")
  (when (called-interactively-p 'any)
    (setq no-sub-entries-out (not no-sub-entries-out)))
  (let* ((case-fold-search t)
	 (total-matches))
    (if (not (string-match "\(\\(and\\|or\\|xor\\|not\\)\\>" expr))
	;; Search string does not contain embedded logic
	;; operators; do a string search instead.
	(setq total-matches (hyrolo-fgrep expr))
      (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 "\(hyrolo-or start end  " t))
      (setq expr (hypb:replace-match-string "\(@ " expr "\(hyrolo-xor start end " t))
      (setq expr (hypb:replace-match-string "\(! " expr "\(hyrolo-not start end " t))
      (setq expr (hypb:replace-match-string "\(& " expr "\(hyrolo-and start end " t))
      (setq expr (format "(hyrolo-logic (quote %s) nil %s %s %s)"
			 expr count-only include-sub-entries no-sub-entries-out))
      (setq total-matches (eval (read expr))))
    (if (called-interactively-p 'interactive)
	(message "%s matching entr%s found in rolo."
		 (if (= total-matches 0) "No" total-matches)
		 (if (= total-matches 1) "y" "ies")))
    total-matches))

(defun hyrolo-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, `hyrolo-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, apply SEXP 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 utilize the
free variables `start' and `end' as the region on which to operate.
Return the number of evaluations of SEXP that match entries."
  (let* ((display-buf (unless count-only
		       (prog1 (set-buffer (get-buffer-create hyrolo-display-buffer))
			 (setq buffer-read-only nil)
			 (erase-buffer))))
	 (result
	  (mapcar
	   (lambda (in-bufs)
	     (hyrolo-map-logic sexp in-bufs count-only include-sub-entries
			       no-sub-entries-out))
	   (cond ((null in-bufs) hyrolo-file-list)
		 ((listp in-bufs) in-bufs)
		 ((list in-bufs)))))
	 (total-matches (apply '+ result)))
    (unless (or count-only (= total-matches 0))
      (hyrolo-display-matches display-buf))
    total-matches))

(defun hyrolo-map-logic (sexp hyrolo-buf &optional count-only
			 include-sub-entries _no-sub-entries-out)
  "Apply logical SEXP to each entry in HYROLO-BUF and write out matching entries to `hyrolo-display-buffer'.
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, apply
SEXP 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 utilize the free variables `start' and `end' as the region on which
to operate.  Return the number of evaluations of SEXP that match entries."
  (setq hyrolo-buf (or (get-buffer hyrolo-buf) hyrolo-buf))
  (if (or (bufferp hyrolo-buf)
	  (if (file-exists-p hyrolo-buf)
	      (setq hyrolo-buf (find-file-noselect hyrolo-buf t))))
      (let* ((display-buf (set-buffer (get-buffer-create hyrolo-display-buffer)))
	     (buffer-read-only))
	(let ((hdr-pos) (num-found 0))
	  (set-buffer hyrolo-buf)
	  (save-excursion
	    (save-restriction
	      (widen)
	      (goto-char 1)
	      ;; Ensure no entries in outline mode are hidden.
	      (outline-show-all)
	      (when (re-search-forward hyrolo-hdr-regexp nil t 2)
		(forward-line)
		(setq hdr-pos (cons (point-min) (point))))
	      (let* ((start)
		     (end)
		     (end-entry-hdr)
		     (curr-entry-level-len))
		(while (re-search-forward hyrolo-entry-regexp nil t)
		  (setq end-entry-hdr (match-end hyrolo-entry-group-number)
			start (match-beginning hyrolo-entry-group-number)
			next-entry-exists nil
			curr-entry-level-len (length (match-string-no-properties hyrolo-entry-group-number))
			end (hyrolo-to-entry-end include-sub-entries curr-entry-level-len))
		  (let ((result (eval sexp `((start . ,start) (end . ,end)))))
		    (unless count-only
		      (and result (= num-found 0) hdr-pos
			   (let* ((src (or (buffer-file-name hyrolo-buf)
					   hyrolo-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
				    hyrolo-buf (car hdr-pos) (cdr hdr-pos))
				   (insert src-line "\n\n"))
			       (insert (format hyrolo-hdr-format src-line)))
			     (set-buffer hyrolo-buf))))
		    (if result
			(progn (goto-char end)
			       (setq num-found (1+ num-found))
			       (or count-only
				   (append-to-buffer display-buf start end)))
		      (goto-char end-entry-hdr)))))))
	  (hyrolo-kill-buffer hyrolo-buf)
	  num-found))
    0))

;;
;; INTERNAL FUNCTIONS.
;;

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

(defun hyrolo-not (start end &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 (null (setq pat (car pat-list)))
		    (and (stringp pat)
			 (goto-char start)
			 (not (search-forward pat end t)))))
      (setq pat-list (cdr pat-list)))
    (not pat-list)))

(defun hyrolo-or (start end &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 (null (setq pat (car pat-list)))
		      (and (stringp pat)
			   (goto-char start)
			   (not (search-forward pat end t)))))
	(setq pat-list (cdr pat-list)))
      (if pat-list t nil))))

(defun hyrolo-xor (start end &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 hyrolo-and (start end &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."
  (unless (memq nil pat-list)
    (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)))
      (not pat-list))))

;; Work with regular expression patterns rather than strings

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

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

(defun hyrolo-r-xor (start end &rest pat-list)
  "Logical <xor> rolo entry filter.  PAT-LIST is a list of pattern elements.
Each element may be t, nil, or a regular expression."
  (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 hyrolo-r-and (start end &rest pat-list)
  "Logical <and> rolo entry filter.  PAT-LIST is a list of pattern elements.
Each element may be t, nil, or a regular expression."
  (unless (memq nil pat-list)
    (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)))
      (not pat-list))))

(provide 'hyrolo-logic)

;;; hyrolo-logic.el ends here
