;;;  -*- Mode:Common-Lisp; Package:ZWEI; Base:10 -*-

;;; Copyright (C) 1986, Texas Instruments Incorporated. All rights reserved.

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1985, Texas Instruments Incorporated. All rights reserved.
;;;
;;;  This file contains the character search commands, which are not supported by TI,
;;;  though they do work.
;;;
;;;  From coms:
;;;
;;;  Character search


(DEFCOM COM-CHAR-SEARCH DOC-CHAR-SEARCH (KM)
  (CHAR-SEARCH-INTERNAL NIL)) 

(DEFUN DOC-CHAR-SEARCH (COMMAND IGNORE TYPE)
  (CASE TYPE
    (:NAME
     (GET COMMAND 'COMMAND-NAME))
    ((:FULL :SHORT)
     (SEND *STANDARD-OUTPUT* :STRING-OUT "Search for a single character.")
     (COND ((EQ TYPE :FULL)
	    (SEND *STANDARD-OUTPUT* :STRING-OUT
		  "
Special characters:
C-A	Do string search (see below).
C-B     Search forward from the beginning of the buffer.
C-E     Search backwards from the end of the buffer.
C-F     Leave the point at the top of the window, if the window must be recentered.
C-R	Search backwards.
C-S	Repeat the last search.

String search, which you get into from C-A, reads in a string and searches for it.
")
	(SEND *STANDARD-OUTPUT* :STRING-OUT *STRING-SEARCH-OPTION-DOCUMENTATION*)
	(SEND *STANDARD-OUTPUT* :STRING-OUT
	      "
This command is not currently supported by TI, but it works in most situations.")))))) 

(DEFCOM COM-REVERSE-CHAR-SEARCH DOC-REVERSE-CHAR-SEARCH (KM)
  (CHAR-SEARCH-INTERNAL T)) 

(DEFUN DOC-REVERSE-CHAR-SEARCH (COMMAND IGNORE TYPE)
  (CASE TYPE
    (:NAME
     (GET COMMAND 'COMMAND-NAME))
    ((:FULL :SHORT)
     (SEND *STANDARD-OUTPUT* :STRING-OUT "Search backward for a single character.")
     (COND ((EQ TYPE :FULL)
	    (SEND *STANDARD-OUTPUT* :STRING-OUT
		  "
Special characters:
C-A	Do Reverse String Search (see below).
C-B     Search forward from the beginning of the buffer.
C-E     Search backwards from the end of the buffer.
C-F	Put the line containing the search object at the top of the screen
C-R	Repeat the last search.
C-S	Repeat the last search.

Reverse String search, which you get into from C-A, reads in a string and searches for it.
")
	(SEND *STANDARD-OUTPUT* :STRING-OUT *STRING-SEARCH-OPTION-DOCUMENTATION*)
	(SEND *STANDARD-OUTPUT* :STRING-OUT
	      "
This command is not currently supported by TI, but it works in most situations.")))))) 


(DEFUN CHAR-SEARCH-INTERNAL (REVERSEP)
  (UNWIND-PROTECT
      (PROG (XCHAR CHAR UCHAR BJP ZJP TOP-P
	     STRING BP FAILED-P QUOTE-P
	     (ORIG-PT (COPY-BP (POINT)))
	     (ARG *NUMERIC-ARG*)
	     (FCN 'SEARCH))
	    (AND (MINUSP ARG)
		 (SETQ REVERSEP (NOT REVERSEP)
		       ARG (- ARG)))
	 LOOP
	    (COND ((OR FAILED-P			;Force redisplay on failing search
		       (NULL (SETQ XCHAR (SEND *STANDARD-INPUT* :READ-CHAR-NO-HANG))))
		   (TYPEIN-LINE-WITH-REDISPLAY "~:|")
		   (AND BJP (FORMAT *QUERY-IO* "Begin "))
		   (AND ZJP (FORMAT *QUERY-IO* "End "))
		   (AND TOP-P (FORMAT *QUERY-IO* "Top Line "))
		   (AND REVERSEP (FORMAT *QUERY-IO* "Reverse "))
		   (AND QUOTE-P (FORMAT *QUERY-IO* "Quoted-ascii "))
		   (FORMAT *QUERY-IO* "Search: ")))
	    (COND ((NOT FAILED-P)
		   (SETQ CHAR (OR XCHAR (TYPEIN-LINE-ACTIVATE (READ-CHAR))))
		   (SETQ UCHAR (CHAR-UPCASE CHAR))
		   (COND (QUOTE-P
			  (OR (ZEROP (CHAR-BITS CHAR))
			      (SETQ CHAR (INT-CHAR (LOGAND 37 (CHAR-CODE CHAR)))))
			  (SETQ STRING CHAR)
			  (SEARCH-RING-PUSH CHAR FCN))
			 ((CHAR= UCHAR #\c-A)
			  (RETURN (COM-STRING-SEARCH-INTERNAL REVERSEP BJP ZJP TOP-P)))
			 ((AND (CHAR= UCHAR #\c-R) (NOT REVERSEP))
			  (SETQ REVERSEP (NOT REVERSEP))
			  (GO LOOP))
			 ((CHAR= UCHAR #\c-B)
			  (SETQ BJP T
				ZJP NIL
				REVERSEP NIL)
			  (GO LOOP))
			 ((CHAR= UCHAR #\c-E)
			  (SETQ ZJP T
				BJP NIL
				REVERSEP T)
			  (GO LOOP))
			 ((CHAR= UCHAR #\c-F)
			  (SETQ *CENTERING-FRACTION* 0.0s0
				TOP-P T)
			  (GO LOOP))
			 ((CHAR= UCHAR #\c-G)
			  (BEEP)
			  (SEND *QUERY-IO* :MAKE-COMPLETE)
			  (GO QUIT))
			 ((OR (CHAR= UCHAR #\c-S)
			      (AND REVERSEP (CHAR= UCHAR #\c-R)))
			  (OR *SEARCH-RING* (BARF))
			  (SETQ STRING (CAAR *SEARCH-RING*)
				FCN (CADAR *SEARCH-RING*)))
			 ((CHAR= UCHAR #\c-Q)	;Funny ascii compatibility
			  (SETQ QUOTE-P T)
			  (GO LOOP))
			 ((> (CHAR-INT CHAR) 220)	;Random control character
			  (BEEP)
			  (GO LOOP))
			 (T
			  (SETQ STRING CHAR)
			  (SEARCH-RING-PUSH CHAR FCN)))))
	    (AND (OR (NULL XCHAR) FAILED-P)
		 (IF (CHARACTERP STRING)
		     (FORMAT *QUERY-IO* "~C×" STRING)
		     (FORMAT *QUERY-IO* "~A×" STRING)))
	    (SETQ BP (AND (NOT FAILED-P)
			  (DO ((I 0 (1+ I))
			       (BP (COND (BJP (INTERVAL-FIRST-BP *INTERVAL*))
					 (ZJP (INTERVAL-LAST-BP *INTERVAL*))
					 (T (POINT)))
				   (FUNCALL FCN BP STRING REVERSEP)))
			      ((OR (>= I ARG)
				   (NULL BP))
			       BP))))
	    (COND (BP
		   (MOVE-BP (POINT) BP))
		  ((OR FAILED-P (NULL XCHAR))
		   (FORMAT *QUERY-IO* " Search failed.")
		   (BARF))
		  (T
		   (SETQ FAILED-P T)
		   (GO LOOP)))			;Failed search typed ahead
	 QUIT
	    (MAYBE-PUSH-POINT ORIG-PT)
	    (RETURN DIS-BPS))
    (SEND *MODE-LINE-WINDOW* :DONE-WITH-MODE-LINE-WINDOW))) 
