Newsgroups: comp.sources.misc
From: daveg@synaptics.com (David Gillespie)
Subject:  v24i073:  gnucalc - GNU Emacs Calculator, v2.00, Part25/56
Message-ID: <1991Oct31.072757.18242@sparky.imd.sterling.com>
X-Md4-Signature: 5191220bb34440415fd008f4ae7bf5c5
Date: Thu, 31 Oct 1991 07:27:57 GMT
Approved: kent@sparky.imd.sterling.com

Submitted-by: daveg@synaptics.com (David Gillespie)
Posting-number: Volume 24, Issue 73
Archive-name: gnucalc/part25
Environment: Emacs
Supersedes: gmcalc: Volume 13, Issue 27-45

---- Cut Here and unpack ----
#!/bin/sh
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc-rewr.el continued
#
if test ! -r _shar_seq_.tmp; then
	echo 'Please unpack part 1 first!'
	exit 1
fi
(read Scheck
 if test "$Scheck" != 25; then
	echo Please unpack part "$Scheck" next!
	exit 1
 else
	exit 0
 fi
) < _shar_seq_.tmp || exit 1
if test ! -f _shar_wnt_.tmp; then
	echo 'x - still skipping calc-rewr.el'
else
echo 'x - continuing file calc-rewr.el'
sed 's/^X//' << 'SHAR_EOF' >> 'calc-rewr.el' &&
;;;         argument is stored in "reg"; otherwise (provided this is an `a r'
;;;         and not a `g r' command) the selected part is stored in "reg".
;;;
;;; (cond expr)
;;;         The "expr", with registers substituted, must simplify to
;;;         a non-zero value.
;;;
;;; (let reg expr)
;;;         Evaluate "expr" and store the result in "reg".  Always succeeds.
;;;
;;; (done rhs remember)
;;;         Rewrite the expression to "rhs", with register substituted.
;;;	    Normalize; if the result is different from the original
;;;	    expression, the match has succeeded.  This is the last
;;;	    instruction of every program.  If "remember" is non-nil,
;;;         record the result of the match as a new literal rule.
X
X
;;; Pseudo-functions related to rewrites:
;;;
;;;  In patterns:  quote, plain, condition, opt, apply, cons, select
;;;
;;;  In righthand sides:  quote, plain, eval, evalsimp, evalextsimp,
;;;                       apply, cons, select
;;;
;;;  In conditions:  let + same as for righthand sides
X
;;; Some optimizations that would be nice to have:
;;;
;;;  * Merge registers with disjoint lifetimes.
;;;  * Merge constant registers with equivalent values.
;;;
;;;  * If an argument of a commutative op math-depends neither on the
;;;    rest of the pattern nor on any of the conditions, then no backtracking
;;;    should be done for that argument.  (This won't apply to very many
;;;    cases.)
;;;
;;;  * If top functor is "select", and its argument is a unique function,
;;;    add the rule to the lists for both "select" and that function.
;;;    (Currently rules like this go on the "nil" list.)
;;;    Same for "func-opt" functions.  (Though not urgent for these.)
;;;
;;;  * Shouldn't evaluate a "let" condition until the end, or until it
;;;    would enable another condition to be evaluated.
;;;
X
;;; Some additional features to add / things to think about:
;;;
;;;  * Figure out what happens to "a +/- b" and "a +/- opt(b)".
;;;
;;;  * Same for interval forms.
;;;
;;;  * Have a name(v,pat) pattern which matches pat, and gives the
;;;    whole match the name v.  Beware of circular structures!
;;;
X
(defun math-compile-patterns (pats)
X  (if (and (eq (car-safe pats) 'var)
X	   (calc-var-value (nth 2 pats)))
X      (let ((prop (get (nth 2 pats) 'math-pattern-cache)))
X	(or prop
X	    (put (nth 2 pats) 'math-pattern-cache (setq prop (list nil))))
X	(or (eq (car prop) (symbol-value (nth 2 pats)))
X	    (progn
X	      (setcdr prop (math-compile-patterns
X			    (symbol-value (nth 2 pats))))
X	      (setcar prop (symbol-value (nth 2 pats)))))
X	(cdr prop))
X    (let ((math-rewrite-whole t))
X      (cdr (math-compile-rewrites (cons
X				   'vec
X				   (mapcar (function (lambda (x)
X						       (list 'vec x
X							     '(var XXX XXX))))
X					   (if (eq (car-safe pats) 'vec)
X					       (cdr pats)
X					     (list pats))))))))
)
(setq math-rewrite-whole nil)
(setq math-make-import-list nil)
X
(defun math-compile-rewrites (rules &optional name)
X  (if (eq (car-safe rules) 'var)
X      (let ((prop (get (nth 2 rules) 'math-rewrite-cache))
X	    (math-import-list nil)
X	    (math-make-import-list t)
X	    p)
X	(or (calc-var-value (nth 2 rules))
X	    (error "Rules variable %s has no stored value" (nth 1 rules)))
X	(or prop
X	    (put (nth 2 rules) 'math-rewrite-cache
X		 (setq prop (list (list (cons (nth 2 rules) nil))))))
X	(setq p (car prop))
X	(while (and p (eq (symbol-value (car (car p))) (cdr (car p))))
X	  (setq p (cdr p)))
X	(or (null p)
X	    (progn
X	      (message "Compiling rule set %s..." (nth 1 rules))
X	      (setcdr prop (math-compile-rewrites
X			    (symbol-value (nth 2 rules))
X			    (nth 2 rules)))
X	      (message "Compiling rule set %s...done" (nth 1 rules))
X	      (setcar prop (cons (cons (nth 2 rules)
X				       (symbol-value (nth 2 rules)))
X				 math-import-list))))
X	(cdr prop))
X    (if (or (not (eq (car-safe rules) 'vec))
X	    (and (memq (length rules) '(3 4))
X		 (let ((p rules))
X		   (while (and (setq p (cdr p))
X			       (memq (car-safe (car p))
X				     '(vec
X				       calcFunc-assign
X				       calcFunc-condition
X				       calcFunc-import
X				       calcFunc-phase
X				       calcFunc-schedule
X				       calcFunc-iterations))))
X		   p)))
X	(setq rules (list rules))
X      (setq rules (cdr rules)))
X    (if (assq 'calcFunc-import rules)
X	(let ((pp (setq rules (copy-sequence rules)))
X	      p part)
X	  (while (setq p (car (cdr pp)))
X	    (if (eq (car-safe p) 'calcFunc-import)
X		(progn
X		  (setcdr pp (cdr (cdr pp)))
X		  (or (and (eq (car-safe (nth 1 p)) 'var)
X			   (setq part (calc-var-value (nth 2 (nth 1 p))))
X			   (memq (car-safe part) '(vec
X						   calcFunc-assign
X						   calcFunc-condition)))
X		      (error "Argument of import() must be a rules variable"))
X		  (if math-make-import-list
X		      (setq math-import-list
X			    (cons (cons (nth 2 (nth 1 p))
X					(symbol-value (nth 2 (nth 1 p))))
X				  math-import-list)))
X		  (while (setq p (cdr (cdr p)))
X		    (or (cdr p)
X			(error "import() must have odd number of arguments"))
X		    (setq part (math-rwcomp-substitute part
X						       (car p) (nth 1 p))))
X		  (if (eq (car-safe part) 'vec)
X		      (setq part (cdr part))
X		    (setq part (list part)))
X		  (setcdr pp (append part (cdr pp))))
X	      (setq pp (cdr pp))))))
X    (let ((rule-set nil)
X	  (all-heads nil)
X	  (nil-rules nil)
X	  (rule-count 0)
X	  (math-schedule nil)
X	  (math-iterations nil)
X	  (math-phases nil)
X	  (math-all-phases nil)
X	  (math-remembering nil)
X	  math-pattern math-rhs math-conds)
X      (while rules
X	(cond
X	 ((and (eq (car-safe (car rules)) 'calcFunc-iterations)
X	       (= (length (car rules)) 2))
X	  (or (integerp (nth 1 (car rules)))
X	      (equal (nth 1 (car rules)) '(var inf var-inf))
X	      (equal (nth 1 (car rules)) '(neg (var inf var-inf)))
X	      (error "Invalid argument for iterations(n)"))
X	  (or math-iterations
X	      (setq math-iterations (nth 1 (car rules)))))
X	 ((eq (car-safe (car rules)) 'calcFunc-schedule)
X	  (or math-schedule
X	      (setq math-schedule (math-parse-schedule (cdr (car rules))))))
X	 ((eq (car-safe (car rules)) 'calcFunc-phase)
X	  (setq math-phases (cdr (car rules)))
X	  (if (equal math-phases '((var all var-all)))
X	      (setq math-phases nil))
X	  (let ((p math-phases))
X	    (while p
X	      (or (integerp (car p))
X		  (error "Phase numbers must be small integers"))
X	      (or (memq (car p) math-all-phases)
X		  (setq math-all-phases (cons (car p) math-all-phases)))
X	      (setq p (cdr p)))))
X	 ((or (and (eq (car-safe (car rules)) 'vec)
X		   (cdr (cdr (car rules)))
X		   (not (nthcdr 4 (car rules)))
X		   (setq math-conds (nth 3 (car rules))
X			 math-rhs (nth 2 (car rules))
X			 math-pattern (nth 1 (car rules))))
X	      (progn
X		(setq math-conds nil
X		      math-pattern (car rules))
X		(while (and (eq (car-safe math-pattern) 'calcFunc-condition)
X			    (= (length math-pattern) 3))
X		  (let ((cond (nth 2 math-pattern)))
X		    (setq math-conds (if math-conds
X					 (list 'calcFunc-land math-conds cond)
X				       cond)
X			  math-pattern (nth 1 math-pattern))))
X		(and (eq (car-safe math-pattern) 'calcFunc-assign)
X		     (= (length math-pattern) 3)
X		     (setq math-rhs (nth 2 math-pattern)
X			   math-pattern (nth 1 math-pattern)))))
X	  (let* ((math-prog (list nil))
X		 (math-prog-last math-prog)
X		 (math-num-regs 1)
X		 (math-regs (list (list nil 0 nil nil)))
X		 (math-bound-vars nil)
X		 (math-aliased-vars nil)
X		 (math-copy-neg nil))
X	    (setq math-conds (and math-conds (math-flatten-lands math-conds)))
X	    (math-rwcomp-pattern math-pattern 0)
X	    (while math-conds
X	      (let ((expr (car math-conds)))
X		(setq math-conds (cdr math-conds))
X		(math-rwcomp-cond-instr expr)))
X	    (math-rwcomp-instr 'done
X			       (math-rwcomp-match-vars math-rhs)
X			       math-remembering)
X	    (setq math-prog (cdr math-prog))
X	    (let* ((heads (math-rewrite-heads math-pattern))
X		   (rule (list (vconcat
X				(nreverse
X				 (mapcar (function (lambda (x) (nth 3 x)))
X					 math-regs)))
X			       math-prog
X			       heads
X			       math-phases))
X		   (head (and (not (Math-primp math-pattern))
X			      (not (and (eq (car (car math-prog)) 'try)
X					(nth 5 (car math-prog))))
X			      (not (memq (car (car math-prog)) '(func-opt
X								 apply
X								 select
X								 alt)))
X			      (if (memq (car (car math-prog)) '(func
X								func-def))
X				  (nth 2 (car math-prog))
X				(if (eq (car math-pattern) 'calcFunc-quote)
X				    (car-safe (nth 1 math-pattern))
X				  (car math-pattern))))))
X	      (let (found)
X		(while heads
X		  (if (setq found (assq (car heads) all-heads))
X		      (setcdr found (1+ (cdr found)))
X		    (setq all-heads (cons (cons (car heads) 1) all-heads)))
X		  (setq heads (cdr heads))))
X	      (if (eq head '-) (setq head '+))
X	      (if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec))
X	      (if head
X		  (progn
X		    (nconc (or (assq head rule-set)
X			       (car (setq rule-set (cons (cons head
X							       (copy-sequence
X								nil-rules))
X							 rule-set))))
X			   (list rule))
X		    (if (eq head '*)
X			(nconc (or (assq '/ rule-set)
X				   (car (setq rule-set (cons (cons
X							      '/
X							      (copy-sequence
X							       nil-rules))
X							     rule-set))))
X			       (list rule))))
X		(setq nil-rules (nconc nil-rules (list rule)))
X		(let ((ptr rule-set))
X		  (while ptr
X		    (nconc (car ptr) (list rule))
X		    (setq ptr (cdr ptr))))))))
X	 (t
X	  (error "Rewrite rule set must be a vector of A := B rules")))
X	(setq rules (cdr rules)))
X      (if nil-rules
X	  (setq rule-set (cons (cons nil nil-rules) rule-set)))
X      (setq all-heads (mapcar 'car
X			      (sort all-heads (function
X					       (lambda (x y)
X						 (< (cdr x) (cdr y)))))))
X      (let ((set rule-set)
X	    rule heads ptr)
X	(while set
X	  (setq rule (cdr (car set)))
X	  (while rule
X	    (if (consp (setq heads (nth 2 (car rule))))
X		(progn
X		  (setq heads (delq (car (car set)) heads)
X			ptr all-heads)
X		  (while (and ptr (not (memq (car ptr) heads)))
X		    (setq ptr (cdr ptr)))
X		  (setcar (nthcdr 2 (car rule)) (car ptr))))
X	    (setq rule (cdr rule)))
X	  (setq set (cdr set))))
X      (let ((plus (assq '+ rule-set)))
X	(if plus
X	    (setq rule-set (cons (cons '- (cdr plus)) rule-set))))
X      (cons (list 'schedule math-iterations name
X		  (or math-schedule
X		      (sort math-all-phases '<)
X		      (list 1)))
X	    rule-set)))
)
X
(defun math-flatten-lands (expr)
X  (if (eq (car-safe expr) 'calcFunc-land)
X      (append (math-flatten-lands (nth 1 expr))
X	      (math-flatten-lands (nth 2 expr)))
X    (list expr))
)
X
(defun math-rewrite-heads (expr &optional more all)
X  (let ((heads more)
X	(skips (and (not all)
X		    '(calcFunc-apply calcFunc-condition calcFunc-opt
X				     calcFunc-por calcFunc-pnot)))
X	(blanks (and (not all)
X		     '(calcFunc-quote calcFunc-plain calcFunc-select
X				      calcFunc-cons calcFunc-rcons
X				      calcFunc-pand))))
X    (or (Math-primp expr)
X	(math-rewrite-heads-rec expr))
X    heads)
)
X
(defun math-rewrite-heads-rec (expr)
X  (or (memq (car expr) skips)
X      (progn
X	(or (memq (car expr) heads)
X	    (memq (car expr) blanks)
X	    (memq 'algebraic (get (car expr) 'math-rewrite-props))
X	    (setq heads (cons (car expr) heads)))
X	(while (setq expr (cdr expr))
X	  (or (Math-primp (car expr))
X	      (math-rewrite-heads-rec (car expr))))))
)
X
(defun math-parse-schedule (sched)
X  (mapcar (function
X	   (lambda (s)
X	     (if (integerp s)
X		 s
X	       (if (math-vectorp s)
X		   (math-parse-schedule (cdr s))
X		 (if (eq (car-safe s) 'var)
X		     (math-var-to-calcFunc s)
X		   (error "Improper component in rewrite schedule"))))))
X	  sched)
)
X
(defun math-rwcomp-match-vars (expr)
X  (if (Math-primp expr)
X      (if (eq (car-safe expr) 'var)
X	  (let ((entry (assq (nth 2 expr) math-regs)))
X	    (if entry
X		(math-rwcomp-register-expr (nth 1 entry))
X	      expr))
X	expr)
X    (if (and (eq (car expr) 'calcFunc-quote)
X	     (= (length expr) 2))
X	(math-rwcomp-match-vars (nth 1 expr))
X      (if (and (eq (car expr) 'calcFunc-plain)
X	       (= (length expr) 2)
X	       (not (Math-primp (nth 1 expr))))
X	  (list (car expr)
X		(cons (car (nth 1 expr))
X		      (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
X	(cons (car expr)
X	      (mapcar 'math-rwcomp-match-vars (cdr expr))))))
)
X
(defun math-rwcomp-register-expr (num)
X  (let ((entry (nth (1- (- math-num-regs num)) math-regs)))
X    (if (nth 2 entry)
X	(list 'neg (list 'calcFunc-register (nth 1 entry)))
X      (list 'calcFunc-register (nth 1 entry))))
)
X
(defun math-rwcomp-substitute (expr old new)
X  (if (and (eq (car-safe old) 'var)
X	   (memq (car-safe new) '(var calcFunc-lambda)))
X      (let ((old-func (math-var-to-calcFunc old))
X	    (new-func (math-var-to-calcFunc new)))
X	(math-rwcomp-subst-rec expr))
X    (let ((old-func nil))
X      (math-rwcomp-subst-rec expr)))
)
X
(defun math-rwcomp-subst-rec (expr)
X  (cond ((equal expr old) new)
X	((Math-primp expr) expr)
X	(t (if (eq (car expr) old-func)
X	       (math-build-call new-func (mapcar 'math-rwcomp-subst-rec
X						 (cdr expr)))
X	     (cons (car expr)
X		   (mapcar 'math-rwcomp-subst-rec (cdr expr))))))
)
X
(setq math-rwcomp-tracing nil)
X
(defun math-rwcomp-trace (instr)
X  (if math-rwcomp-tracing (progn (terpri) (princ instr)))
X  instr
)
X
(defun math-rwcomp-instr (&rest instr)
X  (setcdr math-prog-last
X	  (setq math-prog-last (list (math-rwcomp-trace instr))))
)
X
(defun math-rwcomp-multi-instr (tail &rest instr)
X  (setcdr math-prog-last
X	  (setq math-prog-last (list (math-rwcomp-trace (append instr tail)))))
)
X
(defun math-rwcomp-bind-var (reg var)
X  (setcar (math-rwcomp-reg-entry reg) (nth 2 var))
X  (setq math-bound-vars (cons (nth 2 var) math-bound-vars))
X  (math-rwcomp-do-conditions)
)
X
(defun math-rwcomp-unbind-vars (mark)
X  (while (not (eq math-bound-vars mark))
X    (setcar (assq (car math-bound-vars) math-regs) nil)
X    (setq math-bound-vars (cdr math-bound-vars)))
)
X
(defun math-rwcomp-do-conditions ()
X  (let ((cond math-conds))
X    (while cond
X      (if (math-rwcomp-all-regs-done (car cond))
X	  (let ((expr (car cond)))
X	    (setq math-conds (delq (car cond) math-conds))
X	    (setcar cond 1)
X	    (math-rwcomp-cond-instr expr)))
X      (setq cond (cdr cond))))
)
X
(defun math-rwcomp-cond-instr (expr)
X  (let (op arg)
X    (cond ((and (eq (car-safe expr) 'calcFunc-matches)
X		(= (length expr) 3)
X		(eq (car-safe (setq arg (math-rwcomp-match-vars (nth 1 expr))))
X		    'calcFunc-register))
X	   (math-rwcomp-pattern (nth 2 expr) (nth 1 arg)))
X	  ((math-numberp (setq expr (math-rwcomp-match-vars expr)))
X	   (if (Math-zerop expr)
X	       (math-rwcomp-instr 'backtrack)))
X	  ((and (eq (car expr) 'calcFunc-let)
X		(= (length expr) 3))
X	   (let ((reg (math-rwcomp-reg)))
X	     (math-rwcomp-instr 'let reg (nth 2 expr))
X	     (math-rwcomp-pattern (nth 1 expr) reg)))
X	  ((and (eq (car expr) 'calcFunc-let)
X		(= (length expr) 2)
X		(eq (car-safe (nth 1 expr)) 'calcFunc-assign)
X		(= (length (nth 1 expr)) 3))
X	   (let ((reg (math-rwcomp-reg)))
X	     (math-rwcomp-instr 'let reg (nth 2 (nth 1 expr)))
X	     (math-rwcomp-pattern (nth 1 (nth 1 expr)) reg)))
X	  ((and (setq op (cdr (assq (car-safe expr)
X				    '( (calcFunc-integer  . integer)
X				       (calcFunc-real     . real)
X				       (calcFunc-constant . constant)
X				       (calcFunc-negative . negative) ))))
X		(= (length expr) 2)
X		(or (and (eq (car-safe (nth 1 expr)) 'neg)
X			 (memq op '(integer real constant))
X			 (setq arg (nth 1 (nth 1 expr))))
X		    (setq arg (nth 1 expr)))
X		(eq (car-safe (setq arg (nth 1 expr))) 'calcFunc-register))
X	   (math-rwcomp-instr op (nth 1 arg)))
X	  ((and (assq (car-safe expr) calc-tweak-eqn-table)
X		(= (length expr) 3)
X		(eq (car-safe (nth 1 expr)) 'calcFunc-register))
X	   (if (math-constp (nth 2 expr))
X	       (let ((reg (math-rwcomp-reg)))
X		 (setcar (nthcdr 3 (car math-regs)) (nth 2 expr))
X		 (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
X				    (car expr) reg))
X	     (if (eq (car (nth 2 expr)) 'calcFunc-register)
X		 (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
X				    (car expr) (nth 1 (nth 2 expr)))
X	       (math-rwcomp-instr 'cond expr))))
X	  ((and (eq (car-safe expr) 'calcFunc-eq)
X		(= (length expr) 3)
X		(eq (car-safe (nth 1 expr)) '%)
X		(eq (car-safe (nth 1 (nth 1 expr))) 'calcFunc-register)
X		(math-constp (nth 2 (nth 1 expr)))
X		(math-constp (nth 2 expr)))
X	   (math-rwcomp-instr 'mod (nth 1 (nth 1 (nth 1 expr)))
X			      (nth 2 (nth 1 expr)) (nth 2 expr)))
X	  ((equal expr '(var remember var-remember))
X	   (setq math-remembering 1))
X	  ((and (eq (car-safe expr) 'calcFunc-remember)
X		(= (length expr) 2))
X	   (setq math-remembering (if math-remembering
X				      (list 'calcFunc-lor
X					    math-remembering (nth 1 expr))
X				    (nth 1 expr))))
X	  (t (math-rwcomp-instr 'cond expr))))
)
X
(defun math-rwcomp-same-instr (reg1 reg2 neg)
X  (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
X				 (nth 2 (math-rwcomp-reg-entry reg2)))
X			     neg)
X			 'same-neg
X		       'same)
X		     reg1 reg2)
)
X
(defun math-rwcomp-copy-instr (reg1 reg2 neg)
X  (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
X	      (nth 2 (math-rwcomp-reg-entry reg2)))
X	  neg)
X      (math-rwcomp-instr 'copy-neg reg1 reg2)
X    (or (eq reg1 reg2)
X	(math-rwcomp-instr 'copy reg1 reg2)))
)
X
(defun math-rwcomp-reg ()
X  (prog1
X      math-num-regs
X    (setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
X	  math-num-regs (1+ math-num-regs)))
)
X
(defun math-rwcomp-reg-entry (num)
X  (nth (1- (- math-num-regs num)) math-regs)
)
X
X
(defun math-rwcomp-pattern (expr part &optional not-direct)
X  (cond ((or (math-rwcomp-no-vars expr)
X	     (and (eq (car expr) 'calcFunc-quote)
X		  (= (length expr) 2)
X		  (setq expr (nth 1 expr))))
X 	 (if (eq (car-safe expr) 'calcFunc-register)
X	     (math-rwcomp-same-instr part (nth 1 expr) nil)
X	   (let ((reg (math-rwcomp-reg)))
X	     (setcar (nthcdr 3 (car math-regs)) expr)
X	     (math-rwcomp-same-instr part reg nil))))
X 	((eq (car expr) 'var)
X 	 (let ((entry (assq (nth 2 expr) math-regs)))
X	   (if entry
X	       (math-rwcomp-same-instr part (nth 1 entry) nil)
X	     (if not-direct
X 		 (let ((reg (math-rwcomp-reg)))
X		   (math-rwcomp-pattern expr reg)
X		   (math-rwcomp-copy-instr part reg nil))
X	       (if (setq entry (assq (nth 2 expr) math-aliased-vars))
X		   (progn
X		     (setcar (math-rwcomp-reg-entry (nth 1 entry))
X			     (nth 2 expr))
X		     (setcar entry nil)
X		     (math-rwcomp-copy-instr part (nth 1 entry) nil))
X 		 (math-rwcomp-bind-var part expr))))))
X 	((and (eq (car expr) 'calcFunc-select)
X	      (= (length expr) 2))
X 	 (let ((reg (math-rwcomp-reg)))
X	   (math-rwcomp-instr 'select part reg)
X	   (math-rwcomp-pattern (nth 1 expr) reg)))
X 	((and (eq (car expr) 'calcFunc-opt)
X	      (memq (length expr) '(2 3)))
X 	 (error "opt( ) occurs in context where it is not allowed"))
X 	((eq (car expr) 'neg)
X 	 (if (eq (car (nth 1 expr)) 'var)
X	     (let ((entry (assq (nth 2 (nth 1 expr)) math-regs)))
X	       (if entry
X		   (math-rwcomp-same-instr part (nth 1 entry) t)
X		 (if math-copy-neg
X		     (let ((reg (math-rwcomp-best-reg (nth 1 expr))))
X		       (math-rwcomp-copy-instr part reg t)
X		       (math-rwcomp-pattern (nth 1 expr) reg))
X		   (setcar (cdr (cdr (math-rwcomp-reg-entry part))) t)
X		   (math-rwcomp-pattern (nth 1 expr) part))))
X	   (if (math-rwcomp-is-algebraic (nth 1 expr))
X	       (math-rwcomp-cond-instr (list 'calcFunc-eq
X					     (math-rwcomp-register-expr part)
X					     expr))
X	     (let ((reg (math-rwcomp-reg)))
X	       (math-rwcomp-instr 'func part 'neg reg)
X	       (math-rwcomp-pattern (nth 1 expr) reg)))))
X 	((and (eq (car expr) 'calcFunc-apply)
X	      (= (length expr) 3))
X 	 (let ((reg1 (math-rwcomp-reg))
X	       (reg2 (math-rwcomp-reg)))
X	   (math-rwcomp-instr 'apply part reg1 reg2)
X	   (math-rwcomp-pattern (nth 1 expr) reg1)
X	   (math-rwcomp-pattern (nth 2 expr) reg2)))
X 	((and (eq (car expr) 'calcFunc-cons)
X	      (= (length expr) 3))
X 	 (let ((reg1 (math-rwcomp-reg))
X	       (reg2 (math-rwcomp-reg)))
X	   (math-rwcomp-instr 'cons part reg1 reg2)
X	   (math-rwcomp-pattern (nth 1 expr) reg1)
X	   (math-rwcomp-pattern (nth 2 expr) reg2)))
X 	((and (eq (car expr) 'calcFunc-rcons)
X	      (= (length expr) 3))
X 	 (let ((reg1 (math-rwcomp-reg))
X	       (reg2 (math-rwcomp-reg)))
X	   (math-rwcomp-instr 'rcons part reg1 reg2)
X	   (math-rwcomp-pattern (nth 1 expr) reg1)
X	   (math-rwcomp-pattern (nth 2 expr) reg2)))
X 	((and (eq (car expr) 'calcFunc-condition)
X	      (>= (length expr) 3))
X 	 (math-rwcomp-pattern (nth 1 expr) part)
X 	 (setq expr (cdr expr))
X 	 (while (setq expr (cdr expr))
X	   (let ((cond (math-flatten-lands (car expr))))
X	     (while cond
X	       (if (math-rwcomp-all-regs-done (car cond))
X		   (math-rwcomp-cond-instr (car cond))
X 		 (setq math-conds (cons (car cond) math-conds)))
X	       (setq cond (cdr cond))))))
X 	((and (eq (car expr) 'calcFunc-pand)
X	      (= (length expr) 3))
X 	 (math-rwcomp-pattern (nth 1 expr) part)
X 	 (math-rwcomp-pattern (nth 2 expr) part))
X 	((and (eq (car expr) 'calcFunc-por)
X	      (= (length expr) 3))
X 	 (math-rwcomp-instr 'alt nil nil [nil nil 4])
X 	 (let ((math-conds nil)
X	       (head math-prog-last)
X	       (mark math-bound-vars)
X	       (math-copy-neg t))
X	   (math-rwcomp-pattern (nth 1 expr) part t)
X	   (let ((amark math-aliased-vars)
X		 (math-aliased-vars math-aliased-vars)
X 		 (tail math-prog-last)
X		 (p math-bound-vars)
X		 entry)
X	     (while (not (eq p mark))
X	       (setq entry (assq (car p) math-regs)
X		     math-aliased-vars (cons (list (car p) (nth 1 entry) nil)
X					     math-aliased-vars)
X		     p (cdr p))
X	       (setcar (math-rwcomp-reg-entry (nth 1 entry)) nil))
X	     (setcar (cdr (car head)) (cdr head))
X	     (setcdr head nil)
X	     (setq math-prog-last head)
X	     (math-rwcomp-pattern (nth 2 expr) part)
X	     (math-rwcomp-instr 'same 0 0)
X	     (setcdr tail math-prog-last)
X	     (setq p math-aliased-vars)
X	     (while (not (eq p amark))
X	       (if (car (car p))
X		   (setcar (math-rwcomp-reg-entry (nth 1 (car p)))
X			   (car (car p))))
X	       (setq p (cdr p)))))
X 	 (math-rwcomp-do-conditions))
X 	((and (eq (car expr) 'calcFunc-pnot)
X	      (= (length expr) 2))
X 	 (math-rwcomp-instr 'alt nil nil [nil nil 4])
X 	 (let ((head math-prog-last)
X	       (mark math-bound-vars))
X	   (math-rwcomp-pattern (nth 1 expr) part)
X	   (math-rwcomp-unbind-vars mark)
X	   (math-rwcomp-instr 'end-alt head)
X	   (math-rwcomp-instr 'backtrack)
X	   (setcar (cdr (car head)) (cdr head))
X	   (setcdr head nil)
X	   (setq math-prog-last head)))
X 	(t (let ((props (get (car expr) 'math-rewrite-props)))
X	     (if (and (eq (car expr) 'calcFunc-plain)
X		      (= (length expr) 2)
X		      (not (math-primp (nth 1 expr))))
X 		 (setq expr (nth 1 expr))) ; but "props" is still nil
X	     (if (and (memq 'algebraic props)
X		      (math-rwcomp-is-algebraic expr))
X 		 (math-rwcomp-cond-instr (list 'calcFunc-eq
X					       (math-rwcomp-register-expr part)
X					       expr))
X	       (if (and (memq 'commut props)
X 			(= (length expr) 3))
X		   (let ((arg1 (nth 1 expr))
X 			 (arg2 (nth 2 expr))
X 			 try1 def code head (flip nil))
X		     (if (eq (car expr) '-)
X 			 (setq arg2 (math-rwcomp-neg arg2)))
X		     (setq arg1 (cons arg1 (math-rwcomp-best-reg arg1))
X			   arg2 (cons arg2 (math-rwcomp-best-reg arg2)))
X		     (or (math-rwcomp-order arg1 arg2)
X 			 (setq def arg1 arg1 arg2 arg2 def flip t))
X		     (if (math-rwcomp-optional-arg (car expr) arg1)
X 			 (error "Too many opt( ) arguments in this context"))
X		     (setq def (math-rwcomp-optional-arg (car expr) arg2)
X			   head (if (memq (car expr) '(+ -))
X				    '(+ -)
X				  (if (eq (car expr) '*)
X				      '(* /)
X				    (list (car expr))))
X			   code (if (math-rwcomp-is-constrained
X				     (car arg1) head)
X				    (if (math-rwcomp-is-constrained
X 					 (car arg2) head)
X 					0 1)
X				  2))
X		     (math-rwcomp-multi-instr (and def (list def))
X					      'try part head
X					      (vector nil nil nil code flip)
X					      (cdr arg1))
X		     (setq try1 (car math-prog-last))
X		     (math-rwcomp-pattern (car arg1) (cdr arg1))
X		     (math-rwcomp-instr 'try2 try1 (cdr arg2))
X		     (if (and (= part 0) (not def) (not math-rewrite-whole)
X 			      (setq def (get (car expr)
X 					     'math-rewrite-default)))
X 			 (let ((reg1 (math-rwcomp-reg))
X 			       (reg2 (math-rwcomp-reg)))
X 			   (if (= (aref (nth 3 try1) 3) 0)
X 			       (aset (nth 3 try1) 3 1))
X			   (math-rwcomp-instr 'try (cdr arg2)
X					      (if (equal head '(* /))
X						  '(*) head)
X 					      (vector nil nil nil
X 						      (if (= code 0)
X 							  1 2)
X 						      nil)
X 					      reg1 def)
X 			   (setq try1 (car math-prog-last))
X 			   (math-rwcomp-pattern (car arg2) reg1)
X 			   (math-rwcomp-instr 'try2 try1 reg2)
X 			   (setq math-rhs (list (if (eq (car expr) '-)
X 						    '+ (car expr))
X 						math-rhs
X 						(list 'calcFunc-register
X 						      reg2))))
X 		       (math-rwcomp-pattern (car arg2) (cdr arg2))))
X 		 (let* ((args (mapcar (function
X 				       (lambda (x)
X 					 (cons x (math-rwcomp-best-reg x))))
X 				      (cdr expr)))
X 			(args2 (copy-sequence args))
X 			(argp (reverse args2))
X 			(defs nil)
X 			(num 1))
X 		   (while argp
X 		     (let ((def (math-rwcomp-optional-arg (car expr)
X 							  (car argp))))
X 		       (if def
X 			   (progn
X 			     (setq args2 (delq (car argp) args2)
X 				   defs (cons (cons def (cdr (car argp)))
X 					      defs))
X 			     (math-rwcomp-multi-instr
X 			      (mapcar 'cdr args2)
X 			      (if (or (and (memq 'unary1 props)
X 					   (= (length args2) 1)
X 					   (eq (car args2) (car args)))
X 				      (and (memq 'unary2 props)
X 					   (= (length args) 2)
X 					   (eq (car args2) (nth 1 args))))
X 				  'func-opt
X 				'func-def)
X 			      part (car expr)
X 			      defs))))
X 		     (setq argp (cdr argp)))
X 		   (math-rwcomp-multi-instr (mapcar 'cdr args)
X 					    'func part (car expr))
X 		   (setq args (sort args 'math-rwcomp-order))
X 		   (while args
X 		     (math-rwcomp-pattern (car (car args)) (cdr (car args)))
X 		     (setq num (1+ num)
X 			   args (cdr args)))))))))
)
X
(defun math-rwcomp-best-reg (x)
X  (or (and (eq (car-safe x) 'var)
X	   (let ((entry (assq (nth 2 x) math-aliased-vars)))
X	     (and entry
X		  (not (nth 2 entry))
X		  (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry))))
X		  (progn
X		    (setcar (cdr (cdr entry)) t)
X		    (nth 1 entry)))))
X      (math-rwcomp-reg))
)
X
(defun math-rwcomp-all-regs-done (expr)
X  (if (Math-primp expr)
X      (or (not (eq (car-safe expr) 'var))
X	  (assq (nth 2 expr) math-regs)
X	  (eq (nth 2 expr) 'var-remember)
X	  (math-const-var expr))
X    (if (and (eq (car expr) 'calcFunc-let)
X	     (= (length expr) 3))
X	(math-rwcomp-all-regs-done (nth 2 expr))
X      (if (and (eq (car expr) 'calcFunc-let)
X	       (= (length expr) 2)
X	       (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
X	       (= (length (nth 1 expr)) 3))
X	  (math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
X	(while (and (setq expr (cdr expr))
X		    (math-rwcomp-all-regs-done (car expr))))
X	(null expr))))
)
X
(defun math-rwcomp-no-vars (expr)
X  (if (Math-primp expr)
X      (or (not (eq (car-safe expr) 'var))
X	  (math-const-var expr))
X    (and (not (memq (car expr) '(calcFunc-condition
X				 calcFunc-select calcFunc-quote
X				 calcFunc-plain calcFunc-opt
X				 calcFunc-por calcFunc-pand
X				 calcFunc-pnot calcFunc-apply
X				 calcFunc-cons calcFunc-rcons)))
X	 (progn
X	   (while (and (setq expr (cdr expr))
X		       (math-rwcomp-no-vars (car expr))))
X	   (null expr))))
)
X
(defun math-rwcomp-is-algebraic (expr)
X  (if (Math-primp expr)
X      (or (not (eq (car-safe expr) 'var))
X	  (math-const-var expr)
X	  (assq (nth 2 expr) math-regs))
X    (and (memq 'algebraic (get (car expr) 'math-rewrite-props))
X	 (progn
X	   (while (and (setq expr (cdr expr))
X		       (math-rwcomp-is-algebraic (car expr))))
X	   (null expr))))
)
X
(defun math-rwcomp-is-constrained (expr not-these)
X  (if (Math-primp expr)
X      (not (eq (car-safe expr) 'var))
X    (if (eq (car expr) 'calcFunc-plain)
X	(math-rwcomp-is-constrained (nth 1 expr) not-these)
X      (not (or (memq (car expr) '(neg calcFunc-select))
X	       (memq (car expr) not-these)
X	       (and (memq 'commut (get (car expr) 'math-rewrite-props))
X		    (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
X			(eq (car-safe (nth 2 expr)) 'calcFunc-opt)))))))
)
X
(defun math-rwcomp-optional-arg (head argp)
X  (let ((arg (car argp)))
X    (if (eq (car-safe arg) 'calcFunc-opt)
X	(and (memq (length arg) '(2 3))
X	     (progn
X	       (or (eq (car-safe (nth 1 arg)) 'var)
X		   (error "First argument of opt( ) must be a variable"))
X	       (setcar argp (nth 1 arg))
X	       (if (= (length arg) 2)
X		   (or (get head 'math-rewrite-default)
X		       (error "opt( ) must include a default in this context"))
X		 (nth 2 arg))))
X      (and (eq (car-safe arg) 'neg)
X	   (let* ((part (list (nth 1 arg)))
X		  (partp (math-rwcomp-optional-arg head part)))
X	     (and partp
X		  (setcar argp (math-rwcomp-neg (car part)))
X		  (math-neg partp))))))
)
X
(defun math-rwcomp-neg (expr)
X  (if (memq (car-safe expr) '(* /))
X      (if (eq (car-safe (nth 1 expr)) 'var)
X	  (list (car expr) (list 'neg (nth 1 expr)) (nth 2 expr))
X	(if (eq (car-safe (nth 2 expr)) 'var)
X	    (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
X	  (math-neg expr)))
X    (math-neg expr))
)
X
(defun math-rwcomp-assoc-args (expr)
X  (if (and (eq (car-safe (nth 1 expr)) (car expr))
X	   (= (length (nth 1 expr)) 3))
X      (math-rwcomp-assoc-args (nth 1 expr))
X    (setq math-args (cons (nth 1 expr) math-args)))
X  (if (and (eq (car-safe (nth 2 expr)) (car expr))
X	   (= (length (nth 2 expr)) 3))
X      (math-rwcomp-assoc-args (nth 2 expr))
X    (setq math-args (cons (nth 2 expr) math-args)))
)
X
(defun math-rwcomp-addsub-args (expr)
X  (if (memq (car-safe (nth 1 expr)) '(+ -))
X      (math-rwcomp-addsub-args (nth 1 expr))
X    (setq math-args (cons (nth 1 expr) math-args)))
X  (if (eq (car expr) '-)
X      (setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args))
X    (if (eq (car-safe (nth 2 expr)) '+)
X	(math-rwcomp-addsub-args (nth 2 expr))
X      (setq math-args (cons (nth 2 expr) math-args))))
)
X
(defun math-rwcomp-order (a b)
X  (< (math-rwcomp-priority (car a))
X     (math-rwcomp-priority (car b)))
)
X
;;; Order of priority:    0 Constants and other exact matches (first)
;;;                      10 Functions (except below)
;;;			 20 Meta-variables which occur more than once
;;;			 30 Algebraic functions
;;;			 40 Commutative/associative functions
;;;			 50 Meta-variables which occur only once
;;;		       +100 for every "!!!" (pnot) in the pattern
;;;		      10000 Optional arguments (last)
X
(defun math-rwcomp-priority (expr)
X  (+ (math-rwcomp-count-pnots expr)
X     (cond ((eq (car-safe expr) 'calcFunc-opt)
X	    10000)
X	   ((math-rwcomp-no-vars expr)
X	    0)
X	   ((eq (car expr) 'calcFunc-quote)
X	    0)
X	   ((eq (car expr) 'var)
X	    (if (assq (nth 2 expr) math-regs)
X		0
X	      (if (= (math-rwcomp-count-refs expr) 1)
X		  50
X		20)))
X	   (t (let ((props (get (car expr) 'math-rewrite-props)))
X		(if (or (memq 'commut props)
X			(memq 'assoc props))
X		    40
X		  (if (memq 'algebraic props)
X		      30
X		    10))))))
)
X
(defun math-rwcomp-count-refs (var)
X  (let ((count (or (math-expr-contains-count math-pattern var) 0))
X	(p math-conds))
X    (while p
X      (if (eq (car-safe (car p)) 'calcFunc-let)
X	  (if (= (length (car p)) 3)
X	      (setq count (+ count
X			     (or (math-expr-contains-count (nth 2 (car p)) var)
X				 0)))
X	    (if (and (= (length (car p)) 2)
X		     (eq (car-safe (nth 1 (car p))) 'calcFunc-assign)
X		     (= (length (nth 1 (car p))) 3))
X		(setq count (+ count
X			       (or (math-expr-contains-count
X				    (nth 2 (nth 1 (car p))) var) 0))))))
X      (setq p (cdr p)))
X    count)
)
X
(defun math-rwcomp-count-pnots (expr)
X  (if (Math-primp expr)
X      0
X    (if (eq (car expr) 'calcFunc-pnot)
X	100
X      (let ((count 0))
X	(while (setq expr (cdr expr))
X	  (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
X	count)))
)
X
;;; In the current implementation, all associative functions must
;;; also be commutative.
X
(put '+		     'math-rewrite-props '(algebraic assoc commut))
(put '-		     'math-rewrite-props '(algebraic assoc commut)) ; see below
(put '*		     'math-rewrite-props '(algebraic assoc commut)) ; see below
(put '/		     'math-rewrite-props '(algebraic unary1))
(put '^		     'math-rewrite-props '(algebraic unary1))
(put '%		     'math-rewrite-props '(algebraic))
(put 'neg	     'math-rewrite-props '(algebraic))
(put 'calcFunc-idiv  'math-rewrite-props '(algebraic))
(put 'calcFunc-abs   'math-rewrite-props '(algebraic))
(put 'calcFunc-sign  'math-rewrite-props '(algebraic))
(put 'calcFunc-round 'math-rewrite-props '(algebraic))
(put 'calcFunc-rounde 'math-rewrite-props '(algebraic))
(put 'calcFunc-roundu 'math-rewrite-props '(algebraic))
(put 'calcFunc-trunc 'math-rewrite-props '(algebraic))
(put 'calcFunc-floor 'math-rewrite-props '(algebraic))
(put 'calcFunc-ceil  'math-rewrite-props '(algebraic))
(put 'calcFunc-re    'math-rewrite-props '(algebraic))
(put 'calcFunc-im    'math-rewrite-props '(algebraic))
(put 'calcFunc-conj  'math-rewrite-props '(algebraic))
(put 'calcFunc-arg   'math-rewrite-props '(algebraic))
(put 'calcFunc-and   'math-rewrite-props '(assoc commut))
(put 'calcFunc-or    'math-rewrite-props '(assoc commut))
(put 'calcFunc-xor   'math-rewrite-props '(assoc commut))
(put 'calcFunc-eq    'math-rewrite-props '(commut))
(put 'calcFunc-neq   'math-rewrite-props '(commut))
(put 'calcFunc-land  'math-rewrite-props '(assoc commut))
(put 'calcFunc-lor   'math-rewrite-props '(assoc commut))
(put 'calcFunc-beta  'math-rewrite-props '(commut))
(put 'calcFunc-gcd   'math-rewrite-props '(assoc commut))
(put 'calcFunc-lcm   'math-rewrite-props '(assoc commut))
(put 'calcFunc-max   'math-rewrite-props '(algebraic assoc commut))
(put 'calcFunc-min   'math-rewrite-props '(algebraic assoc commut))
(put 'calcFunc-vunion 'math-rewrite-props '(assoc commut))
(put 'calcFunc-vint  'math-rewrite-props '(assoc commut))
(put 'calcFunc-vxor  'math-rewrite-props '(assoc commut))
X
;;; Note: "*" is not commutative for matrix args, but we pretend it is.
;;; Also, "-" is not commutative but the code tweaks things so that it is.
X
(put '+		     'math-rewrite-default  0)
(put '-		     'math-rewrite-default  0)
(put '*		     'math-rewrite-default  1)
(put '/		     'math-rewrite-default  1)
(put '^		     'math-rewrite-default  1)
(put 'calcFunc-land  'math-rewrite-default  1)
(put 'calcFunc-lor   'math-rewrite-default  0)
(put 'calcFunc-vunion 'math-rewrite-default '(vec))
(put 'calcFunc-vint  'math-rewrite-default '(vec))
(put 'calcFunc-vdiff 'math-rewrite-default '(vec))
(put 'calcFunc-vxor  'math-rewrite-default '(vec))
X
(defmacro math-rwfail (&optional back)
X  (list 'setq 'pc
X	(list 'and
X	      (if back
X		  '(setq btrack (cdr btrack))
X		'btrack)
X	      ''((backtrack))))
)
X
;;; This monstrosity is necessary because the use of static vectors of
;;; registers makes rewrite rules non-reentrant.  Yucko!
(defmacro math-rweval (form)
X  (list 'let '((orig (car rules)))
X	'(setcar rules (quote (nil nil nil no-phase)))
X	(list 'unwind-protect
X	      form
X	      '(setcar rules orig)))
)
X
(setq math-rewrite-phase 1)
X
(defun math-apply-rewrites (expr rules &optional heads ruleset)
X  (and
X   (setq rules (cdr (or (assq (car-safe expr) rules)
X			(assq nil rules))))
X   (let ((result nil)
X	 op regs inst part pc mark btrack
X	 (tracing math-rwcomp-tracing)
X	 (phase math-rewrite-phase))
X     (while rules
X       (or
X	(and (setq part (nth 2 (car rules)))
X	     heads
X	     (not (memq part heads)))
X	(and (setq part (nth 3 (car rules)))
X	     (not (memq phase part)))
X	(progn
X	  (setq regs (car (car rules))
X		pc (nth 1 (car rules))
X		btrack nil)
X	  (aset regs 0 expr)
X	  (while pc
X	     
X	    (and tracing
X		 (progn (terpri) (princ (car pc))
X			(if (and (natnump (nth 1 (car pc)))
X				 (< (nth 1 (car pc)) (length regs)))
X			    (princ (format "\n  part = %s"
X					   (aref regs (nth 1 (car pc))))))))
X	    
X	    (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
X		   (if (and (consp (setq part (aref regs (car (cdr inst)))))
X			    (eq (car part)
X				(car (setq inst (cdr (cdr inst)))))
X			    (progn
X			      (while (and (setq inst (cdr inst)
X						part (cdr part))
X					  inst)
X				(aset regs (car inst) (car part)))
X			      (not (or inst part))))
X		       (setq pc (cdr pc))
X		     (math-rwfail)))
X		  
X		  ((eq op 'same)
X		   (if (or (equal (setq part (aref regs (nth 1 inst)))
X				  (setq mark (aref regs (nth 2 inst))))
X			   (Math-equal part mark))
X		       (setq pc (cdr pc))
X		     (math-rwfail)))
X		  
X		  ((and (eq op 'try)
X			calc-matrix-mode
X			(not (eq calc-matrix-mode 'scalar))
X			(eq (car (nth 2 inst)) '*)
X			(consp (setq part (aref regs (car (cdr inst)))))
X			(eq (car part) '*)
X			(not (math-known-scalarp part)))
X		   (setq mark (nth 3 inst)
X			 pc (cdr pc))
X		   (if (aref mark 4)
X		       (progn
X			 (aset regs (nth 4 inst) (nth 2 part))
X			 (aset mark 1 (cdr (cdr part))))
X		     (aset regs (nth 4 inst) (nth 1 part))
X		     (aset mark 1 (cdr part)))
X		   (aset mark 0 (cdr part))
X		   (aset mark 2 0))
X		  
X		  ((eq op 'try)
X		   (if (and (consp (setq part (aref regs (car (cdr inst)))))
X			    (memq (car part) (nth 2 inst))
X			    (= (length part) 3)
X			    (or (not (eq (car part) '/))
X				(Math-objectp (nth 2 part))))
X		       (progn
X			 (setq op nil
X			       mark (car (cdr (setq inst (cdr (cdr inst))))))
X			 (and
X			  (memq 'assoc (get (car part) 'math-rewrite-props))
X			  (not (= (aref mark 3) 0))
X			  (while (if (and (consp (nth 1 part))
X					  (memq (car (nth 1 part)) (car inst)))
X				     (setq op (cons (if (eq (car part) '-)
X							(math-rwapply-neg
X							 (nth 2 part))
X						      (nth 2 part))
X						    op)
X					   part (nth 1 part))
X				   (if (and (consp (nth 2 part))
X					    (memq (car (nth 2 part))
X						  (car inst))
X					    (not (eq (car (nth 2 part)) '-)))
X				       (setq op (cons (nth 1 part) op)
X					     part (nth 2 part))))))
X			 (setq op (cons (nth 1 part)
X					(cons (if (eq (car part) '-)
X						  (math-rwapply-neg
X						   (nth 2 part))
X						(if (eq (car part) '/)
X						    (math-rwapply-inv
X						     (nth 2 part))
X						  (nth 2 part)))
X					      op))
X			       btrack (cons pc btrack)
X			       pc (cdr pc))
X			 (aset regs (nth 2 inst) (car op))
X			 (aset mark 0 op)
X			 (aset mark 1 op)
X			 (aset mark 2 (if (cdr (cdr op)) 1 0)))
X		     (if (nth 5 inst)
X			 (if (and (consp part)
X				  (eq (car part) 'neg)
X				  (eq (car (nth 2 inst)) '*)
X				  (eq (nth 5 inst) 1))
X			     (progn
X			       (setq mark (nth 3 inst)
X				     pc (cdr pc))
X			       (aset regs (nth 4 inst) (nth 1 part))
X			       (aset mark 1 -1)
X			       (aset mark 2 4))
X			   (setq mark (nth 3 inst)
X				 pc (cdr pc))
X			   (aset regs (nth 4 inst) part)
X			   (aset mark 2 3))
X		       (math-rwfail))))
X		  
X		  ((eq op 'try2)
X		   (setq part (nth 1 inst)   ; try instr
X			 mark (nth 3 part)
X			 op (aref mark 2)
X			 pc (cdr pc))
X		   (aset regs (nth 2 inst)
X			 (cond
X			  ((eq op 0)
X			   (if (eq (aref mark 0) (aref mark 1))
X			       (nth 1 (aref mark 0))
X			     (car (aref mark 0))))
X			  ((eq op 1)
X			   (setq mark (delq (car (aref mark 1))
X					    (copy-sequence (aref mark 0)))
X				 op (car (nth 2 part)))
X			   (if (eq op '*)
X			       (progn
X				 (setq mark (nreverse mark)
X				       part (list '* (nth 1 mark) (car mark))
X				       mark (cdr mark))
X				 (while (setq mark (cdr mark))
X				   (setq part (list '* (car mark) part))))
X			     (setq part (car mark)
X				   mark (cdr mark)
X				   part (if (and (eq op '+)
X						 (consp (car mark))
X						 (eq (car (car mark)) 'neg))
X					    (list '- part
X						  (nth 1 (car mark)))
X					  (list op part (car mark))))
X			     (while (setq mark (cdr mark))
X			       (setq part (if (and (eq op '+)
X						   (consp (car mark))
X						   (eq (car (car mark)) 'neg))
X					      (list '- part
X						    (nth 1 (car mark)))
X					    (list op part (car mark))))))
X			   part)
X			  ((eq op 2)
X			   (car (aref mark 1)))
X			  ((eq op 3) (nth 5 part))
X			  (t (aref mark 1)))))
X		  
X		  ((eq op 'select)
X		   (setq pc (cdr pc))
X		   (if (and (consp (setq part (aref regs (nth 1 inst))))
X			    (eq (car part) 'calcFunc-select))
X		       (aset regs (nth 2 inst) (nth 1 part))
X		     (if math-rewrite-selections
X			 (math-rwfail)
X		       (aset regs (nth 2 inst) part))))
X		  
X		  ((eq op 'same-neg)
X		   (if (or (equal (setq part (aref regs (nth 1 inst)))
X				  (setq mark (math-neg
X					      (aref regs (nth 2 inst)))))
X			   (Math-equal part mark))
X		       (setq pc (cdr pc))
X		     (math-rwfail)))
X		  
X		  ((eq op 'backtrack)
X		   (setq inst (car (car btrack))   ; "try" or "alt" instr
X			 pc (cdr (car btrack))
X			 mark (or (nth 3 inst) [nil nil 4])
X			 op (aref mark 2))
X		   (cond ((eq op 0)
X			  (if (setq op (cdr (aref mark 1)))
X			      (aset regs (nth 4 inst) (car (aset mark 1 op)))
X			    (if (nth 5 inst)
X				(progn
X				  (aset mark 2 3)
X				  (aset regs (nth 4 inst)
X					(aref regs (nth 1 inst))))
X			      (math-rwfail t))))
X			 ((eq op 1)
X			  (if (setq op (cdr (aref mark 1)))
X			      (aset regs (nth 4 inst) (car (aset mark 1 op)))
X			    (if (= (aref mark 3) 1)
X				(if (nth 5 inst)
X				    (progn
X				      (aset mark 2 3)
X				      (aset regs (nth 4 inst)
X					    (aref regs (nth 1 inst))))
X				  (math-rwfail t))
X			      (aset mark 2 2)
X			      (aset mark 1 (cons nil (aref mark 0)))
X			      (math-rwfail))))
X			 ((eq op 2)
X			  (if (setq op (cdr (aref mark 1)))
X			      (progn
X				(setq mark (delq (car (aset mark 1 op))
X						 (copy-sequence
X						  (aref mark 0)))
X				      op (car (nth 2 inst)))
X				(if (eq op '*)
X				    (progn
X				      (setq mark (nreverse mark)
X					    part (list '* (nth 1 mark)
X						       (car mark))
X					    mark (cdr mark))
X				      (while (setq mark (cdr mark))
X					(setq part (list '* (car mark)
X							 part))))
X				  (setq part (car mark)
X					mark (cdr mark)
X					part (if (and (eq op '+)
X						      (consp (car mark))
X						      (eq (car (car mark))
X							  'neg))
X						 (list '- part
X						       (nth 1 (car mark)))
X					       (list op part (car mark))))
X				  (while (setq mark (cdr mark))
X				    (setq part (if (and (eq op '+)
X							(consp (car mark))
X							(eq (car (car mark))
X							    'neg))
X						   (list '- part
X							 (nth 1 (car mark)))
X						 (list op part (car mark))))))
X				(aset regs (nth 4 inst) part))
X			    (if (nth 5 inst)
X				(progn
X				  (aset mark 2 3)
X				  (aset regs (nth 4 inst)
X					(aref regs (nth 1 inst))))
X			      (math-rwfail t))))
X			 ((eq op 4)
X			  (setq btrack (cdr btrack)))
X			 (t (math-rwfail t))))
X		  
X		  ((eq op 'integer)
X		   (if (Math-integerp (setq part (aref regs (nth 1 inst))))
X		       (setq pc (cdr pc))
X		     (if (Math-primp part)
X			 (math-rwfail)
X		       (setq part (math-rweval (math-simplify part)))
X		       (if (Math-integerp part)
X			   (setq pc (cdr pc))
X			 (math-rwfail)))))
X		  
X		  ((eq op 'real)
X		   (if (Math-realp (setq part (aref regs (nth 1 inst))))
X		       (setq pc (cdr pc))
X		     (if (Math-primp part)
X			 (math-rwfail)
X		       (setq part (math-rweval (math-simplify part)))
X		       (if (Math-realp part)
X			   (setq pc (cdr pc))
X			 (math-rwfail)))))
X		  
X		  ((eq op 'constant)
X		   (if (math-constp (setq part (aref regs (nth 1 inst))))
X		       (setq pc (cdr pc))
X		     (if (Math-primp part)
X			 (math-rwfail)
X		       (setq part (math-rweval (math-simplify part)))
X		       (if (math-constp part)
X			   (setq pc (cdr pc))
X			 (math-rwfail)))))
X		  
X		  ((eq op 'negative)
X		   (if (math-looks-negp (setq part (aref regs (nth 1 inst))))
X		       (setq pc (cdr pc))
X		     (if (Math-primp part)
X			 (math-rwfail)
X		       (setq part (math-rweval (math-simplify part)))
X		       (if (math-looks-negp part)
X			   (setq pc (cdr pc))
X			 (math-rwfail)))))
X		  
X		  ((eq op 'rel)
X		   (setq part (math-compare (aref regs (nth 1 inst))
X					    (aref regs (nth 3 inst)))
X			 op (nth 2 inst))
X		   (if (= part 2)
X		       (setq part (math-rweval
X				   (math-simplify
X				    (calcFunc-sign
X				     (math-sub (aref regs (nth 1 inst))
X					       (aref regs (nth 3 inst))))))))
X		   (if (cond ((eq op 'calcFunc-eq)
X			      (eq part 0))
X			     ((eq op 'calcFunc-neq)
X			      (memq part '(-1 1)))
X			     ((eq op 'calcFunc-lt)
X			      (eq part -1))
X			     ((eq op 'calcFunc-leq)
X			      (memq part '(-1 0)))
X			     ((eq op 'calcFunc-gt)
X			      (eq part 1))
X			     ((eq op 'calcFunc-geq)
X			      (memq part '(0 1))))
X		       (setq pc (cdr pc))
X		     (math-rwfail)))
X		  
X		  ((eq op 'func-def)
X		   (if (and (consp (setq part (aref regs (car (cdr inst)))))
X			    (eq (car part)
X				(car (setq inst (cdr (cdr inst))))))
X		       (progn
X			 (setq inst (cdr inst)
X			       mark (car inst))
X			 (while (and (setq inst (cdr inst)
X					   part (cdr part))
X				     inst)
X			   (aset regs (car inst) (car part)))
X			 (if (or inst part)
X			     (setq pc (cdr pc))
X			   (while (eq (car (car (setq pc (cdr pc))))
X				      'func-def))
X			   (setq pc (cdr pc))   ; skip over "func"
X			   (while mark
X			     (aset regs (cdr (car mark)) (car (car mark)))
X			     (setq mark (cdr mark)))))
X		     (math-rwfail)))
X
X		  ((eq op 'func-opt)
X		   (if (or (not (and (consp
X				      (setq part (aref regs (car (cdr inst)))))
X				     (eq (car part) (nth 2 inst))))
X			   (and (= (length part) 2)
X				(setq part (nth 1 part))))
X		       (progn
X			 (setq mark (nth 3 inst))
X			 (aset regs (nth 4 inst) part)
X			 (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
X			 (setq pc (cdr pc))   ; skip over "func"
X			 (while mark
X			   (aset regs (cdr (car mark)) (car (car mark)))
X			   (setq mark (cdr mark))))
X		     (setq pc (cdr pc))))
X
X		  ((eq op 'mod)
X		   (if (if (Math-zerop (setq part (aref regs (nth 1 inst))))
X			   (Math-zerop (nth 3 inst))
X			 (and (not (Math-zerop (nth 2 inst)))
X			      (progn
X				(setq part (math-mod part (nth 2 inst)))
X				(or (Math-numberp part)
X				    (setq part (math-rweval
X						(math-simplify part))))
X				(Math-equal part (nth 3 inst)))))
X		       (setq pc (cdr pc))
X		     (math-rwfail)))
X
X		  ((eq op 'apply)
X		   (if (and (consp (setq part (aref regs (car (cdr inst)))))
X			    (not (Math-objvecp part))
X			    (not (eq (car part) 'var)))
X		       (progn
X			 (aset regs (nth 2 inst)
X			       (math-calcFunc-to-var (car part)))
X			 (aset regs (nth 3 inst)
X			       (cons 'vec (cdr part)))
X			 (setq pc (cdr pc)))
X		     (math-rwfail)))
X
X		  ((eq op 'cons)
X		   (if (and (consp (setq part (aref regs (car (cdr inst)))))
X			    (eq (car part) 'vec)
X			    (cdr part))
X		       (progn
X			 (aset regs (nth 2 inst) (nth 1 part))
X			 (aset regs (nth 3 inst) (cons 'vec (cdr (cdr part))))
X			 (setq pc (cdr pc)))
X		     (math-rwfail)))
X
X		  ((eq op 'rcons)
X		   (if (and (consp (setq part (aref regs (car (cdr inst)))))
X			    (eq (car part) 'vec)
X			    (cdr part))
X		       (progn
X			 (aset regs (nth 2 inst) (calcFunc-rhead part))
X			 (aset regs (nth 3 inst) (calcFunc-rtail part))
X			 (setq pc (cdr pc)))
X		     (math-rwfail)))
X
X		  ((eq op 'cond)
X		   (if (math-is-true
X			(math-rweval
X			 (math-simplify
X			  (math-rwapply-replace-regs (nth 1 inst)))))
X		       (setq pc (cdr pc))
X		     (math-rwfail)))
X		  
X		  ((eq op 'let)
X		   (aset regs (nth 1 inst)
X			 (math-rweval
X			  (math-normalize
X			   (math-rwapply-replace-regs (nth 2 inst)))))
X		   (setq pc (cdr pc)))
X		  
X		  ((eq op 'copy)
X		   (aset regs (nth 2 inst) (aref regs (nth 1 inst)))
X		   (setq pc (cdr pc)))
X		  
X		  ((eq op 'copy-neg)
X		   (aset regs (nth 2 inst)
X			 (math-rwapply-neg (aref regs (nth 1 inst))))
X		   (setq pc (cdr pc)))
X		  
X		  ((eq op 'alt)
X		   (setq btrack (cons pc btrack)
X			 pc (nth 1 inst)))
X		  
X		  ((eq op 'end-alt)
X		   (while (and btrack (not (eq (car btrack) (nth 1 inst))))
X		     (setq btrack (cdr btrack)))
X		   (setq btrack (cdr btrack)
X			 pc (cdr pc)))
X		  
X		  ((eq op 'done)
X		   (setq result (math-rwapply-replace-regs (nth 1 inst)))
X		   (if (or (and (eq (car-safe result) '+)
X				(eq (nth 2 result) 0))
X			   (and (eq (car-safe result) '*)
X				(eq (nth 2 result) 1)))
X		       (setq result (nth 1 result)))
X		   (setq part (and (nth 2 inst)
X				   (math-is-true
X				    (math-rweval
X				     (math-simplify
X				      (math-rwapply-replace-regs
X				       (nth 2 inst)))))))
X		   (if (or (equal result expr)
X			   (equal (setq result (math-normalize result)) expr))
X		       (setq result nil)
X		     (if part (math-rwapply-remember expr result))
X		     (setq rules nil))
X		   (setq pc nil))
X		  
X		  (t (error "%s is not a valid rewrite opcode" op))))))
X       (setq rules (cdr rules)))
X     result))
)
X
(defun math-rwapply-neg (expr)
X  (if (and (consp expr)
X	   (memq (car expr) '(* /)))
X      (if (Math-objectp (nth 2 expr))
X	  (list (car expr) (nth 1 expr) (math-neg (nth 2 expr)))
X	(list (car expr)
X	      (if (Math-objectp (nth 1 expr))
X		  (math-neg (nth 1 expr))
X		(list '* -1 (nth 1 expr)))
X	      (nth 2 expr)))
X    (math-neg expr))
)
X
(defun math-rwapply-inv (expr)
X  (if (and (Math-integerp expr)
X	   calc-prefer-frac)
X      (math-make-frac 1 expr)
X    (list '/ 1 expr))
)
X
(defun math-rwapply-replace-regs (expr)
X  (cond ((Math-primp expr)
X	 expr)
X	((eq (car expr) 'calcFunc-register)
X	 (setq expr (aref regs (nth 1 expr)))
X	 (if (eq (car-safe expr) '*)
X	     (if (eq (nth 1 expr) -1)
X		 (math-neg (nth 2 expr))
X	       (if (eq (nth 1 expr) 1)
X		   (nth 2 expr)
X		 expr))
X	   expr))
X	((and (eq (car expr) 'calcFunc-eval)
X	      (= (length expr) 2))
X	 (calc-with-default-simplification
X	  (math-normalize (math-rwapply-replace-regs (nth 1 expr)))))
X	((and (eq (car expr) 'calcFunc-evalsimp)
X	      (= (length expr) 2))
X	 (math-simplify (math-rwapply-replace-regs (nth 1 expr))))
X	((and (eq (car expr) 'calcFunc-evalextsimp)
X	      (= (length expr) 2))
X	 (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr))))
X	((and (eq (car expr) 'calcFunc-apply)
X	      (= (length expr) 3))
X	 (let ((func (math-rwapply-replace-regs (nth 1 expr)))
X	       (args (math-rwapply-replace-regs (nth 2 expr)))
X	       call)
X	   (if (and (math-vectorp args)
X		    (not (eq (car-safe (setq call (math-build-call
X						   (math-var-to-calcFunc func)
X						   (cdr args))))
X			     'calcFunc-call)))
X	       call
X	     (list 'calcFunc-apply func args))))
X	((and (eq (car expr) 'calcFunc-cons)
X	      (= (length expr) 3))
X	 (let ((head (math-rwapply-replace-regs (nth 1 expr)))
X	       (tail (math-rwapply-replace-regs (nth 2 expr))))
X	   (if (math-vectorp tail)
X	       (cons 'vec (cons head (cdr tail)))
X	     (list 'calcFunc-cons head tail))))
X	((and (eq (car expr) 'calcFunc-rcons)
X	      (= (length expr) 3))
X	 (let ((head (math-rwapply-replace-regs (nth 1 expr)))
X	       (tail (math-rwapply-replace-regs (nth 2 expr))))
X	   (if (math-vectorp head)
X	       (append head (list tail))
X	     (list 'calcFunc-rcons head tail))))
X	((and (eq (car expr) 'neg)
X	      (math-rwapply-reg-looks-negp (nth 1 expr)))
X	 (math-rwapply-reg-neg (nth 1 expr)))
X	((and (eq (car expr) 'neg)
X	      (eq (car-safe (nth 1 expr)) 'calcFunc-register)
X	      (math-scalarp (aref regs (nth 1 (nth 1 expr)))))
X	 (math-neg (math-rwapply-replace-regs (nth 1 expr))))
X	((and (eq (car expr) '+)
X	      (math-rwapply-reg-looks-negp (nth 1 expr)))
X	 (list '- (math-rwapply-replace-regs (nth 2 expr))
X	       (math-rwapply-reg-neg (nth 1 expr))))
X	((and (eq (car expr) '+)
X	      (math-rwapply-reg-looks-negp (nth 2 expr)))
X	 (list '- (math-rwapply-replace-regs (nth 1 expr))
X	       (math-rwapply-reg-neg (nth 2 expr))))
X	((and (eq (car expr) '-)
X	      (math-rwapply-reg-looks-negp (nth 2 expr)))
X	 (list '+ (math-rwapply-replace-regs (nth 1 expr))
X	       (math-rwapply-reg-neg (nth 2 expr))))
X	((eq (car expr) '*)
X	 (cond ((eq (nth 1 expr) -1)
X		(if (math-rwapply-reg-looks-negp (nth 2 expr))
X		    (math-rwapply-reg-neg (nth 2 expr))
X		  (math-neg (math-rwapply-replace-regs (nth 2 expr)))))
X	       ((eq (nth 1 expr) 1)
X		(math-rwapply-replace-regs (nth 2 expr)))
X	       ((eq (nth 2 expr) -1)
X		(if (math-rwapply-reg-looks-negp (nth 1 expr))
X		    (math-rwapply-reg-neg (nth 1 expr))
X		  (math-neg (math-rwapply-replace-regs (nth 1 expr)))))
X	       ((eq (nth 2 expr) 1)
X		(math-rwapply-replace-regs (nth 1 expr)))
X	       (t
X		(let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
X		      (arg2 (math-rwapply-replace-regs (nth 2 expr))))
X		  (cond ((and (eq (car-safe arg1) '/)
X			      (eq (nth 1 arg1) 1))
X			 (list '/ arg2 (nth 2 arg1)))
X			((and (eq (car-safe arg2) '/)
X			      (eq (nth 1 arg2) 1))
X			 (list '/ arg1 (nth 2 arg2)))
X			(t (list '* arg1 arg2)))))))
X	((eq (car expr) '/)
X	 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
X	       (arg2 (math-rwapply-replace-regs (nth 2 expr))))
X	   (if (eq (car-safe arg2) '/)
X	       (list '/ (list '* arg1 (nth 2 arg2)) (nth 1 arg2))
X	     (list '/ arg1 arg2))))
X	((and (eq (car expr) 'calcFunc-plain)
X	      (= (length expr) 2))
X	 (if (Math-primp (nth 1 expr))
X	     (nth 1 expr)
X	   (if (eq (car (nth 1 expr)) 'calcFunc-register)
X	       (aref regs (nth 1 (nth 1 expr)))
X	     (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
X					      (cdr (nth 1 expr)))))))
X	(t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr)))))
)
X
(defun math-rwapply-reg-looks-negp (expr)
X  (if (eq (car-safe expr) 'calcFunc-register)
X      (math-looks-negp (aref regs (nth 1 expr)))
X    (if (memq (car-safe expr) '(* /))
X	(or (math-rwapply-reg-looks-negp (nth 1 expr))
X	    (math-rwapply-reg-looks-negp (nth 2 expr)))))
)
X
(defun math-rwapply-reg-neg (expr)  ; expr must satisfy rwapply-reg-looks-negp
X  (if (eq (car expr) 'calcFunc-register)
X      (math-neg (math-rwapply-replace-regs expr))
X    (if (math-rwapply-reg-looks-negp (nth 1 expr))
X	(math-rwapply-replace-regs (list (car expr)
X					 (math-rwapply-reg-neg (nth 1 expr))
X					 (nth 2 expr)))
X      (math-rwapply-replace-regs (list (car expr)
X				       (nth 1 expr)
X				       (math-rwapply-reg-neg (nth 2 expr))))))
)
X
(defun math-rwapply-remember (old new)
X  (let ((varval (symbol-value (nth 2 (car ruleset))))
X	(rules (assq (car-safe old) ruleset)))
SHAR_EOF
true || echo 'restore of calc-rewr.el failed'
fi
echo 'End of  part 25'
echo 'File calc-rewr.el is continued in part 26'
echo 26 > _shar_seq_.tmp
exit 0
exit 0 # Just in case...
-- 
Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    (402) 291-8300         FAX:      (402) 291-4362
Please send comp.sources.misc-related mail to kent@uunet.uu.net.