cgit.sxemacs.org Git - packages/blob - xemacs-packages/calc/calc-rewr.el

   1 ;; Calculator for GNU Emacs, part II [calc-rewr.el]
   2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
   3 ;; Written by Dave Gillespie, daveg@synaptics.com.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is distributed in the hope that it will be useful,
   8 ;; but WITHOUT ANY WARRANTY.  No author or distributor
   9 ;; accepts responsibility to anyone for the consequences of using it
  10 ;; or for whether it serves any particular purpose or works at all,
  11 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12 ;; License for full details.
  13
  14 ;; Everyone is granted permission to copy, modify and redistribute
  15 ;; GNU Emacs, but only under the conditions described in the
  16 ;; GNU Emacs General Public License.   A copy of this license is
  17 ;; supposed to have been given to you along with GNU Emacs so you
  18 ;; can know your rights and responsibilities.  It should be in a
  19 ;; file named COPYING.  Among other things, the copyright notice
  20 ;; and this notice must be preserved on all copies.
  21
  22
  23
  24 ;; This file is autoloaded from calc-ext.el.
  25 (require 'calc-ext)
  26
  27 (require 'calc-macs)
  28
  29 (defun calc-Need-calc-rewr () nil)
  30
  31
  32 (defun calc-rewrite-selection (rules-str &optional many prefix)
  33   (interactive "sRewrite rule(s): \np")
  34   (calc-slow-wrapper
  35    (calc-preserve-point)
  36    (let* ((num (max 1 (calc-locate-cursor-element (point))))
  37           (reselect t)
  38           (pop-rules nil)
  39           (entry (calc-top num 'entry))
  40           (expr (car entry))
  41           (sel (calc-auto-selection entry))
  42           (math-rewrite-selections t)
  43           (math-rewrite-default-iters 1))
  44      (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
  45          (if (= num 1)
  46              (error "Can't use same stack entry for formula and rules.")
  47            (setq rules (calc-top-n 1 t)
  48                  pop-rules t))
  49        (setq rules (if (stringp rules-str)
  50                        (math-read-exprs rules-str) rules-str))
  51        (if (eq (car-safe rules) 'error)
  52            (error "Bad format in expression: %s" (nth 1 rules)))
  53        (if (= (length rules) 1)
  54            (setq rules (car rules))
  55          (setq rules (cons 'vec rules)))
  56        (or (memq (car-safe rules) '(vec var calcFunc-assign
  57                                         calcFunc-condition))
  58            (let ((rhs (math-read-expr
  59                        (read-string (concat "Rewrite from:    " rules-str
  60                                             "  to: ")))))
  61              (if (eq (car-safe rhs) 'error)
  62                  (error "Bad format in expression: %s" (nth 1 rhs)))
  63              (setq rules (list 'calcFunc-assign rules rhs))))
  64        (or (eq (car-safe rules) 'var)
  65            (calc-record rules "rule")))
  66      (if (eq many 0)
  67          (setq many '(var inf var-inf))
  68        (if many (setq many (prefix-numeric-value many))))
  69      (if sel
  70          (setq expr (calc-replace-sub-formula (car entry)
  71                                               sel
  72                                               (list 'calcFunc-select sel)))
  73        (setq expr (car entry)
  74              reselect nil
  75              math-rewrite-selections nil))
  76      (setq expr (calc-encase-atoms
  77                  (calc-normalize
  78                   (math-rewrite
  79                    (calc-normalize expr)
  80                    rules many)))
  81            sel nil
  82            expr (calc-locate-select-marker expr))
  83      (or (consp sel) (setq sel nil))
  84      (if pop-rules (calc-pop-stack 1))
  85      (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
  86                                 (- num (if pop-rules 1 0))
  87                                 (list (and reselect sel))))
  88    (calc-handle-whys))
  89 )
  90
  91 (defun calc-locate-select-marker (expr)    ; changes "sel"
  92   (if (Math-primp expr)
  93       expr
  94     (if (and (eq (car expr) 'calcFunc-select)
  95              (= (length expr) 2))
  96         (progn
  97           (setq sel (if sel t (nth 1 expr)))
  98           (nth 1 expr))
  99       (cons (car expr)
 100             (mapcar 'calc-locate-select-marker (cdr expr)))))
 101 )
 102
 103
 104
 105 (defun calc-rewrite (rules-str many)
 106   (interactive "sRewrite rule(s): \nP")
 107   (calc-slow-wrapper
 108    (let (n rules expr)
 109      (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
 110          (setq expr (calc-top-n 2)
 111                rules (calc-top-n 1 t)
 112                n 2)
 113        (setq rules (if (stringp rules-str)
 114                        (math-read-exprs rules-str) rules-str))
 115        (if (eq (car-safe rules) 'error)
 116            (error "Bad format in expression: %s" (nth 1 rules)))
 117        (if (= (length rules) 1)
 118            (setq rules (car rules))
 119          (setq rules (cons 'vec rules)))
 120        (or (memq (car-safe rules) '(vec var calcFunc-assign
 121                                         calcFunc-condition))
 122            (let ((rhs (math-read-expr
 123                        (read-string (concat "Rewrite from:    " rules-str
 124                                             " to: ")))))
 125              (if (eq (car-safe rhs) 'error)
 126                  (error "Bad format in expression: %s" (nth 1 rhs)))
 127              (setq rules (list 'calcFunc-assign rules rhs))))
 128        (or (eq (car-safe rules) 'var)
 129            (calc-record rules "rule"))
 130        (setq expr (calc-top-n 1)
 131              n 1))
 132      (if (eq many 0)
 133          (setq many '(var inf var-inf))
 134        (if many (setq many (prefix-numeric-value many))))
 135      (setq expr (calc-normalize (math-rewrite expr rules many)))
 136      (let (sel)
 137        (setq expr (calc-locate-select-marker expr)))
 138      (calc-pop-push-record-list n "rwrt" (list expr)))
 139    (calc-handle-whys))
 140 )
 141
 142 (defun calc-match (pat)
 143   (interactive "sPattern: \n")
 144   (calc-slow-wrapper
 145    (let (n expr)
 146      (if (or (null pat) (equal pat "") (equal pat "$"))
 147          (setq expr (calc-top-n 2)
 148                pat (calc-top-n 1)
 149                n 2)
 150        (if (interactive-p) (setq calc-previous-alg-entry pat))
 151        (setq pat (if (stringp pat) (math-read-expr pat) pat))
 152        (if (eq (car-safe pat) 'error)
 153            (error "Bad format in expression: %s" (nth 1 pat)))
 154        (if (not (eq (car-safe pat) 'var))
 155            (calc-record pat "pat"))
 156        (setq expr (calc-top-n 1)
 157              n 1))
 158      (or (math-vectorp expr) (error "Argument must be a vector"))
 159      (if (calc-is-inverse)
 160          (calc-enter-result n "mtcn" (math-match-patterns pat expr t))
 161        (calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))
 162 )
 163
 164
 165
 166 (defun math-rewrite (whole-expr rules &optional mmt-many)
 167   (let ((crules (math-compile-rewrites rules))
 168         (heads (math-rewrite-heads whole-expr))
 169         (trace-buffer (get-buffer "*Trace*"))
 170         (calc-display-just 'center)
 171         (calc-display-origin 39)
 172         (calc-line-breaking 78)
 173         (calc-line-numbering nil)
 174         (calc-show-selections t)
 175         (calc-why nil)
 176         (mmt-func (function
 177                    (lambda (x)
 178                      (let ((result (math-apply-rewrites x (cdr crules)
 179                                                         heads crules)))
 180                        (if result
 181                            (progn
 182                              (if trace-buffer
 183                                  (let ((fmt (math-format-stack-value
 184                                              (list result nil nil))))
 185                                    (save-excursion
 186                                      (set-buffer trace-buffer)
 187                                      (insert "\nrewrite to\n" fmt "\n"))))
 188                              (setq heads (math-rewrite-heads result heads t))))
 189                        result)))))
 190     (if trace-buffer
 191         (let ((fmt (math-format-stack-value (list whole-expr nil nil))))
 192           (save-excursion
 193             (set-buffer trace-buffer)
 194             (setq truncate-lines t)
 195             (goto-char (point-max))
 196             (insert "\n\nBegin rewriting\n" fmt "\n"))))
 197     (or mmt-many (setq mmt-many (or (nth 1 (car crules))
 198                                     math-rewrite-default-iters)))
 199     (if (equal mmt-many '(var inf var-inf)) (setq mmt-many 1000000))
 200     (if (equal mmt-many '(neg (var inf var-inf))) (setq mmt-many -1000000))
 201     (math-rewrite-phase (nth 3 (car crules)))
 202     (if trace-buffer
 203         (let ((fmt (math-format-stack-value (list whole-expr nil nil))))
 204           (save-excursion
 205             (set-buffer trace-buffer)
 206             (insert "\nDone rewriting"
 207                     (if (= mmt-many 0) " (reached iteration limit)" "")
 208                     ":\n" fmt "\n"))))
 209     whole-expr)
 210 )
 211 (setq math-rewrite-default-iters 100)
 212
 213 (defun math-rewrite-phase (sched)
 214   (while (and sched (/= mmt-many 0))
 215     (if (listp (car sched))
 216         (while (let ((save-expr whole-expr))
 217                  (math-rewrite-phase (car sched))
 218                  (not (equal whole-expr save-expr))))
 219       (if (symbolp (car sched))
 220           (progn
 221             (setq whole-expr (math-normalize (list (car sched) whole-expr)))
 222             (if trace-buffer
 223                 (let ((fmt (math-format-stack-value
 224                             (list whole-expr nil nil))))
 225                   (save-excursion
 226                     (set-buffer trace-buffer)
 227                     (insert "\ncall "
 228                             (substring (symbol-name (car sched)) 9)
 229                             ":\n" fmt "\n")))))
 230         (let ((math-rewrite-phase (car sched)))
 231           (if trace-buffer
 232               (save-excursion
 233                 (set-buffer trace-buffer)
 234                 (insert (format "\n(Phase %d)\n" math-rewrite-phase))))
 235           (while (let ((save-expr whole-expr))
 236                    (setq whole-expr (math-normalize
 237                                      (math-map-tree-rec whole-expr)))
 238                    (not (equal whole-expr save-expr)))))))
 239     (setq sched (cdr sched)))
 240 )
 241
 242 (defun calcFunc-rewrite (expr rules &optional many)
 243   (or (null many) (integerp many)
 244       (equal many '(var inf var-inf)) (equal many '(neg (var inf var-inf)))
 245       (math-reject-arg many 'fixnump))
 246   (condition-case err
 247       (math-rewrite expr rules (or many 1))
 248     (error (math-reject-arg rules (nth 1 err))))
 249 )
 250
 251 (defun calcFunc-match (pat vec)
 252   (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
 253   (condition-case err
 254       (math-match-patterns pat vec nil)
 255     (error (math-reject-arg pat (nth 1 err))))
 256 )
 257
 258 (defun calcFunc-matchnot (pat vec)
 259   (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
 260   (condition-case err
 261       (math-match-patterns pat vec t)
 262     (error (math-reject-arg pat (nth 1 err))))
 263 )
 264
 265 (defun math-match-patterns (pat vec &optional not-flag)
 266   (let ((newvec nil)
 267         (crules (math-compile-patterns pat)))
 268     (while (setq vec (cdr vec))
 269       (if (eq (not (math-apply-rewrites (car vec) crules))
 270               not-flag)
 271           (setq newvec (cons (car vec) newvec))))
 272     (cons 'vec (nreverse newvec)))
 273 )
 274
 275 (defun calcFunc-matches (expr pat)
 276   (condition-case err
 277       (if (math-apply-rewrites expr (math-compile-patterns pat))
 278           1
 279         0)
 280     (error (math-reject-arg pat (nth 1 err))))
 281 )
 282
 283 (defun calcFunc-vmatches (expr pat)
 284   (condition-case err
 285       (or (math-apply-rewrites expr (math-compile-patterns pat))
 286           0)
 287     (error (math-reject-arg pat (nth 1 err))))
 288 )
 289
 290
 291
 292 ;;; A compiled rule set is an a-list of entries whose cars are functors,
 293 ;;; and whose cdrs are lists of rules.  If there are rules with no
 294 ;;; well-defined head functor, they are included on all lists and also
 295 ;;; on an extra list whose car is nil.
 296 ;;;
 297 ;;; The first entry in the a-list is of the form (schedule A B C ...).
 298 ;;;
 299 ;;; Rule list entries take the form (regs prog head phases), where:
 300 ;;;
 301 ;;;   regs   is a vector of match registers.
 302 ;;;
 303 ;;;   prog   is a match program (see below).
 304 ;;;
 305 ;;;   head   is a rare function name appearing in the rule body (but not the
 306 ;;;          head of the whole rule), or nil if none.
 307 ;;;
 308 ;;;   phases is a list of phase numbers for which the rule is enabled.
 309 ;;;
 310 ;;; A match program is a list of match instructions.
 311 ;;;
 312 ;;; In the following, "part" is a register number that contains the
 313 ;;; subexpression to be operated on.
 314 ;;;
 315 ;;; Register 0 is the whole expression being matched.  The others are
 316 ;;; meta-variables in the pattern, temporaries used for matching and
 317 ;;; backtracking, and constant expressions.
 318 ;;;
 319 ;;; (same part reg)
 320 ;;;         The selected part must be math-equal to the contents of "reg".
 321 ;;;
 322 ;;; (same-neg part reg)
 323 ;;;         The selected part must be math-equal to the negative of "reg".
 324 ;;;
 325 ;;; (copy part reg)
 326 ;;;         The selected part is copied into "reg".  (Rarely used.)
 327 ;;;
 328 ;;; (copy-neg part reg)
 329 ;;;         The negative of the selected part is copied into "reg".
 330 ;;;
 331 ;;; (integer part)
 332 ;;;         The selected part must be an integer.
 333 ;;;
 334 ;;; (real part)
 335 ;;;         The selected part must be a real.
 336 ;;;
 337 ;;; (constant part)
 338 ;;;         The selected part must be a constant.
 339 ;;;
 340 ;;; (negative part)
 341 ;;;         The selected part must "look" negative.
 342 ;;;
 343 ;;; (rel part op reg)
 344 ;;;         The selected part must satisfy "part op reg", where "op"
 345 ;;;         is one of the 6 relational ops, and "reg" is a register.
 346 ;;;
 347 ;;; (mod part modulo value)
 348 ;;;         The selected part must satisfy "part % modulo = value", where
 349 ;;;         "modulo" and "value" are constants.
 350 ;;;
 351 ;;; (func part head reg1 reg2 ... regn)
 352 ;;;         The selected part must be an n-ary call to function "head".
 353 ;;;         The arguments are stored in "reg1" through "regn".
 354 ;;;
 355 ;;; (func-def part head defs reg1 reg2 ... regn)
 356 ;;;         The selected part must be an n-ary call to function "head".
 357 ;;;         "Defs" is a list of value/register number pairs for default args.
 358 ;;;         If a match, assign default values to registers and then skip
 359 ;;;         immediately over any following "func-def" instructions and
 360 ;;;         the following "func" instruction.  If wrong number of arguments,
 361 ;;;         proceed to the following "func-def" or "func" instruction.
 362 ;;;
 363 ;;; (func-opt part head defs reg1)
 364 ;;;         Like func-def with "n=1", except that if the selected part is
 365 ;;;         not a call to "head", then the part itself successfully matches
 366 ;;;         "reg1" (and the defaults are assigned).
 367 ;;;
 368 ;;; (try part heads mark reg1 [def])
 369 ;;;         The selected part must be a function of the correct type which is
 370 ;;;         associative and/or commutative.  "Heads" is a list of acceptable
 371 ;;;         types.  An initial assignment of arguments to "reg1" is tried.
 372 ;;;         If the program later fails, it backtracks to this instruction
 373 ;;;         and tries other assignments of arguments to "reg1".
 374 ;;;         If "def" exists and normal matching fails, backtrack and assign
 375 ;;;         "part" to "reg1", and "def" to "reg2" in the following "try2".
 376 ;;;         The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
 377 ;;;         "mark[0]" points to the argument list; "mark[1]" points to the
 378 ;;;         current argument; "mark[2]" is 0 if there are two arguments,
 379 ;;;         1 if reg1 is matching single arguments, 2 if reg2 is matching
 380 ;;;         single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
 381 ;;;         3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
 382 ;;;         have two arguments, 1 if phase-2 can be skipped, 2 if full
 383 ;;;         backtracking is necessary; "mark[4]" is t if the arguments have
 384 ;;;         been switched from the order given in the original pattern.
 385 ;;;
 386 ;;; (try2 try reg2)
 387 ;;;         Every "try" will be followed by a "try2" whose "try" field is
 388 ;;;         a pointer to the corresponding "try".  The arguments which were
 389 ;;;         not stored in "reg1" by that "try" are now stored in "reg2".
 390 ;;;
 391 ;;; (alt instr nil mark)
 392 ;;;         Basic backtracking.  Execute the instruction sequence "instr".
 393 ;;;         If this fails, back up and execute following the "alt" instruction.
 394 ;;;         The "mark" must be the vector "[nil nil 4]".  The "instr" sequence
 395 ;;;         should execute "end-alt" at the end.
 396 ;;;
 397 ;;; (end-alt ptr)
 398 ;;;         Register success of the first alternative of a previous "alt".
 399 ;;;         "Ptr" is a pointer to the next instruction following that "alt".
 400 ;;;
 401 ;;; (apply part reg1 reg2)
 402 ;;;         The selected part must be a function call.  The functor
 403 ;;;         (as a variable name) is stored in "reg1"; the arguments
 404 ;;;         (as a vector) are stored in "reg2".
 405 ;;;
 406 ;;; (cons part reg1 reg2)
 407 ;;;         The selected part must be a nonempty vector.  The first element
 408 ;;;         of the vector is stored in "reg1"; the rest of the vector
 409 ;;;         (as another vector) is stored in "reg2".
 410 ;;;
 411 ;;; (rcons part reg1 reg2)
 412 ;;;         The selected part must be a nonempty vector.  The last element
 413 ;;;         of the vector is stored in "reg2"; the rest of the vector
 414 ;;;         (as another vector) is stored in "reg1".
 415 ;;;
 416 ;;; (select part reg)
 417 ;;;         If the selected part is a unary call to function "select", its
 418 ;;;         argument is stored in "reg"; otherwise (provided this is an `a r'
 419 ;;;         and not a `g r' command) the selected part is stored in "reg".
 420 ;;;
 421 ;;; (cond expr)
 422 ;;;         The "expr", with registers substituted, must simplify to
 423 ;;;         a non-zero value.
 424 ;;;
 425 ;;; (let reg expr)
 426 ;;;         Evaluate "expr" and store the result in "reg".  Always succeeds.
 427 ;;;
 428 ;;; (done rhs remember)
 429 ;;;         Rewrite the expression to "rhs", with register substituted.
 430 ;;;         Normalize; if the result is different from the original
 431 ;;;         expression, the match has succeeded.  This is the last
 432 ;;;         instruction of every program.  If "remember" is non-nil,
 433 ;;;         record the result of the match as a new literal rule.
 434
 435
 436 ;;; Pseudo-functions related to rewrites:
 437 ;;;
 438 ;;;  In patterns:  quote, plain, condition, opt, apply, cons, select
 439 ;;;
 440 ;;;  In righthand sides:  quote, plain, eval, evalsimp, evalextsimp,
 441 ;;;                       apply, cons, select
 442 ;;;
 443 ;;;  In conditions:  let + same as for righthand sides
 444
 445 ;;; Some optimizations that would be nice to have:
 446 ;;;
 447 ;;;  * Merge registers with disjoint lifetimes.
 448 ;;;  * Merge constant registers with equivalent values.
 449 ;;;
 450 ;;;  * If an argument of a commutative op math-depends neither on the
 451 ;;;    rest of the pattern nor on any of the conditions, then no backtracking
 452 ;;;    should be done for that argument.  (This won't apply to very many
 453 ;;;    cases.)
 454 ;;;
 455 ;;;  * If top functor is "select", and its argument is a unique function,
 456 ;;;    add the rule to the lists for both "select" and that function.
 457 ;;;    (Currently rules like this go on the "nil" list.)
 458 ;;;    Same for "func-opt" functions.  (Though not urgent for these.)
 459 ;;;
 460 ;;;  * Shouldn't evaluate a "let" condition until the end, or until it
 461 ;;;    would enable another condition to be evaluated.
 462 ;;;
 463
 464 ;;; Some additional features to add / things to think about:
 465 ;;;
 466 ;;;  * Figure out what happens to "a +/- b" and "a +/- opt(b)".
 467 ;;;
 468 ;;;  * Same for interval forms.
 469 ;;;
 470 ;;;  * Have a name(v,pat) pattern which matches pat, and gives the
 471 ;;;    whole match the name v.  Beware of circular structures!
 472 ;;;
 473
 474 (defun math-compile-patterns (pats)
 475   (if (and (eq (car-safe pats) 'var)
 476            (calc-var-value (nth 2 pats)))
 477       (let ((prop (get (nth 2 pats) 'math-pattern-cache)))
 478         (or prop
 479             (put (nth 2 pats) 'math-pattern-cache (setq prop (list nil))))
 480         (or (eq (car prop) (symbol-value (nth 2 pats)))
 481             (progn
 482               (setcdr prop (math-compile-patterns
 483                             (symbol-value (nth 2 pats))))
 484               (setcar prop (symbol-value (nth 2 pats)))))
 485         (cdr prop))
 486     (let ((math-rewrite-whole t))
 487       (cdr (math-compile-rewrites (cons
 488                                    'vec
 489                                    (mapcar (function (lambda (x)
 490                                                        (list 'vec x t)))
 491                                            (if (eq (car-safe pats) 'vec)
 492                                                (cdr pats)
 493                                              (list pats))))))))
 494 )
 495 (setq math-rewrite-whole nil)
 496 (setq math-make-import-list nil)
 497
 498 (defun math-compile-rewrites (rules &optional name)
 499   (if (eq (car-safe rules) 'var)
 500       (let ((prop (get (nth 2 rules) 'math-rewrite-cache))
 501             (math-import-list nil)
 502             (math-make-import-list t)
 503             p)
 504         (or (calc-var-value (nth 2 rules))
 505             (error "Rules variable %s has no stored value" (nth 1 rules)))
 506         (or prop
 507             (put (nth 2 rules) 'math-rewrite-cache
 508                  (setq prop (list (list (cons (nth 2 rules) nil))))))
 509         (setq p (car prop))
 510         (while (and p (eq (symbol-value (car (car p))) (cdr (car p))))
 511           (setq p (cdr p)))
 512         (or (null p)
 513             (progn
 514               (message "Compiling rule set %s..." (nth 1 rules))
 515               (setcdr prop (math-compile-rewrites
 516                             (symbol-value (nth 2 rules))
 517                             (nth 2 rules)))
 518               (message "Compiling rule set %s...done" (nth 1 rules))
 519               (setcar prop (cons (cons (nth 2 rules)
 520                                        (symbol-value (nth 2 rules)))
 521                                  math-import-list))))
 522         (cdr prop))
 523     (if (or (not (eq (car-safe rules) 'vec))
 524             (and (memq (length rules) '(3 4))
 525                  (let ((p rules))
 526                    (while (and (setq p (cdr p))
 527                                (memq (car-safe (car p))
 528                                      '(vec
 529                                        calcFunc-assign
 530                                        calcFunc-condition
 531                                        calcFunc-import
 532                                        calcFunc-phase
 533                                        calcFunc-schedule
 534                                        calcFunc-iterations))))
 535                    p)))
 536         (setq rules (list rules))
 537       (setq rules (cdr rules)))
 538     (if (assq 'calcFunc-import rules)
 539         (let ((pp (setq rules (copy-sequence rules)))
 540               p part)
 541           (while (setq p (car (cdr pp)))
 542             (if (eq (car-safe p) 'calcFunc-import)
 543                 (progn
 544                   (setcdr pp (cdr (cdr pp)))
 545                   (or (and (eq (car-safe (nth 1 p)) 'var)
 546                            (setq part (calc-var-value (nth 2 (nth 1 p))))
 547                            (memq (car-safe part) '(vec
 548                                                    calcFunc-assign
 549                                                    calcFunc-condition)))
 550                       (error "Argument of import() must be a rules variable"))
 551                   (if math-make-import-list
 552                       (setq math-import-list
 553                             (cons (cons (nth 2 (nth 1 p))
 554                                         (symbol-value (nth 2 (nth 1 p))))
 555                                   math-import-list)))
 556                   (while (setq p (cdr (cdr p)))
 557                     (or (cdr p)
 558                         (error "import() must have odd number of arguments"))
 559                     (setq part (math-rwcomp-substitute part
 560                                                        (car p) (nth 1 p))))
 561                   (if (eq (car-safe part) 'vec)
 562                       (setq part (cdr part))
 563                     (setq part (list part)))
 564                   (setcdr pp (append part (cdr pp))))
 565               (setq pp (cdr pp))))))
 566     (let ((rule-set nil)
 567           (all-heads nil)
 568           (nil-rules nil)
 569           (rule-count 0)
 570           (math-schedule nil)
 571           (math-iterations nil)
 572           (math-phases nil)
 573           (math-all-phases nil)
 574           (math-remembering nil)
 575           math-pattern math-rhs math-conds)
 576       (while rules
 577         (cond
 578          ((and (eq (car-safe (car rules)) 'calcFunc-iterations)
 579                (= (length (car rules)) 2))
 580           (or (integerp (nth 1 (car rules)))
 581               (equal (nth 1 (car rules)) '(var inf var-inf))
 582               (equal (nth 1 (car rules)) '(neg (var inf var-inf)))
 583               (error "Invalid argument for iterations(n)"))
 584           (or math-iterations
 585               (setq math-iterations (nth 1 (car rules)))))
 586          ((eq (car-safe (car rules)) 'calcFunc-schedule)
 587           (or math-schedule
 588               (setq math-schedule (math-parse-schedule (cdr (car rules))))))
 589          ((eq (car-safe (car rules)) 'calcFunc-phase)
 590           (setq math-phases (cdr (car rules)))
 591           (if (equal math-phases '((var all var-all)))
 592               (setq math-phases nil))
 593           (let ((p math-phases))
 594             (while p
 595               (or (integerp (car p))
 596                   (error "Phase numbers must be small integers"))
 597               (or (memq (car p) math-all-phases)
 598                   (setq math-all-phases (cons (car p) math-all-phases)))
 599               (setq p (cdr p)))))
 600          ((or (and (eq (car-safe (car rules)) 'vec)
 601                    (cdr (cdr (car rules)))
 602                    (not (nthcdr 4 (car rules)))
 603                    (setq math-conds (nth 3 (car rules))
 604                          math-rhs (nth 2 (car rules))
 605                          math-pattern (nth 1 (car rules))))
 606               (progn
 607                 (setq math-conds nil
 608                       math-pattern (car rules))
 609                 (while (and (eq (car-safe math-pattern) 'calcFunc-condition)
 610                             (= (length math-pattern) 3))
 611                   (let ((cond (nth 2 math-pattern)))
 612                     (setq math-conds (if math-conds
 613                                          (list 'calcFunc-land math-conds cond)
 614                                        cond)
 615                           math-pattern (nth 1 math-pattern))))
 616                 (and (eq (car-safe math-pattern) 'calcFunc-assign)
 617                      (= (length math-pattern) 3)
 618                      (setq math-rhs (nth 2 math-pattern)
 619                            math-pattern (nth 1 math-pattern)))))
 620           (let* ((math-prog (list nil))
 621                  (math-prog-last math-prog)
 622                  (math-num-regs 1)
 623                  (math-regs (list (list nil 0 nil nil)))
 624                  (math-bound-vars nil)
 625                  (math-aliased-vars nil)
 626                  (math-copy-neg nil))
 627             (setq math-conds (and math-conds (math-flatten-lands math-conds)))
 628             (math-rwcomp-pattern math-pattern 0)
 629             (while math-conds
 630               (let ((expr (car math-conds)))
 631                 (setq math-conds (cdr math-conds))
 632                 (math-rwcomp-cond-instr expr)))
 633             (math-rwcomp-instr 'done
 634                                (if (eq math-rhs t)
 635                                    (cons 'vec
 636                                          (delq
 637                                           nil
 638                                           (nreverse
 639                                            (mapcar
 640                                             (function
 641                                              (lambda (v)
 642                                                (and (car v)
 643                                                     (list
 644                                                      'calcFunc-assign
 645                                                      (math-build-var-name
 646                                                       (car v))
 647                                                      (math-rwcomp-register-expr
 648                                                       (nth 1 v))))))
 649                                             math-regs))))
 650                                  (math-rwcomp-match-vars math-rhs))
 651                                math-remembering)
 652             (setq math-prog (cdr math-prog))
 653             (let* ((heads (math-rewrite-heads math-pattern))
 654                    (rule (list (vconcat
 655                                 (nreverse
 656                                  (mapcar (function (lambda (x) (nth 3 x)))
 657                                          math-regs)))
 658                                math-prog
 659                                heads
 660                                math-phases))
 661                    (head (and (not (Math-primp math-pattern))
 662                               (not (and (eq (car (car math-prog)) 'try)
 663                                         (nth 5 (car math-prog))))
 664                               (not (memq (car (car math-prog)) '(func-opt
 665                                                                  apply
 666                                                                  select
 667                                                                  alt)))
 668                               (if (memq (car (car math-prog)) '(func
 669                                                                 func-def))
 670                                   (nth 2 (car math-prog))
 671                                 (if (eq (car math-pattern) 'calcFunc-quote)
 672                                     (car-safe (nth 1 math-pattern))
 673                                   (car math-pattern))))))
 674               (let (found)
 675                 (while heads
 676                   (if (setq found (assq (car heads) all-heads))
 677                       (setcdr found (1+ (cdr found)))
 678                     (setq all-heads (cons (cons (car heads) 1) all-heads)))
 679                   (setq heads (cdr heads))))
 680               (if (eq head '-) (setq head '+))
 681               (if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec))
 682               (if head
 683                   (progn
 684                     (nconc (or (assq head rule-set)
 685                                (car (setq rule-set (cons (cons head
 686                                                                (copy-sequence
 687                                                                 nil-rules))
 688                                                          rule-set))))
 689                            (list rule))
 690                     (if (eq head '*)
 691                         (nconc (or (assq '/ rule-set)
 692                                    (car (setq rule-set (cons (cons
 693                                                               '/
 694                                                               (copy-sequence
 695                                                                nil-rules))
 696                                                              rule-set))))
 697                                (list rule))))
 698                 (setq nil-rules (nconc nil-rules (list rule)))
 699                 (let ((ptr rule-set))
 700                   (while ptr
 701                     (nconc (car ptr) (list rule))
 702                     (setq ptr (cdr ptr))))))))
 703          (t
 704           (error "Rewrite rule set must be a vector of A := B rules")))
 705         (setq rules (cdr rules)))
 706       (if nil-rules
 707           (setq rule-set (cons (cons nil nil-rules) rule-set)))
 708       (setq all-heads (mapcar 'car
 709                               (sort all-heads (function
 710                                                (lambda (x y)
 711                                                  (< (cdr x) (cdr y)))))))
 712       (let ((set rule-set)
 713             rule heads ptr)
 714         (while set
 715           (setq rule (cdr (car set)))
 716           (while rule
 717             (if (consp (setq heads (nth 2 (car rule))))
 718                 (progn
 719                   (setq heads (delq (car (car set)) heads)
 720                         ptr all-heads)
 721                   (while (and ptr (not (memq (car ptr) heads)))
 722                     (setq ptr (cdr ptr)))
 723                   (setcar (nthcdr 2 (car rule)) (car ptr))))
 724             (setq rule (cdr rule)))
 725           (setq set (cdr set))))
 726       (let ((plus (assq '+ rule-set)))
 727         (if plus
 728             (setq rule-set (cons (cons '- (cdr plus)) rule-set))))
 729       (cons (list 'schedule math-iterations name
 730                   (or math-schedule
 731                       (sort math-all-phases '<)
 732                       (list 1)))
 733             rule-set)))
 734 )
 735
 736 (defun math-flatten-lands (expr)
 737   (if (eq (car-safe expr) 'calcFunc-land)
 738       (append (math-flatten-lands (nth 1 expr))
 739               (math-flatten-lands (nth 2 expr)))
 740     (list expr))
 741 )
 742
 743 (defun math-rewrite-heads (expr &optional more all)
 744   (let ((heads more)
 745         (skips (and (not all)
 746                     '(calcFunc-apply calcFunc-condition calcFunc-opt
 747                                      calcFunc-por calcFunc-pnot)))
 748         (blanks (and (not all)
 749                      '(calcFunc-quote calcFunc-plain calcFunc-select
 750                                       calcFunc-cons calcFunc-rcons
 751                                       calcFunc-pand))))
 752     (or (Math-primp expr)
 753         (math-rewrite-heads-rec expr))
 754     heads)
 755 )
 756
 757 (defun math-rewrite-heads-rec (expr)
 758   (or (memq (car expr) skips)
 759       (progn
 760         (or (memq (car expr) heads)
 761             (memq (car expr) blanks)
 762             (memq 'algebraic (get (car expr) 'math-rewrite-props))
 763             (setq heads (cons (car expr) heads)))
 764         (while (setq expr (cdr expr))
 765           (or (Math-primp (car expr))
 766               (math-rewrite-heads-rec (car expr))))))
 767 )
 768
 769 (defun math-parse-schedule (sched)
 770   (mapcar (function
 771            (lambda (s)
 772              (if (integerp s)
 773                  s
 774                (if (math-vectorp s)
 775                    (math-parse-schedule (cdr s))
 776                  (if (eq (car-safe s) 'var)
 777                      (math-var-to-calcFunc s)
 778                    (error "Improper component in rewrite schedule"))))))
 779           sched)
 780 )
 781
 782 (defun math-rwcomp-match-vars (expr)
 783   (if (Math-primp expr)
 784       (if (eq (car-safe expr) 'var)
 785           (let ((entry (assq (nth 2 expr) math-regs)))
 786             (if entry
 787                 (math-rwcomp-register-expr (nth 1 entry))
 788               expr))
 789         expr)
 790     (if (and (eq (car expr) 'calcFunc-quote)
 791              (= (length expr) 2))
 792         (math-rwcomp-match-vars (nth 1 expr))
 793       (if (and (eq (car expr) 'calcFunc-plain)
 794                (= (length expr) 2)
 795                (not (Math-primp (nth 1 expr))))
 796           (list (car expr)
 797                 (cons (car (nth 1 expr))
 798                       (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
 799         (cons (car expr)
 800               (mapcar 'math-rwcomp-match-vars (cdr expr))))))
 801 )
 802
 803 (defun math-rwcomp-register-expr (num)
 804   (let ((entry (nth (1- (- math-num-regs num)) math-regs)))
 805     (if (nth 2 entry)
 806         (list 'neg (list 'calcFunc-register (nth 1 entry)))
 807       (list 'calcFunc-register (nth 1 entry))))
 808 )
 809
 810 (defun math-rwcomp-substitute (expr old new)
 811   (if (and (eq (car-safe old) 'var)
 812            (memq (car-safe new) '(var calcFunc-lambda)))
 813       (let ((old-func (math-var-to-calcFunc old))
 814             (new-func (math-var-to-calcFunc new)))
 815         (math-rwcomp-subst-rec expr))
 816     (let ((old-func nil))
 817       (math-rwcomp-subst-rec expr)))
 818 )
 819
 820 (defun math-rwcomp-subst-rec (expr)
 821   (cond ((equal expr old) new)
 822         ((Math-primp expr) expr)
 823         (t (if (eq (car expr) old-func)
 824                (math-build-call new-func (mapcar 'math-rwcomp-subst-rec
 825                                                  (cdr expr)))
 826              (cons (car expr)
 827                    (mapcar 'math-rwcomp-subst-rec (cdr expr))))))
 828 )
 829
 830 (setq math-rwcomp-tracing nil)
 831
 832 (defun math-rwcomp-trace (instr)
 833   (if math-rwcomp-tracing (progn (terpri) (princ instr)))
 834   instr
 835 )
 836
 837 (defun math-rwcomp-instr (&rest instr)
 838   (setcdr math-prog-last
 839           (setq math-prog-last (list (math-rwcomp-trace instr))))
 840 )
 841
 842 (defun math-rwcomp-multi-instr (tail &rest instr)
 843   (setcdr math-prog-last
 844           (setq math-prog-last (list (math-rwcomp-trace (append instr tail)))))
 845 )
 846
 847 (defun math-rwcomp-bind-var (reg var)
 848   (setcar (math-rwcomp-reg-entry reg) (nth 2 var))
 849   (setq math-bound-vars (cons (nth 2 var) math-bound-vars))
 850   (math-rwcomp-do-conditions)
 851 )
 852
 853 (defun math-rwcomp-unbind-vars (mark)
 854   (while (not (eq math-bound-vars mark))
 855     (setcar (assq (car math-bound-vars) math-regs) nil)
 856     (setq math-bound-vars (cdr math-bound-vars)))
 857 )
 858
 859 (defun math-rwcomp-do-conditions ()
 860   (let ((cond math-conds))
 861     (while cond
 862       (if (math-rwcomp-all-regs-done (car cond))
 863           (let ((expr (car cond)))
 864             (setq math-conds (delq (car cond) math-conds))
 865             (setcar cond 1)
 866             (math-rwcomp-cond-instr expr)))
 867       (setq cond (cdr cond))))
 868 )
 869
 870 (defun math-rwcomp-cond-instr (expr)
 871   (let (op arg)
 872     (cond ((and (eq (car-safe expr) 'calcFunc-matches)
 873                 (= (length expr) 3)
 874                 (eq (car-safe (setq arg (math-rwcomp-match-vars (nth 1 expr))))
 875                     'calcFunc-register))
 876            (math-rwcomp-pattern (nth 2 expr) (nth 1 arg)))
 877           ((math-numberp (setq expr (math-rwcomp-match-vars expr)))
 878            (if (Math-zerop expr)
 879                (math-rwcomp-instr 'backtrack)))
 880           ((and (eq (car expr) 'calcFunc-let)
 881                 (= (length expr) 3))
 882            (let ((reg (math-rwcomp-reg)))
 883              (math-rwcomp-instr 'let reg (nth 2 expr))
 884              (math-rwcomp-pattern (nth 1 expr) reg)))
 885           ((and (eq (car expr) 'calcFunc-let)
 886                 (= (length expr) 2)
 887                 (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
 888                 (= (length (nth 1 expr)) 3))
 889            (let ((reg (math-rwcomp-reg)))
 890              (math-rwcomp-instr 'let reg (nth 2 (nth 1 expr)))
 891              (math-rwcomp-pattern (nth 1 (nth 1 expr)) reg)))
 892           ((and (setq op (cdr (assq (car-safe expr)
 893                                     '( (calcFunc-integer  . integer)
 894                                        (calcFunc-real     . real)
 895                                        (calcFunc-constant . constant)
 896                                        (calcFunc-negative . negative) ))))
 897                 (= (length expr) 2)
 898                 (or (and (eq (car-safe (nth 1 expr)) 'neg)
 899                          (memq op '(integer real constant))
 900                          (setq arg (nth 1 (nth 1 expr))))
 901                     (setq arg (nth 1 expr)))
 902                 (eq (car-safe (setq arg (nth 1 expr))) 'calcFunc-register))
 903            (math-rwcomp-instr op (nth 1 arg)))
 904           ((and (assq (car-safe expr) calc-tweak-eqn-table)
 905                 (= (length expr) 3)
 906                 (eq (car-safe (nth 1 expr)) 'calcFunc-register))
 907            (if (math-constp (nth 2 expr))
 908                (let ((reg (math-rwcomp-reg)))
 909                  (setcar (nthcdr 3 (car math-regs)) (nth 2 expr))
 910                  (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
 911                                     (car expr) reg))
 912              (if (eq (car (nth 2 expr)) 'calcFunc-register)
 913                  (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
 914                                     (car expr) (nth 1 (nth 2 expr)))
 915                (math-rwcomp-instr 'cond expr))))
 916           ((and (eq (car-safe expr) 'calcFunc-eq)
 917                 (= (length expr) 3)
 918                 (eq (car-safe (nth 1 expr)) '%)
 919                 (eq (car-safe (nth 1 (nth 1 expr))) 'calcFunc-register)
 920                 (math-constp (nth 2 (nth 1 expr)))
 921                 (math-constp (nth 2 expr)))
 922            (math-rwcomp-instr 'mod (nth 1 (nth 1 (nth 1 expr)))
 923                               (nth 2 (nth 1 expr)) (nth 2 expr)))
 924           ((equal expr '(var remember var-remember))
 925            (setq math-remembering 1))
 926           ((and (eq (car-safe expr) 'calcFunc-remember)
 927                 (= (length expr) 2))
 928            (setq math-remembering (if math-remembering
 929                                       (list 'calcFunc-lor
 930                                             math-remembering (nth 1 expr))
 931                                     (nth 1 expr))))
 932           (t (math-rwcomp-instr 'cond expr))))
 933 )
 934
 935 (defun math-rwcomp-same-instr (reg1 reg2 neg)
 936   (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
 937                                  (nth 2 (math-rwcomp-reg-entry reg2)))
 938                              neg)
 939                          'same-neg
 940                        'same)
 941                      reg1 reg2)
 942 )
 943
 944 (defun math-rwcomp-copy-instr (reg1 reg2 neg)
 945   (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
 946               (nth 2 (math-rwcomp-reg-entry reg2)))
 947           neg)
 948       (math-rwcomp-instr 'copy-neg reg1 reg2)
 949     (or (eq reg1 reg2)
 950         (math-rwcomp-instr 'copy reg1 reg2)))
 951 )
 952
 953 (defun math-rwcomp-reg ()
 954   (prog1
 955       math-num-regs
 956     (setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
 957           math-num-regs (1+ math-num-regs)))
 958 )
 959
 960 (defun math-rwcomp-reg-entry (num)
 961   (nth (1- (- math-num-regs num)) math-regs)
 962 )
 963
 964
 965 (defun math-rwcomp-pattern (expr part &optional not-direct)
 966   (cond ((or (math-rwcomp-no-vars expr)
 967              (and (eq (car expr) 'calcFunc-quote)
 968                   (= (length expr) 2)
 969                   (setq expr (nth 1 expr))))
 970          (if (eq (car-safe expr) 'calcFunc-register)
 971              (math-rwcomp-same-instr part (nth 1 expr) nil)
 972            (let ((reg (math-rwcomp-reg)))
 973              (setcar (nthcdr 3 (car math-regs)) expr)
 974              (math-rwcomp-same-instr part reg nil))))
 975         ((eq (car expr) 'var)
 976          (let ((entry (assq (nth 2 expr) math-regs)))
 977            (if entry
 978                (math-rwcomp-same-instr part (nth 1 entry) nil)
 979              (if not-direct
 980                  (let ((reg (math-rwcomp-reg)))
 981                    (math-rwcomp-pattern expr reg)
 982                    (math-rwcomp-copy-instr part reg nil))
 983                (if (setq entry (assq (nth 2 expr) math-aliased-vars))
 984                    (progn
 985                      (setcar (math-rwcomp-reg-entry (nth 1 entry))
 986                              (nth 2 expr))
 987                      (setcar entry nil)
 988                      (math-rwcomp-copy-instr part (nth 1 entry) nil))
 989                  (math-rwcomp-bind-var part expr))))))
 990         ((and (eq (car expr) 'calcFunc-select)
 991               (= (length expr) 2))
 992          (let ((reg (math-rwcomp-reg)))
 993            (math-rwcomp-instr 'select part reg)
 994            (math-rwcomp-pattern (nth 1 expr) reg)))
 995         ((and (eq (car expr) 'calcFunc-opt)
 996               (memq (length expr) '(2 3)))
 997          (error "opt( ) occurs in context where it is not allowed"))
 998         ((eq (car expr) 'neg)
 999          (if (eq (car (nth 1 expr)) 'var)
1000              (let ((entry (assq (nth 2 (nth 1 expr)) math-regs)))
1001                (if entry
1002                    (math-rwcomp-same-instr part (nth 1 entry) t)
1003                  (if math-copy-neg
1004                      (let ((reg (math-rwcomp-best-reg (nth 1 expr))))
1005                        (math-rwcomp-copy-instr part reg t)
1006                        (math-rwcomp-pattern (nth 1 expr) reg))
1007                    (setcar (cdr (cdr (math-rwcomp-reg-entry part))) t)
1008                    (math-rwcomp-pattern (nth 1 expr) part))))
1009            (if (math-rwcomp-is-algebraic (nth 1 expr))
1010                (math-rwcomp-cond-instr (list 'calcFunc-eq
1011                                              (math-rwcomp-register-expr part)
1012                                              expr))
1013              (let ((reg (math-rwcomp-reg)))
1014                (math-rwcomp-instr 'func part 'neg reg)
1015                (math-rwcomp-pattern (nth 1 expr) reg)))))
1016         ((and (eq (car expr) 'calcFunc-apply)
1017               (= (length expr) 3))
1018          (let ((reg1 (math-rwcomp-reg))
1019                (reg2 (math-rwcomp-reg)))
1020            (math-rwcomp-instr 'apply part reg1 reg2)
1021            (math-rwcomp-pattern (nth 1 expr) reg1)
1022            (math-rwcomp-pattern (nth 2 expr) reg2)))
1023         ((and (eq (car expr) 'calcFunc-cons)
1024               (= (length expr) 3))
1025          (let ((reg1 (math-rwcomp-reg))
1026                (reg2 (math-rwcomp-reg)))
1027            (math-rwcomp-instr 'cons part reg1 reg2)
1028            (math-rwcomp-pattern (nth 1 expr) reg1)
1029            (math-rwcomp-pattern (nth 2 expr) reg2)))
1030         ((and (eq (car expr) 'calcFunc-rcons)
1031               (= (length expr) 3))
1032          (let ((reg1 (math-rwcomp-reg))
1033                (reg2 (math-rwcomp-reg)))
1034            (math-rwcomp-instr 'rcons part reg1 reg2)
1035            (math-rwcomp-pattern (nth 1 expr) reg1)
1036            (math-rwcomp-pattern (nth 2 expr) reg2)))
1037         ((and (eq (car expr) 'calcFunc-condition)
1038               (>= (length expr) 3))
1039          (math-rwcomp-pattern (nth 1 expr) part)
1040          (setq expr (cdr expr))
1041          (while (setq expr (cdr expr))
1042            (let ((cond (math-flatten-lands (car expr))))
1043              (while cond
1044                (if (math-rwcomp-all-regs-done (car cond))
1045                    (math-rwcomp-cond-instr (car cond))
1046                  (setq math-conds (cons (car cond) math-conds)))
1047                (setq cond (cdr cond))))))
1048         ((and (eq (car expr) 'calcFunc-pand)
1049               (= (length expr) 3))
1050          (math-rwcomp-pattern (nth 1 expr) part)
1051          (math-rwcomp-pattern (nth 2 expr) part))
1052         ((and (eq (car expr) 'calcFunc-por)
1053               (= (length expr) 3))
1054          (math-rwcomp-instr 'alt nil nil [nil nil 4])
1055          (let ((math-conds nil)
1056                (head math-prog-last)
1057                (mark math-bound-vars)
1058                (math-copy-neg t))
1059            (math-rwcomp-pattern (nth 1 expr) part t)
1060            (let ((amark math-aliased-vars)
1061                  (math-aliased-vars math-aliased-vars)
1062                  (tail math-prog-last)
1063                  (p math-bound-vars)
1064                  entry)
1065              (while (not (eq p mark))
1066                (setq entry (assq (car p) math-regs)
1067                      math-aliased-vars (cons (list (car p) (nth 1 entry) nil)
1068                                              math-aliased-vars)
1069                      p (cdr p))
1070                (setcar (math-rwcomp-reg-entry (nth 1 entry)) nil))
1071              (setcar (cdr (car head)) (cdr head))
1072              (setcdr head nil)
1073              (setq math-prog-last head)
1074              (math-rwcomp-pattern (nth 2 expr) part)
1075              (math-rwcomp-instr 'same 0 0)
1076              (setcdr tail math-prog-last)
1077              (setq p math-aliased-vars)
1078              (while (not (eq p amark))
1079                (if (car (car p))
1080                    (setcar (math-rwcomp-reg-entry (nth 1 (car p)))
1081                            (car (car p))))
1082                (setq p (cdr p)))))
1083          (math-rwcomp-do-conditions))
1084         ((and (eq (car expr) 'calcFunc-pnot)
1085               (= (length expr) 2))
1086          (math-rwcomp-instr 'alt nil nil [nil nil 4])
1087          (let ((head math-prog-last)
1088                (mark math-bound-vars))
1089            (math-rwcomp-pattern (nth 1 expr) part)
1090            (math-rwcomp-unbind-vars mark)
1091            (math-rwcomp-instr 'end-alt head)
1092            (math-rwcomp-instr 'backtrack)
1093            (setcar (cdr (car head)) (cdr head))
1094            (setcdr head nil)
1095            (setq math-prog-last head)))
1096         (t (let ((props (get (car expr) 'math-rewrite-props)))
1097              (if (and (eq (car expr) 'calcFunc-plain)
1098                       (= (length expr) 2)
1099                       (not (math-primp (nth 1 expr))))
1100                  (setq expr (nth 1 expr))) ; but "props" is still nil
1101              (if (and (memq 'algebraic props)
1102                       (math-rwcomp-is-algebraic expr))
1103                  (math-rwcomp-cond-instr (list 'calcFunc-eq
1104                                                (math-rwcomp-register-expr part)
1105                                                expr))
1106                (if (and (memq 'commut props)
1107                         (= (length expr) 3))
1108                    (let ((arg1 (nth 1 expr))
1109                          (arg2 (nth 2 expr))
1110                          try1 def code head (flip nil))
1111                      (if (eq (car expr) '-)
1112                          (setq arg2 (math-rwcomp-neg arg2)))
1113                      (setq arg1 (cons arg1 (math-rwcomp-best-reg arg1))
1114                            arg2 (cons arg2 (math-rwcomp-best-reg arg2)))
1115                      (or (math-rwcomp-order arg1 arg2)
1116                          (setq def arg1 arg1 arg2 arg2 def flip t))
1117                      (if (math-rwcomp-optional-arg (car expr) arg1)
1118                          (error "Too many opt( ) arguments in this context"))
1119                      (setq def (math-rwcomp-optional-arg (car expr) arg2)
1120                            head (if (memq (car expr) '(+ -))
1121                                     '(+ -)
1122                                   (if (eq (car expr) '*)
1123                                       '(* /)
1124                                     (list (car expr))))
1125                            code (if (math-rwcomp-is-constrained
1126                                      (car arg1) head)
1127                                     (if (math-rwcomp-is-constrained
1128                                          (car arg2) head)
1129                                         0 1)
1130                                   2))
1131                      (math-rwcomp-multi-instr (and def (list def))
1132                                               'try part head
1133                                               (vector nil nil nil code flip)
1134                                               (cdr arg1))
1135                      (setq try1 (car math-prog-last))
1136                      (math-rwcomp-pattern (car arg1) (cdr arg1))
1137                      (math-rwcomp-instr 'try2 try1 (cdr arg2))
1138                      (if (and (= part 0) (not def) (not math-rewrite-whole)
1139                               (not (eq math-rhs t))
1140                               (setq def (get (car expr)
1141                                              'math-rewrite-default)))
1142                          (let ((reg1 (math-rwcomp-reg))
1143                                (reg2 (math-rwcomp-reg)))
1144                            (if (= (aref (nth 3 try1) 3) 0)
1145                                (aset (nth 3 try1) 3 1))
1146                            (math-rwcomp-instr 'try (cdr arg2)
1147                                               (if (equal head '(* /))
1148                                                   '(*) head)
1149                                               (vector nil nil nil
1150                                                       (if (= code 0)
1151                                                           1 2)
1152                                                       nil)
1153                                               reg1 def)
1154                            (setq try1 (car math-prog-last))
1155                            (math-rwcomp-pattern (car arg2) reg1)
1156                            (math-rwcomp-instr 'try2 try1 reg2)
1157                            (setq math-rhs (list (if (eq (car expr) '-)
1158                                                     '+ (car expr))
1159                                                 math-rhs
1160                                                 (list 'calcFunc-register
1161                                                       reg2))))
1162                        (math-rwcomp-pattern (car arg2) (cdr arg2))))
1163                  (let* ((args (mapcar (function
1164                                        (lambda (x)
1165                                          (cons x (math-rwcomp-best-reg x))))
1166                                       (cdr expr)))
1167                         (args2 (copy-sequence args))
1168                         (argp (reverse args2))
1169                         (defs nil)
1170                         (num 1))
1171                    (while argp
1172                      (let ((def (math-rwcomp-optional-arg (car expr)
1173                                                           (car argp))))
1174                        (if def
1175                            (progn
1176                              (setq args2 (delq (car argp) args2)
1177                                    defs (cons (cons def (cdr (car argp)))
1178                                               defs))
1179                              (math-rwcomp-multi-instr
1180                               (mapcar 'cdr args2)
1181                               (if (or (and (memq 'unary1 props)
1182                                            (= (length args2) 1)
1183                                            (eq (car args2) (car args)))
1184                                       (and (memq 'unary2 props)
1185                                            (= (length args) 2)
1186                                            (eq (car args2) (nth 1 args))))
1187                                   'func-opt
1188                                 'func-def)
1189                               part (car expr)
1190                               defs))))
1191                      (setq argp (cdr argp)))
1192                    (math-rwcomp-multi-instr (mapcar 'cdr args)
1193                                             'func part (car expr))
1194                    (setq args (sort args 'math-rwcomp-order))
1195                    (while args
1196                      (math-rwcomp-pattern (car (car args)) (cdr (car args)))
1197                      (setq num (1+ num)
1198                            args (cdr args)))))))))
1199 )
1200
1201 (defun math-rwcomp-best-reg (x)
1202   (or (and (eq (car-safe x) 'var)
1203            (let ((entry (assq (nth 2 x) math-aliased-vars)))
1204              (and entry
1205                   (not (nth 2 entry))
1206                   (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry))))
1207                   (progn
1208                     (setcar (cdr (cdr entry)) t)
1209                     (nth 1 entry)))))
1210       (math-rwcomp-reg))
1211 )
1212
1213 (defun math-rwcomp-all-regs-done (expr)
1214   (if (Math-primp expr)
1215       (or (not (eq (car-safe expr) 'var))
1216           (assq (nth 2 expr) math-regs)
1217           (eq (nth 2 expr) 'var-remember)
1218           (math-const-var expr))
1219     (if (and (eq (car expr) 'calcFunc-let)
1220              (= (length expr) 3))
1221         (math-rwcomp-all-regs-done (nth 2 expr))
1222       (if (and (eq (car expr) 'calcFunc-let)
1223                (= (length expr) 2)
1224                (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
1225                (= (length (nth 1 expr)) 3))
1226           (math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
1227         (while (and (setq expr (cdr expr))
1228                     (math-rwcomp-all-regs-done (car expr))))
1229         (null expr))))
1230 )
1231
1232 (defun math-rwcomp-no-vars (expr)
1233   (if (Math-primp expr)
1234       (or (not (eq (car-safe expr) 'var))
1235           (math-const-var expr))
1236     (and (not (memq (car expr) '(calcFunc-condition
1237                                  calcFunc-select calcFunc-quote
1238                                  calcFunc-plain calcFunc-opt
1239                                  calcFunc-por calcFunc-pand
1240                                  calcFunc-pnot calcFunc-apply
1241                                  calcFunc-cons calcFunc-rcons)))
1242          (progn
1243            (while (and (setq expr (cdr expr))
1244                        (math-rwcomp-no-vars (car expr))))
1245            (null expr))))
1246 )
1247
1248 (defun math-rwcomp-is-algebraic (expr)
1249   (if (Math-primp expr)
1250       (or (not (eq (car-safe expr) 'var))
1251           (math-const-var expr)
1252           (assq (nth 2 expr) math-regs))
1253     (and (memq 'algebraic (get (car expr) 'math-rewrite-props))
1254          (progn
1255            (while (and (setq expr (cdr expr))
1256                        (math-rwcomp-is-algebraic (car expr))))
1257            (null expr))))
1258 )
1259
1260 (defun math-rwcomp-is-constrained (expr not-these)
1261   (if (Math-primp expr)
1262       (not (eq (car-safe expr) 'var))
1263     (if (eq (car expr) 'calcFunc-plain)
1264         (math-rwcomp-is-constrained (nth 1 expr) not-these)
1265       (not (or (memq (car expr) '(neg calcFunc-select))
1266                (memq (car expr) not-these)
1267                (and (memq 'commut (get (car expr) 'math-rewrite-props))
1268                     (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
1269                         (eq (car-safe (nth 2 expr)) 'calcFunc-opt)))))))
1270 )
1271
1272 (defun math-rwcomp-optional-arg (head argp)
1273   (let ((arg (car argp)))
1274     (if (eq (car-safe arg) 'calcFunc-opt)
1275         (and (memq (length arg) '(2 3))
1276              (progn
1277                (or (eq (car-safe (nth 1 arg)) 'var)
1278                    (error "First argument of opt( ) must be a variable"))
1279                (setcar argp (nth 1 arg))
1280                (if (= (length arg) 2)
1281                    (or (get head 'math-rewrite-default)
1282                        (error "opt( ) must include a default in this context"))
1283                  (nth 2 arg))))
1284       (and (eq (car-safe arg) 'neg)
1285            (let* ((part (list (nth 1 arg)))
1286                   (partp (math-rwcomp-optional-arg head part)))
1287              (and partp
1288                   (setcar argp (math-rwcomp-neg (car part)))
1289                   (math-neg partp))))))
1290 )
1291
1292 (defun math-rwcomp-neg (expr)
1293   (if (memq (car-safe expr) '(* /))
1294       (if (eq (car-safe (nth 1 expr)) 'var)
1295           (list (car expr) (list 'neg (nth 1 expr)) (nth 2 expr))
1296         (if (eq (car-safe (nth 2 expr)) 'var)
1297             (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
1298           (math-neg expr)))
1299     (math-neg expr))
1300 )
1301
1302 (defun math-rwcomp-assoc-args (expr)
1303   (if (and (eq (car-safe (nth 1 expr)) (car expr))
1304            (= (length (nth 1 expr)) 3))
1305       (math-rwcomp-assoc-args (nth 1 expr))
1306     (setq math-args (cons (nth 1 expr) math-args)))
1307   (if (and (eq (car-safe (nth 2 expr)) (car expr))
1308            (= (length (nth 2 expr)) 3))
1309       (math-rwcomp-assoc-args (nth 2 expr))
1310     (setq math-args (cons (nth 2 expr) math-args)))
1311 )
1312
1313 (defun math-rwcomp-addsub-args (expr)
1314   (if (memq (car-safe (nth 1 expr)) '(+ -))
1315       (math-rwcomp-addsub-args (nth 1 expr))
1316     (setq math-args (cons (nth 1 expr) math-args)))
1317   (if (eq (car expr) '-)
1318       (setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args))
1319     (if (eq (car-safe (nth 2 expr)) '+)
1320         (math-rwcomp-addsub-args (nth 2 expr))
1321       (setq math-args (cons (nth 2 expr) math-args))))
1322 )
1323
1324 (defun math-rwcomp-order (a b)
1325   (< (math-rwcomp-priority (car a))
1326      (math-rwcomp-priority (car b)))
1327 )
1328
1329 ;;; Order of priority:    0 Constants and other exact matches (first)
1330 ;;;                      10 Functions (except below)
1331 ;;;                      20 Meta-variables which occur more than once
1332 ;;;                      30 Algebraic functions
1333 ;;;                      40 Commutative/associative functions
1334 ;;;                      50 Meta-variables which occur only once
1335 ;;;                    +100 for every "!!!" (pnot) in the pattern
1336 ;;;                   10000 Optional arguments (last)
1337
1338 (defun math-rwcomp-priority (expr)
1339   (+ (math-rwcomp-count-pnots expr)
1340      (cond ((eq (car-safe expr) 'calcFunc-opt)
1341             10000)
1342            ((math-rwcomp-no-vars expr)
1343             0)
1344            ((eq (car expr) 'calcFunc-quote)
1345             0)
1346            ((eq (car expr) 'var)
1347             (if (assq (nth 2 expr) math-regs)
1348                 0
1349               (if (= (math-rwcomp-count-refs expr) 1)
1350                   50
1351                 20)))
1352            (t (let ((props (get (car expr) 'math-rewrite-props)))
1353                 (if (or (memq 'commut props)
1354                         (memq 'assoc props))
1355                     40
1356                   (if (memq 'algebraic props)
1357                       30
1358                     10))))))
1359 )
1360
1361 (defun math-rwcomp-count-refs (var)
1362   (let ((count (or (math-expr-contains-count math-pattern var) 0))
1363         (p math-conds))
1364     (while p
1365       (if (eq (car-safe (car p)) 'calcFunc-let)
1366           (if (= (length (car p)) 3)
1367               (setq count (+ count
1368                              (or (math-expr-contains-count (nth 2 (car p)) var)
1369                                  0)))
1370             (if (and (= (length (car p)) 2)
1371                      (eq (car-safe (nth 1 (car p))) 'calcFunc-assign)
1372                      (= (length (nth 1 (car p))) 3))
1373                 (setq count (+ count
1374                                (or (math-expr-contains-count
1375                                     (nth 2 (nth 1 (car p))) var) 0))))))
1376       (setq p (cdr p)))
1377     count)
1378 )
1379
1380 (defun math-rwcomp-count-pnots (expr)
1381   (if (Math-primp expr)
1382       0
1383     (if (eq (car expr) 'calcFunc-pnot)
1384         100
1385       (let ((count 0))
1386         (while (setq expr (cdr expr))
1387           (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
1388         count)))
1389 )
1390
1391 ;;; In the current implementation, all associative functions must
1392 ;;; also be commutative.
1393
1394 (put '+              'math-rewrite-props '(algebraic assoc commut))
1395 (put '-              'math-rewrite-props '(algebraic assoc commut)) ; see below
1396 (put '*              'math-rewrite-props '(algebraic assoc commut)) ; see below
1397 (put '/              'math-rewrite-props '(algebraic unary1))
1398 (put '^              'math-rewrite-props '(algebraic unary1))
1399 (put '%              'math-rewrite-props '(algebraic))
1400 (put 'neg            'math-rewrite-props '(algebraic))
1401 (put 'calcFunc-idiv  'math-rewrite-props '(algebraic))
1402 (put 'calcFunc-abs   'math-rewrite-props '(algebraic))
1403 (put 'calcFunc-sign  'math-rewrite-props '(algebraic))
1404 (put 'calcFunc-round 'math-rewrite-props '(algebraic))
1405 (put 'calcFunc-rounde 'math-rewrite-props '(algebraic))
1406 (put 'calcFunc-roundu 'math-rewrite-props '(algebraic))
1407 (put 'calcFunc-trunc 'math-rewrite-props '(algebraic))
1408 (put 'calcFunc-floor 'math-rewrite-props '(algebraic))
1409 (put 'calcFunc-ceil  'math-rewrite-props '(algebraic))
1410 (put 'calcFunc-re    'math-rewrite-props '(algebraic))
1411 (put 'calcFunc-im    'math-rewrite-props '(algebraic))
1412 (put 'calcFunc-conj  'math-rewrite-props '(algebraic))
1413 (put 'calcFunc-arg   'math-rewrite-props '(algebraic))
1414 (put 'calcFunc-and   'math-rewrite-props '(assoc commut))
1415 (put 'calcFunc-or    'math-rewrite-props '(assoc commut))
1416 (put 'calcFunc-xor   'math-rewrite-props '(assoc commut))
1417 (put 'calcFunc-eq    'math-rewrite-props '(commut))
1418 (put 'calcFunc-neq   'math-rewrite-props '(commut))
1419 (put 'calcFunc-land  'math-rewrite-props '(assoc commut))
1420 (put 'calcFunc-lor   'math-rewrite-props '(assoc commut))
1421 (put 'calcFunc-beta  'math-rewrite-props '(commut))
1422 (put 'calcFunc-gcd   'math-rewrite-props '(assoc commut))
1423 (put 'calcFunc-lcm   'math-rewrite-props '(assoc commut))
1424 (put 'calcFunc-max   'math-rewrite-props '(algebraic assoc commut))
1425 (put 'calcFunc-min   'math-rewrite-props '(algebraic assoc commut))
1426 (put 'calcFunc-vunion 'math-rewrite-props '(assoc commut))
1427 (put 'calcFunc-vint  'math-rewrite-props '(assoc commut))
1428 (put 'calcFunc-vxor  'math-rewrite-props '(assoc commut))
1429
1430 ;;; Note: "*" is not commutative for matrix args, but we pretend it is.
1431 ;;; Also, "-" is not commutative but the code tweaks things so that it is.
1432
1433 (put '+              'math-rewrite-default  0)
1434 (put '-              'math-rewrite-default  0)
1435 (put '*              'math-rewrite-default  1)
1436 (put '/              'math-rewrite-default  1)
1437 (put '^              'math-rewrite-default  1)
1438 (put 'calcFunc-land  'math-rewrite-default  1)
1439 (put 'calcFunc-lor   'math-rewrite-default  0)
1440 (put 'calcFunc-vunion 'math-rewrite-default '(vec))
1441 (put 'calcFunc-vint  'math-rewrite-default '(vec))
1442 (put 'calcFunc-vdiff 'math-rewrite-default '(vec))
1443 (put 'calcFunc-vxor  'math-rewrite-default '(vec))
1444
1445 (defmacro math-rwfail (&optional back)
1446   (list 'setq 'pc
1447         (list 'and
1448               (if back
1449                   '(setq btrack (cdr btrack))
1450                 'btrack)
1451               ''((backtrack))))
1452 )
1453
1454 ;;; This monstrosity is necessary because the use of static vectors of
1455 ;;; registers makes rewrite rules non-reentrant.  Yucko!
1456 (defmacro math-rweval (form)
1457   (list 'let '((orig (car rules)))
1458         '(setcar rules (quote (nil nil nil no-phase)))
1459         (list 'unwind-protect
1460               form
1461               '(setcar rules orig)))
1462 )
1463
1464 (setq math-rewrite-phase 1)
1465
1466 (defun math-apply-rewrites (expr rules &optional heads ruleset)
1467   (and
1468    (setq rules (cdr (or (assq (car-safe expr) rules)
1469                         (assq nil rules))))
1470    (let ((result nil)
1471          op regs inst part pc mark btrack
1472          (tracing math-rwcomp-tracing)
1473          (phase math-rewrite-phase))
1474      (while rules
1475        (or
1476         (and (setq part (nth 2 (car rules)))
1477              heads
1478              (not (memq part heads)))
1479         (and (setq part (nth 3 (car rules)))
1480              (not (memq phase part)))
1481         (progn
1482           (setq regs (car (car rules))
1483                 pc (nth 1 (car rules))
1484                 btrack nil)
1485           (aset regs 0 expr)
1486           (while pc
1487
1488             (and tracing
1489                  (progn (terpri) (princ (car pc))
1490                         (if (and (natnump (nth 1 (car pc)))
1491                                  (< (nth 1 (car pc)) (length regs)))
1492                             (princ (format "\n  part = %s"
1493                                            (aref regs (nth 1 (car pc))))))))
1494
1495             (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
1496                    (if (and (consp (setq part (aref regs (car (cdr inst)))))
1497                             (eq (car part)
1498                                 (car (setq inst (cdr (cdr inst)))))
1499                             (progn
1500                               (while (and (setq inst (cdr inst)
1501                                                 part (cdr part))
1502                                           inst)
1503                                 (aset regs (car inst) (car part)))
1504                               (not (or inst part))))
1505                        (setq pc (cdr pc))
1506                      (math-rwfail)))
1507
1508                   ((eq op 'same)
1509                    (if (or (equal (setq part (aref regs (nth 1 inst)))
1510                                   (setq mark (aref regs (nth 2 inst))))
1511                            (Math-equal part mark))
1512                        (setq pc (cdr pc))
1513                      (math-rwfail)))
1514
1515                   ((and (eq op 'try)
1516                         calc-matrix-mode
1517                         (not (eq calc-matrix-mode 'scalar))
1518                         (eq (car (nth 2 inst)) '*)
1519                         (consp (setq part (aref regs (car (cdr inst)))))
1520                         (eq (car part) '*)
1521                         (not (math-known-scalarp part)))
1522                    (setq mark (nth 3 inst)
1523                          pc (cdr pc))
1524                    (if (aref mark 4)
1525                        (progn
1526                          (aset regs (nth 4 inst) (nth 2 part))
1527                          (aset mark 1 (cdr (cdr part))))
1528                      (aset regs (nth 4 inst) (nth 1 part))
1529                      (aset mark 1 (cdr part)))
1530                    (aset mark 0 (cdr part))
1531                    (aset mark 2 0))
1532
1533                   ((eq op 'try)
1534                    (if (and (consp (setq part (aref regs (car (cdr inst)))))
1535                             (memq (car part) (nth 2 inst))
1536                             (= (length part) 3)
1537                             (or (not (eq (car part) '/))
1538                                 (Math-objectp (nth 2 part))))
1539                        (progn
1540                          (setq op nil
1541                                mark (car (cdr (setq inst (cdr (cdr inst))))))
1542                          (and
1543                           (memq 'assoc (get (car part) 'math-rewrite-props))
1544                           (not (= (aref mark 3) 0))
1545                           (while (if (and (consp (nth 1 part))
1546                                           (memq (car (nth 1 part)) (car inst)))
1547                                      (setq op (cons (if (eq (car part) '-)
1548                                                         (math-rwapply-neg
1549                                                          (nth 2 part))
1550                                                       (nth 2 part))
1551                                                     op)
1552                                            part (nth 1 part))
1553                                    (if (and (consp (nth 2 part))
1554                                             (memq (car (nth 2 part))
1555                                                   (car inst))
1556                                             (not (eq (car (nth 2 part)) '-)))
1557                                        (setq op (cons (nth 1 part) op)
1558                                              part (nth 2 part))))))
1559                          (setq op (cons (nth 1 part)
1560                                         (cons (if (eq (car part) '-)
1561                                                   (math-rwapply-neg
1562                                                    (nth 2 part))
1563                                                 (if (eq (car part) '/)
1564                                                     (math-rwapply-inv
1565                                                      (nth 2 part))
1566                                                   (nth 2 part)))
1567                                               op))
1568                                btrack (cons pc btrack)
1569                                pc (cdr pc))
1570                          (aset regs (nth 2 inst) (car op))
1571                          (aset mark 0 op)
1572                          (aset mark 1 op)
1573                          (aset mark 2 (if (cdr (cdr op)) 1 0)))
1574                      (if (nth 5 inst)
1575                          (if (and (consp part)
1576                                   (eq (car part) 'neg)
1577                                   (eq (car (nth 2 inst)) '*)
1578                                   (eq (nth 5 inst) 1))
1579                              (progn
1580                                (setq mark (nth 3 inst)
1581                                      pc (cdr pc))
1582                                (aset regs (nth 4 inst) (nth 1 part))
1583                                (aset mark 1 -1)
1584                                (aset mark 2 4))
1585                            (setq mark (nth 3 inst)
1586                                  pc (cdr pc))
1587                            (aset regs (nth 4 inst) part)
1588                            (aset mark 2 3))
1589                        (math-rwfail))))
1590
1591                   ((eq op 'try2)
1592                    (setq part (nth 1 inst)   ; try instr
1593                          mark (nth 3 part)
1594                          op (aref mark 2)
1595                          pc (cdr pc))
1596                    (aset regs (nth 2 inst)
1597                          (cond
1598                           ((eq op 0)
1599                            (if (eq (aref mark 0) (aref mark 1))
1600                                (nth 1 (aref mark 0))
1601                              (car (aref mark 0))))
1602                           ((eq op 1)
1603                            (setq mark (delq (car (aref mark 1))
1604                                             (copy-sequence (aref mark 0)))
1605                                  op (car (nth 2 part)))
1606                            (if (eq op '*)
1607                                (progn
1608                                  (setq mark (nreverse mark)
1609                                        part (list '* (nth 1 mark) (car mark))
1610                                        mark (cdr mark))
1611                                  (while (setq mark (cdr mark))
1612                                    (setq part (list '* (car mark) part))))
1613                              (setq part (car mark)
1614                                    mark (cdr mark)
1615                                    part (if (and (eq op '+)
1616                                                  (consp (car mark))
1617                                                  (eq (car (car mark)) 'neg))
1618                                             (list '- part
1619                                                   (nth 1 (car mark)))
1620                                           (list op part (car mark))))
1621                              (while (setq mark (cdr mark))
1622                                (setq part (if (and (eq op '+)
1623                                                    (consp (car mark))
1624                                                    (eq (car (car mark)) 'neg))
1625                                               (list '- part
1626                                                     (nth 1 (car mark)))
1627                                             (list op part (car mark))))))
1628                            part)
1629                           ((eq op 2)
1630                            (car (aref mark 1)))
1631                           ((eq op 3) (nth 5 part))
1632                           (t (aref mark 1)))))
1633
1634                   ((eq op 'select)
1635                    (setq pc (cdr pc))
1636                    (if (and (consp (setq part (aref regs (nth 1 inst))))
1637                             (eq (car part) 'calcFunc-select))
1638                        (aset regs (nth 2 inst) (nth 1 part))
1639                      (if math-rewrite-selections
1640                          (math-rwfail)
1641                        (aset regs (nth 2 inst) part))))
1642
1643                   ((eq op 'same-neg)
1644                    (if (or (equal (setq part (aref regs (nth 1 inst)))
1645                                   (setq mark (math-neg
1646                                               (aref regs (nth 2 inst)))))
1647                            (Math-equal part mark))
1648                        (setq pc (cdr pc))
1649                      (math-rwfail)))
1650
1651                   ((eq op 'backtrack)
1652                    (setq inst (car (car btrack))   ; "try" or "alt" instr
1653                          pc (cdr (car btrack))
1654                          mark (or (nth 3 inst) [nil nil 4])
1655                          op (aref mark 2))
1656                    (cond ((eq op 0)
1657                           (if (setq op (cdr (aref mark 1)))
1658                               (aset regs (nth 4 inst) (car (aset mark 1 op)))
1659                             (if (nth 5 inst)
1660                                 (progn
1661                                   (aset mark 2 3)
1662                                   (aset regs (nth 4 inst)
1663                                         (aref regs (nth 1 inst))))
1664                               (math-rwfail t))))
1665                          ((eq op 1)
1666                           (if (setq op (cdr (aref mark 1)))
1667                               (aset regs (nth 4 inst) (car (aset mark 1 op)))
1668                             (if (= (aref mark 3) 1)
1669                                 (if (nth 5 inst)
1670                                     (progn
1671                                       (aset mark 2 3)
1672                                       (aset regs (nth 4 inst)
1673                                             (aref regs (nth 1 inst))))
1674                                   (math-rwfail t))
1675                               (aset mark 2 2)
1676                               (aset mark 1 (cons nil (aref mark 0)))
1677                               (math-rwfail))))
1678                          ((eq op 2)
1679                           (if (setq op (cdr (aref mark 1)))
1680                               (progn
1681                                 (setq mark (delq (car (aset mark 1 op))
1682                                                  (copy-sequence
1683                                                   (aref mark 0)))
1684                                       op (car (nth 2 inst)))
1685                                 (if (eq op '*)
1686                                     (progn
1687                                       (setq mark (nreverse mark)
1688                                             part (list '* (nth 1 mark)
1689                                                        (car mark))
1690                                             mark (cdr mark))
1691                                       (while (setq mark (cdr mark))
1692                                         (setq part (list '* (car mark)
1693                                                          part))))
1694                                   (setq part (car mark)
1695                                         mark (cdr mark)
1696                                         part (if (and (eq op '+)
1697                                                       (consp (car mark))
1698                                                       (eq (car (car mark))
1699                                                           'neg))
1700                                                  (list '- part
1701                                                        (nth 1 (car mark)))
1702                                                (list op part (car mark))))
1703                                   (while (setq mark (cdr mark))
1704                                     (setq part (if (and (eq op '+)
1705                                                         (consp (car mark))
1706                                                         (eq (car (car mark))
1707                                                             'neg))
1708                                                    (list '- part
1709                                                          (nth 1 (car mark)))
1710                                                  (list op part (car mark))))))
1711                                 (aset regs (nth 4 inst) part))
1712                             (if (nth 5 inst)
1713                                 (progn
1714                                   (aset mark 2 3)
1715                                   (aset regs (nth 4 inst)
1716                                         (aref regs (nth 1 inst))))
1717                               (math-rwfail t))))
1718                          ((eq op 4)
1719                           (setq btrack (cdr btrack)))
1720                          (t (math-rwfail t))))
1721
1722                   ((eq op 'integer)
1723                    (if (Math-integerp (setq part (aref regs (nth 1 inst))))
1724                        (setq pc (cdr pc))
1725                      (if (Math-primp part)
1726                          (math-rwfail)
1727                        (setq part (math-rweval (math-simplify part)))
1728                        (if (Math-integerp part)
1729                            (setq pc (cdr pc))
1730                          (math-rwfail)))))
1731
1732                   ((eq op 'real)
1733                    (if (Math-realp (setq part (aref regs (nth 1 inst))))
1734                        (setq pc (cdr pc))
1735                      (if (Math-primp part)
1736                          (math-rwfail)
1737                        (setq part (math-rweval (math-simplify part)))
1738                        (if (Math-realp part)
1739                            (setq pc (cdr pc))
1740                          (math-rwfail)))))
1741
1742                   ((eq op 'constant)
1743                    (if (math-constp (setq part (aref regs (nth 1 inst))))
1744                        (setq pc (cdr pc))
1745                      (if (Math-primp part)
1746                          (math-rwfail)
1747                        (setq part (math-rweval (math-simplify part)))
1748                        (if (math-constp part)
1749                            (setq pc (cdr pc))
1750                          (math-rwfail)))))
1751
1752                   ((eq op 'negative)
1753                    (if (math-looks-negp (setq part (aref regs (nth 1 inst))))
1754                        (setq pc (cdr pc))
1755                      (if (Math-primp part)
1756                          (math-rwfail)
1757                        (setq part (math-rweval (math-simplify part)))
1758                        (if (math-looks-negp part)
1759                            (setq pc (cdr pc))
1760                          (math-rwfail)))))
1761
1762                   ((eq op 'rel)
1763                    (setq part (math-compare (aref regs (nth 1 inst))
1764                                             (aref regs (nth 3 inst)))
1765                          op (nth 2 inst))
1766                    (if (= part 2)
1767                        (setq part (math-rweval
1768                                    (math-simplify
1769                                     (calcFunc-sign
1770                                      (math-sub (aref regs (nth 1 inst))
1771                                                (aref regs (nth 3 inst))))))))
1772                    (if (cond ((eq op 'calcFunc-eq)
1773                               (eq part 0))
1774                              ((eq op 'calcFunc-neq)
1775                               (memq part '(-1 1)))
1776                              ((eq op 'calcFunc-lt)
1777                               (eq part -1))
1778                              ((eq op 'calcFunc-leq)
1779                               (memq part '(-1 0)))
1780                              ((eq op 'calcFunc-gt)
1781                               (eq part 1))
1782                              ((eq op 'calcFunc-geq)
1783                               (memq part '(0 1))))
1784                        (setq pc (cdr pc))
1785                      (math-rwfail)))
1786
1787                   ((eq op 'func-def)
1788                    (if (and (consp (setq part (aref regs (car (cdr inst)))))
1789                             (eq (car part)
1790                                 (car (setq inst (cdr (cdr inst))))))
1791                        (progn
1792                          (setq inst (cdr inst)
1793                                mark (car inst))
1794                          (while (and (setq inst (cdr inst)
1795                                            part (cdr part))
1796                                      inst)
1797                            (aset regs (car inst) (car part)))
1798                          (if (or inst part)
1799                              (setq pc (cdr pc))
1800                            (while (eq (car (car (setq pc (cdr pc))))
1801                                       'func-def))
1802                            (setq pc (cdr pc))   ; skip over "func"
1803                            (while mark
1804                              (aset regs (cdr (car mark)) (car (car mark)))
1805                              (setq mark (cdr mark)))))
1806                      (math-rwfail)))
1807
1808                   ((eq op 'func-opt)
1809                    (if (or (not (and (consp
1810                                       (setq part (aref regs (car (cdr inst)))))
1811                                      (eq (car part) (nth 2 inst))))
1812                            (and (= (length part) 2)
1813                                 (setq part (nth 1 part))))
1814                        (progn
1815                          (setq mark (nth 3 inst))
1816                          (aset regs (nth 4 inst) part)
1817                          (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
1818                          (setq pc (cdr pc))   ; skip over "func"
1819                          (while mark
1820                            (aset regs (cdr (car mark)) (car (car mark)))
1821                            (setq mark (cdr mark))))
1822                      (setq pc (cdr pc))))
1823
1824                   ((eq op 'mod)
1825                    (if (if (Math-zerop (setq part (aref regs (nth 1 inst))))
1826                            (Math-zerop (nth 3 inst))
1827                          (and (not (Math-zerop (nth 2 inst)))
1828                               (progn
1829                                 (setq part (math-mod part (nth 2 inst)))
1830                                 (or (Math-numberp part)
1831                                     (setq part (math-rweval
1832                                                 (math-simplify part))))
1833                                 (Math-equal part (nth 3 inst)))))
1834                        (setq pc (cdr pc))
1835                      (math-rwfail)))
1836
1837                   ((eq op 'apply)
1838                    (if (and (consp (setq part (aref regs (car (cdr inst)))))
1839                             (not (Math-objvecp part))
1840                             (not (eq (car part) 'var)))
1841                        (progn
1842                          (aset regs (nth 2 inst)
1843                                (math-calcFunc-to-var (car part)))
1844                          (aset regs (nth 3 inst)
1845                                (cons 'vec (cdr part)))
1846                          (setq pc (cdr pc)))
1847                      (math-rwfail)))
1848
1849                   ((eq op 'cons)
1850                    (if (and (consp (setq part (aref regs (car (cdr inst)))))
1851                             (eq (car part) 'vec)
1852                             (cdr part))
1853                        (progn
1854                          (aset regs (nth 2 inst) (nth 1 part))
1855                          (aset regs (nth 3 inst) (cons 'vec (cdr (cdr part))))
1856                          (setq pc (cdr pc)))
1857                      (math-rwfail)))
1858
1859                   ((eq op 'rcons)
1860                    (if (and (consp (setq part (aref regs (car (cdr inst)))))
1861                             (eq (car part) 'vec)
1862                             (cdr part))
1863                        (progn
1864                          (aset regs (nth 2 inst) (calcFunc-rhead part))
1865                          (aset regs (nth 3 inst) (calcFunc-rtail part))
1866                          (setq pc (cdr pc)))
1867                      (math-rwfail)))
1868
1869                   ((eq op 'cond)
1870                    (if (math-is-true
1871                         (math-rweval
1872                          (math-simplify
1873                           (math-rwapply-replace-regs (nth 1 inst)))))
1874                        (setq pc (cdr pc))
1875                      (math-rwfail)))
1876
1877                   ((eq op 'let)
1878                    (aset regs (nth 1 inst)
1879                          (math-rweval
1880                           (math-normalize
1881                            (math-rwapply-replace-regs (nth 2 inst)))))
1882                    (setq pc (cdr pc)))
1883
1884                   ((eq op 'copy)
1885                    (aset regs (nth 2 inst) (aref regs (nth 1 inst)))
1886                    (setq pc (cdr pc)))
1887
1888                   ((eq op 'copy-neg)
1889                    (aset regs (nth 2 inst)
1890                          (math-rwapply-neg (aref regs (nth 1 inst))))
1891                    (setq pc (cdr pc)))
1892
1893                   ((eq op 'alt)
1894                    (setq btrack (cons pc btrack)
1895                          pc (nth 1 inst)))
1896
1897                   ((eq op 'end-alt)
1898                    (while (and btrack (not (eq (car btrack) (nth 1 inst))))
1899                      (setq btrack (cdr btrack)))
1900                    (setq btrack (cdr btrack)
1901                          pc (cdr pc)))
1902
1903                   ((eq op 'done)
1904                    (setq result (math-rwapply-replace-regs (nth 1 inst)))
1905                    (if (or (and (eq (car-safe result) '+)
1906                                 (eq (nth 2 result) 0))
1907                            (and (eq (car-safe result) '*)
1908                                 (eq (nth 2 result) 1)))
1909                        (setq result (nth 1 result)))
1910                    (setq part (and (nth 2 inst)
1911                                    (math-is-true
1912                                     (math-rweval
1913                                      (math-simplify
1914                                       (math-rwapply-replace-regs
1915                                        (nth 2 inst)))))))
1916                    (if (or (equal result expr)
1917                            (equal (setq result (math-normalize result)) expr))
1918                        (setq result nil)
1919                      (if part (math-rwapply-remember expr result))
1920                      (setq rules nil))
1921                    (setq pc nil))
1922
1923                   (t (error "%s is not a valid rewrite opcode" op))))))
1924        (setq rules (cdr rules)))
1925      result))
1926 )
1927
1928 (defun math-rwapply-neg (expr)
1929   (if (and (consp expr)
1930            (memq (car expr) '(* /)))
1931       (if (Math-objectp (nth 2 expr))
1932           (list (car expr) (nth 1 expr) (math-neg (nth 2 expr)))
1933         (list (car expr)
1934               (if (Math-objectp (nth 1 expr))
1935                   (math-neg (nth 1 expr))
1936                 (list '* -1 (nth 1 expr)))
1937               (nth 2 expr)))
1938     (math-neg expr))
1939 )
1940
1941 (defun math-rwapply-inv (expr)
1942   (if (and (Math-integerp expr)
1943            calc-prefer-frac)
1944       (math-make-frac 1 expr)
1945     (list '/ 1 expr))
1946 )
1947
1948 (defun math-rwapply-replace-regs (expr)
1949   (cond ((Math-primp expr)
1950          expr)
1951         ((eq (car expr) 'calcFunc-register)
1952          (setq expr (aref regs (nth 1 expr)))
1953          (if (eq (car-safe expr) '*)
1954              (if (eq (nth 1 expr) -1)
1955                  (math-neg (nth 2 expr))
1956                (if (eq (nth 1 expr) 1)
1957                    (nth 2 expr)
1958                  expr))
1959            expr))
1960         ((and (eq (car expr) 'calcFunc-eval)
1961               (= (length expr) 2))
1962          (calc-with-default-simplification
1963           (math-normalize (math-rwapply-replace-regs (nth 1 expr)))))
1964         ((and (eq (car expr) 'calcFunc-evalsimp)
1965               (= (length expr) 2))
1966          (math-simplify (math-rwapply-replace-regs (nth 1 expr))))
1967         ((and (eq (car expr) 'calcFunc-evalextsimp)
1968               (= (length expr) 2))
1969          (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr))))
1970         ((and (eq (car expr) 'calcFunc-apply)
1971               (= (length expr) 3))
1972          (let ((func (math-rwapply-replace-regs (nth 1 expr)))
1973                (args (math-rwapply-replace-regs (nth 2 expr)))
1974                call)
1975            (if (and (math-vectorp args)
1976                     (not (eq (car-safe (setq call (math-build-call
1977                                                    (math-var-to-calcFunc func)
1978                                                    (cdr args))))
1979                              'calcFunc-call)))
1980                call
1981              (list 'calcFunc-apply func args))))
1982         ((and (eq (car expr) 'calcFunc-cons)
1983               (= (length expr) 3))
1984          (let ((head (math-rwapply-replace-regs (nth 1 expr)))
1985                (tail (math-rwapply-replace-regs (nth 2 expr))))
1986            (if (math-vectorp tail)
1987                (cons 'vec (cons head (cdr tail)))
1988              (list 'calcFunc-cons head tail))))
1989         ((and (eq (car expr) 'calcFunc-rcons)
1990               (= (length expr) 3))
1991          (let ((head (math-rwapply-replace-regs (nth 1 expr)))
1992                (tail (math-rwapply-replace-regs (nth 2 expr))))
1993            (if (math-vectorp head)
1994                (append head (list tail))
1995              (list 'calcFunc-rcons head tail))))
1996         ((and (eq (car expr) 'neg)
1997               (math-rwapply-reg-looks-negp (nth 1 expr)))
1998          (math-rwapply-reg-neg (nth 1 expr)))
1999         ((and (eq (car expr) 'neg)
2000               (eq (car-safe (nth 1 expr)) 'calcFunc-register)
2001               (math-scalarp (aref regs (nth 1 (nth 1 expr)))))
2002          (math-neg (math-rwapply-replace-regs (nth 1 expr))))
2003         ((and (eq (car expr) '+)
2004               (math-rwapply-reg-looks-negp (nth 1 expr)))
2005          (list '- (math-rwapply-replace-regs (nth 2 expr))
2006                (math-rwapply-reg-neg (nth 1 expr))))
2007         ((and (eq (car expr) '+)
2008               (math-rwapply-reg-looks-negp (nth 2 expr)))
2009          (list '- (math-rwapply-replace-regs (nth 1 expr))
2010                (math-rwapply-reg-neg (nth 2 expr))))
2011         ((and (eq (car expr) '-)
2012               (math-rwapply-reg-looks-negp (nth 2 expr)))
2013          (list '+ (math-rwapply-replace-regs (nth 1 expr))
2014                (math-rwapply-reg-neg (nth 2 expr))))
2015         ((eq (car expr) '*)
2016          (cond ((eq (nth 1 expr) -1)
2017                 (if (math-rwapply-reg-looks-negp (nth 2 expr))
2018                     (math-rwapply-reg-neg (nth 2 expr))
2019                   (math-neg (math-rwapply-replace-regs (nth 2 expr)))))
2020                ((eq (nth 1 expr) 1)
2021                 (math-rwapply-replace-regs (nth 2 expr)))
2022                ((eq (nth 2 expr) -1)
2023                 (if (math-rwapply-reg-looks-negp (nth 1 expr))
2024                     (math-rwapply-reg-neg (nth 1 expr))
2025                   (math-neg (math-rwapply-replace-regs (nth 1 expr)))))
2026                ((eq (nth 2 expr) 1)
2027                 (math-rwapply-replace-regs (nth 1 expr)))
2028                (t
2029                 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
2030                       (arg2 (math-rwapply-replace-regs (nth 2 expr))))
2031                   (cond ((and (eq (car-safe arg1) '/)
2032                               (eq (nth 1 arg1) 1))
2033                          (list '/ arg2 (nth 2 arg1)))
2034                         ((and (eq (car-safe arg2) '/)
2035                               (eq (nth 1 arg2) 1))
2036                          (list '/ arg1 (nth 2 arg2)))
2037                         (t (list '* arg1 arg2)))))))
2038         ((eq (car expr) '/)
2039          (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
2040                (arg2 (math-rwapply-replace-regs (nth 2 expr))))
2041            (if (eq (car-safe arg2) '/)
2042                (list '/ (list '* arg1 (nth 2 arg2)) (nth 1 arg2))
2043              (list '/ arg1 arg2))))
2044         ((and (eq (car expr) 'calcFunc-plain)
2045               (= (length expr) 2))
2046          (if (Math-primp (nth 1 expr))
2047              (nth 1 expr)
2048            (if (eq (car (nth 1 expr)) 'calcFunc-register)
2049                (aref regs (nth 1 (nth 1 expr)))
2050              (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
2051                                               (cdr (nth 1 expr)))))))
2052         (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr)))))
2053 )
2054
2055 (defun math-rwapply-reg-looks-negp (expr)
2056   (if (eq (car-safe expr) 'calcFunc-register)
2057       (math-looks-negp (aref regs (nth 1 expr)))
2058     (if (memq (car-safe expr) '(* /))
2059         (or (math-rwapply-reg-looks-negp (nth 1 expr))
2060             (math-rwapply-reg-looks-negp (nth 2 expr)))))
2061 )
2062
2063 (defun math-rwapply-reg-neg (expr)  ; expr must satisfy rwapply-reg-looks-negp
2064   (if (eq (car expr) 'calcFunc-register)
2065       (math-neg (math-rwapply-replace-regs expr))
2066     (if (math-rwapply-reg-looks-negp (nth 1 expr))
2067         (math-rwapply-replace-regs (list (car expr)
2068                                          (math-rwapply-reg-neg (nth 1 expr))
2069                                          (nth 2 expr)))
2070       (math-rwapply-replace-regs (list (car expr)
2071                                        (nth 1 expr)
2072                                        (math-rwapply-reg-neg (nth 2 expr))))))
2073 )
2074
2075 (defun math-rwapply-remember (old new)
2076   (let ((varval (symbol-value (nth 2 (car ruleset))))
2077         (rules (assq (car-safe old) ruleset)))
2078     (if (and (eq (car-safe varval) 'vec)
2079              (not (memq (car-safe old) '(nil schedule + -)))
2080              rules)
2081         (progn
2082           (setcdr varval (cons (list 'calcFunc-assign
2083                                      (if (math-rwcomp-no-vars old)
2084                                          old
2085                                        (list 'calcFunc-quote old))
2086                                      new)
2087                                (cdr varval)))
2088           (setcdr rules (cons (list (vector nil old)
2089                                     (list (list 'same 0 1)
2090                                           (list 'done new nil))
2091                                     nil nil)
2092                               (cdr rules))))))
2093 )
2094
2095
2096
2097