;;;-*- Mode:LISP; Package:ZWEI -*-
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **

;;; Functions and commands for doing searching

;;; First value is BP found at, or NIL if not found.
;;; If LINES-TO-SEARCH is not NIL, it is a number of lines to give up after.
;;; In that case, if we give up, the first value is a bp to where to resume,
;;; and the second value is T.  The resumption bp is such that no occurrences
;;; are missed by being split across it (this could happen in reverse searches
;;; if the bp were chosen randomly).
(DEFUN SEARCH (BP STRING &OPTIONAL REVERSEP FIXUP-P LINES-TO-SEARCH LIMIT-BP &AUX NLPOS)
  (OR LIMIT-BP (SETQ LIMIT-BP (IF REVERSEP
				  (INTERVAL-FIRST-BP *INTERVAL*)
				  (INTERVAL-LAST-BP *INTERVAL*))))
  (PROG SEARCH ()
   (RETURN
    (COND ((NUMBERP STRING)
	   (IF (NOT REVERSEP)
	       ;; Forward search for a character.
	       (CHARMAP-PER-LINE (BP LIMIT-BP (IF FIXUP-P (COPY-BP LIMIT-BP) NIL))
				 ((AND LINES-TO-SEARCH
				       (ZEROP (SETQ LINES-TO-SEARCH
						    (1- LINES-TO-SEARCH)))
				       (RETURN-FROM SEARCH
						    (CREATE-BP LINE *FIRST-INDEX*)
						    T)))
		 (AND (CHAR-EQUAL STRING (CHARMAP-CHAR))
		      (CHARMAP-RETURN (CHARMAP-BP-AFTER))))
	       ;; Reverse search for a character.
	       (RCHARMAP-PER-LINE (BP LIMIT-BP (IF FIXUP-P (COPY-BP LIMIT-BP) NIL))
				  ((AND LINES-TO-SEARCH
					(ZEROP (SETQ LINES-TO-SEARCH
						     (1- LINES-TO-SEARCH)))
					(RETURN-FROM SEARCH
						     (END-OF-LINE LINE)
						     T)))
		 (AND (CHAR-EQUAL STRING (RCHARMAP-CHAR))
		      (RCHARMAP-RETURN (RCHARMAP-BP-BEFORE))))))
	  ((SETQ NLPOS (STRING-SEARCH-CHAR #\CR STRING))
	   (SEARCH-CR-FULL BP STRING REVERSEP FIXUP-P NLPOS LINES-TO-SEARCH LIMIT-BP))
	  (T
	   (IF (NOT REVERSEP)
	       ;; Search forward for a 1-line string.
	       (DO ((LINE (BP-LINE BP) (LINE-NEXT LINE))
		    (LEN (STRING-LENGTH STRING))
		    (FROM-INDEX (BP-INDEX BP) 0)
		    (LAST-LINE (BP-LINE LIMIT-BP)))
		   ((AND LINES-TO-SEARCH
			 (ZEROP (SETQ LINES-TO-SEARCH (1- LINES-TO-SEARCH))))
		    (RETURN-FROM SEARCH (CREATE-BP LINE FROM-INDEX) T))
		 (LET ((LASTP (EQ LINE LAST-LINE)))
		   (LET ((INDEX (STRING-SEARCH STRING LINE FROM-INDEX)))
		     (COND ((AND (NOT (NULL INDEX))
				 (OR (NOT LASTP)
				     ( INDEX (- (BP-INDEX LIMIT-BP) LEN))))
			    (RETURN (CREATE-BP LINE (+ INDEX LEN))))
			   (LASTP
			    (RETURN (IF FIXUP-P (COPY-BP LIMIT-BP) NIL)))))))
	       ;; Search backward for a 1-line string.
	       (DO ((LINE (BP-LINE BP) (LINE-PREVIOUS LINE))
		    (LEN (STRING-LENGTH STRING))
		    (FROM-INDEX (BP-INDEX BP) NIL)
		    (FIRST-LINE (BP-LINE LIMIT-BP)))
		   ((AND LINES-TO-SEARCH
			 (ZEROP (SETQ LINES-TO-SEARCH (1- LINES-TO-SEARCH))))
		    (RETURN-FROM SEARCH (END-OF-LINE LINE) T))
		 (LET ((FIRSTP (EQ LINE FIRST-LINE)))
		   (LET ((INDEX (STRING-REVERSE-SEARCH STRING LINE FROM-INDEX)))
		     (COND ((AND (NOT (NULL INDEX))
				 (OR (NOT FIRSTP)
				     ( INDEX (- (BP-INDEX LIMIT-BP) LEN))))
			    (RETURN (CREATE-BP LINE INDEX)))
			   (FIRSTP
			    (RETURN (IF FIXUP-P (COPY-BP LIMIT-BP) NIL)))))))))))))

;;; Subroutine of SEARCH.  Used to search for a string containing a CR.
;;; NLPOS is the index in STRING of the first CR.
(DEFUN SEARCH-CR-FULL (BP STRING REVERSEP FIXUP-P NLPOS LINES-TO-SEARCH LIMIT-BP)
  (PROG SEARCH-CR-FULL ((STRING-LENGTH (STRING-LENGTH STRING)))
    (RETURN
      (IF (NOT REVERSEP)
	  (LET ((CHAR1 (AREF STRING 0))
		(CRLEADS (ZEROP NLPOS)))
	     (DO-NAMED LUPO
		 ((LINE (IF (AND (NOT CRLEADS)
				 ( (- (LINE-LENGTH (BP-LINE BP)) (BP-INDEX BP)) NLPOS))
			    (BP-LINE BP)
			    (LINE-NEXT (BP-LINE BP)))
			(LINE-NEXT LINE))
		  (LAST-LINE (BP-LINE LIMIT-BP)))
		 ((OR (NULL LINE) (AND (EQ LINE LAST-LINE)
				       (NOT CRLEADS)))
		  ;; Since string contains a NEWLINE, it cannot start on LAST-LINE.
		  ;; Unless the NEWLINE is at the beginning.
		  (IF FIXUP-P (COPY-BP LIMIT-BP) NIL))
	       (AND LINES-TO-SEARCH
		    (ZEROP (SETQ LINES-TO-SEARCH (1- LINES-TO-SEARCH)))
		    (RETURN-FROM SEARCH-CR-FULL (BEG-OF-LINE LINE) T))
	       (LET ((START-INDEX (IF CRLEADS 0 (- (LINE-LENGTH LINE) NLPOS))))
		 (COND ((OR CRLEADS
			    (AND ( START-INDEX 0)
				 (CHAR-EQUAL CHAR1 (AREF LINE START-INDEX))))
			(LET ((I (IF CRLEADS 1 0)))
			  (CHARMAP ((CREATE-BP LINE START-INDEX)
				    LIMIT-BP
				    (RETURN-FROM LUPO (CHARMAP-BP-BEFORE)))
			    (IF ( I STRING-LENGTH)
				(RETURN-FROM LUPO (CHARMAP-BP-BEFORE)))
			    (IF (NOT (CHAR-EQUAL (CHARMAP-CHAR) (AREF STRING I)))
				(CHARMAP-RETURN NIL))
				(SETQ I (1+ I)))))))
	       (AND CRLEADS (EQ LINE LAST-LINE)
		    (RETURN (IF FIXUP-P (COPY-BP LIMIT-BP) NIL)))))
	  (SETQ NLPOS (STRING-REVERSE-SEARCH-CHAR #\CR STRING))
	  (LET ((CHARL (AREF STRING (1- STRING-LENGTH)))
		;; One less than number of chars after the last CR.
		(START-INDEX (- STRING-LENGTH NLPOS 2)))
	    (DO-NAMED LUPO
		((LINE (IF (> (BP-INDEX BP) START-INDEX)
			   (BP-LINE BP)
			   (LINE-PREVIOUS (BP-LINE BP)))
		       (LINE-PREVIOUS LINE))
		 (CRTRAILS (CHAR-EQUAL CHARL #\CR))
		 (FIRST-LINE (BP-LINE LIMIT-BP)))
		((OR (NULL LINE) (EQ LINE FIRST-LINE))
		 (IF FIXUP-P (COPY-BP LIMIT-BP) NIL))
	      (AND LINES-TO-SEARCH
		   (ZEROP (SETQ LINES-TO-SEARCH (1- LINES-TO-SEARCH)))
		   (RETURN-FROM SEARCH-CR-FULL (BEG-LINE (CREATE-BP LINE 0) 1) T))
	      (COND ((OR CRTRAILS (AND (> (LINE-LENGTH LINE) START-INDEX)
				       (CHAR-EQUAL CHARL (AREF LINE START-INDEX))))
		     (LET ((I (1- STRING-LENGTH)))
		       (RCHARMAP ((CREATE-BP LINE (1+ START-INDEX))
				  LIMIT-BP
				  (RETURN-FROM LUPO (RCHARMAP-BP-AFTER)))
			 (IF (< I 0)
			     (RETURN-FROM LUPO (RCHARMAP-BP-AFTER)))
			 (IF (NOT (CHAR-EQUAL (RCHARMAP-CHAR) (AREF STRING I)))
			     (RCHARMAP-RETURN NIL)
			     (SETQ I (1- I)))))))))))))

;;; Word search infernal function
(DEFUN WORD-SEARCH (BP KEY &OPTIONAL REVERSE-P FIXUP-P LIMIT-BP &AUX LEN KEY1 LEN1)
  (OR LIMIT-BP (SETQ LIMIT-BP (IF REVERSE-P
				  (INTERVAL-FIRST-BP *INTERVAL*)
				  (INTERVAL-LAST-BP *INTERVAL*))))
  (SETQ LEN (STRING-LENGTH KEY))
  (DO ((I 0 (1+ I)))
      ((OR ( I LEN) ( (WORD-SYNTAX (AREF KEY I)) WORD-ALPHABETIC))
       (SETQ LEN1 I KEY1 (NSUBSTRING KEY 0 I))))
  (COND ((NOT REVERSE-P)
         (DO-NAMED LINES
             ((LINE (BP-LINE BP) (LINE-NEXT LINE))
              (LIMIT (BP-LINE LIMIT-BP))
              (IDX (BP-INDEX BP) 0))
             (NIL)
           (DO-NAMED PER-LINE
               ((LLEN (LINE-LENGTH LINE)))
               (NIL)
             (OR (SETQ IDX (STRING-SEARCH KEY1 LINE IDX))	;Find first word in line
                 (RETURN NIL))
	     (DO-NAMED MATCH-REMAINING-WORDS
		 ((I IDX)			;I index of character in line
		  (J LEN1)			;J index in search key
		  (LINE1 LINE)			;Copy these in case we advance to next line
		  (LLEN1 LLEN))
		 (NIL)
	       ;; Space forward in line to end of this word
	       (DO NIL (NIL)
		 (AND (OR ( I LLEN1)
			  ( (WORD-SYNTAX (AREF LINE1 I)) WORD-ALPHABETIC))
		      (RETURN NIL))
		 (SETQ I (1+ I)))
	       ;; Space forward in key to start of next word
	       ;; If key exhausted, the search succeeds
	       (DO NIL (NIL)
		 (COND (( J LEN)
			(RETURN-FROM LINES (CREATE-BP LINE1 I)))	;Point after last word
		       ((= (WORD-SYNTAX (AREF KEY J)) WORD-ALPHABETIC)
			(RETURN NIL)))
		 (SETQ J (1+ J)))
	       ;; Space forward in line to start of next word.  This may actually
	       ;; be on the next line.
	       (DO NIL (NIL)
		 (COND (( I LLEN1)		;This line used up, advance to next
			(AND (EQ LINE1 LIMIT) (RETURN-FROM MATCH-REMAINING-WORDS))
			(SETQ LINE1 (LINE-NEXT LINE1)
			      LLEN1 (LINE-LENGTH LINE1)
			      I 0))
		       ((= (WORD-SYNTAX (AREF LINE1 I)) WORD-ALPHABETIC)
			(RETURN NIL))
		       (T
			(SETQ I (1+ I)))))
	       ;; Check that these two words match
	       (DO ((CH1 (AREF LINE1 I))
		    (CH2 (AREF KEY J)))
		   (NIL)
		 (COND (( (WORD-SYNTAX CH2) WORD-ALPHABETIC)	;key can be shorter than data
			(RETURN NIL))				;allowing word abbreviation
		       ((NOT (CHAR-EQUAL CH1 CH2))
			(RETURN-FROM MATCH-REMAINING-WORDS)))
		 (SETQ CH1 (IF ( (SETQ I (1+ I)) LLEN1) #\CR (AREF LINE1 I)))
		 (SETQ CH2 (IF ( (SETQ J (1+ J)) LEN) #\CR (AREF KEY J)))))
	     (SETQ IDX (1+ IDX)))		;search for next instance of first word
           (AND (EQ LINE LIMIT)
                (RETURN (AND FIXUP-P (COPY-BP LIMIT-BP))))))
        (T
         (DO-NAMED LINES
             ((LINE (BP-LINE BP) (LINE-PREVIOUS LINE))
              (LIMIT (BP-LINE LIMIT-BP))
              (FORWARD-LIMIT (BP-LINE (INTERVAL-LAST-BP *INTERVAL*)))
	      (IDX (BP-INDEX BP) NIL))
             (NIL)
           (DO-NAMED PER-LINE
               ((LLEN (LINE-LENGTH LINE)))
               (NIL)
             (OR (SETQ IDX (STRING-REVERSE-SEARCH KEY1 LINE IDX))
                 (RETURN NIL))
	     (DO-NAMED MATCH-REMAINING-WORDS
		 ((I IDX)			;I index of character in line
		  (J LEN1)			;J index in search key
		  (LINE1 LINE)			;Copy these in case we advance to next line
		  (LLEN1 LLEN))
		 (NIL)
	       ;; Space forward in line to end of this word
	       (DO NIL (NIL)
		 (AND (OR ( I LLEN1)
			  ( (WORD-SYNTAX (AREF LINE1 I)) WORD-ALPHABETIC))
		      (RETURN NIL))
		 (SETQ I (1+ I)))
	       ;; Space forward in key to start of next word
	       ;; If key exhausted, the search succeeds
	       (DO NIL (NIL)
		 (COND (( J LEN)
			(RETURN-FROM LINES (CREATE-BP LINE IDX))) ;Point before first word
		       ((= (WORD-SYNTAX (AREF KEY J)) WORD-ALPHABETIC)
			(RETURN NIL)))
		 (SETQ J (1+ J)))
	       ;; Space forward in line to start of next word.  This may actually
	       ;; be on the next line.
	       (DO NIL (NIL)
		 (COND (( I LLEN1)		;This line used up, advance to next
			(AND (EQ LINE1 FORWARD-LIMIT) (RETURN-FROM MATCH-REMAINING-WORDS))
			(SETQ LINE1 (LINE-NEXT LINE1)
			      LLEN1 (LINE-LENGTH LINE1)
			      I 0))
		       ((= (WORD-SYNTAX (AREF LINE1 I)) WORD-ALPHABETIC)
			(RETURN NIL))
		       (T
			(SETQ I (1+ I)))))
	       ;; Check that these two words match
	       (DO ((CH1 (AREF LINE1 I))
		    (CH2 (AREF KEY J)))
		   (NIL)
		 (COND (( (WORD-SYNTAX CH2) WORD-ALPHABETIC)	;key can be shorter than data
			(RETURN NIL))				;allowing word abbreviation
		       ((NOT (CHAR-EQUAL CH1 CH2))
			(RETURN-FROM MATCH-REMAINING-WORDS)))
		 (SETQ CH1 (IF ( (SETQ I (1+ I)) LLEN1) #\CR (AREF LINE1 I)))
		 (SETQ CH2 (IF ( (SETQ J (1+ J)) LEN) #\CR (AREF KEY J)))))
	     (SETQ IDX (+ IDX (STRING-LENGTH KEY1) -1)))
           (AND (EQ LINE LIMIT)
                (RETURN (AND FIXUP-P (COPY-BP LIMIT-BP))))))))

(DEFUN SEARCH-SET (BP LIST &OPTIONAL REVERSEP FIXUP-P LIMIT-BP &AUX CH)
  (OR LIMIT-BP (SETQ LIMIT-BP (IF REVERSEP
				  (INTERVAL-FIRST-BP *INTERVAL*)
				  (INTERVAL-LAST-BP *INTERVAL*))))
  (IF (NOT REVERSEP)
      (CHARMAP (BP LIMIT-BP (AND FIXUP-P LIMIT-BP))
	(AND (MEMQ (SETQ CH (CHARMAP-CH-CHAR)) LIST)
	     (CHARMAP-RETURN (CHARMAP-BP-AFTER) CH)))
      (RCHARMAP (BP LIMIT-BP (AND FIXUP-P LIMIT-BP))
	(AND (MEMQ (SETQ CH (RCHARMAP-CH-CHAR)) LIST)
	     (RCHARMAP-RETURN (RCHARMAP-BP-BEFORE) CH)))))

(DEFVAR *LAST-DELIMITED-SEARCH-STRING* NIL)
(DEFVAR *LAST-DELIMITED-SEARCH-STRING-WITH-DELIMITERS*)

(DEFUN DELIMITED-SEARCH (BP STRING &OPTIONAL REVERSE-P FIXUP-P LIMIT-BP)
  (SETQ STRING (IF (EQ STRING *LAST-DELIMITED-SEARCH-STRING*)
		   *LAST-DELIMITED-SEARCH-STRING-WITH-DELIMITERS*
		   (SETQ *LAST-DELIMITED-SEARCH-STRING* STRING)
		   (LET* ((LENGTH (STRING-LENGTH STRING))
			  (NEW-STRING (MAKE-ARRAY NIL 'ART-16B (+ LENGTH 2))))
		     (ASET 20005 NEW-STRING 0)
		     (COPY-ARRAY-PORTION STRING 0 LENGTH NEW-STRING 1 (1+ LENGTH))
		     (ASET 20005 NEW-STRING (1+ LENGTH))
		     (SETQ *LAST-DELIMITED-SEARCH-STRING-WITH-DELIMITERS*
			   (NCONS NEW-STRING)))))
  (SETQ BP (FSM-SEARCH BP STRING REVERSE-P FIXUP-P NIL LIMIT-BP))
  (AND BP (IF REVERSE-P (IBP BP) (DBP BP))))

(DEFUN SEARCH-RING-PUSH (STRING FCN)
  (AND (NUMBERP (CAAR *SEARCH-RING*)) (SETQ *SEARCH-RING* (CDR *SEARCH-RING*)))
  (PUSH (LIST STRING FCN) *SEARCH-RING*)
  (AND (> (LENGTH *SEARCH-RING*) *SEARCH-RING-MAX*)
       (DELETE-LAST-ELEMENT *SEARCH-RING*)))

(DEFUN SEARCH-RING-POP (&AUX KEY FCN)
  (COND ((NULL *SEARCH-RING*)
	 (BARF))
	(T
	 (SETQ KEY (CAAR *SEARCH-RING*)
	       FCN (CADAR *SEARCH-RING*))
	 (SETQ *SEARCH-RING*
	       (NCONC (CDR *SEARCH-RING*)
		      (RPLACD *SEARCH-RING* NIL)))
	 (VALUES KEY FCN))))

;;; Returns the number of replacements that were made.
(DEFUN REPLACE-STRING (BP FROM TO &OPTIONAL TIMES)
  (LET ((LEN (STRING-LENGTH FROM)))
    (DOTIMES (I (OR TIMES 7777777))
      (OR (SETQ BP (SEARCH BP FROM)) (RETURN I))
      (SETQ BP (CASE-REPLACE (FORWARD-CHAR BP (- LEN)) BP TO T)))))

(DEFUN CHAR-UPPERCASE-P (CHAR)
  (SETQ CHAR (LDB %%CH-CHAR CHAR))
  (AND ( CHAR #/A) ( CHAR #/Z)))

(DEFUN CHAR-LOWERCASE-P (CHAR)
  (SETQ CHAR (LDB %%CH-CHAR CHAR))
  (AND ( CHAR #/a) ( CHAR #/z)))

;; Replace the given interval with the given chars.  If *case-replace-p*
;; is set, attempt to maintain case compatibility.  Returns a BP to the end
;; of the newly inserted stuff.
(DEFUN CASE-REPLACE (BP1 BP2 TO &OPTIONAL IN-ORDER-P &AUX BP FIRST SECOND)
  (OR IN-ORDER-P (ORDER-BPS BP1 BP2))
  (WITH-BP (BP3 BP1 ':NORMAL)
    (COND ((NOT *CASE-REPLACE-P*)
	   (DELETE-INTERVAL BP1 BP2 T)
	   (INSERT BP3 TO))
	  (T
	   ;; Get the first alphabetic char, and following char.
	   (SETQ BP (FORWARD-TO-WORD BP1 1 T))
	   (SETQ FIRST (BP-CHAR BP))
	   (SETQ BP (FORWARD-CHAR BP 1 T))
	   (SETQ SECOND (BP-CHAR BP))
	   ;; Now do the replacement, leaving BP3 and BP2 denoting the region.
	   (DELETE-INTERVAL BP1 BP2)
	   (SETQ BP2 (INSERT BP3 (IN-CURRENT-FONT TO (LDB %%CH-FONT FIRST))))
	   (COND ((CHAR-UPPERCASE-P FIRST)
		  (COND ((OR (CHAR-UPPERCASE-P SECOND)
			     (AND (NOT (CHAR-LOWERCASE-P SECOND))
				  (GET *MAJOR-MODE* 'ALL-UPPERCASE)))
			 ;; They are both upper case or the second one is not alphabetic
			 ;; and this mode has all uppercase.  Uppercasify the whole thing.
			 (UPCASE-INTERVAL BP3 BP2 T))
			(T
			 ;; Only the first is uppercase.  Capitalize on this fact.
			 (UPCASE-CHAR BP3)))))
	   BP2))))

;;; FSM character search

;;; Format of characters in target strings:
(DEFVAR %%FSM-NOT 1701)			;match any but this char
(DEFVAR %%FSM-STAR 1601)		;match zero or more of this char
(DEFVAR %%FSM-SET 1501)			;match member of set, rather than char
(DEFVAR %%FSM-STAR1 1401)		;match one or more of this char
(DEFVAR %FSM-NOOP (DPB 1 1301 0))	;ignore this when building fsm
(DEFVAR %%FSM-CHAR %%CH-CHAR)		;actual character or set index

;;; Set lists, a list in place of a character means all characters in that range
;;; inclusive.  A symbol in place of the whole list means a predicate applied to
;;; all characters.
(DEFVAR *FSM-SEARCH-SET-LIST*
  '((#\SP #\TAB #\BS)			;0 - linear whitespace
    (#\SP #\TAB #\BS #\CR)		;1 - all whitespace
    ((#/A #/Z) (#/a #/z))		;2 - alphabetic
    ((#/0 #/9))				;3 - digits
    ((#/A #/Z))				;4 - uppercase
    FSM-WORD-DELIMITER-CHAR-P		;5 - word delimiter
    FSM-ATOM-DELIMITER-CHAR-P		;6 - atom delimiter
    FSM-TRUE				;7 - any charactera
    ))

(DEFVAR *FSM-STRING-LIST* NIL)		;strings last searched for
(DEFVAR *FSM-CHARACTER-TABLE*)		;character  character_type
(DEFVAR *FSM-STATE-TABLE*)		;state,character_type  new_state
(DEFVAR *FSM-WORD-TABLE*)		;state  word_found
(DEFVAR *FSM-SEARCH-SET-TABLE*)		;search_set  list of character_type's
(DEFVAR *FSM-BACKPOINTER-TABLE*)	;state  back_state
(DEFVAR *FSM-CHARACTER-SET-TABLE*)	;character  set_number's
(DEFVAR *FSM-CHARACTER-SET-TABLE-16*)	;indirect array to above

;;; Build the fsm from the string list
(DEFUN BUILD-FSM (STRING-LIST &OPTIONAL CASE-DEPENDENT-P &AUX NCHARN NSTATES)
  (SETQ *FSM-STRING-LIST* STRING-LIST)
  (SETQ NCHARN (BUILD-FSM-CHARACTER-SET STRING-LIST CASE-DEPENDENT-P))
  (SETQ NSTATES (BUILD-FSM-TREE STRING-LIST NCHARN))
  (CLEAN-FSM NSTATES NCHARN))

;;; Build up the character translation tables, returns number of character types
(DEFUN BUILD-FSM-CHARACTER-SET (STRING-LIST CASE-DEPENDENT-P &AUX (MAXCHAR 0))
  ;; First pass, get all the alphabetic characters
  (OR (BOUNDP '*FSM-CHARACTER-TABLE*)
      (SETQ *FSM-CHARACTER-TABLE* (MAKE-ARRAY NIL 'ART-16B 400)))
  (FILLARRAY *FSM-CHARACTER-TABLE* '(0))
  (DOLIST (STRING STRING-LIST)
    (DO ((I 0 (1+ I))
	 (LEN (STRING-LENGTH STRING))
	 (CH))
	(( I LEN))
      (OR (LDB-TEST %%FSM-SET (SETQ CH (AREF STRING I)))
	  (COND ((ZEROP (AREF *FSM-CHARACTER-TABLE* (SETQ CH (LDB %%FSM-CHAR CH))))
		 (ASET (SETQ MAXCHAR (1+ MAXCHAR)) *FSM-CHARACTER-TABLE* CH)
		 (AND (NOT CASE-DEPENDENT-P)
		      (OR (AND ( CH #/A) ( CH #/Z))
			  (AND ( CH #/a) ( CH #/z)))
		      (ASET MAXCHAR *FSM-CHARACTER-TABLE* (LOGXOR CH 40))))))))
  ;; Second pass, get the character types for all the sets mentioned
  (IF (NOT (BOUNDP '*FSM-CHARACTER-SET-TABLE*))
      (SETQ *FSM-CHARACTER-SET-TABLE* (MAKE-ARRAY NIL 'ART-1B '(16. 400))
	    *FSM-CHARACTER-SET-TABLE-16* (MAKE-ARRAY NIL 'ART-16B 400
						     *FSM-CHARACTER-SET-TABLE*))
      (FILLARRAY *FSM-CHARACTER-SET-TABLE-16* '(0)))
  (LET ((LEN (LENGTH *FSM-SEARCH-SET-LIST*)))
    (IF (OR (NOT (BOUNDP '*FSM-SEARCH-SET-TABLE*))
	    (< (ARRAY-LENGTH *FSM-SEARCH-SET-TABLE*) LEN))
	(SETQ *FSM-SEARCH-SET-TABLE* (MAKE-ARRAY NIL 'ART-Q LEN))
	(FILLARRAY *FSM-SEARCH-SET-TABLE* '(NIL))))
  (DOLIST (STRING STRING-LIST)
    (DO ((I 0 (1+ I))
	 (LEN (STRING-LENGTH STRING))
	 (CH))
	(( I LEN))
      (AND (LDB-TEST %%FSM-SET (SETQ CH (AREF STRING I)))
	   (NOT (AREF *FSM-SEARCH-SET-TABLE* (SETQ CH (LDB %%FSM-CHAR CH))))
	   (LOCAL-DECLARE ((SPECIAL *LIST*))
	     (LET ((*LIST* NIL))
	       (MAP-OVER-FSM-SEARCH-SET CH
		 #'(LAMBDA (SET CH &AUX CHARN)
		     (IF (ZEROP (SETQ CHARN (AREF *FSM-CHARACTER-TABLE* CH)))
			 (ASET 1 *FSM-CHARACTER-SET-TABLE* SET CH)
			 (OR (MEMQ CHARN *LIST*) (PUSH CHARN *LIST*)))))
	       (ASET (NREVERSE *LIST*) *FSM-SEARCH-SET-TABLE* CH))))))
  ;; Now assign character types for all the set intersections
  (DO ((CH 0 (1+ CH))
       (SET-ALIST NIL)
       (MASK) (ENTRY))
      (( CH 400))
    (COND ((NOT (ZEROP (SETQ MASK (AREF *FSM-CHARACTER-SET-TABLE-16* CH))))
	   (COND ((NOT (SETQ ENTRY (ASSQ MASK SET-ALIST)))
		  (PUSH (SETQ ENTRY (CONS MASK (SETQ MAXCHAR (1+ MAXCHAR)))) SET-ALIST)
		  (DO ((SET 0 (1+ SET))
		       (BIT 0001 (+ BIT 0100)))
		      (( SET 16.))
		    (AND (LDB-TEST BIT MASK)
			 (PUSH MAXCHAR (AREF *FSM-SEARCH-SET-TABLE* SET))))))
	   (ASET (CDR ENTRY) *FSM-CHARACTER-TABLE* CH))))
  ;; Finally return the number of character types
  (1+ MAXCHAR))

;;; Apply FUNCTION to all members of a character set,
;;; FUNCTION is caled with SET-NUMBER and character
(DEFUN MAP-OVER-FSM-SEARCH-SET (SET-NUMBER FUNCTION &AUX SET)
  (SETQ SET (NTH SET-NUMBER *FSM-SEARCH-SET-LIST*))
  (IF (NLISTP SET)
      (DOTIMES (CH 400)
	(AND (FUNCALL SET CH) (FUNCALL FUNCTION SET-NUMBER CH)))
      (DOLIST (CHAR SET)
	(IF (NUMBERP CHAR)
	    (FUNCALL FUNCTION SET-NUMBER CHAR)
	    (DO ((CH (CAR CHAR) (1+ CH))
		 (LIM (CADR CHAR)))
		((> CH LIM))
	      (FUNCALL FUNCTION SET-NUMBER CH))))))

(DEFUN FSM-WORD-DELIMITER-CHAR-P (CH)
  (OR (> CH 220) (= (WORD-SYNTAX CH) WORD-DELIMITER)))

(DEFUN FSM-ATOM-DELIMITER-CHAR-P (CH)
  (OR (> CH 220) (= (ATOM-WORD-SYNTAX CH) WORD-DELIMITER)))

(DEFUN FSM-CHAR-TRUE (IGNORE) T)

(LOCAL-DECLARE ((SPECIAL *NCHARN* *MAXSTATE*))

;;; Build the actual tree from the strings, NCHARN is the number of character types,
;;; Returns the number of states
(DEFUN BUILD-FSM-TREE (STRING-LIST *NCHARN* &AUX (*MAXSTATE* 0))
  (OR (BOUNDP '*FSM-STATE-TABLE*)
      (SETQ *FSM-STATE-TABLE* (MAKE-ARRAY NIL 'ART-16B '(1000. 200))))
  (DOTIMES (I (ARRAY-DIMENSION-N 1 *FSM-STATE-TABLE*))
    (DOTIMES (J (ARRAY-DIMENSION-N 2 *FSM-STATE-TABLE*))
      (ASET 0 *FSM-STATE-TABLE* I J)))
  (OR (BOUNDP '*FSM-WORD-TABLE*)
      (SETQ *FSM-WORD-TABLE* (MAKE-ARRAY NIL 'ART-Q 1000.)))
  (FILLARRAY *FSM-WORD-TABLE* '(NIL))
  (DOLIST (STRING STRING-LIST)
    (BUILD-FSM-TREE-1 STRING 0 0 (STRING-LENGTH STRING)))
  (1+ *MAXSTATE*))

;; Handle a single character
(DEFUN BUILD-FSM-TREE-1 (STRING INDEX STATE LENGTH &AUX CHAR NOT-P STAR-P SET-P CH STAR1-P)
  (COND (( INDEX LENGTH)
	 (ASET STRING *FSM-WORD-TABLE* STATE))	;End of string, save winner
	((= (SETQ CHAR (AREF STRING INDEX)) %FSM-NOOP)
	 (BUILD-FSM-TREE-1 STRING (1+ INDEX) STATE LENGTH))
	(T
	 (SETQ NOT-P (LDB-TEST %%FSM-NOT CHAR)
	       STAR-P (LDB-TEST %%FSM-STAR CHAR)
	       SET-P (LDB-TEST %%FSM-SET CHAR)
	       STAR1-P (LDB-TEST %%FSM-STAR1 CHAR)
	       CH (LDB %%FSM-CHAR CHAR))
	 (IF SET-P
	     (LET ((SET (AREF *FSM-SEARCH-SET-TABLE* CH)))
	       (IF NOT-P
		   (DOTIMES (NCH *NCHARN*)
		     (OR (MEMQ NCH SET)
			 (BUILD-FSM-TREE-2 STRING INDEX STATE LENGTH NCH STAR-P STAR1-P)))
		   (DOLIST (NCH SET)
		     (BUILD-FSM-TREE-2 STRING INDEX STATE LENGTH NCH STAR-P STAR1-P))))
	     (SETQ CH (AREF *FSM-CHARACTER-TABLE* CH))
	     (IF NOT-P
		 (DOTIMES (NCH *NCHARN*)
		   (OR (= NCH CH)
		       (BUILD-FSM-TREE-2 STRING INDEX STATE LENGTH NCH STAR-P STAR1-P)))
		 (BUILD-FSM-TREE-2 STRING INDEX STATE LENGTH CH STAR-P STAR1-P))))))

;; Handle a single state transition
(DEFUN BUILD-FSM-TREE-2 (STRING INDEX STATE LENGTH CHARN STAR-P STAR1-P &AUX NEW-STATE)
  (AND (OR STAR-P STAR1-P) (ASET (SETQ NEW-STATE STATE) *FSM-STATE-TABLE* STATE CHARN))
  (AND (OR (NOT STAR-P) STAR1-P)
       (AND (ZEROP (SETQ NEW-STATE (AREF *FSM-STATE-TABLE* STATE CHARN)))
	    (ASET (SETQ NEW-STATE (SETQ *MAXSTATE* (1+ *MAXSTATE*)))
		  *FSM-STATE-TABLE* STATE CHARN)))
  (BUILD-FSM-TREE-1 STRING (1+ INDEX) NEW-STATE LENGTH))

);LOCAL-DECLARE

;;; Clean up the fsm and build up the backpointers
(DEFUN CLEAN-FSM (NSTATES NCHARS)
  (IF (OR (NOT (BOUNDP '*FSM-BACKPOINTER-TABLE*))
	  (< (ARRAY-LENGTH *FSM-BACKPOINTER-TABLE*) NSTATES))
      (SETQ *FSM-BACKPOINTER-TABLE* (MAKE-ARRAY NIL 'ART-Q NSTATES))
      (FILLARRAY *FSM-BACKPOINTER-TABLE* '(NIL)))
  (DOTIMES (STATE NSTATES)
    (DOTIMES (CH NCHARS)
      (LET ((NEW-STATE (AREF *FSM-STATE-TABLE* STATE CH)))
	(AND (> NEW-STATE STATE) (NULL (AREF *FSM-BACKPOINTER-TABLE* NEW-STATE))
	     (LET ((GCTAIL (LET ((BACKPTR (AREF *FSM-BACKPOINTER-TABLE* STATE)))
			     (IF BACKPTR (AREF *FSM-STATE-TABLE* BACKPTR CH) 0))))
	       (ASET GCTAIL *FSM-BACKPOINTER-TABLE* NEW-STATE)
	       (OR (AREF *FSM-WORD-TABLE* NEW-STATE)
		   (ASET (AREF *FSM-WORD-TABLE* GCTAIL) *FSM-WORD-TABLE* NEW-STATE))
	       (DOTIMES (NCH NCHARS)
		 (AND (ZEROP (AREF *FSM-STATE-TABLE* NEW-STATE NCH))
		      (ASET (AREF *FSM-STATE-TABLE* GCTAIL NCH)
			    *FSM-STATE-TABLE* NEW-STATE NCH)))))))
    (LET ((BACKPTR (AREF *FSM-BACKPOINTER-TABLE* STATE)))
      (AND (LET ((WORD (AND BACKPTR (AREF *FSM-WORD-TABLE* BACKPTR))))
	     (OR (NULL WORD) (EQ WORD (AREF *FSM-WORD-TABLE* STATE))))
	   (ASET (AND BACKPTR (AREF *FSM-BACKPOINTER-TABLE* BACKPTR))
		 *FSM-BACKPOINTER-TABLE* STATE)))))

;;; Attempt a matching of a string
(DEFUN MATCH-FSM (STRING)
  (DO ((I 0 (1+ I))
       (LEN (STRING-LENGTH STRING))
       (LIST NIL)
       (STATE 0)
       (CH))
      (( I LEN) (NREVERSE LIST))
    (SETQ CH (AREF *FSM-CHARACTER-TABLE* (LDB %%CH-CHAR (AREF STRING I)))
	  STATE (AREF *FSM-STATE-TABLE* STATE CH))
    (DO ((STATE STATE (AREF *FSM-BACKPOINTER-TABLE* STATE))
	 (OSTATE NIL STATE)
	 (WORD))
	((OR (NULL STATE) (EQ STATE OSTATE)))
      (OR (SETQ WORD (AREF *FSM-WORD-TABLE* STATE))
	  (RETURN NIL))
      (PUSH (LIST (1+ I) WORD) LIST))))

;;; Look for a matching pattern via fsm search
(DEFUN FSM-STRING-SEARCH (KEY STRING &OPTIONAL FROM TO
				     &AUX (LEN (STRING-LENGTH STRING))
					  (STRINGS (CAR KEY)) (EXPR (CADR KEY))
					  (CR-P (CADDR KEY)))
  (OR (EQ STRINGS *FSM-STRING-LIST*)
      (BUILD-FSM STRINGS))
  (OR FROM (SETQ FROM (IF CR-P -1 0)))
  (OR TO (SETQ TO (IF CR-P (1+ LEN) LEN)))
  (DO ((I FROM (1+ I))
       (LIST NIL)
       (STATE 0)
       (CH))
      (( I TO)
       (SETQ LIST (NREVERSE LIST))
       (IF EXPR (FUNCALL EXPR LIST) (CAAR LIST)))
    (SETQ CH (AREF *FSM-CHARACTER-TABLE* (IF (OR (MINUSP I) ( I LEN)) #\CR
					     (LDB %%CH-CHAR (AREF STRING I))))
	  STATE (AREF *FSM-STATE-TABLE* STATE CH))
    (DO ((STATE STATE (AREF *FSM-BACKPOINTER-TABLE* STATE))
	 (OSTATE NIL STATE)
	 (WORD))
	((OR (NULL STATE) (EQ STATE OSTATE)))
      (OR (SETQ WORD (AREF *FSM-WORD-TABLE* STATE))
	  (RETURN NIL))
      (PUSH (LIST (1+ I) WORD) LIST))))

;;; Do fsm search within lines
(DEFUN FSM-SEARCH-WITHIN-LINES (BP KEY &OPTIONAL REVERSE-P FIXUP-P IGNORE LIMIT-BP
				       &AUX (START-LINE (BP-LINE BP))
					    (START-INDEX (BP-INDEX BP)))
  (OR LIMIT-BP (SETQ LIMIT-BP (IF REVERSE-P
				  (INTERVAL-FIRST-BP *INTERVAL*)
				  (INTERVAL-LAST-BP *INTERVAL*))))
  (IF (NOT REVERSE-P)
      (DO ((LINE START-LINE (LINE-NEXT LINE))
	   (LAST-LINE (BP-LINE LIMIT-BP))
	   (LAST-INDEX (BP-INDEX LIMIT-BP))
	   (INDEX))
	  (NIL)
	(AND (SETQ INDEX (FSM-STRING-SEARCH KEY LINE
					    (AND (EQ LINE START-LINE) START-INDEX)
					    (AND (EQ LINE LAST-LINE) LAST-INDEX)))
	     (RETURN (CREATE-BP LINE INDEX)))
	(AND (EQ LINE LAST-LINE)
	     (RETURN (AND FIXUP-P LIMIT-BP))))
      (DO ((LINE START-LINE (LINE-NEXT LINE))
	   (FIRST-LINE (BP-LINE LIMIT-BP))
	   (FIRST-INDEX (BP-INDEX LIMIT-BP))
	   (INDEX))
	  (NIL)
	(AND (SETQ INDEX (FSM-STRING-SEARCH KEY LINE
					    (AND (EQ LINE FIRST-LINE) FIRST-INDEX)
					    (AND (EQ LINE START-LINE) START-INDEX)))
	     (RETURN (CREATE-BP LINE INDEX)))
	(AND (EQ LINE FIRST-LINE)
	     (RETURN (AND FIXUP-P LIMIT-BP))))))

;;; Search by characters
(DEFUN FSM-SEARCH (BP STRINGS &OPTIONAL REVERSE-P FIXUP-P IGNORE LIMIT-BP (STATE 0)
			      &AUX WORD)
  (OR LIMIT-BP (SETQ LIMIT-BP (IF REVERSE-P
				  (INTERVAL-FIRST-BP *INTERVAL*)
				  (INTERVAL-LAST-BP *INTERVAL*))))
  (AND REVERSE-P (FERROR NIL "Backwards FSM search does not work, bitch at MMcM"))
  (OR (EQ STRINGS *FSM-STRING-LIST*)
      (BUILD-FSM STRINGS))
  (CHARMAP (BP LIMIT-BP (AND FIXUP-P LIMIT-BP))
    (SETQ STATE (AREF *FSM-STATE-TABLE* STATE (AREF *FSM-CHARACTER-TABLE* (CHARMAP-CH-CHAR))))
    (AND (SETQ WORD (AREF *FSM-WORD-TABLE* STATE))
	 (CHARMAP-RETURN (CHARMAP-BP-AFTER) WORD STATE))))

(DEFUN FSM-EXPR-SEARCH (BP KEY &OPTIONAL REVERSE-P FIXUP-P IGNORE LIMIT-BP (STATE 0)
			       &AUX (STRINGS (CAR KEY)) (EXPR (CADR KEY)) LIST)
  (AND REVERSE-P (FERROR NIL "Backwards FSM search does not work, bitch at MMcM"))
  (OR (EQ STRINGS *FSM-STRING-LIST*)
      (BUILD-FSM STRINGS))
  (CHARMAP (BP LIMIT-BP (AND FIXUP-P LIMIT-BP))
    (SETQ STATE (AREF *FSM-STATE-TABLE* STATE (AREF *FSM-CHARACTER-TABLE* (CHARMAP-CH-CHAR))))
    (DO ((STATE STATE (AREF *FSM-BACKPOINTER-TABLE* STATE))
	 (OSTATE NIL STATE)
	 (WORD))
	((OR (NULL STATE) (EQ STATE OSTATE)))
      (OR (SETQ WORD (AREF *FSM-WORD-TABLE* STATE))
	  (RETURN NIL))
      (PUSH (LIST (CHARMAP-BP-BEFORE) WORD) LIST)))
  (SETQ LIST (NREVERSE LIST))
  (IF EXPR (FUNCALL EXPR LIST) (CAAR LIST)))

(DEFVAR *SEARCH-MINI-BUFFER-COMTAB*)
(DEFVAR *STRING-SEARCH-MINI-BUFFER-COMTAB*)
(DEFVAR *SEARCH-CONTROL-H-COMTAB*)
(DEFVAR *STRING-SEARCH-CONTROL-H-COMTAB*)
(DEFVAR *STRING-SEARCH-SINGLE-LINE-COMTAB*)
(DEFUN INITIALIZE-EXTENDED-SEARCH ()
  (COND ((NOT (BOUNDP '*SEARCH-MINI-BUFFER-COMTAB*))
	 (SETQ *SEARCH-CONTROL-H-COMTAB*
	       (SET-COMTAB NIL '(#/( COM-EXTENDED-SEARCH-OPEN
				 #/) COM-EXTENDED-SEARCH-CLOSE
				 #/ COM-EXTENDED-SEARCH-OR
				 #/O COM-EXTENDED-SEARCH-OR
				 #/ COM-EXTENDED-SEARCH-AND
				 #/& COM-EXTENDED-SEARCH-AND
				 #/~ COM-EXTENDED-SEARCH-NOT
				 #\SP COM-EXTENDED-SEARCH-WHITESPACE
				 #/- COM-EXTENDED-SEARCH-DELIMITER
				 #/A COM-EXTENDED-SEARCH-ALPHABETIC
				 #/* COM-EXTENDED-SEARCH-SOME
				 #/X COM-EXTENDED-SEARCH-ANY
				 #\HELP COM-DOCUMENT-CONTAINING-PREFIX-COMMAND
				 )))
	 (SET-COMTAB-CONTROL-INDIRECTION *SEARCH-CONTROL-H-COMTAB*)
	 (SETQ *SEARCH-MINI-BUFFER-COMTAB*
	       (SET-COMTAB NIL (LIST #\HELP 'COM-DOCUMENT-EXTENDED-SEARCH
				     #/H (MAKE-EXTENDED-COMMAND *SEARCH-CONTROL-H-COMTAB*))))
	 (SET-COMTAB-INDIRECTION *SEARCH-MINI-BUFFER-COMTAB* *MINI-BUFFER-COMTAB*)))
  (COND ((NOT (BOUNDP '*STRING-SEARCH-CONTROL-H-COMTAB*))
	 (SETQ *STRING-SEARCH-CONTROL-H-COMTAB*
	       (SET-COMTAB NIL '(#/B COM-EXTENDED-SEARCH-BEGINNING
				 #/E COM-EXTENDED-SEARCH-END
				 #/F COM-EXTENDED-SEARCH-TOP-LINE
				 #/R COM-EXTENDED-SEARCH-REVERSE)))
	 (SET-COMTAB-INDIRECTION *STRING-SEARCH-CONTROL-H-COMTAB* *SEARCH-CONTROL-H-COMTAB*)
	 (SETQ *STRING-SEARCH-MINI-BUFFER-COMTAB*
	       (SET-COMTAB NIL (LIST #/ 'COM-END-OF-MINI-BUFFER
				     #\HELP 'COM-DOCUMENT-EXTENDED-SEARCH
				     #/H (MAKE-EXTENDED-COMMAND
					     *STRING-SEARCH-CONTROL-H-COMTAB*))))
	 (SET-COMTAB-INDIRECTION *STRING-SEARCH-MINI-BUFFER-COMTAB*
				 *MINI-BUFFER-MULTI-LINE-COMTAB*)))
  (COND ((NOT (BOUNDP '*STRING-SEARCH-SINGLE-LINE-COMTAB*))
	 (SETQ *STRING-SEARCH-SINGLE-LINE-COMTAB*
	       (SET-COMTAB NIL '(#\CR COM-END-OF-MINI-BUFFER)))
	 (SET-COMTAB-INDIRECTION *STRING-SEARCH-SINGLE-LINE-COMTAB*
				 *STRING-SEARCH-MINI-BUFFER-COMTAB*))))

(ADD-INITIALIZATION "INITIALIZE-EXTENDED-SEARCH" '(INITIALIZE-EXTENDED-SEARCH)
		    '(:NORMAL) '*EDITOR-INITIALIZATION-LIST*)

(DEFUN GET-SEARCH-MINI-BUFFER-WINDOW ()
  (FUNCALL *MODE-LINE-WINDOW* ':SEARCH-MINI-BUFFER-WINDOW))

(DEFVAR *SEARCH-MINI-BUFFER-NAME*)
(DEFUN GET-EXTENDED-SEARCH-STRINGS (*SEARCH-MINI-BUFFER-NAME*
				    &AUX STR STRINGS EXPR CR-P FUNCTION)
  (DECLARE (RETURN-LIST FUNCTION ARG))
  (LET ((*MINI-BUFFER-WINDOW* (GET-SEARCH-MINI-BUFFER-WINDOW)))
    (EDIT-IN-MINI-BUFFER *SEARCH-MINI-BUFFER-COMTAB* NIL NIL '(*SEARCH-MINI-BUFFER-NAME*)))
  (SETQ STR (SEARCH-MINI-BUFFER-STRING-INTERVAL))
  (MULTIPLE-VALUE (STRINGS EXPR CR-P)
    (PARSE-EXTENDED-SEARCH-STRING STR))
  (IF (OR (LISTP STRINGS) CR-P)
      (SETQ FUNCTION 'FSM-STRING-SEARCH
	    STRINGS (LIST (IF (LISTP STRINGS) STRINGS (NCONS STRINGS)) EXPR CR-P))
      (SETQ FUNCTION 'STRING-SEARCH))
  (VALUES FUNCTION STRINGS STR))

(DEFCOM COM-DOCUMENT-EXTENDED-SEARCH "Simple help for hairy search" ()
  (FORMAT T "~%You are typing in a search string.  Control-H is a prefix for more commands.")
  DIS-NONE)

(DEFCOM COM-EXTENDED-SEARCH-OPEN "Beginning of new nesting level" ()
  (INSERT-MOVING (POINT) (DPB 1 %%CH-FONT 0))
  DIS-TEXT)

(DEFCOM COM-EXTENDED-SEARCH-CLOSE "End of nesting level" ()
  (INSERT-MOVING (POINT) (DPB 1 %%CH-FONT 1))
  DIS-TEXT)

(DEFCOM COM-EXTENDED-SEARCH-OR "Infix or of two strings" ()
  (INSERT-MOVING (POINT) (DPB 1 %%CH-FONT 2))
  DIS-TEXT)

(DEFCOM COM-EXTENDED-SEARCH-AND "Infix and of two string with lines" ()
  (INSERT-MOVING (POINT) (DPB 1 %%CH-FONT 3))
  DIS-TEXT)

(DEFCOM COM-EXTENDED-SEARCH-NOT "Negation on next character" ()
  (INSERT-MOVING (POINT) (DPB 1 %%CH-FONT 4))
  DIS-TEXT)

(DEFCOM COM-EXTENDED-SEARCH-WHITESPACE "Match any whitespace character" ()
  (INSERT-MOVING (POINT) (DPB 1 %%CH-FONT 5))
  DIS-TEXT)

(DEFCOM COM-EXTENDED-SEARCH-SOME "Match any number of next character" ()
  (INSERT-MOVING (POINT) (DPB 1 %%CH-FONT 6))
  DIS-TEXT)

(DEFCOM COM-EXTENDED-SEARCH-DELIMITER "Match any delimiter" ()
  (INSERT-MOVING (POINT) (DPB 1 %%CH-FONT 7))
  DIS-TEXT)

(DEFCOM COM-EXTENDED-SEARCH-ALPHABETIC "Match any alphabetic character" ()
  (INSERT-MOVING (POINT) (DPB 1 %%CH-FONT 10))
  DIS-TEXT)

(DEFCOM COM-EXTENDED-SEARCH-ANY "Match any character" ()
  (INSERT-MOVING (POINT) (DPB 1 %%CH-FONT 11))
  DIS-TEXT)

(DEFVAR *EXTENDED-STRING-SEARCH-LAST-ARG* "")
(DEFVAR *EXTENDED-STRING-SEARCH-LAST-FUNCTION* 'SEARCH)
(DEFCOM COM-EXTENDED-STRING-SEARCH "Search for a hairy string
String is read in a mini-buffer in which Control-H is a prefix for special characters" ()
  (EXTENDED-STRING-SEARCH-INTERNAL NIL))

(DEFCOM COM-EXTENDED-REVERSE-STRING-SEARCH "Search for a hairy string backward
String is read in a mini-buffer in which Control-H is a prefix for special characters" ()
  (EXTENDED-STRING-SEARCH-INTERNAL T))

(DEFUN EXTENDED-STRING-SEARCH-INTERNAL (REVERSE-P &AUX (BP (POINT)) BJ-P TOP-LINE-P)
  (OR *NUMERIC-ARG-P*
      (MULTIPLE-VALUE (*EXTENDED-STRING-SEARCH-LAST-FUNCTION*
		       *EXTENDED-STRING-SEARCH-LAST-ARG*
		       REVERSE-P BJ-P TOP-LINE-P)
	(GET-EXTENDED-STRING-SEARCH-STRINGS REVERSE-P)))
  (AND BJ-P
       (SETQ BP (IF REVERSE-P (INTERVAL-LAST-BP *INTERVAL*) (INTERVAL-FIRST-BP *INTERVAL*))))
  (OR (SETQ BP (FUNCALL *EXTENDED-STRING-SEARCH-LAST-FUNCTION* BP
			*EXTENDED-STRING-SEARCH-LAST-ARG* REVERSE-P))
      (BARF))
  (MOVE-BP (POINT) BP)
  DIS-BPS)

(DEFVAR *EXTENDED-STRING-SEARCH-BJ-P*)
(DEFVAR *EXTENDED-STRING-SEARCH-ZJ-P*)
(DEFVAR *EXTENDED-STRING-SEARCH-REVERSE-P*)
(DEFVAR *EXTENDED-STRING-SEARCH-TOP-LINE-P*)

;;; Read a string for string search and then return the function to use
(DEFUN GET-EXTENDED-STRING-SEARCH-STRINGS (&OPTIONAL *EXTENDED-STRING-SEARCH-REVERSE-P*
						     (*SEARCH-MINI-BUFFER-NAME* "Search:")
						   (COMTAB *STRING-SEARCH-MINI-BUFFER-COMTAB*)
					   &AUX (*EXTENDED-STRING-SEARCH-BJ-P* NIL)
						(*EXTENDED-STRING-SEARCH-ZJ-P* NIL)
						(*EXTENDED-STRING-SEARCH-TOP-LINE-P* NIL)
						STRINGS EXPR CR-P FUNCTION)
  (DECLARE (RETURN-LIST FUNCTION ARG REVERSE-P BJ-P TOP-LINE-P))
  (LET ((*MINI-BUFFER-WINDOW* (GET-SEARCH-MINI-BUFFER-WINDOW)))
    (EDIT-IN-MINI-BUFFER COMTAB NIL NIL
			 '((*EXTENDED-STRING-SEARCH-BJ-P* "BJ ")
			   (*EXTENDED-STRING-SEARCH-ZJ-P* "ZJ ")
			   (*EXTENDED-STRING-SEARCH-REVERSE-P* "Reverse ")
			   (*EXTENDED-STRING-SEARCH-TOP-LINE-P* "Top line ")
			   *SEARCH-MINI-BUFFER-NAME*)))
  (MULTIPLE-VALUE (STRINGS EXPR CR-P)
    (PARSE-EXTENDED-SEARCH-STRING))
  (IF (LISTP STRINGS)
      (IF EXPR
	  (SETQ FUNCTION 'FSM-SEARCH-WITHIN-LINES
		STRINGS (LIST STRINGS EXPR CR-P))
	  (SETQ FUNCTION 'FSM-SEARCH))
      (SETQ FUNCTION 'SEARCH))
  (VALUES FUNCTION STRINGS
	    *EXTENDED-STRING-SEARCH-REVERSE-P*
	    (OR *EXTENDED-STRING-SEARCH-BJ-P* *EXTENDED-STRING-SEARCH-ZJ-P*)
	    *EXTENDED-STRING-SEARCH-TOP-LINE-P*))

(DEFCOM COM-EXTENDED-SEARCH-BEGINNING "" ()
  (COND ((SETQ *EXTENDED-STRING-SEARCH-BJ-P* (NOT *EXTENDED-STRING-SEARCH-BJ-P*))
	 (SETQ *EXTENDED-STRING-SEARCH-ZJ-P* NIL
	       *EXTENDED-STRING-SEARCH-REVERSE-P* NIL)))
  DIS-NONE)

(DEFCOM COM-EXTENDED-SEARCH-END "" ()
  (COND ((SETQ *EXTENDED-STRING-SEARCH-ZJ-P* (NOT *EXTENDED-STRING-SEARCH-ZJ-P*))
	 (SETQ *EXTENDED-STRING-SEARCH-BJ-P* NIL
	       *EXTENDED-STRING-SEARCH-REVERSE-P* T)))
  DIS-NONE)

(DEFCOM COM-EXTENDED-SEARCH-TOP-LINE "" ()
  (SETQ *EXTENDED-STRING-SEARCH-TOP-LINE-P* (NOT *EXTENDED-STRING-SEARCH-TOP-LINE-P*)))

(DEFCOM COM-EXTENDED-SEARCH-REVERSE "" ()
  (IF (SETQ *EXTENDED-STRING-SEARCH-REVERSE-P* (NOT *EXTENDED-STRING-SEARCH-REVERSE-P*))
      (SETQ *EXTENDED-STRING-SEARCH-BJ-P* NIL)
      (SETQ *EXTENDED-STRING-SEARCH-ZJ-P* NIL))
  DIS-NONE)

(DEFVAR *EXTENDED-SEARCH-CR-P*)
(DEFUN PARSE-EXTENDED-SEARCH-STRING (&OPTIONAL STRING
				     &AUX *EXTENDED-SEARCH-CR-P* STRINGS EXPR LEN)
  (OR STRING
      (SETQ STRING (STRING-INTERVAL (WINDOW-INTERVAL (GET-SEARCH-MINI-BUFFER-WINDOW)))))
  (MULTIPLE-VALUE (STRINGS EXPR LEN)
    (PARSE-EXTENDED-SEARCH-STRING-1 STRING 0 (STRING-LENGTH STRING) 0))
  (AND (NLISTP STRINGS)
       (DOTIMES (I LEN)
	 (AND (LDB-TEST 1010 (AREF STRINGS I))
	      (RETURN T)))
       (SETQ STRINGS (NCONS STRINGS)))
  (OR STRINGS (SETQ STRINGS ""))
  (AND EXPR
       (LET ((SYMBOL (GENSYM)))
	 (FSET SYMBOL `(LAMBDA (MATCHING-LIST) ,EXPR))
	 (COMPILE SYMBOL)
	 (SETQ EXPR SYMBOL)))
  (VALUES STRINGS EXPR *EXTENDED-SEARCH-CR-P*))

(DEFUN PARSE-EXTENDED-SEARCH-STRING-1 (STRING INDEX LENGTH PAREN-LEVEL)
  (DO ((I INDEX (1+ I))
       (SYN) (CH)
       (NEW-STRINGS) (NEW-EXPR)
       (OLD-STRINGS) (OLD-EXPR))
      (NIL)
    (MULTIPLE-VALUE (SYN CH I)
      (PARSE-EXTENDED-SEARCH-STRING-SYNTAX STRING I LENGTH))
    (IF (ZEROP SYN)
	(AND OLD-STRINGS (IF (LISTP OLD-STRINGS)
			     (DO ((OS OLD-STRINGS (CDR OS)))
				 ((NULL OS))
			       (SETF (CAR OS) (STRING-APPEND (CAR OS) CH)))
			     (SETQ OLD-STRINGS (STRING-APPEND OLD-STRINGS CH))))
	(OR OLD-STRINGS
	    (SETQ OLD-STRINGS (AND (NOT (= INDEX I)) (SUBSTRING STRING INDEX I))))
	(COND ((BIT-TEST 120000 SYN)		;EOF or CLOSE
	       (IF (PLUSP PAREN-LEVEL)
		   (AND (= SYN 100000)		;EOF
			(BARF "End of string inside parenthesis"))
		   (AND (= SYN 20000)		;CLOSE
			(BARF "Unmatched close")))
	       (RETURN OLD-STRINGS OLD-EXPR I)))
	(COND ((= SYN 40000)			;OPEN
	       (MULTIPLE-VALUE (NEW-STRINGS NEW-EXPR I)
		 (PARSE-EXTENDED-SEARCH-STRING-1 STRING (1+ I) LENGTH (1+ PAREN-LEVEL)))
	       (IF (NOT OLD-STRINGS)
		   (SETQ OLD-STRINGS NEW-STRINGS)
		   (AND OLD-EXPR (BARF "I don't know how to combine these"))
		   (COND ((LISTP NEW-STRINGS)
			  (AND (LISTP OLD-STRINGS)
			       (BARF "I don't know how to combine these"))
			  (DO ((NS NEW-STRINGS (CDR NS)))
			      ((NULL NS) (SETQ OLD-STRINGS NEW-STRINGS))
			    (SETF (CAR NS) (STRING-APPEND OLD-STRINGS
							  (CAR NS)))))
			 ((LISTP OLD-STRINGS)
			  (DO ((OS OLD-STRINGS (CDR OS)))
			      ((NULL OS))
			    (SETF (CAR OS) (STRING-APPEND (CAR OS) NEW-STRINGS))))
			 (T
			  (SETQ OLD-STRINGS (STRING-APPEND OLD-STRINGS
							   NEW-STRINGS)))))
	       (SETQ OLD-EXPR NEW-EXPR))
	      (T		  
	       (OR OLD-STRINGS (BARF "Special token at the beginning of the string"))
	       (AND (OR (= SYN 10000) NEW-EXPR)
		    (OR OLD-EXPR
			(SETQ OLD-EXPR (IF (LISTP OLD-STRINGS)
					   (CONS 'OR
						 (MAPCAR #'EXTENDED-SEARCH-STRING-MATCHER
							 OLD-STRINGS))
					   (EXTENDED-SEARCH-STRING-MATCHER OLD-STRINGS)))))
	       (OR (LISTP OLD-STRINGS)
		   (SETQ OLD-STRINGS (NCONS OLD-STRINGS)))
	       (MULTIPLE-VALUE (NEW-STRINGS NEW-EXPR I)
		 (PARSE-EXTENDED-SEARCH-STRING-1 STRING (1+ I) LENGTH PAREN-LEVEL))
	       (OR (LISTP NEW-STRINGS)
		   (SETQ NEW-STRINGS (NCONS NEW-STRINGS)))
	       (IF (= SYN 4000)			;OR
		   (RETURN (NCONC OLD-STRINGS NEW-STRINGS)
			   (AND NEW-EXPR `(OR ,OLD-EXPR ,NEW-EXPR))
			   I)
		   (OR NEW-EXPR			;AND
		       (SETQ NEW-EXPR (CONS 'OR
					    (MAPCAR #'EXTENDED-SEARCH-STRING-MATCHER
						    NEW-STRINGS))))
		   (RETURN (NCONC OLD-STRINGS NEW-STRINGS)
			   `(AND ,OLD-EXPR ,NEW-EXPR)
			   I)))))))

(DEFUN PARSE-EXTENDED-SEARCH-STRING-SYNTAX (STRING INDEX LENGTH &OPTIONAL NOT-TOP-LEVEL
							       &AUX CH)
  (IF ( INDEX LENGTH)
      (IF NOT-TOP-LEVEL (BARF "EOF in special context") (VALUES 100000 NIL INDEX))
      (VALUES (IF (ZEROP (LDB %%CH-FONT (SETQ CH (AREF STRING INDEX))))
		  (PROG1 0 (AND (= CH #\CR) (SETQ *EXTENDED-SEARCH-CR-P* T)))
		  (SELECTQ (SETQ CH (LDB %%CH-CHAR CH))
		    (0 40000)			;OPEN
		    (1 20000)			;CLOSE
		    (2 4000)			;AND
		    (3 10000)			;OR
		    ((4 6 !FOO!)		;NOT,SOME,!FOO!
		     (MULTIPLE-VALUE-BIND (SYN NCH)
			 (PARSE-EXTENDED-SEARCH-STRING-SYNTAX STRING (1+ INDEX)
							      LENGTH T)
		       (OR (ZEROP SYN) (BARF "NOT modifier on a special character"))
		       (ASET (SETQ CH (DPB 1 (SELECTQ CH
					       (4 %%FSM-NOT)
					       (6 %%FSM-STAR1)
					       (!FOO! %%FSM-STAR))
					   NCH))
			     STRING INDEX)
		       (ASET %FSM-NOOP STRING (SETQ INDEX (1+ INDEX))))
		     0)
		    ((5 7 10 11)		;WHITESPACE,DELIMITER,ALPHABETIC,ANY
		     (ASET (SETQ CH (DPB 1 %%FSM-SET
					 (SELECTQ CH
					   (5 0)
					   (7 5)
					   (10 2)
					   (11 7))))
			   STRING INDEX)
		     0)
		    (OTHERWISE 0)))
		CH INDEX)))

(DEFUN EXTENDED-SEARCH-STRING-MATCHER (STRING)
  `(DO L MATCHING-LIST (CDR L) (NULL L)
     (AND (EQ (CADAR L) ',STRING) (RETURN (CAAR L)))))

;;; Special handling for search strings
(DEFSTRUCT (16B-STRING :ARRAY-LEADER :NAMED (:MAKE-ARRAY (:LENGTH 20. :TYPE 'ART-FAT-STRING)))
  (16B-STRING-LENGTH 0))

(DEFPROP 16B-STRING 16B-STRING-NAMED-STRUCTURE-INVOKE NAMED-STRUCTURE-INVOKE)
(DEFSELECT 16B-STRING-NAMED-STRUCTURE-INVOKE
  ((:PRINT-SELF) (STRING &OPTIONAL (STREAM STANDARD-OUTPUT) IGNORE SLASHIFY-P)
   (AND SLASHIFY-P (ASSQ #/" (SI:RDTBL-/#-MACRO-ALIST READTABLE))
	(FUNCALL STREAM ':TYO #/#))
   (SI:PRINT-QUOTED-STRING STRING SLASHIFY-P STREAM
			   (MEMQ ':STRING-OUT (FUNCALL STREAM ':WHICH-OPERATIONS)))))

(DEFUN MY-/#/"-MACRO (IGNORE STREAM)
  (DO ((STRING (MAKE-16B-STRING))
       (CHAR)
       (SLASH-P NIL))
      (NIL)
    (SETQ CHAR (FUNCALL STREAM ':TYI))
    (COND (SLASH-P
	   (SETQ SLASH-P NIL)
	   (ARRAY-PUSH-EXTEND STRING CHAR))
	  ((= CHAR #/")
	   (RETURN STRING))
	  ((= CHAR #//)
	   (SETQ SLASH-P T))
	  (T
	   (ARRAY-PUSH-EXTEND STRING CHAR)))))

(DEFVAR SPECIAL-/#/"-READTABLE)
(DEFUN INITIALIZE-SPECIAL-/#/"-READTABLE ()
  (COND ((NOT (BOUNDP 'SPECIAL-/#/"-READTABLE))
	 (SETQ SPECIAL-/#/"-READTABLE (SI:COPY-READTABLE))
	 (SET-SYNTAX-/#-MACRO-CHAR #/" 'MY-/#/"-MACRO SPECIAL-/#/"-READTABLE)))
  SPECIAL-/#/"-READTABLE)

(DEFUN SEARCH-MINI-BUFFER-STRING-INTERVAL (&AUX INT STRING)
  (SETQ INT (WINDOW-INTERVAL (GET-SEARCH-MINI-BUFFER-WINDOW)))
  (LET ((LEN (COUNT-CHARS INT)))
    (SETQ STRING (MAKE-16B-STRING 16B-STRING-LENGTH LEN
				  MAKE-ARRAY (:LENGTH LEN))))
  (LET ((INT-STRING (STRING-INTERVAL INT)))
    (COPY-ARRAY-CONTENTS INT-STRING STRING)
    (RETURN-ARRAY INT-STRING))
  STRING)

;;; Return a string itself, suitable for printing and reading back
(DEFUN GET-EXTENDED-SEARCH-16B-STRING (*SEARCH-MINI-BUFFER-NAME*)
  (LET ((*MINI-BUFFER-WINDOW* (GET-SEARCH-MINI-BUFFER-WINDOW)))
    (EDIT-IN-MINI-BUFFER *SEARCH-MINI-BUFFER-COMTAB* NIL NIL '(*SEARCH-MINI-BUFFER-NAME*)))
  (SEARCH-MINI-BUFFER-STRING-INTERVAL))

;;; Parse something read back
(DEFUN PARSE-EXTENDED-SEARCH-16B-STRING (STRING &AUX FUNCTION STRINGS EXPR)
  (DECLARE (RETURN-LIST FUNCTION KEY))
  (MULTIPLE-VALUE (STRINGS EXPR)
    (PARSE-EXTENDED-SEARCH-STRING STRING))
  (COND ((NLISTP STRINGS)
	 (SETQ FUNCTION 'SEARCH))
	(EXPR
	 (SETQ FUNCTION 'FSM-EXPR-SEARCH
	       STRINGS (LIST STRINGS EXPR)))
	(T
	 (SETQ FUNCTION 'FSM-SEARCH)))
  (VALUES FUNCTION STRINGS))