Initial import of Calc 2.02f.

1 files changed, 2097 insertions, 0 deletions

diff --git a/lisp/calc/calc-rewr.el b/lisp/calc/calc-rewr.el
new file mode 100644
index 00000000000..4250533f623
--- /dev/null
+++ b/lisp/calc/calc-rewr.el
@@ -0,0 +1,2097 @@
+;; Calculator for GNU Emacs, part II [calc-rewr.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY.  No author or distributor
+;; accepts responsibility to anyone for the consequences of using it
+;; or for whether it serves any particular purpose or works at all,
+;; unless he says so in writing.  Refer to the GNU Emacs General Public
+;; License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute
+;; GNU Emacs, but only under the conditions described in the
+;; GNU Emacs General Public License.   A copy of this license is
+;; supposed to have been given to you along with GNU Emacs so you
+;; can know your rights and responsibilities.  It should be in a
+;; file named COPYING.  Among other things, the copyright notice
+;; and this notice must be preserved on all copies.
+
+
+
+;; This file is autoloaded from calc-ext.el.
+(require 'calc-ext)
+
+(require 'calc-macs)
+
+(defun calc-Need-calc-rewr () nil)
+
+
+(defun calc-rewrite-selection (rules-str &optional many prefix)
+  (interactive "sRewrite rule(s): \np")
+  (calc-slow-wrapper
+   (calc-preserve-point)
+   (let* ((num (max 1 (calc-locate-cursor-element (point))))
+	  (reselect t)
+	  (pop-rules nil)
+	  (entry (calc-top num 'entry))
+	  (expr (car entry))
+	  (sel (calc-auto-selection entry))
+	  (math-rewrite-selections t)
+	  (math-rewrite-default-iters 1))
+     (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
+	 (if (= num 1)
+	     (error "Can't use same stack entry for formula and rules.")
+	   (setq rules (calc-top-n 1 t)
+		 pop-rules t))
+       (setq rules (if (stringp rules-str)
+		       (math-read-exprs rules-str) rules-str))
+       (if (eq (car-safe rules) 'error)
+	   (error "Bad format in expression: %s" (nth 1 rules)))
+       (if (= (length rules) 1)
+	   (setq rules (car rules))
+	 (setq rules (cons 'vec rules)))
+       (or (memq (car-safe rules) '(vec var calcFunc-assign
+					calcFunc-condition))
+	   (let ((rhs (math-read-expr
+		       (read-string (concat "Rewrite from:    " rules-str
+					    "  to: ")))))
+	     (if (eq (car-safe rhs) 'error)
+		 (error "Bad format in expression: %s" (nth 1 rhs)))
+	     (setq rules (list 'calcFunc-assign rules rhs))))
+       (or (eq (car-safe rules) 'var)
+	   (calc-record rules "rule")))
+     (if (eq many 0)
+	 (setq many '(var inf var-inf))
+       (if many (setq many (prefix-numeric-value many))))
+     (if sel
+	 (setq expr (calc-replace-sub-formula (car entry)
+					      sel
+					      (list 'calcFunc-select sel)))
+       (setq expr (car entry)
+	     reselect nil
+	     math-rewrite-selections nil))
+     (setq expr (calc-encase-atoms
+		 (calc-normalize
+		  (math-rewrite
+		   (calc-normalize expr)
+		   rules many)))
+	   sel nil
+	   expr (calc-locate-select-marker expr))
+     (or (consp sel) (setq sel nil))
+     (if pop-rules (calc-pop-stack 1))
+     (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
+				(- num (if pop-rules 1 0))
+				(list (and reselect sel))))
+   (calc-handle-whys))
+)
+
+(defun calc-locate-select-marker (expr)    ; changes "sel"
+  (if (Math-primp expr)
+      expr
+    (if (and (eq (car expr) 'calcFunc-select)
+	     (= (length expr) 2))
+	(progn
+	  (setq sel (if sel t (nth 1 expr)))
+	  (nth 1 expr))
+      (cons (car expr)
+	    (mapcar 'calc-locate-select-marker (cdr expr)))))
+)
+
+
+
+(defun calc-rewrite (rules-str many)
+  (interactive "sRewrite rule(s): \nP")
+  (calc-slow-wrapper
+   (let (n rules expr)
+     (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
+	 (setq expr (calc-top-n 2)
+	       rules (calc-top-n 1 t)
+	       n 2)
+       (setq rules (if (stringp rules-str)
+		       (math-read-exprs rules-str) rules-str))
+       (if (eq (car-safe rules) 'error)
+	   (error "Bad format in expression: %s" (nth 1 rules)))
+       (if (= (length rules) 1)
+	   (setq rules (car rules))
+	 (setq rules (cons 'vec rules)))
+       (or (memq (car-safe rules) '(vec var calcFunc-assign
+					calcFunc-condition))
+	   (let ((rhs (math-read-expr
+		       (read-string (concat "Rewrite from:    " rules-str
+					    " to: ")))))
+	     (if (eq (car-safe rhs) 'error)
+		 (error "Bad format in expression: %s" (nth 1 rhs)))
+	     (setq rules (list 'calcFunc-assign rules rhs))))
+       (or (eq (car-safe rules) 'var)
+	   (calc-record rules "rule"))
+       (setq expr (calc-top-n 1)
+	     n 1))
+     (if (eq many 0)
+	 (setq many '(var inf var-inf))
+       (if many (setq many (prefix-numeric-value many))))
+     (setq expr (calc-normalize (math-rewrite expr rules many)))
+     (let (sel)
+       (setq expr (calc-locate-select-marker expr)))
+     (calc-pop-push-record-list n "rwrt" (list expr)))
+   (calc-handle-whys))
+)
+
+(defun calc-match (pat)
+  (interactive "sPattern: \n")
+  (calc-slow-wrapper
+   (let (n expr)
+     (if (or (null pat) (equal pat "") (equal pat "$"))
+	 (setq expr (calc-top-n 2)
+	       pat (calc-top-n 1)
+	       n 2)
+       (if (interactive-p) (setq calc-previous-alg-entry pat))
+       (setq pat (if (stringp pat) (math-read-expr pat) pat))
+       (if (eq (car-safe pat) 'error)
+	   (error "Bad format in expression: %s" (nth 1 pat)))
+       (if (not (eq (car-safe pat) 'var))
+	   (calc-record pat "pat"))
+       (setq expr (calc-top-n 1)
+	     n 1))
+     (or (math-vectorp expr) (error "Argument must be a vector"))
+     (if (calc-is-inverse)
+	 (calc-enter-result n "mtcn" (math-match-patterns pat expr t))
+       (calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))
+)
+
+
+
+(defun math-rewrite (whole-expr rules &optional mmt-many)
+  (let ((crules (math-compile-rewrites rules))
+	(heads (math-rewrite-heads whole-expr))
+	(trace-buffer (get-buffer "*Trace*"))
+	(calc-display-just 'center)
+	(calc-display-origin 39)
+	(calc-line-breaking 78)
+	(calc-line-numbering nil)
+	(calc-show-selections t)
+	(calc-why nil)
+	(mmt-func (function
+		   (lambda (x)
+		     (let ((result (math-apply-rewrites x (cdr crules)
+							heads crules)))
+		       (if result
+			   (progn
+			     (if trace-buffer
+				 (let ((fmt (math-format-stack-value
+					     (list result nil nil))))
+				   (save-excursion
+				     (set-buffer trace-buffer)
+				     (insert "\nrewrite to\n" fmt "\n"))))
+			     (setq heads (math-rewrite-heads result heads t))))
+		       result)))))
+    (if trace-buffer
+	(let ((fmt (math-format-stack-value (list whole-expr nil nil))))
+	  (save-excursion
+	    (set-buffer trace-buffer)
+	    (setq truncate-lines t)
+	    (goto-char (point-max))
+	    (insert "\n\nBegin rewriting\n" fmt "\n"))))
+    (or mmt-many (setq mmt-many (or (nth 1 (car crules))
+				    math-rewrite-default-iters)))
+    (if (equal mmt-many '(var inf var-inf)) (setq mmt-many 1000000))
+    (if (equal mmt-many '(neg (var inf var-inf))) (setq mmt-many -1000000))
+    (math-rewrite-phase (nth 3 (car crules)))
+    (if trace-buffer
+	(let ((fmt (math-format-stack-value (list whole-expr nil nil))))
+	  (save-excursion
+	    (set-buffer trace-buffer)
+	    (insert "\nDone rewriting"
+		    (if (= mmt-many 0) " (reached iteration limit)" "")
+		    ":\n" fmt "\n"))))
+    whole-expr)
+)
+(setq math-rewrite-default-iters 100)
+
+(defun math-rewrite-phase (sched)
+  (while (and sched (/= mmt-many 0))
+    (if (listp (car sched))
+	(while (let ((save-expr whole-expr))
+		 (math-rewrite-phase (car sched))
+		 (not (equal whole-expr save-expr))))
+      (if (symbolp (car sched))
+	  (progn
+	    (setq whole-expr (math-normalize (list (car sched) whole-expr)))
+	    (if trace-buffer
+		(let ((fmt (math-format-stack-value
+			    (list whole-expr nil nil))))
+		  (save-excursion
+		    (set-buffer trace-buffer)
+		    (insert "\ncall "
+			    (substring (symbol-name (car sched)) 9)
+			    ":\n" fmt "\n")))))
+	(let ((math-rewrite-phase (car sched)))
+	  (if trace-buffer
+	      (save-excursion
+		(set-buffer trace-buffer)
+		(insert (format "\n(Phase %d)\n" math-rewrite-phase))))
+	  (while (let ((save-expr whole-expr))
+		   (setq whole-expr (math-normalize
+				     (math-map-tree-rec whole-expr)))
+		   (not (equal whole-expr save-expr)))))))
+    (setq sched (cdr sched)))
+)
+
+(defun calcFunc-rewrite (expr rules &optional many)
+  (or (null many) (integerp many)
+      (equal many '(var inf var-inf)) (equal many '(neg (var inf var-inf)))
+      (math-reject-arg many 'fixnump))
+  (condition-case err
+      (math-rewrite expr rules (or many 1))
+    (error (math-reject-arg rules (nth 1 err))))
+)
+
+(defun calcFunc-match (pat vec)
+  (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
+  (condition-case err
+      (math-match-patterns pat vec nil)
+    (error (math-reject-arg pat (nth 1 err))))
+)
+
+(defun calcFunc-matchnot (pat vec)
+  (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
+  (condition-case err
+      (math-match-patterns pat vec t)
+    (error (math-reject-arg pat (nth 1 err))))
+)
+
+(defun math-match-patterns (pat vec &optional not-flag)
+  (let ((newvec nil)
+	(crules (math-compile-patterns pat)))
+    (while (setq vec (cdr vec))
+      (if (eq (not (math-apply-rewrites (car vec) crules))
+	      not-flag)
+	  (setq newvec (cons (car vec) newvec))))
+    (cons 'vec (nreverse newvec)))
+)
+
+(defun calcFunc-matches (expr pat)
+  (condition-case err
+      (if (math-apply-rewrites expr (math-compile-patterns pat))
+	  1
+	0)
+    (error (math-reject-arg pat (nth 1 err))))
+)
+
+(defun calcFunc-vmatches (expr pat)
+  (condition-case err
+      (or (math-apply-rewrites expr (math-compile-patterns pat))
+	  0)
+    (error (math-reject-arg pat (nth 1 err))))
+)
+
+
+
+;;; A compiled rule set is an a-list of entries whose cars are functors,
+;;; and whose cdrs are lists of rules.  If there are rules with no
+;;; well-defined head functor, they are included on all lists and also
+;;; on an extra list whose car is nil.
+;;;
+;;; The first entry in the a-list is of the form (schedule A B C ...).
+;;;
+;;; Rule list entries take the form (regs prog head phases), where:
+;;;
+;;;   regs   is a vector of match registers.
+;;;
+;;;   prog   is a match program (see below).
+;;;
+;;;   head   is a rare function name appearing in the rule body (but not the
+;;;	     head of the whole rule), or nil if none.
+;;;
+;;;   phases is a list of phase numbers for which the rule is enabled.
+;;;
+;;; A match program is a list of match instructions.
+;;;
+;;; In the following, "part" is a register number that contains the
+;;; subexpression to be operated on.
+;;;
+;;; Register 0 is the whole expression being matched.  The others are
+;;; meta-variables in the pattern, temporaries used for matching and
+;;; backtracking, and constant expressions.
+;;;
+;;; (same part reg)
+;;;         The selected part must be math-equal to the contents of "reg".
+;;;
+;;; (same-neg part reg)
+;;;         The selected part must be math-equal to the negative of "reg".
+;;;
+;;; (copy part reg)
+;;;	    The selected part is copied into "reg".  (Rarely used.)
+;;;
+;;; (copy-neg part reg)
+;;;	    The negative of the selected part is copied into "reg".
+;;;
+;;; (integer part)
+;;;         The selected part must be an integer.
+;;;
+;;; (real part)
+;;;         The selected part must be a real.
+;;;
+;;; (constant part)
+;;;         The selected part must be a constant.
+;;;
+;;; (negative part)
+;;;	    The selected part must "look" negative.
+;;;
+;;; (rel part op reg)
+;;;         The selected part must satisfy "part op reg", where "op"
+;;;	    is one of the 6 relational ops, and "reg" is a register.
+;;;
+;;; (mod part modulo value)
+;;;         The selected part must satisfy "part % modulo = value", where
+;;;         "modulo" and "value" are constants.
+;;;
+;;; (func part head reg1 reg2 ... regn)
+;;;         The selected part must be an n-ary call to function "head".
+;;;         The arguments are stored in "reg1" through "regn".
+;;;
+;;; (func-def part head defs reg1 reg2 ... regn)
+;;;	    The selected part must be an n-ary call to function "head".
+;;;	    "Defs" is a list of value/register number pairs for default args.
+;;;	    If a match, assign default values to registers and then skip
+;;;	    immediately over any following "func-def" instructions and
+;;;	    the following "func" instruction.  If wrong number of arguments,
+;;;	    proceed to the following "func-def" or "func" instruction.
+;;;
+;;; (func-opt part head defs reg1)
+;;;	    Like func-def with "n=1", except that if the selected part is
+;;;	    not a call to "head", then the part itself successfully matches
+;;;	    "reg1" (and the defaults are assigned).
+;;;
+;;; (try part heads mark reg1 [def])
+;;;         The selected part must be a function of the correct type which is
+;;;         associative and/or commutative.  "Heads" is a list of acceptable
+;;;         types.  An initial assignment of arguments to "reg1" is tried.
+;;;	    If the program later fails, it backtracks to this instruction
+;;;	    and tries other assignments of arguments to "reg1".
+;;;	    If "def" exists and normal matching fails, backtrack and assign
+;;;	    "part" to "reg1", and "def" to "reg2" in the following "try2".
+;;;	    The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
+;;;	    "mark[0]" points to the argument list; "mark[1]" points to the
+;;;	    current argument; "mark[2]" is 0 if there are two arguments,
+;;;	    1 if reg1 is matching single arguments, 2 if reg2 is matching
+;;;	    single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
+;;;         3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
+;;;	    have two arguments, 1 if phase-2 can be skipped, 2 if full
+;;;	    backtracking is necessary; "mark[4]" is t if the arguments have
+;;;	    been switched from the order given in the original pattern.
+;;;
+;;; (try2 try reg2)
+;;;         Every "try" will be followed by a "try2" whose "try" field is
+;;;	    a pointer to the corresponding "try".  The arguments which were
+;;;	    not stored in "reg1" by that "try" are now stored in "reg2".
+;;;
+;;; (alt instr nil mark)
+;;;	    Basic backtracking.  Execute the instruction sequence "instr".
+;;;	    If this fails, back up and execute following the "alt" instruction.
+;;;	    The "mark" must be the vector "[nil nil 4]".  The "instr" sequence
+;;;	    should execute "end-alt" at the end.
+;;;
+;;; (end-alt ptr)
+;;; 	    Register success of the first alternative of a previous "alt".
+;;;	    "Ptr" is a pointer to the next instruction following that "alt".
+;;;
+;;; (apply part reg1 reg2)
+;;;         The selected part must be a function call.  The functor
+;;;	    (as a variable name) is stored in "reg1"; the arguments
+;;;	    (as a vector) are stored in "reg2".
+;;;
+;;; (cons part reg1 reg2)
+;;;	    The selected part must be a nonempty vector.  The first element
+;;;	    of the vector is stored in "reg1"; the rest of the vector
+;;;	    (as another vector) is stored in "reg2".
+;;;
+;;; (rcons part reg1 reg2)
+;;;	    The selected part must be a nonempty vector.  The last element
+;;;	    of the vector is stored in "reg2"; the rest of the vector
+;;;	    (as another vector) is stored in "reg1".
+;;;
+;;; (select part reg)
+;;;         If the selected part is a unary call to function "select", its
+;;;         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.
+
+
+;;; 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
+
+;;; 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.
+;;;
+
+;;; 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!
+;;;
+
+(defun math-compile-patterns (pats)
+  (if (and (eq (car-safe pats) 'var)
+	   (calc-var-value (nth 2 pats)))
+      (let ((prop (get (nth 2 pats) 'math-pattern-cache)))
+	(or prop
+	    (put (nth 2 pats) 'math-pattern-cache (setq prop (list nil))))
+	(or (eq (car prop) (symbol-value (nth 2 pats)))
+	    (progn
+	      (setcdr prop (math-compile-patterns
+			    (symbol-value (nth 2 pats))))
+	      (setcar prop (symbol-value (nth 2 pats)))))
+	(cdr prop))
+    (let ((math-rewrite-whole t))
+      (cdr (math-compile-rewrites (cons
+				   'vec
+				   (mapcar (function (lambda (x)
+						       (list 'vec x t)))
+					   (if (eq (car-safe pats) 'vec)
+					       (cdr pats)
+					     (list pats))))))))
+)
+(setq math-rewrite-whole nil)
+(setq math-make-import-list nil)
+
+(defun math-compile-rewrites (rules &optional name)
+  (if (eq (car-safe rules) 'var)
+      (let ((prop (get (nth 2 rules) 'math-rewrite-cache))
+	    (math-import-list nil)
+	    (math-make-import-list t)
+	    p)
+	(or (calc-var-value (nth 2 rules))
+	    (error "Rules variable %s has no stored value" (nth 1 rules)))
+	(or prop
+	    (put (nth 2 rules) 'math-rewrite-cache
+		 (setq prop (list (list (cons (nth 2 rules) nil))))))
+	(setq p (car prop))
+	(while (and p (eq (symbol-value (car (car p))) (cdr (car p))))
+	  (setq p (cdr p)))
+	(or (null p)
+	    (progn
+	      (message "Compiling rule set %s..." (nth 1 rules))
+	      (setcdr prop (math-compile-rewrites
+			    (symbol-value (nth 2 rules))
+			    (nth 2 rules)))
+	      (message "Compiling rule set %s...done" (nth 1 rules))
+	      (setcar prop (cons (cons (nth 2 rules)
+				       (symbol-value (nth 2 rules)))
+				 math-import-list))))
+	(cdr prop))
+    (if (or (not (eq (car-safe rules) 'vec))
+	    (and (memq (length rules) '(3 4))
+		 (let ((p rules))
+		   (while (and (setq p (cdr p))
+			       (memq (car-safe (car p))
+				     '(vec
+				       calcFunc-assign
+				       calcFunc-condition
+				       calcFunc-import
+				       calcFunc-phase
+				       calcFunc-schedule
+				       calcFunc-iterations))))
+		   p)))
+	(setq rules (list rules))
+      (setq rules (cdr rules)))
+    (if (assq 'calcFunc-import rules)
+	(let ((pp (setq rules (copy-sequence rules)))
+	      p part)
+	  (while (setq p (car (cdr pp)))
+	    (if (eq (car-safe p) 'calcFunc-import)
+		(progn
+		  (setcdr pp (cdr (cdr pp)))
+		  (or (and (eq (car-safe (nth 1 p)) 'var)
+			   (setq part (calc-var-value (nth 2 (nth 1 p))))
+			   (memq (car-safe part) '(vec
+						   calcFunc-assign
+						   calcFunc-condition)))
+		      (error "Argument of import() must be a rules variable"))
+		  (if math-make-import-list
+		      (setq math-import-list
+			    (cons (cons (nth 2 (nth 1 p))
+					(symbol-value (nth 2 (nth 1 p))))
+				  math-import-list)))
+		  (while (setq p (cdr (cdr p)))
+		    (or (cdr p)
+			(error "import() must have odd number of arguments"))
+		    (setq part (math-rwcomp-substitute part
+						       (car p) (nth 1 p))))
+		  (if (eq (car-safe part) 'vec)
+		      (setq part (cdr part))
+		    (setq part (list part)))
+		  (setcdr pp (append part (cdr pp))))
+	      (setq pp (cdr pp))))))
+    (let ((rule-set nil)
+	  (all-heads nil)
+	  (nil-rules nil)
+	  (rule-count 0)
+	  (math-schedule nil)
+	  (math-iterations nil)
+	  (math-phases nil)
+	  (math-all-phases nil)
+	  (math-remembering nil)
+	  math-pattern math-rhs math-conds)
+      (while rules
+	(cond
+	 ((and (eq (car-safe (car rules)) 'calcFunc-iterations)
+	       (= (length (car rules)) 2))
+	  (or (integerp (nth 1 (car rules)))
+	      (equal (nth 1 (car rules)) '(var inf var-inf))
+	      (equal (nth 1 (car rules)) '(neg (var inf var-inf)))
+	      (error "Invalid argument for iterations(n)"))
+	  (or math-iterations
+	      (setq math-iterations (nth 1 (car rules)))))
+	 ((eq (car-safe (car rules)) 'calcFunc-schedule)
+	  (or math-schedule
+	      (setq math-schedule (math-parse-schedule (cdr (car rules))))))
+	 ((eq (car-safe (car rules)) 'calcFunc-phase)
+	  (setq math-phases (cdr (car rules)))
+	  (if (equal math-phases '((var all var-all)))
+	      (setq math-phases nil))
+	  (let ((p math-phases))
+	    (while p
+	      (or (integerp (car p))
+		  (error "Phase numbers must be small integers"))
+	      (or (memq (car p) math-all-phases)
+		  (setq math-all-phases (cons (car p) math-all-phases)))
+	      (setq p (cdr p)))))
+	 ((or (and (eq (car-safe (car rules)) 'vec)
+		   (cdr (cdr (car rules)))
+		   (not (nthcdr 4 (car rules)))
+		   (setq math-conds (nth 3 (car rules))
+			 math-rhs (nth 2 (car rules))
+			 math-pattern (nth 1 (car rules))))
+	      (progn
+		(setq math-conds nil
+		      math-pattern (car rules))
+		(while (and (eq (car-safe math-pattern) 'calcFunc-condition)
+			    (= (length math-pattern) 3))
+		  (let ((cond (nth 2 math-pattern)))
+		    (setq math-conds (if math-conds
+					 (list 'calcFunc-land math-conds cond)
+				       cond)
+			  math-pattern (nth 1 math-pattern))))
+		(and (eq (car-safe math-pattern) 'calcFunc-assign)
+		     (= (length math-pattern) 3)
+		     (setq math-rhs (nth 2 math-pattern)
+			   math-pattern (nth 1 math-pattern)))))
+	  (let* ((math-prog (list nil))
+		 (math-prog-last math-prog)
+		 (math-num-regs 1)
+		 (math-regs (list (list nil 0 nil nil)))
+		 (math-bound-vars nil)
+		 (math-aliased-vars nil)
+		 (math-copy-neg nil))
+	    (setq math-conds (and math-conds (math-flatten-lands math-conds)))
+	    (math-rwcomp-pattern math-pattern 0)
+	    (while math-conds
+	      (let ((expr (car math-conds)))
+		(setq math-conds (cdr math-conds))
+		(math-rwcomp-cond-instr expr)))
+	    (math-rwcomp-instr 'done
+			       (if (eq math-rhs t)
+				   (cons 'vec
+					 (delq
+					  nil
+					  (nreverse
+					   (mapcar
+					    (function
+					     (lambda (v)
+					       (and (car v)
+						    (list
+						     'calcFunc-assign
+						     (math-build-var-name
+						      (car v))
+						     (math-rwcomp-register-expr
+						      (nth 1 v))))))
+					    math-regs))))
+				 (math-rwcomp-match-vars math-rhs))
+			       math-remembering)
+	    (setq math-prog (cdr math-prog))
+	    (let* ((heads (math-rewrite-heads math-pattern))
+		   (rule (list (vconcat
+				(nreverse
+				 (mapcar (function (lambda (x) (nth 3 x)))
+					 math-regs)))
+			       math-prog
+			       heads
+			       math-phases))
+		   (head (and (not (Math-primp math-pattern))
+			      (not (and (eq (car (car math-prog)) 'try)
+					(nth 5 (car math-prog))))
+			      (not (memq (car (car math-prog)) '(func-opt
+								 apply
+								 select
+								 alt)))
+			      (if (memq (car (car math-prog)) '(func
+								func-def))
+				  (nth 2 (car math-prog))
+				(if (eq (car math-pattern) 'calcFunc-quote)
+				    (car-safe (nth 1 math-pattern))
+				  (car math-pattern))))))
+	      (let (found)
+		(while heads
+		  (if (setq found (assq (car heads) all-heads))
+		      (setcdr found (1+ (cdr found)))
+		    (setq all-heads (cons (cons (car heads) 1) all-heads)))
+		  (setq heads (cdr heads))))
+	      (if (eq head '-) (setq head '+))
+	      (if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec))
+	      (if head
+		  (progn
+		    (nconc (or (assq head rule-set)
+			       (car (setq rule-set (cons (cons head
+							       (copy-sequence
+								nil-rules))
+							 rule-set))))
+			   (list rule))
+		    (if (eq head '*)
+			(nconc (or (assq '/ rule-set)
+				   (car (setq rule-set (cons (cons
+							      '/
+							      (copy-sequence
+							       nil-rules))
+							     rule-set))))
+			       (list rule))))
+		(setq nil-rules (nconc nil-rules (list rule)))
+		(let ((ptr rule-set))
+		  (while ptr
+		    (nconc (car ptr) (list rule))
+		    (setq ptr (cdr ptr))))))))
+	 (t
+	  (error "Rewrite rule set must be a vector of A := B rules")))
+	(setq rules (cdr rules)))
+      (if nil-rules
+	  (setq rule-set (cons (cons nil nil-rules) rule-set)))
+      (setq all-heads (mapcar 'car
+			      (sort all-heads (function
+					       (lambda (x y)
+						 (< (cdr x) (cdr y)))))))
+      (let ((set rule-set)
+	    rule heads ptr)
+	(while set
+	  (setq rule (cdr (car set)))
+	  (while rule
+	    (if (consp (setq heads (nth 2 (car rule))))
+		(progn
+		  (setq heads (delq (car (car set)) heads)
+			ptr all-heads)
+		  (while (and ptr (not (memq (car ptr) heads)))
+		    (setq ptr (cdr ptr)))
+		  (setcar (nthcdr 2 (car rule)) (car ptr))))
+	    (setq rule (cdr rule)))
+	  (setq set (cdr set))))
+      (let ((plus (assq '+ rule-set)))
+	(if plus
+	    (setq rule-set (cons (cons '- (cdr plus)) rule-set))))
+      (cons (list 'schedule math-iterations name
+		  (or math-schedule
+		      (sort math-all-phases '<)
+		      (list 1)))
+	    rule-set)))
+)
+
+(defun math-flatten-lands (expr)
+  (if (eq (car-safe expr) 'calcFunc-land)
+      (append (math-flatten-lands (nth 1 expr))
+	      (math-flatten-lands (nth 2 expr)))
+    (list expr))
+)
+
+(defun math-rewrite-heads (expr &optional more all)
+  (let ((heads more)
+	(skips (and (not all)
+		    '(calcFunc-apply calcFunc-condition calcFunc-opt
+				     calcFunc-por calcFunc-pnot)))
+	(blanks (and (not all)
+		     '(calcFunc-quote calcFunc-plain calcFunc-select
+				      calcFunc-cons calcFunc-rcons
+				      calcFunc-pand))))
+    (or (Math-primp expr)
+	(math-rewrite-heads-rec expr))
+    heads)
+)
+
+(defun math-rewrite-heads-rec (expr)
+  (or (memq (car expr) skips)
+      (progn
+	(or (memq (car expr) heads)
+	    (memq (car expr) blanks)
+	    (memq 'algebraic (get (car expr) 'math-rewrite-props))
+	    (setq heads (cons (car expr) heads)))
+	(while (setq expr (cdr expr))
+	  (or (Math-primp (car expr))
+	      (math-rewrite-heads-rec (car expr))))))
+)
+
+(defun math-parse-schedule (sched)
+  (mapcar (function
+	   (lambda (s)
+	     (if (integerp s)
+		 s
+	       (if (math-vectorp s)
+		   (math-parse-schedule (cdr s))
+		 (if (eq (car-safe s) 'var)
+		     (math-var-to-calcFunc s)
+		   (error "Improper component in rewrite schedule"))))))
+	  sched)
+)
+
+(defun math-rwcomp-match-vars (expr)
+  (if (Math-primp expr)
+      (if (eq (car-safe expr) 'var)
+	  (let ((entry (assq (nth 2 expr) math-regs)))
+	    (if entry
+		(math-rwcomp-register-expr (nth 1 entry))
+	      expr))
+	expr)
+    (if (and (eq (car expr) 'calcFunc-quote)
+	     (= (length expr) 2))
+	(math-rwcomp-match-vars (nth 1 expr))
+      (if (and (eq (car expr) 'calcFunc-plain)
+	       (= (length expr) 2)
+	       (not (Math-primp (nth 1 expr))))
+	  (list (car expr)
+		(cons (car (nth 1 expr))
+		      (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
+	(cons (car expr)
+	      (mapcar 'math-rwcomp-match-vars (cdr expr))))))
+)
+
+(defun math-rwcomp-register-expr (num)
+  (let ((entry (nth (1- (- math-num-regs num)) math-regs)))
+    (if (nth 2 entry)
+	(list 'neg (list 'calcFunc-register (nth 1 entry)))
+      (list 'calcFunc-register (nth 1 entry))))
+)
+
+(defun math-rwcomp-substitute (expr old new)
+  (if (and (eq (car-safe old) 'var)
+	   (memq (car-safe new) '(var calcFunc-lambda)))
+      (let ((old-func (math-var-to-calcFunc old))
+	    (new-func (math-var-to-calcFunc new)))
+	(math-rwcomp-subst-rec expr))
+    (let ((old-func nil))
+      (math-rwcomp-subst-rec expr)))
+)
+
+(defun math-rwcomp-subst-rec (expr)
+  (cond ((equal expr old) new)
+	((Math-primp expr) expr)
+	(t (if (eq (car expr) old-func)
+	       (math-build-call new-func (mapcar 'math-rwcomp-subst-rec
+						 (cdr expr)))
+	     (cons (car expr)
+		   (mapcar 'math-rwcomp-subst-rec (cdr expr))))))
+)
+
+(setq math-rwcomp-tracing nil)
+
+(defun math-rwcomp-trace (instr)
+  (if math-rwcomp-tracing (progn (terpri) (princ instr)))
+  instr
+)
+
+(defun math-rwcomp-instr (&rest instr)
+  (setcdr math-prog-last
+	  (setq math-prog-last (list (math-rwcomp-trace instr))))
+)
+
+(defun math-rwcomp-multi-instr (tail &rest instr)
+  (setcdr math-prog-last
+	  (setq math-prog-last (list (math-rwcomp-trace (append instr tail)))))
+)
+
+(defun math-rwcomp-bind-var (reg var)
+  (setcar (math-rwcomp-reg-entry reg) (nth 2 var))
+  (setq math-bound-vars (cons (nth 2 var) math-bound-vars))
+  (math-rwcomp-do-conditions)
+)
+
+(defun math-rwcomp-unbind-vars (mark)
+  (while (not (eq math-bound-vars mark))
+    (setcar (assq (car math-bound-vars) math-regs) nil)
+    (setq math-bound-vars (cdr math-bound-vars)))
+)
+
+(defun math-rwcomp-do-conditions ()
+  (let ((cond math-conds))
+    (while cond
+      (if (math-rwcomp-all-regs-done (car cond))
+	  (let ((expr (car cond)))
+	    (setq math-conds (delq (car cond) math-conds))
+	    (setcar cond 1)
+	    (math-rwcomp-cond-instr expr)))
+      (setq cond (cdr cond))))
+)
+
+(defun math-rwcomp-cond-instr (expr)
+  (let (op arg)
+    (cond ((and (eq (car-safe expr) 'calcFunc-matches)
+		(= (length expr) 3)
+		(eq (car-safe (setq arg (math-rwcomp-match-vars (nth 1 expr))))
+		    'calcFunc-register))
+	   (math-rwcomp-pattern (nth 2 expr) (nth 1 arg)))
+	  ((math-numberp (setq expr (math-rwcomp-match-vars expr)))
+	   (if (Math-zerop expr)
+	       (math-rwcomp-instr 'backtrack)))
+	  ((and (eq (car expr) 'calcFunc-let)
+		(= (length expr) 3))
+	   (let ((reg (math-rwcomp-reg)))
+	     (math-rwcomp-instr 'let reg (nth 2 expr))
+	     (math-rwcomp-pattern (nth 1 expr) reg)))
+	  ((and (eq (car expr) 'calcFunc-let)
+		(= (length expr) 2)
+		(eq (car-safe (nth 1 expr)) 'calcFunc-assign)
+		(= (length (nth 1 expr)) 3))
+	   (let ((reg (math-rwcomp-reg)))
+	     (math-rwcomp-instr 'let reg (nth 2 (nth 1 expr)))
+	     (math-rwcomp-pattern (nth 1 (nth 1 expr)) reg)))
+	  ((and (setq op (cdr (assq (car-safe expr)
+				    '( (calcFunc-integer  . integer)
+				       (calcFunc-real     . real)
+				       (calcFunc-constant . constant)
+				       (calcFunc-negative . negative) ))))
+		(= (length expr) 2)
+		(or (and (eq (car-safe (nth 1 expr)) 'neg)
+			 (memq op '(integer real constant))
+			 (setq arg (nth 1 (nth 1 expr))))
+		    (setq arg (nth 1 expr)))
+		(eq (car-safe (setq arg (nth 1 expr))) 'calcFunc-register))
+	   (math-rwcomp-instr op (nth 1 arg)))
+	  ((and (assq (car-safe expr) calc-tweak-eqn-table)
+		(= (length expr) 3)
+		(eq (car-safe (nth 1 expr)) 'calcFunc-register))
+	   (if (math-constp (nth 2 expr))
+	       (let ((reg (math-rwcomp-reg)))
+		 (setcar (nthcdr 3 (car math-regs)) (nth 2 expr))
+		 (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
+				    (car expr) reg))
+	     (if (eq (car (nth 2 expr)) 'calcFunc-register)
+		 (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
+				    (car expr) (nth 1 (nth 2 expr)))
+	       (math-rwcomp-instr 'cond expr))))
+	  ((and (eq (car-safe expr) 'calcFunc-eq)
+		(= (length expr) 3)
+		(eq (car-safe (nth 1 expr)) '%)
+		(eq (car-safe (nth 1 (nth 1 expr))) 'calcFunc-register)
+		(math-constp (nth 2 (nth 1 expr)))
+		(math-constp (nth 2 expr)))
+	   (math-rwcomp-instr 'mod (nth 1 (nth 1 (nth 1 expr)))
+			      (nth 2 (nth 1 expr)) (nth 2 expr)))
+	  ((equal expr '(var remember var-remember))
+	   (setq math-remembering 1))
+	  ((and (eq (car-safe expr) 'calcFunc-remember)
+		(= (length expr) 2))
+	   (setq math-remembering (if math-remembering
+				      (list 'calcFunc-lor
+					    math-remembering (nth 1 expr))
+				    (nth 1 expr))))
+	  (t (math-rwcomp-instr 'cond expr))))
+)
+
+(defun math-rwcomp-same-instr (reg1 reg2 neg)
+  (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
+				 (nth 2 (math-rwcomp-reg-entry reg2)))
+			     neg)
+			 'same-neg
+		       'same)
+		     reg1 reg2)
+)
+
+(defun math-rwcomp-copy-instr (reg1 reg2 neg)
+  (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
+	      (nth 2 (math-rwcomp-reg-entry reg2)))
+	  neg)
+      (math-rwcomp-instr 'copy-neg reg1 reg2)
+    (or (eq reg1 reg2)
+	(math-rwcomp-instr 'copy reg1 reg2)))
+)
+
+(defun math-rwcomp-reg ()
+  (prog1
+      math-num-regs
+    (setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
+	  math-num-regs (1+ math-num-regs)))
+)
+
+(defun math-rwcomp-reg-entry (num)
+  (nth (1- (- math-num-regs num)) math-regs)
+)
+
+
+(defun math-rwcomp-pattern (expr part &optional not-direct)
+  (cond ((or (math-rwcomp-no-vars expr)
+	     (and (eq (car expr) 'calcFunc-quote)
+		  (= (length expr) 2)
+		  (setq expr (nth 1 expr))))
+ 	 (if (eq (car-safe expr) 'calcFunc-register)
+	     (math-rwcomp-same-instr part (nth 1 expr) nil)
+	   (let ((reg (math-rwcomp-reg)))
+	     (setcar (nthcdr 3 (car math-regs)) expr)
+	     (math-rwcomp-same-instr part reg nil))))
+ 	((eq (car expr) 'var)
+ 	 (let ((entry (assq (nth 2 expr) math-regs)))
+	   (if entry
+	       (math-rwcomp-same-instr part (nth 1 entry) nil)
+	     (if not-direct
+ 		 (let ((reg (math-rwcomp-reg)))
+		   (math-rwcomp-pattern expr reg)
+		   (math-rwcomp-copy-instr part reg nil))
+	       (if (setq entry (assq (nth 2 expr) math-aliased-vars))
+		   (progn
+		     (setcar (math-rwcomp-reg-entry (nth 1 entry))
+			     (nth 2 expr))
+		     (setcar entry nil)
+		     (math-rwcomp-copy-instr part (nth 1 entry) nil))
+ 		 (math-rwcomp-bind-var part expr))))))
+ 	((and (eq (car expr) 'calcFunc-select)
+	      (= (length expr) 2))
+ 	 (let ((reg (math-rwcomp-reg)))
+	   (math-rwcomp-instr 'select part reg)
+	   (math-rwcomp-pattern (nth 1 expr) reg)))
+ 	((and (eq (car expr) 'calcFunc-opt)
+	      (memq (length expr) '(2 3)))
+ 	 (error "opt( ) occurs in context where it is not allowed"))
+ 	((eq (car expr) 'neg)
+ 	 (if (eq (car (nth 1 expr)) 'var)
+	     (let ((entry (assq (nth 2 (nth 1 expr)) math-regs)))
+	       (if entry
+		   (math-rwcomp-same-instr part (nth 1 entry) t)
+		 (if math-copy-neg
+		     (let ((reg (math-rwcomp-best-reg (nth 1 expr))))
+		       (math-rwcomp-copy-instr part reg t)
+		       (math-rwcomp-pattern (nth 1 expr) reg))
+		   (setcar (cdr (cdr (math-rwcomp-reg-entry part))) t)
+		   (math-rwcomp-pattern (nth 1 expr) part))))
+	   (if (math-rwcomp-is-algebraic (nth 1 expr))
+	       (math-rwcomp-cond-instr (list 'calcFunc-eq
+					     (math-rwcomp-register-expr part)
+					     expr))
+	     (let ((reg (math-rwcomp-reg)))
+	       (math-rwcomp-instr 'func part 'neg reg)
+	       (math-rwcomp-pattern (nth 1 expr) reg)))))
+ 	((and (eq (car expr) 'calcFunc-apply)
+	      (= (length expr) 3))
+ 	 (let ((reg1 (math-rwcomp-reg))
+	       (reg2 (math-rwcomp-reg)))
+	   (math-rwcomp-instr 'apply part reg1 reg2)
+	   (math-rwcomp-pattern (nth 1 expr) reg1)
+	   (math-rwcomp-pattern (nth 2 expr) reg2)))
+ 	((and (eq (car expr) 'calcFunc-cons)
+	      (= (length expr) 3))
+ 	 (let ((reg1 (math-rwcomp-reg))
+	       (reg2 (math-rwcomp-reg)))
+	   (math-rwcomp-instr 'cons part reg1 reg2)
+	   (math-rwcomp-pattern (nth 1 expr) reg1)
+	   (math-rwcomp-pattern (nth 2 expr) reg2)))
+ 	((and (eq (car expr) 'calcFunc-rcons)
+	      (= (length expr) 3))
+ 	 (let ((reg1 (math-rwcomp-reg))
+	       (reg2 (math-rwcomp-reg)))
+	   (math-rwcomp-instr 'rcons part reg1 reg2)
+	   (math-rwcomp-pattern (nth 1 expr) reg1)
+	   (math-rwcomp-pattern (nth 2 expr) reg2)))
+ 	((and (eq (car expr) 'calcFunc-condition)
+	      (>= (length expr) 3))
+ 	 (math-rwcomp-pattern (nth 1 expr) part)
+ 	 (setq expr (cdr expr))
+ 	 (while (setq expr (cdr expr))
+	   (let ((cond (math-flatten-lands (car expr))))
+	     (while cond
+	       (if (math-rwcomp-all-regs-done (car cond))
+		   (math-rwcomp-cond-instr (car cond))
+ 		 (setq math-conds (cons (car cond) math-conds)))
+	       (setq cond (cdr cond))))))
+ 	((and (eq (car expr) 'calcFunc-pand)
+	      (= (length expr) 3))
+ 	 (math-rwcomp-pattern (nth 1 expr) part)
+ 	 (math-rwcomp-pattern (nth 2 expr) part))
+ 	((and (eq (car expr) 'calcFunc-por)
+	      (= (length expr) 3))
+ 	 (math-rwcomp-instr 'alt nil nil [nil nil 4])
+ 	 (let ((math-conds nil)
+	       (head math-prog-last)
+	       (mark math-bound-vars)
+	       (math-copy-neg t))
+	   (math-rwcomp-pattern (nth 1 expr) part t)
+	   (let ((amark math-aliased-vars)
+		 (math-aliased-vars math-aliased-vars)
+ 		 (tail math-prog-last)
+		 (p math-bound-vars)
+		 entry)
+	     (while (not (eq p mark))
+	       (setq entry (assq (car p) math-regs)
+		     math-aliased-vars (cons (list (car p) (nth 1 entry) nil)
+					     math-aliased-vars)
+		     p (cdr p))
+	       (setcar (math-rwcomp-reg-entry (nth 1 entry)) nil))
+	     (setcar (cdr (car head)) (cdr head))
+	     (setcdr head nil)
+	     (setq math-prog-last head)
+	     (math-rwcomp-pattern (nth 2 expr) part)
+	     (math-rwcomp-instr 'same 0 0)
+	     (setcdr tail math-prog-last)
+	     (setq p math-aliased-vars)
+	     (while (not (eq p amark))
+	       (if (car (car p))
+		   (setcar (math-rwcomp-reg-entry (nth 1 (car p)))
+			   (car (car p))))
+	       (setq p (cdr p)))))
+ 	 (math-rwcomp-do-conditions))
+ 	((and (eq (car expr) 'calcFunc-pnot)
+	      (= (length expr) 2))
+ 	 (math-rwcomp-instr 'alt nil nil [nil nil 4])
+ 	 (let ((head math-prog-last)
+	       (mark math-bound-vars))
+	   (math-rwcomp-pattern (nth 1 expr) part)
+	   (math-rwcomp-unbind-vars mark)
+	   (math-rwcomp-instr 'end-alt head)
+	   (math-rwcomp-instr 'backtrack)
+	   (setcar (cdr (car head)) (cdr head))
+	   (setcdr head nil)
+	   (setq math-prog-last head)))
+ 	(t (let ((props (get (car expr) 'math-rewrite-props)))
+	     (if (and (eq (car expr) 'calcFunc-plain)
+		      (= (length expr) 2)
+		      (not (math-primp (nth 1 expr))))
+ 		 (setq expr (nth 1 expr))) ; but "props" is still nil
+	     (if (and (memq 'algebraic props)
+		      (math-rwcomp-is-algebraic expr))
+ 		 (math-rwcomp-cond-instr (list 'calcFunc-eq
+					       (math-rwcomp-register-expr part)
+					       expr))
+	       (if (and (memq 'commut props)
+ 			(= (length expr) 3))
+		   (let ((arg1 (nth 1 expr))
+ 			 (arg2 (nth 2 expr))
+ 			 try1 def code head (flip nil))
+		     (if (eq (car expr) '-)
+ 			 (setq arg2 (math-rwcomp-neg arg2)))
+		     (setq arg1 (cons arg1 (math-rwcomp-best-reg arg1))
+			   arg2 (cons arg2 (math-rwcomp-best-reg arg2)))
+		     (or (math-rwcomp-order arg1 arg2)
+ 			 (setq def arg1 arg1 arg2 arg2 def flip t))
+		     (if (math-rwcomp-optional-arg (car expr) arg1)
+ 			 (error "Too many opt( ) arguments in this context"))
+		     (setq def (math-rwcomp-optional-arg (car expr) arg2)
+			   head (if (memq (car expr) '(+ -))
+				    '(+ -)
+				  (if (eq (car expr) '*)
+				      '(* /)
+				    (list (car expr))))
+			   code (if (math-rwcomp-is-constrained
+				     (car arg1) head)
+				    (if (math-rwcomp-is-constrained
+ 					 (car arg2) head)
+ 					0 1)
+				  2))
+		     (math-rwcomp-multi-instr (and def (list def))
+					      'try part head
+					      (vector nil nil nil code flip)
+					      (cdr arg1))
+		     (setq try1 (car math-prog-last))
+		     (math-rwcomp-pattern (car arg1) (cdr arg1))
+		     (math-rwcomp-instr 'try2 try1 (cdr arg2))
+		     (if (and (= part 0) (not def) (not math-rewrite-whole)
+			      (not (eq math-rhs t))
+ 			      (setq def (get (car expr)
+ 					     'math-rewrite-default)))
+ 			 (let ((reg1 (math-rwcomp-reg))
+ 			       (reg2 (math-rwcomp-reg)))
+ 			   (if (= (aref (nth 3 try1) 3) 0)
+ 			       (aset (nth 3 try1) 3 1))
+			   (math-rwcomp-instr 'try (cdr arg2)
+					      (if (equal head '(* /))
+						  '(*) head)
+ 					      (vector nil nil nil
+ 						      (if (= code 0)
+ 							  1 2)
+ 						      nil)
+ 					      reg1 def)
+ 			   (setq try1 (car math-prog-last))
+ 			   (math-rwcomp-pattern (car arg2) reg1)
+ 			   (math-rwcomp-instr 'try2 try1 reg2)
+ 			   (setq math-rhs (list (if (eq (car expr) '-)
+ 						    '+ (car expr))
+ 						math-rhs
+ 						(list 'calcFunc-register
+ 						      reg2))))
+ 		       (math-rwcomp-pattern (car arg2) (cdr arg2))))
+ 		 (let* ((args (mapcar (function
+ 				       (lambda (x)
+ 					 (cons x (math-rwcomp-best-reg x))))
+ 				      (cdr expr)))
+ 			(args2 (copy-sequence args))
+ 			(argp (reverse args2))
+ 			(defs nil)
+ 			(num 1))
+ 		   (while argp
+ 		     (let ((def (math-rwcomp-optional-arg (car expr)
+ 							  (car argp))))
+ 		       (if def
+ 			   (progn
+ 			     (setq args2 (delq (car argp) args2)
+ 				   defs (cons (cons def (cdr (car argp)))
+ 					      defs))
+ 			     (math-rwcomp-multi-instr
+ 			      (mapcar 'cdr args2)
+ 			      (if (or (and (memq 'unary1 props)
+ 					   (= (length args2) 1)
+ 					   (eq (car args2) (car args)))
+ 				      (and (memq 'unary2 props)
+ 					   (= (length args) 2)
+ 					   (eq (car args2) (nth 1 args))))
+ 				  'func-opt
+ 				'func-def)
+ 			      part (car expr)
+ 			      defs))))
+ 		     (setq argp (cdr argp)))
+ 		   (math-rwcomp-multi-instr (mapcar 'cdr args)
+ 					    'func part (car expr))
+ 		   (setq args (sort args 'math-rwcomp-order))
+ 		   (while args
+ 		     (math-rwcomp-pattern (car (car args)) (cdr (car args)))
+ 		     (setq num (1+ num)
+ 			   args (cdr args)))))))))
+)
+
+(defun math-rwcomp-best-reg (x)
+  (or (and (eq (car-safe x) 'var)
+	   (let ((entry (assq (nth 2 x) math-aliased-vars)))
+	     (and entry
+		  (not (nth 2 entry))
+		  (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry))))
+		  (progn
+		    (setcar (cdr (cdr entry)) t)
+		    (nth 1 entry)))))
+      (math-rwcomp-reg))
+)
+
+(defun math-rwcomp-all-regs-done (expr)
+  (if (Math-primp expr)
+      (or (not (eq (car-safe expr) 'var))
+	  (assq (nth 2 expr) math-regs)
+	  (eq (nth 2 expr) 'var-remember)
+	  (math-const-var expr))
+    (if (and (eq (car expr) 'calcFunc-let)
+	     (= (length expr) 3))
+	(math-rwcomp-all-regs-done (nth 2 expr))
+      (if (and (eq (car expr) 'calcFunc-let)
+	       (= (length expr) 2)
+	       (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
+	       (= (length (nth 1 expr)) 3))
+	  (math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
+	(while (and (setq expr (cdr expr))
+		    (math-rwcomp-all-regs-done (car expr))))
+	(null expr))))
+)
+
+(defun math-rwcomp-no-vars (expr)
+  (if (Math-primp expr)
+      (or (not (eq (car-safe expr) 'var))
+	  (math-const-var expr))
+    (and (not (memq (car expr) '(calcFunc-condition
+				 calcFunc-select calcFunc-quote
+				 calcFunc-plain calcFunc-opt
+				 calcFunc-por calcFunc-pand
+				 calcFunc-pnot calcFunc-apply
+				 calcFunc-cons calcFunc-rcons)))
+	 (progn
+	   (while (and (setq expr (cdr expr))
+		       (math-rwcomp-no-vars (car expr))))
+	   (null expr))))
+)
+
+(defun math-rwcomp-is-algebraic (expr)
+  (if (Math-primp expr)
+      (or (not (eq (car-safe expr) 'var))
+	  (math-const-var expr)
+	  (assq (nth 2 expr) math-regs))
+    (and (memq 'algebraic (get (car expr) 'math-rewrite-props))
+	 (progn
+	   (while (and (setq expr (cdr expr))
+		       (math-rwcomp-is-algebraic (car expr))))
+	   (null expr))))
+)
+
+(defun math-rwcomp-is-constrained (expr not-these)
+  (if (Math-primp expr)
+      (not (eq (car-safe expr) 'var))
+    (if (eq (car expr) 'calcFunc-plain)
+	(math-rwcomp-is-constrained (nth 1 expr) not-these)
+      (not (or (memq (car expr) '(neg calcFunc-select))
+	       (memq (car expr) not-these)
+	       (and (memq 'commut (get (car expr) 'math-rewrite-props))
+		    (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
+			(eq (car-safe (nth 2 expr)) 'calcFunc-opt)))))))
+)
+
+(defun math-rwcomp-optional-arg (head argp)
+  (let ((arg (car argp)))
+    (if (eq (car-safe arg) 'calcFunc-opt)
+	(and (memq (length arg) '(2 3))
+	     (progn
+	       (or (eq (car-safe (nth 1 arg)) 'var)
+		   (error "First argument of opt( ) must be a variable"))
+	       (setcar argp (nth 1 arg))
+	       (if (= (length arg) 2)
+		   (or (get head 'math-rewrite-default)
+		       (error "opt( ) must include a default in this context"))
+		 (nth 2 arg))))
+      (and (eq (car-safe arg) 'neg)
+	   (let* ((part (list (nth 1 arg)))
+		  (partp (math-rwcomp-optional-arg head part)))
+	     (and partp
+		  (setcar argp (math-rwcomp-neg (car part)))
+		  (math-neg partp))))))
+)
+
+(defun math-rwcomp-neg (expr)
+  (if (memq (car-safe expr) '(* /))
+      (if (eq (car-safe (nth 1 expr)) 'var)
+	  (list (car expr) (list 'neg (nth 1 expr)) (nth 2 expr))
+	(if (eq (car-safe (nth 2 expr)) 'var)
+	    (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
+	  (math-neg expr)))
+    (math-neg expr))
+)
+
+(defun math-rwcomp-assoc-args (expr)
+  (if (and (eq (car-safe (nth 1 expr)) (car expr))
+	   (= (length (nth 1 expr)) 3))
+      (math-rwcomp-assoc-args (nth 1 expr))
+    (setq math-args (cons (nth 1 expr) math-args)))
+  (if (and (eq (car-safe (nth 2 expr)) (car expr))
+	   (= (length (nth 2 expr)) 3))
+      (math-rwcomp-assoc-args (nth 2 expr))
+    (setq math-args (cons (nth 2 expr) math-args)))
+)
+
+(defun math-rwcomp-addsub-args (expr)
+  (if (memq (car-safe (nth 1 expr)) '(+ -))
+      (math-rwcomp-addsub-args (nth 1 expr))
+    (setq math-args (cons (nth 1 expr) math-args)))
+  (if (eq (car expr) '-)
+      (setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args))
+    (if (eq (car-safe (nth 2 expr)) '+)
+	(math-rwcomp-addsub-args (nth 2 expr))
+      (setq math-args (cons (nth 2 expr) math-args))))
+)
+
+(defun math-rwcomp-order (a b)
+  (< (math-rwcomp-priority (car a))
+     (math-rwcomp-priority (car b)))
+)
+
+;;; 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)
+
+(defun math-rwcomp-priority (expr)
+  (+ (math-rwcomp-count-pnots expr)
+     (cond ((eq (car-safe expr) 'calcFunc-opt)
+	    10000)
+	   ((math-rwcomp-no-vars expr)
+	    0)
+	   ((eq (car expr) 'calcFunc-quote)
+	    0)
+	   ((eq (car expr) 'var)
+	    (if (assq (nth 2 expr) math-regs)
+		0
+	      (if (= (math-rwcomp-count-refs expr) 1)
+		  50
+		20)))
+	   (t (let ((props (get (car expr) 'math-rewrite-props)))
+		(if (or (memq 'commut props)
+			(memq 'assoc props))
+		    40
+		  (if (memq 'algebraic props)
+		      30
+		    10))))))
+)
+
+(defun math-rwcomp-count-refs (var)
+  (let ((count (or (math-expr-contains-count math-pattern var) 0))
+	(p math-conds))
+    (while p
+      (if (eq (car-safe (car p)) 'calcFunc-let)
+	  (if (= (length (car p)) 3)
+	      (setq count (+ count
+			     (or (math-expr-contains-count (nth 2 (car p)) var)
+				 0)))
+	    (if (and (= (length (car p)) 2)
+		     (eq (car-safe (nth 1 (car p))) 'calcFunc-assign)
+		     (= (length (nth 1 (car p))) 3))
+		(setq count (+ count
+			       (or (math-expr-contains-count
+				    (nth 2 (nth 1 (car p))) var) 0))))))
+      (setq p (cdr p)))
+    count)
+)
+
+(defun math-rwcomp-count-pnots (expr)
+  (if (Math-primp expr)
+      0
+    (if (eq (car expr) 'calcFunc-pnot)
+	100
+      (let ((count 0))
+	(while (setq expr (cdr expr))
+	  (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
+	count)))
+)
+
+;;; In the current implementation, all associative functions must
+;;; also be commutative.
+
+(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))
+
+;;; 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.
+
+(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))
+
+(defmacro math-rwfail (&optional back)
+  (list 'setq 'pc
+	(list 'and
+	      (if back
+		  '(setq btrack (cdr btrack))
+		'btrack)
+	      ''((backtrack))))
+)
+
+;;; This monstrosity is necessary because the use of static vectors of
+;;; registers makes rewrite rules non-reentrant.  Yucko!
+(defmacro math-rweval (form)
+  (list 'let '((orig (car rules)))
+	'(setcar rules (quote (nil nil nil no-phase)))
+	(list 'unwind-protect
+	      form
+	      '(setcar rules orig)))
+)
+
+(setq math-rewrite-phase 1)
+
+(defun math-apply-rewrites (expr rules &optional heads ruleset)
+  (and
+   (setq rules (cdr (or (assq (car-safe expr) rules)
+			(assq nil rules))))
+   (let ((result nil)
+	 op regs inst part pc mark btrack
+	 (tracing math-rwcomp-tracing)
+	 (phase math-rewrite-phase))
+     (while rules
+       (or
+	(and (setq part (nth 2 (car rules)))
+	     heads
+	     (not (memq part heads)))
+	(and (setq part (nth 3 (car rules)))
+	     (not (memq phase part)))
+	(progn
+	  (setq regs (car (car rules))
+		pc (nth 1 (car rules))
+		btrack nil)
+	  (aset regs 0 expr)
+	  (while pc
+	     
+	    (and tracing
+		 (progn (terpri) (princ (car pc))
+			(if (and (natnump (nth 1 (car pc)))
+				 (< (nth 1 (car pc)) (length regs)))
+			    (princ (format "\n  part = %s"
+					   (aref regs (nth 1 (car pc))))))))
+	    
+	    (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
+		   (if (and (consp (setq part (aref regs (car (cdr inst)))))
+			    (eq (car part)
+				(car (setq inst (cdr (cdr inst)))))
+			    (progn
+			      (while (and (setq inst (cdr inst)
+						part (cdr part))
+					  inst)
+				(aset regs (car inst) (car part)))
+			      (not (or inst part))))
+		       (setq pc (cdr pc))
+		     (math-rwfail)))
+		  
+		  ((eq op 'same)
+		   (if (or (equal (setq part (aref regs (nth 1 inst)))
+				  (setq mark (aref regs (nth 2 inst))))
+			   (Math-equal part mark))
+		       (setq pc (cdr pc))
+		     (math-rwfail)))
+		  
+		  ((and (eq op 'try)
+			calc-matrix-mode
+			(not (eq calc-matrix-mode 'scalar))
+			(eq (car (nth 2 inst)) '*)
+			(consp (setq part (aref regs (car (cdr inst)))))
+			(eq (car part) '*)
+			(not (math-known-scalarp part)))
+		   (setq mark (nth 3 inst)
+			 pc (cdr pc))
+		   (if (aref mark 4)
+		       (progn
+			 (aset regs (nth 4 inst) (nth 2 part))
+			 (aset mark 1 (cdr (cdr part))))
+		     (aset regs (nth 4 inst) (nth 1 part))
+		     (aset mark 1 (cdr part)))
+		   (aset mark 0 (cdr part))
+		   (aset mark 2 0))
+		  
+		  ((eq op 'try)
+		   (if (and (consp (setq part (aref regs (car (cdr inst)))))
+			    (memq (car part) (nth 2 inst))
+			    (= (length part) 3)
+			    (or (not (eq (car part) '/))
+				(Math-objectp (nth 2 part))))
+		       (progn
+			 (setq op nil
+			       mark (car (cdr (setq inst (cdr (cdr inst))))))
+			 (and
+			  (memq 'assoc (get (car part) 'math-rewrite-props))
+			  (not (= (aref mark 3) 0))
+			  (while (if (and (consp (nth 1 part))
+					  (memq (car (nth 1 part)) (car inst)))
+				     (setq op (cons (if (eq (car part) '-)
+							(math-rwapply-neg
+							 (nth 2 part))
+						      (nth 2 part))
+						    op)
+					   part (nth 1 part))
+				   (if (and (consp (nth 2 part))
+					    (memq (car (nth 2 part))
+						  (car inst))
+					    (not (eq (car (nth 2 part)) '-)))
+				       (setq op (cons (nth 1 part) op)
+					     part (nth 2 part))))))
+			 (setq op (cons (nth 1 part)
+					(cons (if (eq (car part) '-)
+						  (math-rwapply-neg
+						   (nth 2 part))
+						(if (eq (car part) '/)
+						    (math-rwapply-inv
+						     (nth 2 part))
+						  (nth 2 part)))
+					      op))
+			       btrack (cons pc btrack)
+			       pc (cdr pc))
+			 (aset regs (nth 2 inst) (car op))
+			 (aset mark 0 op)
+			 (aset mark 1 op)
+			 (aset mark 2 (if (cdr (cdr op)) 1 0)))
+		     (if (nth 5 inst)
+			 (if (and (consp part)
+				  (eq (car part) 'neg)
+				  (eq (car (nth 2 inst)) '*)
+				  (eq (nth 5 inst) 1))
+			     (progn
+			       (setq mark (nth 3 inst)
+				     pc (cdr pc))
+			       (aset regs (nth 4 inst) (nth 1 part))
+			       (aset mark 1 -1)
+			       (aset mark 2 4))
+			   (setq mark (nth 3 inst)
+				 pc (cdr pc))
+			   (aset regs (nth 4 inst) part)
+			   (aset mark 2 3))
+		       (math-rwfail))))
+		  
+		  ((eq op 'try2)
+		   (setq part (nth 1 inst)   ; try instr
+			 mark (nth 3 part)
+			 op (aref mark 2)
+			 pc (cdr pc))
+		   (aset regs (nth 2 inst)
+			 (cond
+			  ((eq op 0)
+			   (if (eq (aref mark 0) (aref mark 1))
+			       (nth 1 (aref mark 0))
+			     (car (aref mark 0))))
+			  ((eq op 1)
+			   (setq mark (delq (car (aref mark 1))
+					    (copy-sequence (aref mark 0)))
+				 op (car (nth 2 part)))
+			   (if (eq op '*)
+			       (progn
+				 (setq mark (nreverse mark)
+				       part (list '* (nth 1 mark) (car mark))
+				       mark (cdr mark))
+				 (while (setq mark (cdr mark))
+				   (setq part (list '* (car mark) part))))
+			     (setq part (car mark)
+				   mark (cdr mark)
+				   part (if (and (eq op '+)
+						 (consp (car mark))
+						 (eq (car (car mark)) 'neg))
+					    (list '- part
+						  (nth 1 (car mark)))
+					  (list op part (car mark))))
+			     (while (setq mark (cdr mark))
+			       (setq part (if (and (eq op '+)
+						   (consp (car mark))
+						   (eq (car (car mark)) 'neg))
+					      (list '- part
+						    (nth 1 (car mark)))
+					    (list op part (car mark))))))
+			   part)
+			  ((eq op 2)
+			   (car (aref mark 1)))
+			  ((eq op 3) (nth 5 part))
+			  (t (aref mark 1)))))
+		  
+		  ((eq op 'select)
+		   (setq pc (cdr pc))
+		   (if (and (consp (setq part (aref regs (nth 1 inst))))
+			    (eq (car part) 'calcFunc-select))
+		       (aset regs (nth 2 inst) (nth 1 part))
+		     (if math-rewrite-selections
+			 (math-rwfail)
+		       (aset regs (nth 2 inst) part))))
+		  
+		  ((eq op 'same-neg)
+		   (if (or (equal (setq part (aref regs (nth 1 inst)))
+				  (setq mark (math-neg
+					      (aref regs (nth 2 inst)))))
+			   (Math-equal part mark))
+		       (setq pc (cdr pc))
+		     (math-rwfail)))
+		  
+		  ((eq op 'backtrack)
+		   (setq inst (car (car btrack))   ; "try" or "alt" instr
+			 pc (cdr (car btrack))
+			 mark (or (nth 3 inst) [nil nil 4])
+			 op (aref mark 2))
+		   (cond ((eq op 0)
+			  (if (setq op (cdr (aref mark 1)))
+			      (aset regs (nth 4 inst) (car (aset mark 1 op)))
+			    (if (nth 5 inst)
+				(progn
+				  (aset mark 2 3)
+				  (aset regs (nth 4 inst)
+					(aref regs (nth 1 inst))))
+			      (math-rwfail t))))
+			 ((eq op 1)
+			  (if (setq op (cdr (aref mark 1)))
+			      (aset regs (nth 4 inst) (car (aset mark 1 op)))
+			    (if (= (aref mark 3) 1)
+				(if (nth 5 inst)
+				    (progn
+				      (aset mark 2 3)
+				      (aset regs (nth 4 inst)
+					    (aref regs (nth 1 inst))))
+				  (math-rwfail t))
+			      (aset mark 2 2)
+			      (aset mark 1 (cons nil (aref mark 0)))
+			      (math-rwfail))))
+			 ((eq op 2)
+			  (if (setq op (cdr (aref mark 1)))
+			      (progn
+				(setq mark (delq (car (aset mark 1 op))
+						 (copy-sequence
+						  (aref mark 0)))
+				      op (car (nth 2 inst)))
+				(if (eq op '*)
+				    (progn
+				      (setq mark (nreverse mark)
+					    part (list '* (nth 1 mark)
+						       (car mark))
+					    mark (cdr mark))
+				      (while (setq mark (cdr mark))
+					(setq part (list '* (car mark)
+							 part))))
+				  (setq part (car mark)
+					mark (cdr mark)
+					part (if (and (eq op '+)
+						      (consp (car mark))
+						      (eq (car (car mark))
+							  'neg))
+						 (list '- part
+						       (nth 1 (car mark)))
+					       (list op part (car mark))))
+				  (while (setq mark (cdr mark))
+				    (setq part (if (and (eq op '+)
+							(consp (car mark))
+							(eq (car (car mark))
+							    'neg))
+						   (list '- part
+							 (nth 1 (car mark)))
+						 (list op part (car mark))))))
+				(aset regs (nth 4 inst) part))
+			    (if (nth 5 inst)
+				(progn
+				  (aset mark 2 3)
+				  (aset regs (nth 4 inst)
+					(aref regs (nth 1 inst))))
+			      (math-rwfail t))))
+			 ((eq op 4)
+			  (setq btrack (cdr btrack)))
+			 (t (math-rwfail t))))
+		  
+		  ((eq op 'integer)
+		   (if (Math-integerp (setq part (aref regs (nth 1 inst))))
+		       (setq pc (cdr pc))
+		     (if (Math-primp part)
+			 (math-rwfail)
+		       (setq part (math-rweval (math-simplify part)))
+		       (if (Math-integerp part)
+			   (setq pc (cdr pc))
+			 (math-rwfail)))))
+		  
+		  ((eq op 'real)
+		   (if (Math-realp (setq part (aref regs (nth 1 inst))))
+		       (setq pc (cdr pc))
+		     (if (Math-primp part)
+			 (math-rwfail)
+		       (setq part (math-rweval (math-simplify part)))
+		       (if (Math-realp part)
+			   (setq pc (cdr pc))
+			 (math-rwfail)))))
+		  
+		  ((eq op 'constant)
+		   (if (math-constp (setq part (aref regs (nth 1 inst))))
+		       (setq pc (cdr pc))
+		     (if (Math-primp part)
+			 (math-rwfail)
+		       (setq part (math-rweval (math-simplify part)))
+		       (if (math-constp part)
+			   (setq pc (cdr pc))
+			 (math-rwfail)))))
+		  
+		  ((eq op 'negative)
+		   (if (math-looks-negp (setq part (aref regs (nth 1 inst))))
+		       (setq pc (cdr pc))
+		     (if (Math-primp part)
+			 (math-rwfail)
+		       (setq part (math-rweval (math-simplify part)))
+		       (if (math-looks-negp part)
+			   (setq pc (cdr pc))
+			 (math-rwfail)))))
+		  
+		  ((eq op 'rel)
+		   (setq part (math-compare (aref regs (nth 1 inst))
+					    (aref regs (nth 3 inst)))
+			 op (nth 2 inst))
+		   (if (= part 2)
+		       (setq part (math-rweval
+				   (math-simplify
+				    (calcFunc-sign
+				     (math-sub (aref regs (nth 1 inst))
+					       (aref regs (nth 3 inst))))))))
+		   (if (cond ((eq op 'calcFunc-eq)
+			      (eq part 0))
+			     ((eq op 'calcFunc-neq)
+			      (memq part '(-1 1)))
+			     ((eq op 'calcFunc-lt)
+			      (eq part -1))
+			     ((eq op 'calcFunc-leq)
+			      (memq part '(-1 0)))
+			     ((eq op 'calcFunc-gt)
+			      (eq part 1))
+			     ((eq op 'calcFunc-geq)
+			      (memq part '(0 1))))
+		       (setq pc (cdr pc))
+		     (math-rwfail)))
+		  
+		  ((eq op 'func-def)
+		   (if (and (consp (setq part (aref regs (car (cdr inst)))))
+			    (eq (car part)
+				(car (setq inst (cdr (cdr inst))))))
+		       (progn
+			 (setq inst (cdr inst)
+			       mark (car inst))
+			 (while (and (setq inst (cdr inst)
+					   part (cdr part))
+				     inst)
+			   (aset regs (car inst) (car part)))
+			 (if (or inst part)
+			     (setq pc (cdr pc))
+			   (while (eq (car (car (setq pc (cdr pc))))
+				      'func-def))
+			   (setq pc (cdr pc))   ; skip over "func"
+			   (while mark
+			     (aset regs (cdr (car mark)) (car (car mark)))
+			     (setq mark (cdr mark)))))
+		     (math-rwfail)))
+
+		  ((eq op 'func-opt)
+		   (if (or (not (and (consp
+				      (setq part (aref regs (car (cdr inst)))))
+				     (eq (car part) (nth 2 inst))))
+			   (and (= (length part) 2)
+				(setq part (nth 1 part))))
+		       (progn
+			 (setq mark (nth 3 inst))
+			 (aset regs (nth 4 inst) part)
+			 (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
+			 (setq pc (cdr pc))   ; skip over "func"
+			 (while mark
+			   (aset regs (cdr (car mark)) (car (car mark)))
+			   (setq mark (cdr mark))))
+		     (setq pc (cdr pc))))
+
+		  ((eq op 'mod)
+		   (if (if (Math-zerop (setq part (aref regs (nth 1 inst))))
+			   (Math-zerop (nth 3 inst))
+			 (and (not (Math-zerop (nth 2 inst)))
+			      (progn
+				(setq part (math-mod part (nth 2 inst)))
+				(or (Math-numberp part)
+				    (setq part (math-rweval
+						(math-simplify part))))
+				(Math-equal part (nth 3 inst)))))
+		       (setq pc (cdr pc))
+		     (math-rwfail)))
+
+		  ((eq op 'apply)
+		   (if (and (consp (setq part (aref regs (car (cdr inst)))))
+			    (not (Math-objvecp part))
+			    (not (eq (car part) 'var)))
+		       (progn
+			 (aset regs (nth 2 inst)
+			       (math-calcFunc-to-var (car part)))
+			 (aset regs (nth 3 inst)
+			       (cons 'vec (cdr part)))
+			 (setq pc (cdr pc)))
+		     (math-rwfail)))
+
+		  ((eq op 'cons)
+		   (if (and (consp (setq part (aref regs (car (cdr inst)))))
+			    (eq (car part) 'vec)
+			    (cdr part))
+		       (progn
+			 (aset regs (nth 2 inst) (nth 1 part))
+			 (aset regs (nth 3 inst) (cons 'vec (cdr (cdr part))))
+			 (setq pc (cdr pc)))
+		     (math-rwfail)))
+
+		  ((eq op 'rcons)
+		   (if (and (consp (setq part (aref regs (car (cdr inst)))))
+			    (eq (car part) 'vec)
+			    (cdr part))
+		       (progn
+			 (aset regs (nth 2 inst) (calcFunc-rhead part))
+			 (aset regs (nth 3 inst) (calcFunc-rtail part))
+			 (setq pc (cdr pc)))
+		     (math-rwfail)))
+
+		  ((eq op 'cond)
+		   (if (math-is-true
+			(math-rweval
+			 (math-simplify
+			  (math-rwapply-replace-regs (nth 1 inst)))))
+		       (setq pc (cdr pc))
+		     (math-rwfail)))
+		  
+		  ((eq op 'let)
+		   (aset regs (nth 1 inst)
+			 (math-rweval
+			  (math-normalize
+			   (math-rwapply-replace-regs (nth 2 inst)))))
+		   (setq pc (cdr pc)))
+		  
+		  ((eq op 'copy)
+		   (aset regs (nth 2 inst) (aref regs (nth 1 inst)))
+		   (setq pc (cdr pc)))
+		  
+		  ((eq op 'copy-neg)
+		   (aset regs (nth 2 inst)
+			 (math-rwapply-neg (aref regs (nth 1 inst))))
+		   (setq pc (cdr pc)))
+		  
+		  ((eq op 'alt)
+		   (setq btrack (cons pc btrack)
+			 pc (nth 1 inst)))
+		  
+		  ((eq op 'end-alt)
+		   (while (and btrack (not (eq (car btrack) (nth 1 inst))))
+		     (setq btrack (cdr btrack)))
+		   (setq btrack (cdr btrack)
+			 pc (cdr pc)))
+		  
+		  ((eq op 'done)
+		   (setq result (math-rwapply-replace-regs (nth 1 inst)))
+		   (if (or (and (eq (car-safe result) '+)
+				(eq (nth 2 result) 0))
+			   (and (eq (car-safe result) '*)
+				(eq (nth 2 result) 1)))
+		       (setq result (nth 1 result)))
+		   (setq part (and (nth 2 inst)
+				   (math-is-true
+				    (math-rweval
+				     (math-simplify
+				      (math-rwapply-replace-regs
+				       (nth 2 inst)))))))
+		   (if (or (equal result expr)
+			   (equal (setq result (math-normalize result)) expr))
+		       (setq result nil)
+		     (if part (math-rwapply-remember expr result))
+		     (setq rules nil))
+		   (setq pc nil))
+		  
+		  (t (error "%s is not a valid rewrite opcode" op))))))
+       (setq rules (cdr rules)))
+     result))
+)
+
+(defun math-rwapply-neg (expr)
+  (if (and (consp expr)
+	   (memq (car expr) '(* /)))
+      (if (Math-objectp (nth 2 expr))
+	  (list (car expr) (nth 1 expr) (math-neg (nth 2 expr)))
+	(list (car expr)
+	      (if (Math-objectp (nth 1 expr))
+		  (math-neg (nth 1 expr))
+		(list '* -1 (nth 1 expr)))
+	      (nth 2 expr)))
+    (math-neg expr))
+)
+
+(defun math-rwapply-inv (expr)
+  (if (and (Math-integerp expr)
+	   calc-prefer-frac)
+      (math-make-frac 1 expr)
+    (list '/ 1 expr))
+)
+
+(defun math-rwapply-replace-regs (expr)
+  (cond ((Math-primp expr)
+	 expr)
+	((eq (car expr) 'calcFunc-register)
+	 (setq expr (aref regs (nth 1 expr)))
+	 (if (eq (car-safe expr) '*)
+	     (if (eq (nth 1 expr) -1)
+		 (math-neg (nth 2 expr))
+	       (if (eq (nth 1 expr) 1)
+		   (nth 2 expr)
+		 expr))
+	   expr))
+	((and (eq (car expr) 'calcFunc-eval)
+	      (= (length expr) 2))
+	 (calc-with-default-simplification
+	  (math-normalize (math-rwapply-replace-regs (nth 1 expr)))))
+	((and (eq (car expr) 'calcFunc-evalsimp)
+	      (= (length expr) 2))
+	 (math-simplify (math-rwapply-replace-regs (nth 1 expr))))
+	((and (eq (car expr) 'calcFunc-evalextsimp)
+	      (= (length expr) 2))
+	 (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr))))
+	((and (eq (car expr) 'calcFunc-apply)
+	      (= (length expr) 3))
+	 (let ((func (math-rwapply-replace-regs (nth 1 expr)))
+	       (args (math-rwapply-replace-regs (nth 2 expr)))
+	       call)
+	   (if (and (math-vectorp args)
+		    (not (eq (car-safe (setq call (math-build-call
+						   (math-var-to-calcFunc func)
+						   (cdr args))))
+			     'calcFunc-call)))
+	       call
+	     (list 'calcFunc-apply func args))))
+	((and (eq (car expr) 'calcFunc-cons)
+	      (= (length expr) 3))
+	 (let ((head (math-rwapply-replace-regs (nth 1 expr)))
+	       (tail (math-rwapply-replace-regs (nth 2 expr))))
+	   (if (math-vectorp tail)
+	       (cons 'vec (cons head (cdr tail)))
+	     (list 'calcFunc-cons head tail))))
+	((and (eq (car expr) 'calcFunc-rcons)
+	      (= (length expr) 3))
+	 (let ((head (math-rwapply-replace-regs (nth 1 expr)))
+	       (tail (math-rwapply-replace-regs (nth 2 expr))))
+	   (if (math-vectorp head)
+	       (append head (list tail))
+	     (list 'calcFunc-rcons head tail))))
+	((and (eq (car expr) 'neg)
+	      (math-rwapply-reg-looks-negp (nth 1 expr)))
+	 (math-rwapply-reg-neg (nth 1 expr)))
+	((and (eq (car expr) 'neg)
+	      (eq (car-safe (nth 1 expr)) 'calcFunc-register)
+	      (math-scalarp (aref regs (nth 1 (nth 1 expr)))))
+	 (math-neg (math-rwapply-replace-regs (nth 1 expr))))
+	((and (eq (car expr) '+)
+	      (math-rwapply-reg-looks-negp (nth 1 expr)))
+	 (list '- (math-rwapply-replace-regs (nth 2 expr))
+	       (math-rwapply-reg-neg (nth 1 expr))))
+	((and (eq (car expr) '+)
+	      (math-rwapply-reg-looks-negp (nth 2 expr)))
+	 (list '- (math-rwapply-replace-regs (nth 1 expr))
+	       (math-rwapply-reg-neg (nth 2 expr))))
+	((and (eq (car expr) '-)
+	      (math-rwapply-reg-looks-negp (nth 2 expr)))
+	 (list '+ (math-rwapply-replace-regs (nth 1 expr))
+	       (math-rwapply-reg-neg (nth 2 expr))))
+	((eq (car expr) '*)
+	 (cond ((eq (nth 1 expr) -1)
+		(if (math-rwapply-reg-looks-negp (nth 2 expr))
+		    (math-rwapply-reg-neg (nth 2 expr))
+		  (math-neg (math-rwapply-replace-regs (nth 2 expr)))))
+	       ((eq (nth 1 expr) 1)
+		(math-rwapply-replace-regs (nth 2 expr)))
+	       ((eq (nth 2 expr) -1)
+		(if (math-rwapply-reg-looks-negp (nth 1 expr))
+		    (math-rwapply-reg-neg (nth 1 expr))
+		  (math-neg (math-rwapply-replace-regs (nth 1 expr)))))
+	       ((eq (nth 2 expr) 1)
+		(math-rwapply-replace-regs (nth 1 expr)))
+	       (t
+		(let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
+		      (arg2 (math-rwapply-replace-regs (nth 2 expr))))
+		  (cond ((and (eq (car-safe arg1) '/)
+			      (eq (nth 1 arg1) 1))
+			 (list '/ arg2 (nth 2 arg1)))
+			((and (eq (car-safe arg2) '/)
+			      (eq (nth 1 arg2) 1))
+			 (list '/ arg1 (nth 2 arg2)))
+			(t (list '* arg1 arg2)))))))
+	((eq (car expr) '/)
+	 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
+	       (arg2 (math-rwapply-replace-regs (nth 2 expr))))
+	   (if (eq (car-safe arg2) '/)
+	       (list '/ (list '* arg1 (nth 2 arg2)) (nth 1 arg2))
+	     (list '/ arg1 arg2))))
+	((and (eq (car expr) 'calcFunc-plain)
+	      (= (length expr) 2))
+	 (if (Math-primp (nth 1 expr))
+	     (nth 1 expr)
+	   (if (eq (car (nth 1 expr)) 'calcFunc-register)
+	       (aref regs (nth 1 (nth 1 expr)))
+	     (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
+					      (cdr (nth 1 expr)))))))
+	(t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr)))))
+)
+
+(defun math-rwapply-reg-looks-negp (expr)
+  (if (eq (car-safe expr) 'calcFunc-register)
+      (math-looks-negp (aref regs (nth 1 expr)))
+    (if (memq (car-safe expr) '(* /))
+	(or (math-rwapply-reg-looks-negp (nth 1 expr))
+	    (math-rwapply-reg-looks-negp (nth 2 expr)))))
+)
+
+(defun math-rwapply-reg-neg (expr)  ; expr must satisfy rwapply-reg-looks-negp
+  (if (eq (car expr) 'calcFunc-register)
+      (math-neg (math-rwapply-replace-regs expr))
+    (if (math-rwapply-reg-looks-negp (nth 1 expr))
+	(math-rwapply-replace-regs (list (car expr)
+					 (math-rwapply-reg-neg (nth 1 expr))
+					 (nth 2 expr)))
+      (math-rwapply-replace-regs (list (car expr)
+				       (nth 1 expr)
+				       (math-rwapply-reg-neg (nth 2 expr))))))
+)
+
+(defun math-rwapply-remember (old new)
+  (let ((varval (symbol-value (nth 2 (car ruleset))))
+	(rules (assq (car-safe old) ruleset)))
+    (if (and (eq (car-safe varval) 'vec)
+	     (not (memq (car-safe old) '(nil schedule + -)))
+	     rules)
+	(progn
+	  (setcdr varval (cons (list 'calcFunc-assign
+				     (if (math-rwcomp-no-vars old)
+					 old
+				       (list 'calcFunc-quote old))
+				     new)
+			       (cdr varval)))
+	  (setcdr rules (cons (list (vector nil old)
+				    (list (list 'same 0 1)
+					  (list 'done new nil))
+				    nil nil)
+			      (cdr rules))))))
+)
+
+
+
+