File psl-1983/3-1/util/history.sl artifact 5d255989c1 part of check-in 2f3b3fd537


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; File containing functions to create a history mechanism.
;;	(exploited what is there with (inp n) (ans n) and historylist*).
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  This file depends upon : init.lisp (basic lisp functions and syntax).
;;			(in <lanam.dhl>).
;;
;;  This file written by Douglas H. Lanam. September 1982.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; How to use the history mechanism implemented in this file:
;;
;;  This file allows you to take any previous input or output and substitute
;;	it in place of what you typed.  Thus you can either print or redo
;;	any input you have previously done.  You can also print or
;;	execute any result you have previously received.
;;	The system will work identify commands by either their history number,
;;	or by a subword in the input command.
;;
;;	This file also allows you to take any previously expression and do
;;	global substitutions on subwords inside words or numbers inside
;;	expressions(Thus allowing spelling corrections, and other word
;;	changes easily.)
;;
;;	This file has a set of read macros that insert the previous history
;;	text asked for inplace of them selves.  Thus they can be put inside
;;	any lisp expression typed by the user.  The system will evaluate
;;	the resulting expression the same as if the user had retyped everything
;;	in himself.
;;
;;	^^ : means insert last input command inplace of ^^.
;;		As an input command by itself,
;;			^^ by itself means redo last command.
;;
;;	^n : where n is a number replaces itself with the result of
;;		(inp n). ^n by itself means (redo n).
;;	^+n : same as ^n.
;;	^-n : is replaced by the nth back command. 
;;		replaced with the result of
;;		(inp (- current-history-number n)).
;;		by itself means (redo (- current-history-number n))
;;
;;	^word : where word starts with 'a'-'z' or 'A'-'Z', means
;;		take the last input command that has word as a subword
;;		or pattern of what was typed (after readmacros were
;;		executed.), and replace that ^word with that entire input
;;		command.
;;		If you want a word that doesn't begin with 'a'-'z', or 'A'-'Z',
;;		use ^?word where word can be any lisp atom.
;;		(say 23, *, |"ab|, word).
;;		ex.:  1 lisp> (plus 2 3)
;;			5
;;		      2 lisp> (* 4 5)
;;			20
;;		      3 lisp> ^us
;;			(PLUS 2 3)
;;			5
;;		      4 lisp> (* 3 ^lu)
;;			(PLUS 2 3)
;;			15
;;
;;		Case is ignored in word.  Word is read by the command read,
;;		And thus should be a normal lisp atom.  Use the escape
;;		character as needed.
;;
;;	If the first ^ in any of the above commands is replaced with
;;	^@, then instead of (inp n) , the read macro is replaced with
;;	(ans n).  Words are still matched against the input, not the
;;	answer.  (Probably something should be added to allow matching
;;	of subwords against the answer also.)
;;
;;	Thus:(if typed as commands by themselves):
;;	
;;	^@^ = (eval (ans (last-command)))
;;	^@3 = (eval (ans 3))
;;
;;	^@plus = (eval (ans (last-command which has plus as a subword in
;;				its input))).
;;
;;
;; Once the ^ readmacro is replaced with its history expression, you are
;;	allowed to do some editing of the command.  The way to do this
;;	is to type a colon immediately after the ^ command as described
;;	above before any space or other delimiting character.
;;	ex.: ^plus:p 
;;		^2:s/ab/cd/
;;		^^:p
;;		^@^:p
;;
;;	Currently there are two types of editing commands allowed.
;;
;;	:p means print only, do not insert in expression, whole 
;;		read macro returns only nil.
;;
;;	:s/word1/word2/ means take each atom in the expression found,
;;		and if word1 is a subword of that atom, replace the
;;		subword word1 with word2.  Read is used to read word1
;;		and word2, thus the system expects an atom and will
;;		ignore anything after what read sees before the /.
;;		Use escape characters as necessary.
;;
;;	:n where n is a positive unsigned number, means take the nth 
;;		element of the command(must be a list) and return it.
;;	
;;      ^string1^string2^ is equivalent to ^string1:s/string1/string2/
;;	ex.: ^plus^times^  is equivalent to ^plus:s/plus/times/ .
;;
;;	After a :s, ^ or :<n> command you may have another :s command, ^
;;	or a :p
;;	command.  :p command may not be followed by any other command.
;;
;;	The expression as modified by the :s commands is what is
;;	returned in place of the ^ readmacro.
;;	You need a closing / as seen in the :s command above.
;;	After the command you should type a delimiting character if
;;	you wish the next expression to begin with a :, since a :
;;	will be interpreted as another editing command.
;;
;;	On substitution, case is ignored when matching the subword,
;;	and the replacement subword
;;	is capitalized(unless you use an escape character before 
;;	typing a lowercase letter).
;;
;;	Examples:
;;	1 lisp> (plus 23 34)
;;	57
;;	2 lisp> ^^:s/plus/times/
;;	(TIMES 23 34)
;;	782
;;	3 lisp> ^plus:s/3/5/
;;	(PLUS 25 54)
;;	79
;;	4 lisp>
;;
;;
(defmacro unreadch (x) `(unreadchar (id2int ,x)))
(defmacro last-command () `(caadr historylist*))
(defmacro last-answer () `(cdadr historylist*))
(defun nth-command (n part) (cond ((eq part 'input) (inp n))
				  (t (ans n))))

(defun my-nthcdr (l n)
  (cond ((<= n 0) l)
	((null l) nil)
	((my-nthcdr (cdr l) (- n 1)))))

(defvar *print-history-command-expansion t)

(de skip-if (stop-char)
    (let ((x (readch)))
      (or (eq x stop-char) (unreadch x))))

(defun return-command (command)
  (and *print-history-command-expansion
       command
       ($prpr command) (terpri))
  command)

(defun do-history-command-and-return-command (string1 c)
  (let ((command (do-history-command string1 c)))
    (and *print-history-command-expansion command
	 ($prpr command) (terpri))
    command))

(defun nth-back-command (n)
  (do ((i n (+ 1 i))
       (command-list historylist*
		     (cdr command-list)))
      ((eq i 0) (caar command-list))))

(defvar *flink (*makhunk 80))

(defun kmp-flowchart-construction (p m)
  (rplacx 0 *flink -1)
  (do ((i 1 (+ 1 i)))
      ((> i m))
    (do ((j (cxr (- i 1) *flink) (cxr j *flink)))
	((or (= j -1) (= (cxr j p) (cxr (- i 1) p)))
	 (rplacx i *flink (+ j 1))))))

(defun kmp-scan (p m s)
  (and s
       (prog (j)
	 (setq j 0)
	loop (cond ((and (<> j -1) (<> (uppercassify (cxr j p))
				       (uppercassify (car s))))
		    (setq j (cxr j *flink)) (go loop)))
	 (and (= j m) (return t))
	 (or (setq j (+ 1 j) s (cdr s)) (return nil))
	 (go loop))))

(defun match-list-beginnings (starting-list list)
  (do ((x starting-list (cdr x))
       (y list (cdr y)))
      ((null x) t)
    (or (eq (car x) (car y))
	(return nil))))

(defun uppercassify (y)
  (cond ((and (>= y '|a|) (<= y '|z|))
	 (+ y (- '|A| '|a|)))
	(t y)))

(defun read-till-and-raise (stop-char)
  (let ((s (my-syntax stop-char)) (d))
    (my-set-syntax stop-char 17)
    (setq d (read)) (skip-if stop-char)
    (my-set-syntax stop-char s)
    d))

(defun do-history-command (string1 command)
  (let ((b))
       ;; colon after word indicates history command.
       ;; 
       (cond ((eq (setq b (readch)) '|:|)
	      ;; read key command
	      (selectq (setq b (readch))
		       (p
			;; only print result - dont execute
			;; return nil so that a quoted version doesn't confuse the
			;; history mechanism later.  ( i would like to change this
							 ;; to enter command in the history list but not execute).
			($prpr command) (terpri)
			(rplaca (car historylist*) command)
			(*throw '$error$ nil))
		       (s ; change all subwords of string1 with string2.
			  (do-history-command string1
					      (let ((delimiter (readch)))
						   (match-and-substitute
						    (read-till-and-raise delimiter) command
						    (read-till-and-raise delimiter)))))
		       ;;
		       ;; number indicates get that element of the command out of
		       ;; the list.
		       ;;
		       ((|0| |1| |2| |3| |4| |5| |6| |7| |8| |9|)
			(unreadch b)
			(let ((s (my-syntax '|:|))
			      (s1 (my-syntax '|^|))
			      (n))
			     (my-set-syntax '|:| 17)
			     (my-set-syntax '|^| 17)
			     (setq n (read))
			     (my-set-syntax '|:| s)
			     (my-set-syntax '|^| s1)
			     (cond ((null (dtpr command))
				    (princ "Error: not a list : ") ($prpr command)
				    (terpri) nil)
				   ((null (numberp n))
				    (princ "Error: expected number.  ")
				    (princ n)
				    (princ " is not a number.")
				    (terpri) nil)
				   ((> n (length command))
				    (princ "Error: ") (princ n)
				    (princ " is out of range for ") ($prpr command)
				    (terpri) nil)
				   (t (do-history-command string1 (nth command n))))))
		       (t
			(princ "Error: unknown command key : \|") 
			(princ b) (princ "|") 
			(terpri)
			;; return original command
			command)))
	     ((eq b '|^|)	
	      ;; equivalent to :s/string1/string2/
	      ;; is ^string1^string2^
	      (cond (string1 (match-and-substitute
			      string1 command
			      (read-till-and-raise '|^|)))
		    (t (terpri)
		       (princ "illegal option to history command.")
		       (terpri)
		       nil)))
	     (t (unreadch b)
		;; return original command
		command))))

(defun match-back-command (partial-match /&optional (part-to-return 'input))
  (let ((p (list2vector (explode partial-match))))
    (let ((m (upbv p)))
      (kmp-flowchart-construction p m)
      (do ((x (cdr historylist*) (cdr x)))
	  ((null x) nil)
	(and (kmp-scan p m (explode (caar x)))
	     (cond ((eq part-to-return 'input)
		    (return (caar x)))
		   (t (return (cdar x)))))))))

(defun match-and-substitute (partial-match command replacement)
  (let ((p (list2vector (explode partial-match))))
    (let ((m (upbv p)))
      (kmp-flowchart-construction p m)
      (let ((l (flatsize partial-match)))
	(match-and-substitute1 p m (explode partial-match)
			       command (explode replacement) l)))))

(defun match-and-substitute1 (p m s command replacement l)
  (cond ((or (atom command) (numberp command))
	 (kmp-scan-and-replace p m (explode command)
			       replacement l command))
	(t (cons
	    (match-and-substitute1 p m s (car command) replacement l)
	    (match-and-substitute1 p m s (cdr command) replacement l)))))

(defun kmp-scan-and-replace (p m s replacement l command)
  (and s (prog (j k flag)
	   (setq flag (stringp command))
	   (setq j 0) (setq k nil)
	  loop
	   (cond ((and (<> j -1)
		       (<> (uppercassify (cxr j p))
			   (uppercassify (car s))))
		  (setq j (cxr j *flink)) (go loop)))
	   (setq k (cons (car s) k))
	   (and (= j m)
		(return (cond ((stringp command)
			       (list2string
				(cdr (append
				      (append (nreverse (my-nthcdr k l))
					      replacement)
				      (cdr (nreverse
					    (cdr (nreverse s))))))))
			      (t (let ((x (append
					   (append
					    (nreverse (my-nthcdr k l))
					    replacement)
					   (cdr s))))
				   (and (= (my-syntax (car x)) 14)
					(<= (my-syntax (cadr x)) 10)
					(setq x (cdr x)))
				   (let ((y (implode x)))
				     (cond ((eq (flatsize y) (length x)) y)
					   (t (intern (list2string x))))))))))
	   (or (setq j (+ 1 j) s (cdr s)) (return command))
	   (go loop))))

(defun read-sub-word ()
  (let ((c (my-syntax '|:|))
	(d))
    ;; dont read : since it is the special command character.
    (my-set-syntax '|:| 17)
    (setq d (read))
    (my-set-syntax '|:| c)
    d))

(defun re-execute-command (/&optional (part 'input))
  (let ((y (readch)))
    (cond ((eq y '\^) (do-history-command-and-return-command 
		       nil (last-command)))
	  ((eq y '\*) (do-history-command-and-return-command 
		       nil (last-answer)))
	  ((eq y '\@) (re-execute-command 'answer))
	  ((eq y '\?) 
	   (let ((yy (read-sub-word)))
		(do-history-command-and-return-command yy
		 (match-back-command yy part))))
	  ((or (digit y) (memq y '(|+| |-|)))
	   (unreadch y)
	   (let ((y (read-sub-word)))
	     (cond ((numberp y)
		    (cond ((> y 0) (do-history-command-and-return-command nil
				    (nth-command y part)))
			  ((< y 0) (do-history-command-and-return-command nil
				    (nth-back-command y))))))))
	  ((liter y)
	   (unreadch y)
	   (let ((yy (read-sub-word)))
		(do-history-command-and-return-command  
		 yy
		 (match-back-command yy))))
	  )))

(my-set-readmacro '\^ (function re-execute-command))


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]