Artifact 5d255989c1aaeafc9e47a99d9583132a931ff5d83853a82f14522ddb123380b6:

• File psl-1983/3-1/util/history.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 12361) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/util/history.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 12361) [annotate] [blame] [check-ins using]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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))