root/trunk/lisp/calc/calc-rewr.el

;;; calc-rewr.el --- rewriting functions for Calc

;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.

;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

;; This file is autoloaded from calc-ext.el.

(require 'calc-ext)
(require 'calc-macs)

(defvar math-rewrite-default-iters 100)

;; The variable calc-rewr-sel is local to calc-rewrite-selection and 
;; calc-rewrite, but is used by calc-locate-selection-marker.
(defvar calc-rewr-sel)

(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)
          rules
          (entry (calc-top num 'entry))
          (expr (car entry))
          (calc-rewr-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 calc-rewr-sel
         (setq expr (calc-replace-sub-formula (car entry)
                                              calc-rewr-sel
                                              (list 'calcFunc-select calc-rewr-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)))
           calc-rewr-sel nil
           expr (calc-locate-select-marker expr))
     (or (consp calc-rewr-sel) (setq calc-rewr-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 calc-rewr-sel))))
   (calc-handle-whys)))

(defun calc-locate-select-marker (expr)
  (if (Math-primp expr)
      expr
    (if (and (eq (car expr) 'calcFunc-select)
             (= (length expr) 2))
        (progn
          (setq calc-rewr-sel (if calc-rewr-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 (calc-rewr-sel)
       (setq expr (calc-locate-select-marker expr)))
     (calc-pop-push-record-list n "rwrt" (list expr)))
   (calc-handle-whys)))

(defun calc-match (pat &optional interactive)
  (interactive "sPattern: \np")
  (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)
       (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))))))


(defvar math-mt-many)

;; The variable math-rewrite-whole-expr is local to math-rewrite,
;; but is used by math-rewrite-phase
(defvar math-rewrite-whole-expr)

(defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many)
  (let* ((crules (math-compile-rewrites rules))
         (heads (math-rewrite-heads math-rewrite-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)
         (math-mt-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 math-rewrite-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 math-mt-many (setq math-mt-many (or (nth 1 (car crules))
                                    math-rewrite-default-iters)))
    (if (equal math-mt-many '(var inf var-inf)) (setq math-mt-many 1000000))
    (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000))
    (math-rewrite-phase (nth 3 (car crules)))
    (if trace-buffer
        (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
          (save-excursion
            (set-buffer trace-buffer)
            (insert "\nDone rewriting"
                    (if (= math-mt-many 0) " (reached iteration limit)" "")
                    ":\n" fmt "\n"))))
    math-rewrite-whole-expr))

(defun math-rewrite-phase (sched)
  (while (and sched (/= math-mt-many 0))
    (if (listp (car sched))
        (while (let ((save-expr math-rewrite-whole-expr))
                 (math-rewrite-phase (car sched))
                 (not (equal math-rewrite-whole-expr save-expr))))
      (if (symbolp (car sched))
          (progn
            (setq math-rewrite-whole-expr 
                  (math-normalize (list (car sched) math-rewrite-whole-expr)))
            (if trace-buffer
                (let ((fmt (math-format-stack-value
                            (list math-rewrite-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 math-rewrite-whole-expr))
                   (setq math-rewrite-whole-expr (math-normalize
                                     (math-map-tree-rec math-rewrite-whole-expr)))
                   (not (equal math-rewrite-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)))))))))

(defvar math-rewrite-whole nil)
(defvar math-make-import-list nil)

;; The variable math-import-list is local to part of math-compile-rewrites,
;; but is also used in a different part, and so the local version could
;; be affected by the non-local version when math-compile-rewrites calls itself. 
(defvar math-import-list nil)

;; The variables math-regs, math-num-regs, math-prog-last, math-bound-vars, 
;; math-conds, math-copy-neg, math-rhs, math-pattern, math-remembering and
;; math-aliased-vars are local to math-compile-rewrites, 
;; but are used by many functions math-rwcomp-*, which are called by 
;; math-compile-rewrites.
(defvar math-regs)
(defvar math-num-regs)
(defvar math-prog-last)
(defvar math-bound-vars)
(defvar math-conds)
(defvar math-copy-neg)
(defvar math-rhs)
(defvar math-pattern)
(defvar math-remembering)
(defvar math-aliased-vars)

(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 '*)
  &nbs