1 ;;; calc-rewr.el --- rewriting functions for Calc
3 ;; Copyright (C) 1990-1993, 2001-2015 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;; This file is autoloaded from calc-ext.el.
32 (defvar math-rewrite-default-iters 100)
34 ;; The variable calc-rewr-sel is local to calc-rewrite-selection and
35 ;; calc-rewrite, but is used by calc-locate-selection-marker.
36 (defvar calc-rewr-sel)
38 (defun calc-rewrite-selection (rules-str &optional many prefix)
39 (interactive "sRewrite rule(s): \np")
42 (let* ((num (max 1 (calc-locate-cursor-element (point))))
46 (entry (calc-top num 'entry))
48 (calc-rewr-sel (calc-auto-selection entry))
49 (math-rewrite-selections t)
50 (math-rewrite-default-iters 1))
51 (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
53 (error "Can't use same stack entry for formula and rules")
54 (setq rules (calc-top-n 1 t)
56 (setq rules (if (stringp rules-str)
57 (math-read-exprs rules-str) rules-str))
58 (if (eq (car-safe rules) 'error)
59 (error "Bad format in expression: %s" (nth 1 rules)))
60 (if (= (length rules) 1)
61 (setq rules (car rules))
62 (setq rules (cons 'vec rules)))
63 (or (memq (car-safe rules) '(vec var calcFunc-assign
65 (let ((rhs (math-read-expr
66 (read-string (concat "Rewrite from: " rules-str
68 (if (eq (car-safe rhs) 'error)
69 (error "Bad format in expression: %s" (nth 1 rhs)))
70 (setq rules (list 'calcFunc-assign rules rhs))))
71 (or (eq (car-safe rules) 'var)
72 (calc-record rules "rule")))
74 (setq many '(var inf var-inf))
75 (if many (setq many (prefix-numeric-value many))))
77 (setq expr (calc-replace-sub-formula (car entry)
79 (list 'calcFunc-select calc-rewr-sel)))
80 (setq expr (car entry)
82 math-rewrite-selections nil))
83 (setq expr (calc-encase-atoms
89 expr (calc-locate-select-marker expr))
90 (or (consp calc-rewr-sel) (setq calc-rewr-sel nil))
91 (if pop-rules (calc-pop-stack 1))
92 (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
93 (- num (if pop-rules 1 0))
94 (list (and reselect calc-rewr-sel))))
97 (defun calc-locate-select-marker (expr)
100 (if (and (eq (car expr) 'calcFunc-select)
103 (setq calc-rewr-sel (if calc-rewr-sel t (nth 1 expr)))
106 (mapcar 'calc-locate-select-marker (cdr expr))))))
110 (defun calc-rewrite (rules-str many)
111 (interactive "sRewrite rule(s): \nP")
114 (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
115 (setq expr (calc-top-n 2)
116 rules (calc-top-n 1 t)
118 (setq rules (if (stringp rules-str)
119 (math-read-exprs rules-str) rules-str))
120 (if (eq (car-safe rules) 'error)
121 (error "Bad format in expression: %s" (nth 1 rules)))
122 (if (= (length rules) 1)
123 (setq rules (car rules))
124 (setq rules (cons 'vec rules)))
125 (or (memq (car-safe rules) '(vec var calcFunc-assign
127 (let ((rhs (math-read-expr
128 (read-string (concat "Rewrite from: " rules-str
130 (if (eq (car-safe rhs) 'error)
131 (error "Bad format in expression: %s" (nth 1 rhs)))
132 (setq rules (list 'calcFunc-assign rules rhs))))
133 (or (eq (car-safe rules) 'var)
134 (calc-record rules "rule"))
135 (setq expr (calc-top-n 1)
138 (setq many '(var inf var-inf))
139 (if many (setq many (prefix-numeric-value many))))
140 (setq expr (calc-normalize (math-rewrite expr rules many)))
142 (setq expr (calc-locate-select-marker expr)))
143 (calc-pop-push-record-list n "rwrt" (list expr)))
146 (defun calc-match (pat &optional interactive)
147 (interactive "sPattern: \np")
150 (if (or (null pat) (equal pat "") (equal pat "$"))
151 (setq expr (calc-top-n 2)
154 (setq pat (if (stringp pat) (math-read-expr pat) pat))
155 (if (eq (car-safe pat) 'error)
156 (error "Bad format in expression: %s" (nth 1 pat)))
157 (if (not (eq (car-safe pat) 'var))
158 (calc-record pat "pat"))
159 (setq expr (calc-top-n 1)
161 (or (math-vectorp expr) (error "Argument must be a vector"))
162 (if (calc-is-inverse)
163 (calc-enter-result n "mtcn" (math-match-patterns pat expr t))
164 (calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))
167 (defvar math-mt-many)
169 ;; The variable math-rewrite-whole-expr is local to math-rewrite,
170 ;; but is used by math-rewrite-phase
171 (defvar math-rewrite-whole-expr)
173 (defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many)
174 (let* ((crules (math-compile-rewrites rules))
175 (heads (math-rewrite-heads math-rewrite-whole-expr))
176 (trace-buffer (get-buffer "*Trace*"))
177 (calc-display-just 'center)
178 (calc-display-origin 39)
179 (calc-line-breaking 78)
180 (calc-line-numbering nil)
181 (calc-show-selections t)
183 (math-mt-func (function
185 (let ((result (math-apply-rewrites x (cdr crules)
190 (let ((fmt (math-format-stack-value
191 (list result nil nil))))
192 (with-current-buffer trace-buffer
193 (insert "\nrewrite to\n" fmt "\n"))))
194 (setq heads (math-rewrite-heads result heads t))))
197 (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
198 (with-current-buffer trace-buffer
199 (setq truncate-lines t)
200 (goto-char (point-max))
201 (insert "\n\nBegin rewriting\n" fmt "\n"))))
202 (or math-mt-many (setq math-mt-many (or (nth 1 (car crules))
203 math-rewrite-default-iters)))
204 (if (equal math-mt-many '(var inf var-inf)) (setq math-mt-many 1000000))
205 (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000))
206 (math-rewrite-phase (nth 3 (car crules)))
208 (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
209 (with-current-buffer trace-buffer
210 (insert "\nDone rewriting"
211 (if (= math-mt-many 0) " (reached iteration limit)" "")
213 math-rewrite-whole-expr))
215 (defun math-rewrite-phase (sched)
216 (while (and sched (/= math-mt-many 0))
217 (if (listp (car sched))
218 (while (let ((save-expr math-rewrite-whole-expr))
219 (math-rewrite-phase (car sched))
220 (not (equal math-rewrite-whole-expr save-expr))))
221 (if (symbolp (car sched))
223 (setq math-rewrite-whole-expr
224 (math-normalize (list (car sched) math-rewrite-whole-expr)))
226 (let ((fmt (math-format-stack-value
227 (list math-rewrite-whole-expr nil nil))))
228 (with-current-buffer trace-buffer
230 (substring (symbol-name (car sched)) 9)
232 (let ((math-rewrite-phase (car sched)))
234 (with-current-buffer trace-buffer
235 (insert (format "\n(Phase %d)\n" math-rewrite-phase))))
236 (while (let ((save-expr math-rewrite-whole-expr))
237 (setq math-rewrite-whole-expr (math-normalize
238 (math-map-tree-rec math-rewrite-whole-expr)))
239 (not (equal math-rewrite-whole-expr save-expr)))))))
240 (setq sched (cdr sched))))
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))
247 (math-rewrite expr rules (or many 1))
248 (error (math-reject-arg rules (nth 1 err)))))
250 (defun calcFunc-match (pat vec)
251 (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
253 (math-match-patterns pat vec nil)
254 (error (math-reject-arg pat (nth 1 err)))))
256 (defun calcFunc-matchnot (pat vec)
257 (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
259 (math-match-patterns pat vec t)
260 (error (math-reject-arg pat (nth 1 err)))))
262 (defun math-match-patterns (pat vec &optional not-flag)
264 (crules (math-compile-patterns pat)))
265 (while (setq vec (cdr vec))
266 (if (eq (not (math-apply-rewrites (car vec) crules))
268 (setq newvec (cons (car vec) newvec))))
269 (cons 'vec (nreverse newvec))))
271 (defun calcFunc-matches (expr pat)
273 (if (math-apply-rewrites expr (math-compile-patterns pat))
276 (error (math-reject-arg pat (nth 1 err)))))
278 (defun calcFunc-vmatches (expr pat)
280 (or (math-apply-rewrites expr (math-compile-patterns pat))
282 (error (math-reject-arg pat (nth 1 err)))))
286 ;; A compiled rule set is an a-list of entries whose cars are functors,
287 ;; and whose cdrs are lists of rules. If there are rules with no
288 ;; well-defined head functor, they are included on all lists and also
289 ;; on an extra list whose car is nil.
291 ;; The first entry in the a-list is of the form (schedule A B C ...).
293 ;; Rule list entries take the form (regs prog head phases), where:
295 ;; regs is a vector of match registers.
297 ;; prog is a match program (see below).
299 ;; head is a rare function name appearing in the rule body (but not the
300 ;; head of the whole rule), or nil if none.
302 ;; phases is a list of phase numbers for which the rule is enabled.
304 ;; A match program is a list of match instructions.
306 ;; In the following, "part" is a register number that contains the
307 ;; subexpression to be operated on.
309 ;; Register 0 is the whole expression being matched. The others are
310 ;; meta-variables in the pattern, temporaries used for matching and
311 ;; backtracking, and constant expressions.
314 ;; The selected part must be math-equal to the contents of "reg".
316 ;; (same-neg part reg)
317 ;; The selected part must be math-equal to the negative of "reg".
320 ;; The selected part is copied into "reg". (Rarely used.)
322 ;; (copy-neg part reg)
323 ;; The negative of the selected part is copied into "reg".
326 ;; The selected part must be an integer.
329 ;; The selected part must be a real.
332 ;; The selected part must be a constant.
335 ;; The selected part must "look" negative.
338 ;; The selected part must satisfy "part op reg", where "op"
339 ;; is one of the 6 relational ops, and "reg" is a register.
341 ;; (mod part modulo value)
342 ;; The selected part must satisfy "part % modulo = value", where
343 ;; "modulo" and "value" are constants.
345 ;; (func part head reg1 reg2 ... regn)
346 ;; The selected part must be an n-ary call to function "head".
347 ;; The arguments are stored in "reg1" through "regn".
349 ;; (func-def part head defs reg1 reg2 ... regn)
350 ;; The selected part must be an n-ary call to function "head".
351 ;; "Defs" is a list of value/register number pairs for default args.
352 ;; If a match, assign default values to registers and then skip
353 ;; immediately over any following "func-def" instructions and
354 ;; the following "func" instruction. If wrong number of arguments,
355 ;; proceed to the following "func-def" or "func" instruction.
357 ;; (func-opt part head defs reg1)
358 ;; Like func-def with "n=1", except that if the selected part is
359 ;; not a call to "head", then the part itself successfully matches
360 ;; "reg1" (and the defaults are assigned).
362 ;; (try part heads mark reg1 [def])
363 ;; The selected part must be a function of the correct type which is
364 ;; associative and/or commutative. "Heads" is a list of acceptable
365 ;; types. An initial assignment of arguments to "reg1" is tried.
366 ;; If the program later fails, it backtracks to this instruction
367 ;; and tries other assignments of arguments to "reg1".
368 ;; If "def" exists and normal matching fails, backtrack and assign
369 ;; "part" to "reg1", and "def" to "reg2" in the following "try2".
370 ;; The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
371 ;; "mark[0]" points to the argument list; "mark[1]" points to the
372 ;; current argument; "mark[2]" is 0 if there are two arguments,
373 ;; 1 if reg1 is matching single arguments, 2 if reg2 is matching
374 ;; single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
375 ;; 3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
376 ;; have two arguments, 1 if phase-2 can be skipped, 2 if full
377 ;; backtracking is necessary; "mark[4]" is t if the arguments have
378 ;; been switched from the order given in the original pattern.
381 ;; Every "try" will be followed by a "try2" whose "try" field is
382 ;; a pointer to the corresponding "try". The arguments which were
383 ;; not stored in "reg1" by that "try" are now stored in "reg2".
385 ;; (alt instr nil mark)
386 ;; Basic backtracking. Execute the instruction sequence "instr".
387 ;; If this fails, back up and execute following the "alt" instruction.
388 ;; The "mark" must be the vector "[nil nil 4]". The "instr" sequence
389 ;; should execute "end-alt" at the end.
392 ;; Register success of the first alternative of a previous "alt".
393 ;; "Ptr" is a pointer to the next instruction following that "alt".
395 ;; (apply part reg1 reg2)
396 ;; The selected part must be a function call. The functor
397 ;; (as a variable name) is stored in "reg1"; the arguments
398 ;; (as a vector) are stored in "reg2".
400 ;; (cons part reg1 reg2)
401 ;; The selected part must be a nonempty vector. The first element
402 ;; of the vector is stored in "reg1"; the rest of the vector
403 ;; (as another vector) is stored in "reg2".
405 ;; (rcons part reg1 reg2)
406 ;; The selected part must be a nonempty vector. The last element
407 ;; of the vector is stored in "reg2"; the rest of the vector
408 ;; (as another vector) is stored in "reg1".
411 ;; If the selected part is a unary call to function "select", its
412 ;; argument is stored in "reg"; otherwise (provided this is an `a r'
413 ;; and not a `g r' command) the selected part is stored in "reg".
416 ;; The "expr", with registers substituted, must simplify to
420 ;; Evaluate "expr" and store the result in "reg". Always succeeds.
422 ;; (done rhs remember)
423 ;; Rewrite the expression to "rhs", with register substituted.
424 ;; Normalize; if the result is different from the original
425 ;; expression, the match has succeeded. This is the last
426 ;; instruction of every program. If "remember" is non-nil,
427 ;; record the result of the match as a new literal rule.
430 ;; Pseudo-functions related to rewrites:
432 ;; In patterns: quote, plain, condition, opt, apply, cons, select
434 ;; In righthand sides: quote, plain, eval, evalsimp, evalextsimp,
435 ;; apply, cons, select
437 ;; In conditions: let + same as for righthand sides
439 ;; Some optimizations that would be nice to have:
441 ;; * Merge registers with disjoint lifetimes.
442 ;; * Merge constant registers with equivalent values.
444 ;; * If an argument of a commutative op math-depends neither on the
445 ;; rest of the pattern nor on any of the conditions, then no backtracking
446 ;; should be done for that argument. (This won't apply to very many
449 ;; * If top functor is "select", and its argument is a unique function,
450 ;; add the rule to the lists for both "select" and that function.
451 ;; (Currently rules like this go on the "nil" list.)
452 ;; Same for "func-opt" functions. (Though not urgent for these.)
454 ;; * Shouldn't evaluate a "let" condition until the end, or until it
455 ;; would enable another condition to be evaluated.
458 ;; Some additional features to add / things to think about:
460 ;;; * Figure out what happens to "a +/- b" and "a +/- opt(b)".
462 ;;; * Same for interval forms.
464 ;;; * Have a name(v,pat) pattern which matches pat, and gives the
465 ;;; whole match the name v. Beware of circular structures!
468 (defun math-compile-patterns (pats)
469 (if (and (eq (car-safe pats) 'var)
470 (calc-var-value (nth 2 pats)))
471 (let ((prop (get (nth 2 pats) 'math-pattern-cache)))
473 (put (nth 2 pats) 'math-pattern-cache (setq prop (list nil))))
474 (or (eq (car prop) (symbol-value (nth 2 pats)))
476 (setcdr prop (math-compile-patterns
477 (symbol-value (nth 2 pats))))
478 (setcar prop (symbol-value (nth 2 pats)))))
480 (let ((math-rewrite-whole t))
481 (cdr (math-compile-rewrites (cons
483 (mapcar (function (lambda (x)
485 (if (eq (car-safe pats) 'vec)
489 (defvar math-rewrite-whole nil)
490 (defvar math-make-import-list nil)
492 ;; The variable math-import-list is local to part of math-compile-rewrites,
493 ;; but is also used in a different part, and so the local version could
494 ;; be affected by the non-local version when math-compile-rewrites calls itself.
495 (defvar math-import-list nil)
497 ;; The variables math-regs, math-num-regs, math-prog-last, math-bound-vars,
498 ;; math-conds, math-copy-neg, math-rhs, math-pattern, math-remembering and
499 ;; math-aliased-vars are local to math-compile-rewrites,
500 ;; but are used by many functions math-rwcomp-*, which are called by
501 ;; math-compile-rewrites.
503 (defvar math-num-regs)
504 (defvar math-prog-last)
505 (defvar math-bound-vars)
507 (defvar math-copy-neg)
509 (defvar math-pattern)
510 (defvar math-remembering)
511 (defvar math-aliased-vars)
513 (defun math-compile-rewrites (rules &optional name)
514 (if (eq (car-safe rules) 'var)
515 (let ((prop (get (nth 2 rules) 'math-rewrite-cache))
516 (math-import-list nil)
517 (math-make-import-list t)
519 (or (calc-var-value (nth 2 rules))
520 (error "Rules variable %s has no stored value" (nth 1 rules)))
522 (put (nth 2 rules) 'math-rewrite-cache
523 (setq prop (list (list (cons (nth 2 rules) nil))))))
525 (while (and p (eq (symbol-value (car (car p))) (cdr (car p))))
529 (message "Compiling rule set %s..." (nth 1 rules))
530 (setcdr prop (math-compile-rewrites
531 (symbol-value (nth 2 rules))
533 (message "Compiling rule set %s...done" (nth 1 rules))
534 (setcar prop (cons (cons (nth 2 rules)
535 (symbol-value (nth 2 rules)))
538 (if (or (not (eq (car-safe rules) 'vec))
539 (and (memq (length rules) '(3 4))
541 (while (and (setq p (cdr p))
542 (memq (car-safe (car p))
549 calcFunc-iterations))))
551 (setq rules (list rules))
552 (setq rules (cdr rules)))
553 (if (assq 'calcFunc-import rules)
554 (let ((pp (setq rules (copy-sequence rules)))
556 (while (setq p (car (cdr pp)))
557 (if (eq (car-safe p) 'calcFunc-import)
559 (setcdr pp (cdr (cdr pp)))
560 (or (and (eq (car-safe (nth 1 p)) 'var)
561 (setq part (calc-var-value (nth 2 (nth 1 p))))
562 (memq (car-safe part) '(vec
564 calcFunc-condition)))
565 (error "Argument of import() must be a rules variable"))
566 (if math-make-import-list
567 (setq math-import-list
568 (cons (cons (nth 2 (nth 1 p))
569 (symbol-value (nth 2 (nth 1 p))))
571 (while (setq p (cdr (cdr p)))
573 (error "import() must have odd number of arguments"))
574 (setq part (math-rwcomp-substitute part
576 (if (eq (car-safe part) 'vec)
577 (setq part (cdr part))
578 (setq part (list part)))
579 (setcdr pp (append part (cdr pp))))
580 (setq pp (cdr pp))))))
586 (math-iterations nil)
588 (math-all-phases nil)
589 (math-remembering nil)
590 math-pattern math-rhs math-conds)
593 ((and (eq (car-safe (car rules)) 'calcFunc-iterations)
594 (= (length (car rules)) 2))
595 (or (integerp (nth 1 (car rules)))
596 (equal (nth 1 (car rules)) '(var inf var-inf))
597 (equal (nth 1 (car rules)) '(neg (var inf var-inf)))
598 (error "Invalid argument for iterations(n)"))
600 (setq math-iterations (nth 1 (car rules)))))
601 ((eq (car-safe (car rules)) 'calcFunc-schedule)
603 (setq math-schedule (math-parse-schedule (cdr (car rules))))))
604 ((eq (car-safe (car rules)) 'calcFunc-phase)
605 (setq math-phases (cdr (car rules)))
606 (if (equal math-phases '((var all var-all)))
607 (setq math-phases nil))
608 (let ((p math-phases))
610 (or (integerp (car p))
611 (error "Phase numbers must be small integers"))
612 (or (memq (car p) math-all-phases)
613 (setq math-all-phases (cons (car p) math-all-phases)))
615 ((or (and (eq (car-safe (car rules)) 'vec)
616 (cdr (cdr (car rules)))
617 (not (nthcdr 4 (car rules)))
618 (setq math-conds (nth 3 (car rules))
619 math-rhs (nth 2 (car rules))
620 math-pattern (nth 1 (car rules))))
623 math-pattern (car rules))
624 (while (and (eq (car-safe math-pattern) 'calcFunc-condition)
625 (= (length math-pattern) 3))
626 (let ((cond (nth 2 math-pattern)))
627 (setq math-conds (if math-conds
628 (list 'calcFunc-land math-conds cond)
630 math-pattern (nth 1 math-pattern))))
631 (and (eq (car-safe math-pattern) 'calcFunc-assign)
632 (= (length math-pattern) 3)
633 (setq math-rhs (nth 2 math-pattern)
634 math-pattern (nth 1 math-pattern)))))
635 (let* ((math-prog (list nil))
636 (math-prog-last math-prog)
638 (math-regs (list (list nil 0 nil nil)))
639 (math-bound-vars nil)
640 (math-aliased-vars nil)
642 (setq math-conds (and math-conds (math-flatten-lands math-conds)))
643 (math-rwcomp-pattern math-pattern 0)
645 (let ((expr (car math-conds)))
646 (setq math-conds (cdr math-conds))
647 (math-rwcomp-cond-instr expr)))
648 (math-rwcomp-instr 'done
662 (math-rwcomp-register-expr
665 (math-rwcomp-match-vars math-rhs))
667 (setq math-prog (cdr math-prog))
668 (let* ((heads (math-rewrite-heads math-pattern))
671 (mapcar (function (lambda (x) (nth 3 x)))
676 (head (and (not (Math-primp math-pattern))
677 (not (and (eq (car (car math-prog)) 'try)
678 (nth 5 (car math-prog))))
679 (not (memq (car (car math-prog)) '(func-opt
683 (if (memq (car (car math-prog)) '(func
685 (nth 2 (car math-prog))
686 (if (eq (car math-pattern) 'calcFunc-quote)
687 (car-safe (nth 1 math-pattern))
688 (car math-pattern))))))
691 (if (setq found (assq (car heads) all-heads))
692 (setcdr found (1+ (cdr found)))
693 (setq all-heads (cons (cons (car heads) 1) all-heads)))
694 (setq heads (cdr heads))))
695 (if (eq head '-) (setq head '+))
696 (if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec))
699 (nconc (or (assq head rule-set)
700 (car (setq rule-set (cons (cons head
706 (nconc (or (assq '/ rule-set)
707 (car (setq rule-set (cons (cons
713 (setq nil-rules (nconc nil-rules (list rule)))
714 (let ((ptr rule-set))
716 (nconc (car ptr) (list rule))
717 (setq ptr (cdr ptr))))))))
719 (error "Rewrite rule set must be a vector of A := B rules")))
720 (setq rules (cdr rules)))
722 (setq rule-set (cons (cons nil nil-rules) rule-set)))
723 (setq all-heads (mapcar 'car
724 (sort all-heads (function
726 (< (cdr x) (cdr y)))))))
730 (setq rule (cdr (car set)))
732 (if (consp (setq heads (nth 2 (car rule))))
734 (setq heads (delq (car (car set)) heads)
736 (while (and ptr (not (memq (car ptr) heads)))
737 (setq ptr (cdr ptr)))
738 (setcar (nthcdr 2 (car rule)) (car ptr))))
739 (setq rule (cdr rule)))
740 (setq set (cdr set))))
741 (let ((plus (assq '+ rule-set)))
743 (setq rule-set (cons (cons '- (cdr plus)) rule-set))))
744 (cons (list 'schedule math-iterations name
746 (sort math-all-phases '<)
750 (defun math-flatten-lands (expr)
751 (if (eq (car-safe expr) 'calcFunc-land)
752 (append (math-flatten-lands (nth 1 expr))
753 (math-flatten-lands (nth 2 expr)))
756 ;; The variables math-rewrite-heads-heads (i.e.; heads for math-rewrite-heads)
757 ;; math-rewrite-heads-blanks and math-rewrite-heads-skips are local to
758 ;; math-rewrite-heads, but used by math-rewrite-heads-rec, which is called by
759 ;; math-rewrite-heads.
760 (defvar math-rewrite-heads-heads)
761 (defvar math-rewrite-heads-skips)
762 (defvar math-rewrite-heads-blanks)
764 (defun math-rewrite-heads (expr &optional more all)
765 (let ((math-rewrite-heads-heads more)
766 (math-rewrite-heads-skips (and (not all)
767 '(calcFunc-apply calcFunc-condition calcFunc-opt
768 calcFunc-por calcFunc-pnot)))
769 (math-rewrite-heads-blanks (and (not all)
770 '(calcFunc-quote calcFunc-plain calcFunc-select
771 calcFunc-cons calcFunc-rcons
773 (or (Math-primp expr)
774 (math-rewrite-heads-rec expr))
775 math-rewrite-heads-heads))
777 (defun math-rewrite-heads-rec (expr)
778 (or (memq (car expr) math-rewrite-heads-skips)
780 (or (memq (car expr) math-rewrite-heads-heads)
781 (memq (car expr) math-rewrite-heads-blanks)
782 (memq 'algebraic (get (car expr) 'math-rewrite-props))
783 (setq math-rewrite-heads-heads (cons (car expr) math-rewrite-heads-heads)))
784 (while (setq expr (cdr expr))
785 (or (Math-primp (car expr))
786 (math-rewrite-heads-rec (car expr)))))))
788 (defun math-parse-schedule (sched)
794 (math-parse-schedule (cdr s))
795 (if (eq (car-safe s) 'var)
796 (math-var-to-calcFunc s)
797 (error "Improper component in rewrite schedule"))))))
800 (defun math-rwcomp-match-vars (expr)
801 (if (Math-primp expr)
802 (if (eq (car-safe expr) 'var)
803 (let ((entry (assq (nth 2 expr) math-regs)))
805 (math-rwcomp-register-expr (nth 1 entry))
808 (if (and (eq (car expr) 'calcFunc-quote)
810 (math-rwcomp-match-vars (nth 1 expr))
811 (if (and (eq (car expr) 'calcFunc-plain)
813 (not (Math-primp (nth 1 expr))))
815 (cons (car (nth 1 expr))
816 (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
818 (mapcar 'math-rwcomp-match-vars (cdr expr)))))))
820 (defun math-rwcomp-register-expr (num)
821 (let ((entry (nth (1- (- math-num-regs num)) math-regs)))
823 (list 'neg (list 'calcFunc-register (nth 1 entry)))
824 (list 'calcFunc-register (nth 1 entry)))))
826 ;; The variables math-rwcomp-subst-old, math-rwcomp-subst-new,
827 ;; math-rwcomp-subst-old-func and math-rwcomp-subst-new-func
828 ;; are local to math-rwcomp-substitute, but are used by
829 ;; math-rwcomp-subst-rec, which is called by math-rwcomp-substitute.
830 (defvar math-rwcomp-subst-new)
831 (defvar math-rwcomp-subst-old)
832 (defvar math-rwcomp-subst-new-func)
833 (defvar math-rwcomp-subst-old-func)
835 (defun math-rwcomp-substitute (expr math-rwcomp-subst-old math-rwcomp-subst-new)
836 (if (and (eq (car-safe math-rwcomp-subst-old) 'var)
837 (memq (car-safe math-rwcomp-subst-new) '(var calcFunc-lambda)))
838 (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc math-rwcomp-subst-old))
839 (math-rwcomp-subst-new-func (math-var-to-calcFunc math-rwcomp-subst-new)))
840 (math-rwcomp-subst-rec expr))
841 (let ((math-rwcomp-subst-old-func nil))
842 (math-rwcomp-subst-rec expr))))
844 (defun math-rwcomp-subst-rec (expr)
845 (cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new)
846 ((Math-primp expr) expr)
847 (t (if (eq (car expr) math-rwcomp-subst-old-func)
848 (math-build-call math-rwcomp-subst-new-func
849 (mapcar 'math-rwcomp-subst-rec
852 (mapcar 'math-rwcomp-subst-rec (cdr expr)))))))
854 (defvar math-rwcomp-tracing nil)
856 (defun math-rwcomp-trace (instr)
857 (when math-rwcomp-tracing
858 (terpri) (princ instr))
861 (defun math-rwcomp-instr (&rest instr)
862 (setcdr math-prog-last
863 (setq math-prog-last (list (math-rwcomp-trace instr)))))
865 (defun math-rwcomp-multi-instr (tail &rest instr)
866 (setcdr math-prog-last
867 (setq math-prog-last (list (math-rwcomp-trace (append instr tail))))))
869 (defun math-rwcomp-bind-var (reg var)
870 (setcar (math-rwcomp-reg-entry reg) (nth 2 var))
871 (setq math-bound-vars (cons (nth 2 var) math-bound-vars))
872 (math-rwcomp-do-conditions))
874 (defun math-rwcomp-unbind-vars (mark)
875 (while (not (eq math-bound-vars mark))
876 (setcar (assq (car math-bound-vars) math-regs) nil)
877 (setq math-bound-vars (cdr math-bound-vars))))
879 (defun math-rwcomp-do-conditions ()
880 (let ((cond math-conds))
882 (if (math-rwcomp-all-regs-done (car cond))
883 (let ((expr (car cond)))
884 (setq math-conds (delq (car cond) math-conds))
886 (math-rwcomp-cond-instr expr)))
887 (setq cond (cdr cond)))))
889 (defun math-rwcomp-cond-instr (expr)
891 (cond ((and (eq (car-safe expr) 'calcFunc-matches)
893 (eq (car-safe (setq arg (math-rwcomp-match-vars (nth 1 expr))))
895 (math-rwcomp-pattern (nth 2 expr) (nth 1 arg)))
896 ((math-numberp (setq expr (math-rwcomp-match-vars expr)))
897 (if (Math-zerop expr)
898 (math-rwcomp-instr 'backtrack)))
899 ((and (eq (car expr) 'calcFunc-let)
901 (let ((reg (math-rwcomp-reg)))
902 (math-rwcomp-instr 'let reg (nth 2 expr))
903 (math-rwcomp-pattern (nth 1 expr) reg)))
904 ((and (eq (car expr) 'calcFunc-let)
906 (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
907 (= (length (nth 1 expr)) 3))
908 (let ((reg (math-rwcomp-reg)))
909 (math-rwcomp-instr 'let reg (nth 2 (nth 1 expr)))
910 (math-rwcomp-pattern (nth 1 (nth 1 expr)) reg)))
911 ((and (setq op (cdr (assq (car-safe expr)
912 '( (calcFunc-integer . integer)
913 (calcFunc-real . real)
914 (calcFunc-constant . constant)
915 (calcFunc-negative . negative) ))))
917 (or (and (eq (car-safe (nth 1 expr)) 'neg)
918 (memq op '(integer real constant))
919 (setq arg (nth 1 (nth 1 expr))))
920 (setq arg (nth 1 expr)))
921 (eq (car-safe (setq arg (nth 1 expr))) 'calcFunc-register))
922 (math-rwcomp-instr op (nth 1 arg)))
923 ((and (assq (car-safe expr) calc-tweak-eqn-table)
925 (eq (car-safe (nth 1 expr)) 'calcFunc-register))
926 (if (math-constp (nth 2 expr))
927 (let ((reg (math-rwcomp-reg)))
928 (setcar (nthcdr 3 (car math-regs)) (nth 2 expr))
929 (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
931 (if (eq (car (nth 2 expr)) 'calcFunc-register)
932 (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
933 (car expr) (nth 1 (nth 2 expr)))
934 (math-rwcomp-instr 'cond expr))))
935 ((and (eq (car-safe expr) 'calcFunc-eq)
937 (eq (car-safe (nth 1 expr)) '%)
938 (eq (car-safe (nth 1 (nth 1 expr))) 'calcFunc-register)
939 (math-constp (nth 2 (nth 1 expr)))
940 (math-constp (nth 2 expr)))
941 (math-rwcomp-instr 'mod (nth 1 (nth 1 (nth 1 expr)))
942 (nth 2 (nth 1 expr)) (nth 2 expr)))
943 ((equal expr '(var remember var-remember))
944 (setq math-remembering 1))
945 ((and (eq (car-safe expr) 'calcFunc-remember)
947 (setq math-remembering (if math-remembering
949 math-remembering (nth 1 expr))
951 (t (math-rwcomp-instr 'cond expr)))))
953 (defun math-rwcomp-same-instr (reg1 reg2 neg)
954 (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
955 (nth 2 (math-rwcomp-reg-entry reg2)))
961 (defun math-rwcomp-copy-instr (reg1 reg2 neg)
962 (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
963 (nth 2 (math-rwcomp-reg-entry reg2)))
965 (math-rwcomp-instr 'copy-neg reg1 reg2)
967 (math-rwcomp-instr 'copy reg1 reg2))))
969 (defun math-rwcomp-reg ()
972 (setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
973 math-num-regs (1+ math-num-regs))))
975 (defun math-rwcomp-reg-entry (num)
976 (nth (1- (- math-num-regs num)) math-regs))
979 (defun math-rwcomp-pattern (expr part &optional not-direct)
980 (cond ((or (math-rwcomp-no-vars expr)
981 (and (eq (car expr) 'calcFunc-quote)
983 (setq expr (nth 1 expr))))
984 (if (eq (car-safe expr) 'calcFunc-register)
985 (math-rwcomp-same-instr part (nth 1 expr) nil)
986 (let ((reg (math-rwcomp-reg)))
987 (setcar (nthcdr 3 (car math-regs)) expr)
988 (math-rwcomp-same-instr part reg nil))))
989 ((eq (car expr) 'var)
990 (let ((entry (assq (nth 2 expr) math-regs)))
992 (math-rwcomp-same-instr part (nth 1 entry) nil)
994 (let ((reg (math-rwcomp-reg)))
995 (math-rwcomp-pattern expr reg)
996 (math-rwcomp-copy-instr part reg nil))
997 (if (setq entry (assq (nth 2 expr) math-aliased-vars))
999 (setcar (math-rwcomp-reg-entry (nth 1 entry))
1002 (math-rwcomp-copy-instr part (nth 1 entry) nil))
1003 (math-rwcomp-bind-var part expr))))))
1004 ((and (eq (car expr) 'calcFunc-select)
1005 (= (length expr) 2))
1006 (let ((reg (math-rwcomp-reg)))
1007 (math-rwcomp-instr 'select part reg)
1008 (math-rwcomp-pattern (nth 1 expr) reg)))
1009 ((and (eq (car expr) 'calcFunc-opt)
1010 (memq (length expr) '(2 3)))
1011 (error "opt( ) occurs in context where it is not allowed"))
1012 ((eq (car expr) 'neg)
1013 (if (eq (car (nth 1 expr)) 'var)
1014 (let ((entry (assq (nth 2 (nth 1 expr)) math-regs)))
1016 (math-rwcomp-same-instr part (nth 1 entry) t)
1018 (let ((reg (math-rwcomp-best-reg (nth 1 expr))))
1019 (math-rwcomp-copy-instr part reg t)
1020 (math-rwcomp-pattern (nth 1 expr) reg))
1021 (setcar (cdr (cdr (math-rwcomp-reg-entry part))) t)
1022 (math-rwcomp-pattern (nth 1 expr) part))))
1023 (if (math-rwcomp-is-algebraic (nth 1 expr))
1024 (math-rwcomp-cond-instr (list 'calcFunc-eq
1025 (math-rwcomp-register-expr part)
1027 (let ((reg (math-rwcomp-reg)))
1028 (math-rwcomp-instr 'func part 'neg reg)
1029 (math-rwcomp-pattern (nth 1 expr) reg)))))
1030 ((and (eq (car expr) 'calcFunc-apply)
1031 (= (length expr) 3))
1032 (let ((reg1 (math-rwcomp-reg))
1033 (reg2 (math-rwcomp-reg)))
1034 (math-rwcomp-instr 'apply 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-cons)
1038 (= (length expr) 3))
1039 (let ((reg1 (math-rwcomp-reg))
1040 (reg2 (math-rwcomp-reg)))
1041 (math-rwcomp-instr 'cons part reg1 reg2)
1042 (math-rwcomp-pattern (nth 1 expr) reg1)
1043 (math-rwcomp-pattern (nth 2 expr) reg2)))
1044 ((and (eq (car expr) 'calcFunc-rcons)
1045 (= (length expr) 3))
1046 (let ((reg1 (math-rwcomp-reg))
1047 (reg2 (math-rwcomp-reg)))
1048 (math-rwcomp-instr 'rcons part reg1 reg2)
1049 (math-rwcomp-pattern (nth 1 expr) reg1)
1050 (math-rwcomp-pattern (nth 2 expr) reg2)))
1051 ((and (eq (car expr) 'calcFunc-condition)
1052 (>= (length expr) 3))
1053 (math-rwcomp-pattern (nth 1 expr) part)
1054 (setq expr (cdr expr))
1055 (while (setq expr (cdr expr))
1056 (let ((cond (math-flatten-lands (car expr))))
1058 (if (math-rwcomp-all-regs-done (car cond))
1059 (math-rwcomp-cond-instr (car cond))
1060 (setq math-conds (cons (car cond) math-conds)))
1061 (setq cond (cdr cond))))))
1062 ((and (eq (car expr) 'calcFunc-pand)
1063 (= (length expr) 3))
1064 (math-rwcomp-pattern (nth 1 expr) part)
1065 (math-rwcomp-pattern (nth 2 expr) part))
1066 ((and (eq (car expr) 'calcFunc-por)
1067 (= (length expr) 3))
1068 (math-rwcomp-instr 'alt nil nil [nil nil 4])
1069 (let ((math-conds nil)
1070 (head math-prog-last)
1071 (mark math-bound-vars)
1073 (math-rwcomp-pattern (nth 1 expr) part t)
1074 (let ((amark math-aliased-vars)
1075 (math-aliased-vars math-aliased-vars)
1076 (tail math-prog-last)
1079 (while (not (eq p mark))
1080 (setq entry (assq (car p) math-regs)
1081 math-aliased-vars (cons (list (car p) (nth 1 entry) nil)
1084 (setcar (math-rwcomp-reg-entry (nth 1 entry)) nil))
1085 (setcar (cdr (car head)) (cdr head))
1087 (setq math-prog-last head)
1088 (math-rwcomp-pattern (nth 2 expr) part)
1089 (math-rwcomp-instr 'same 0 0)
1090 (setcdr tail math-prog-last)
1091 (setq p math-aliased-vars)
1092 (while (not (eq p amark))
1094 (setcar (math-rwcomp-reg-entry (nth 1 (car p)))
1097 (math-rwcomp-do-conditions))
1098 ((and (eq (car expr) 'calcFunc-pnot)
1099 (= (length expr) 2))
1100 (math-rwcomp-instr 'alt nil nil [nil nil 4])
1101 (let ((head math-prog-last)
1102 (mark math-bound-vars))
1103 (math-rwcomp-pattern (nth 1 expr) part)
1104 (math-rwcomp-unbind-vars mark)
1105 (math-rwcomp-instr 'end-alt head)
1106 (math-rwcomp-instr 'backtrack)
1107 (setcar (cdr (car head)) (cdr head))
1109 (setq math-prog-last head)))
1110 (t (let ((props (get (car expr) 'math-rewrite-props)))
1111 (if (and (eq (car expr) 'calcFunc-plain)
1113 (not (math-primp (nth 1 expr))))
1114 (setq expr (nth 1 expr))) ; but "props" is still nil
1115 (if (and (memq 'algebraic props)
1116 (math-rwcomp-is-algebraic expr))
1117 (math-rwcomp-cond-instr (list 'calcFunc-eq
1118 (math-rwcomp-register-expr part)
1120 (if (and (memq 'commut props)
1121 (= (length expr) 3))
1122 (let ((arg1 (nth 1 expr))
1124 try1 def code head (flip nil))
1125 (if (eq (car expr) '-)
1126 (setq arg2 (math-rwcomp-neg arg2)))
1127 (setq arg1 (cons arg1 (math-rwcomp-best-reg arg1))
1128 arg2 (cons arg2 (math-rwcomp-best-reg arg2)))
1129 (or (math-rwcomp-order arg1 arg2)
1130 (setq def arg1 arg1 arg2 arg2 def flip t))
1131 (if (math-rwcomp-optional-arg (car expr) arg1)
1132 (error "Too many opt( ) arguments in this context"))
1133 (setq def (math-rwcomp-optional-arg (car expr) arg2)
1134 head (if (memq (car expr) '(+ -))
1136 (if (eq (car expr) '*)
1139 code (if (math-rwcomp-is-constrained
1141 (if (math-rwcomp-is-constrained
1145 (math-rwcomp-multi-instr (and def (list def))
1147 (vector nil nil nil code flip)
1149 (setq try1 (car math-prog-last))
1150 (math-rwcomp-pattern (car arg1) (cdr arg1))
1151 (math-rwcomp-instr 'try2 try1 (cdr arg2))
1152 (if (and (= part 0) (not def) (not math-rewrite-whole)
1153 (not (eq math-rhs t))
1154 (setq def (get (car expr)
1155 'math-rewrite-default)))
1156 (let ((reg1 (math-rwcomp-reg))
1157 (reg2 (math-rwcomp-reg)))
1158 (if (= (aref (nth 3 try1) 3) 0)
1159 (aset (nth 3 try1) 3 1))
1160 (math-rwcomp-instr 'try (cdr arg2)
1161 (if (equal head '(* /))
1168 (setq try1 (car math-prog-last))
1169 (math-rwcomp-pattern (car arg2) reg1)
1170 (math-rwcomp-instr 'try2 try1 reg2)
1171 (setq math-rhs (list (if (eq (car expr) '-)
1174 (list 'calcFunc-register
1176 (math-rwcomp-pattern (car arg2) (cdr arg2))))
1177 (let* ((args (mapcar (function
1179 (cons x (math-rwcomp-best-reg x))))
1181 (args2 (copy-sequence args))
1182 (argp (reverse args2))
1186 (let ((def (math-rwcomp-optional-arg (car expr)
1190 (setq args2 (delq (car argp) args2)
1191 defs (cons (cons def (cdr (car argp)))
1193 (math-rwcomp-multi-instr
1195 (if (or (and (memq 'unary1 props)
1196 (= (length args2) 1)
1197 (eq (car args2) (car args)))
1198 (and (memq 'unary2 props)
1200 (eq (car args2) (nth 1 args))))
1205 (setq argp (cdr argp)))
1206 (math-rwcomp-multi-instr (mapcar 'cdr args)
1207 'func part (car expr))
1208 (setq args (sort args 'math-rwcomp-order))
1210 (math-rwcomp-pattern (car (car args)) (cdr (car args)))
1212 args (cdr args))))))))))
1214 (defun math-rwcomp-best-reg (x)
1215 (or (and (eq (car-safe x) 'var)
1216 (let ((entry (assq (nth 2 x) math-aliased-vars)))
1219 (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry))))
1221 (setcar (cdr (cdr entry)) t)
1225 (defun math-rwcomp-all-regs-done (expr)
1226 (if (Math-primp expr)
1227 (or (not (eq (car-safe expr) 'var))
1228 (assq (nth 2 expr) math-regs)
1229 (eq (nth 2 expr) 'var-remember)
1230 (math-const-var expr))
1231 (if (and (eq (car expr) 'calcFunc-let)
1232 (= (length expr) 3))
1233 (math-rwcomp-all-regs-done (nth 2 expr))
1234 (if (and (eq (car expr) 'calcFunc-let)
1236 (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
1237 (= (length (nth 1 expr)) 3))
1238 (math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
1239 (while (and (setq expr (cdr expr))
1240 (math-rwcomp-all-regs-done (car expr))))
1243 (defun math-rwcomp-no-vars (expr)
1244 (if (Math-primp expr)
1245 (or (not (eq (car-safe expr) 'var))
1246 (math-const-var expr))
1247 (and (not (memq (car expr) '(calcFunc-condition
1248 calcFunc-select calcFunc-quote
1249 calcFunc-plain calcFunc-opt
1250 calcFunc-por calcFunc-pand
1251 calcFunc-pnot calcFunc-apply
1252 calcFunc-cons calcFunc-rcons)))
1254 (while (and (setq expr (cdr expr))
1255 (math-rwcomp-no-vars (car expr))))
1258 (defun math-rwcomp-is-algebraic (expr)
1259 (if (Math-primp expr)
1260 (or (not (eq (car-safe expr) 'var))
1261 (math-const-var expr)
1262 (assq (nth 2 expr) math-regs))
1263 (and (memq 'algebraic (get (car expr) 'math-rewrite-props))
1265 (while (and (setq expr (cdr expr))
1266 (math-rwcomp-is-algebraic (car expr))))
1269 (defun math-rwcomp-is-constrained (expr not-these)
1270 (if (Math-primp expr)
1271 (not (eq (car-safe expr) 'var))
1272 (if (eq (car expr) 'calcFunc-plain)
1273 (math-rwcomp-is-constrained (nth 1 expr) not-these)
1274 (not (or (memq (car expr) '(neg calcFunc-select))
1275 (memq (car expr) not-these)
1276 (and (memq 'commut (get (car expr) 'math-rewrite-props))
1277 (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
1278 (eq (car-safe (nth 2 expr)) 'calcFunc-opt))))))))
1280 (defun math-rwcomp-optional-arg (head argp)
1281 (let ((arg (car argp)))
1282 (if (eq (car-safe arg) 'calcFunc-opt)
1283 (and (memq (length arg) '(2 3))
1285 (or (eq (car-safe (nth 1 arg)) 'var)
1286 (error "First argument of opt( ) must be a variable"))
1287 (setcar argp (nth 1 arg))
1288 (if (= (length arg) 2)
1289 (or (get head 'math-rewrite-default)
1290 (error "opt( ) must include a default in this context"))
1292 (and (eq (car-safe arg) 'neg)
1293 (let* ((part (list (nth 1 arg)))
1294 (partp (math-rwcomp-optional-arg head part)))
1296 (setcar argp (math-rwcomp-neg (car part)))
1297 (math-neg partp)))))))
1299 (defun math-rwcomp-neg (expr)
1300 (if (memq (car-safe expr) '(* /))
1301 (if (eq (car-safe (nth 1 expr)) 'var)
1302 (list (car expr) (list 'neg (nth 1 expr)) (nth 2 expr))
1303 (if (eq (car-safe (nth 2 expr)) 'var)
1304 (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
1308 (defun math-rwcomp-assoc-args (expr)
1309 (if (and (eq (car-safe (nth 1 expr)) (car expr))
1310 (= (length (nth 1 expr)) 3))
1311 (math-rwcomp-assoc-args (nth 1 expr)))
1312 (if (and (eq (car-safe (nth 2 expr)) (car expr))
1313 (= (length (nth 2 expr)) 3))
1314 (math-rwcomp-assoc-args (nth 2 expr))))
1316 (defun math-rwcomp-addsub-args (expr)
1317 (if (memq (car-safe (nth 1 expr)) '(+ -))
1318 (math-rwcomp-addsub-args (nth 1 expr)))
1319 (if (eq (car expr) '-)
1321 (if (eq (car-safe (nth 2 expr)) '+)
1322 (math-rwcomp-addsub-args (nth 2 expr)))))
1324 (defun math-rwcomp-order (a b)
1325 (< (math-rwcomp-priority (car a))
1326 (math-rwcomp-priority (car b))))
1328 ;; Order of priority: 0 Constants and other exact matches (first)
1329 ;; 10 Functions (except below)
1330 ;; 20 Meta-variables which occur more than once
1331 ;; 30 Algebraic functions
1332 ;; 40 Commutative/associative functions
1333 ;; 50 Meta-variables which occur only once
1334 ;; +100 for every "!!!" (pnot) in the pattern
1335 ;; 10000 Optional arguments (last)
1337 (defun math-rwcomp-priority (expr)
1338 (+ (math-rwcomp-count-pnots expr)
1339 (cond ((eq (car-safe expr) 'calcFunc-opt)
1341 ((math-rwcomp-no-vars expr)
1343 ((eq (car expr) 'calcFunc-quote)
1345 ((eq (car expr) 'var)
1346 (if (assq (nth 2 expr) math-regs)
1348 (if (= (math-rwcomp-count-refs expr) 1)
1351 (t (let ((props (get (car expr) 'math-rewrite-props)))
1352 (if (or (memq 'commut props)
1353 (memq 'assoc props))
1355 (if (memq 'algebraic props)
1359 (defun math-rwcomp-count-refs (var)
1360 (let ((count (or (math-expr-contains-count math-pattern var) 0))
1363 (if (eq (car-safe (car p)) 'calcFunc-let)
1364 (if (= (length (car p)) 3)
1365 (setq count (+ count
1366 (or (math-expr-contains-count (nth 2 (car p)) var)
1368 (if (and (= (length (car p)) 2)
1369 (eq (car-safe (nth 1 (car p))) 'calcFunc-assign)
1370 (= (length (nth 1 (car p))) 3))
1371 (setq count (+ count
1372 (or (math-expr-contains-count
1373 (nth 2 (nth 1 (car p))) var) 0))))))
1377 (defun math-rwcomp-count-pnots (expr)
1378 (if (Math-primp expr)
1380 (if (eq (car expr) 'calcFunc-pnot)
1383 (while (setq expr (cdr expr))
1384 (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
1387 ;; In the current implementation, all associative functions must
1388 ;; also be commutative.
1390 (put '+ 'math-rewrite-props '(algebraic assoc commut))
1391 (put '- 'math-rewrite-props '(algebraic assoc commut)) ; see below
1392 (put '* 'math-rewrite-props '(algebraic assoc commut)) ; see below
1393 (put '/ 'math-rewrite-props '(algebraic unary1))
1394 (put '^ 'math-rewrite-props '(algebraic unary1))
1395 (put '% 'math-rewrite-props '(algebraic))
1396 (put 'neg 'math-rewrite-props '(algebraic))
1397 (put 'calcFunc-idiv 'math-rewrite-props '(algebraic))
1398 (put 'calcFunc-abs 'math-rewrite-props '(algebraic))
1399 (put 'calcFunc-sign 'math-rewrite-props '(algebraic))
1400 (put 'calcFunc-round 'math-rewrite-props '(algebraic))
1401 (put 'calcFunc-rounde 'math-rewrite-props '(algebraic))
1402 (put 'calcFunc-roundu 'math-rewrite-props '(algebraic))
1403 (put 'calcFunc-trunc 'math-rewrite-props '(algebraic))
1404 (put 'calcFunc-floor 'math-rewrite-props '(algebraic))
1405 (put 'calcFunc-ceil 'math-rewrite-props '(algebraic))
1406 (put 'calcFunc-re 'math-rewrite-props '(algebraic))
1407 (put 'calcFunc-im 'math-rewrite-props '(algebraic))
1408 (put 'calcFunc-conj 'math-rewrite-props '(algebraic))
1409 (put 'calcFunc-arg 'math-rewrite-props '(algebraic))
1410 (put 'calcFunc-and 'math-rewrite-props '(assoc commut))
1411 (put 'calcFunc-or 'math-rewrite-props '(assoc commut))
1412 (put 'calcFunc-xor 'math-rewrite-props '(assoc commut))
1413 (put 'calcFunc-eq 'math-rewrite-props '(commut))
1414 (put 'calcFunc-neq 'math-rewrite-props '(commut))
1415 (put 'calcFunc-land 'math-rewrite-props '(assoc commut))
1416 (put 'calcFunc-lor 'math-rewrite-props '(assoc commut))
1417 (put 'calcFunc-beta 'math-rewrite-props '(commut))
1418 (put 'calcFunc-gcd 'math-rewrite-props '(assoc commut))
1419 (put 'calcFunc-lcm 'math-rewrite-props '(assoc commut))
1420 (put 'calcFunc-max 'math-rewrite-props '(algebraic assoc commut))
1421 (put 'calcFunc-min 'math-rewrite-props '(algebraic assoc commut))
1422 (put 'calcFunc-vunion 'math-rewrite-props '(assoc commut))
1423 (put 'calcFunc-vint 'math-rewrite-props '(assoc commut))
1424 (put 'calcFunc-vxor 'math-rewrite-props '(assoc commut))
1426 ;; Note: "*" is not commutative for matrix args, but we pretend it is.
1427 ;; Also, "-" is not commutative but the code tweaks things so that it is.
1429 (put '+ 'math-rewrite-default 0)
1430 (put '- 'math-rewrite-default 0)
1431 (put '* 'math-rewrite-default 1)
1432 (put '/ 'math-rewrite-default 1)
1433 (put '^ 'math-rewrite-default 1)
1434 (put 'calcFunc-land 'math-rewrite-default 1)
1435 (put 'calcFunc-lor 'math-rewrite-default 0)
1436 (put 'calcFunc-vunion 'math-rewrite-default '(vec))
1437 (put 'calcFunc-vint 'math-rewrite-default '(vec))
1438 (put 'calcFunc-vdiff 'math-rewrite-default '(vec))
1439 (put 'calcFunc-vxor 'math-rewrite-default '(vec))
1441 (defmacro math-rwfail (&optional back)
1442 `(setq pc (and ,(if back
1443 '(setq btrack (cdr btrack))
1447 ;; This monstrosity is necessary because the use of static vectors of
1448 ;; registers makes rewrite rules non-reentrant. Yucko!
1449 (defmacro math-rweval (form)
1450 `(let ((orig (car rules)))
1451 (setcar rules '(nil nil nil no-phase))
1454 (setcar rules orig))))
1456 (defvar math-rewrite-phase 1)
1458 ;; The variable math-apply-rw-regs is local to math-apply-rewrites,
1459 ;; but is used by math-rwapply-replace-regs and math-rwapply-reg-looks-negp
1460 ;; which are called by math-apply-rewrites.
1461 (defvar math-apply-rw-regs)
1463 ;; The variable math-apply-rw-ruleset is local to math-apply-rewrites,
1464 ;; but is used by math-rwapply-remember.
1465 (defvar math-apply-rw-ruleset)
1467 (defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset)
1469 (setq rules (cdr (or (assq (car-safe expr) rules)
1472 op math-apply-rw-regs inst part pc mark btrack
1473 (tracing math-rwcomp-tracing)
1474 (phase math-rewrite-phase))
1477 (and (setq part (nth 2 (car rules)))
1479 (not (memq part heads)))
1480 (and (setq part (nth 3 (car rules)))
1481 (not (memq phase part)))
1483 (setq math-apply-rw-regs (car (car rules))
1484 pc (nth 1 (car rules))
1486 (aset math-apply-rw-regs 0 expr)
1490 (progn (terpri) (princ (car pc))
1491 (if (and (natnump (nth 1 (car pc)))
1492 (< (nth 1 (car pc)) (length math-apply-rw-regs)))
1494 (format "\n part = %s"
1495 (aref math-apply-rw-regs (nth 1 (car pc))))))))
1497 (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
1499 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1501 (car (setq inst (cdr (cdr inst)))))
1503 (while (and (setq inst (cdr inst)
1506 (aset math-apply-rw-regs (car inst) (car part)))
1507 (not (or inst part))))
1512 (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1513 (setq mark (aref math-apply-rw-regs (nth 2 inst))))
1514 (Math-equal part mark))
1520 (not (eq calc-matrix-mode 'scalar))
1521 (eq (car (nth 2 inst)) '*)
1522 (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1524 (not (math-known-scalarp part)))
1525 (setq mark (nth 3 inst)
1529 (aset math-apply-rw-regs (nth 4 inst) (nth 2 part))
1530 (aset mark 1 (cdr (cdr part))))
1531 (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1532 (aset mark 1 (cdr part)))
1533 (aset mark 0 (cdr part))
1537 (if (and (consp (setq part
1538 (aref math-apply-rw-regs (car (cdr inst)))))
1539 (memq (car part) (nth 2 inst))
1541 (or (not (eq (car part) '/))
1542 (Math-objectp (nth 2 part))))
1545 mark (car (cdr (setq inst (cdr (cdr inst))))))
1547 (memq 'assoc (get (car part) 'math-rewrite-props))
1548 (not (= (aref mark 3) 0))
1549 (while (if (and (consp (nth 1 part))
1550 (memq (car (nth 1 part)) (car inst)))
1551 (setq op (cons (if (eq (car part) '-)
1557 (if (and (consp (nth 2 part))
1558 (memq (car (nth 2 part))
1560 (not (eq (car (nth 2 part)) '-)))
1561 (setq op (cons (nth 1 part) op)
1562 part (nth 2 part))))))
1563 (setq op (cons (nth 1 part)
1564 (cons (if (eq (car part) '-)
1567 (if (eq (car part) '/)
1572 btrack (cons pc btrack)
1574 (aset math-apply-rw-regs (nth 2 inst) (car op))
1577 (aset mark 2 (if (cdr (cdr op)) 1 0)))
1579 (if (and (consp part)
1580 (eq (car part) 'neg)
1581 (eq (car (nth 2 inst)) '*)
1582 (eq (nth 5 inst) 1))
1584 (setq mark (nth 3 inst)
1586 (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1589 (setq mark (nth 3 inst)
1591 (aset math-apply-rw-regs (nth 4 inst) part)
1596 (setq part (nth 1 inst) ; try instr
1600 (aset math-apply-rw-regs (nth 2 inst)
1603 (if (eq (aref mark 0) (aref mark 1))
1604 (nth 1 (aref mark 0))
1605 (car (aref mark 0))))
1607 (setq mark (delq (car (aref mark 1))
1608 (copy-sequence (aref mark 0)))
1609 op (car (nth 2 part)))
1612 (setq mark (nreverse mark)
1613 part (list '* (nth 1 mark) (car mark))
1615 (while (setq mark (cdr mark))
1616 (setq part (list '* (car mark) part))))
1617 (setq part (car mark)
1619 part (if (and (eq op '+)
1621 (eq (car (car mark)) 'neg))
1624 (list op part (car mark))))
1625 (while (setq mark (cdr mark))
1626 (setq part (if (and (eq op '+)
1628 (eq (car (car mark)) 'neg))
1631 (list op part (car mark))))))
1634 (car (aref mark 1)))
1635 ((eq op 3) (nth 5 part))
1636 (t (aref mark 1)))))
1640 (if (and (consp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1641 (eq (car part) 'calcFunc-select))
1642 (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1643 (if math-rewrite-selections
1645 (aset math-apply-rw-regs (nth 2 inst) part))))
1648 (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1649 (setq mark (math-neg
1650 (aref math-apply-rw-regs (nth 2 inst)))))
1651 (Math-equal part mark))
1656 (setq inst (car (car btrack)) ; "try" or "alt" instr
1657 pc (cdr (car btrack))
1658 mark (or (nth 3 inst) [nil nil 4])
1661 (if (setq op (cdr (aref mark 1)))
1662 (aset math-apply-rw-regs (nth 4 inst)
1663 (car (aset mark 1 op)))
1667 (aset math-apply-rw-regs (nth 4 inst)
1668 (aref math-apply-rw-regs (nth 1 inst))))
1671 (if (setq op (cdr (aref mark 1)))
1672 (aset math-apply-rw-regs (nth 4 inst)
1673 (car (aset mark 1 op)))
1674 (if (= (aref mark 3) 1)
1678 (aset math-apply-rw-regs (nth 4 inst)
1679 (aref math-apply-rw-regs (nth 1 inst))))
1682 (aset mark 1 (cons nil (aref mark 0)))
1685 (if (setq op (cdr (aref mark 1)))
1687 (setq mark (delq (car (aset mark 1 op))
1690 op (car (nth 2 inst)))
1693 (setq mark (nreverse mark)
1694 part (list '* (nth 1 mark)
1697 (while (setq mark (cdr mark))
1698 (setq part (list '* (car mark)
1700 (setq part (car mark)
1702 part (if (and (eq op '+)
1704 (eq (car (car mark))
1708 (list op part (car mark))))
1709 (while (setq mark (cdr mark))
1710 (setq part (if (and (eq op '+)
1712 (eq (car (car mark))
1716 (list op part (car mark))))))
1717 (aset math-apply-rw-regs (nth 4 inst) part))
1721 (aset math-apply-rw-regs (nth 4 inst)
1722 (aref math-apply-rw-regs (nth 1 inst))))
1725 (setq btrack (cdr btrack)))
1726 (t (math-rwfail t))))
1729 (if (Math-integerp (setq part
1730 (aref math-apply-rw-regs (nth 1 inst))))
1732 (if (Math-primp part)
1734 (setq part (math-rweval (math-simplify part)))
1735 (if (Math-integerp part)
1740 (if (Math-realp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1742 (if (Math-primp part)
1744 (setq part (math-rweval (math-simplify part)))
1745 (if (Math-realp part)
1750 (if (math-constp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1752 (if (Math-primp part)
1754 (setq part (math-rweval (math-simplify part)))
1755 (if (math-constp part)
1760 (if (math-looks-negp (setq part
1761 (aref math-apply-rw-regs (nth 1 inst))))
1763 (if (Math-primp part)
1765 (setq part (math-rweval (math-simplify part)))
1766 (if (math-looks-negp part)
1771 (setq part (math-compare (aref math-apply-rw-regs (nth 1 inst))
1772 (aref math-apply-rw-regs (nth 3 inst)))
1775 (setq part (math-rweval
1779 (aref math-apply-rw-regs (nth 1 inst))
1780 (aref math-apply-rw-regs (nth 3 inst))))))))
1781 (if (cond ((eq op 'calcFunc-eq)
1783 ((eq op 'calcFunc-neq)
1784 (memq part '(-1 1)))
1785 ((eq op 'calcFunc-lt)
1787 ((eq op 'calcFunc-leq)
1788 (memq part '(-1 0)))
1789 ((eq op 'calcFunc-gt)
1791 ((eq op 'calcFunc-geq)
1792 (memq part '(0 1))))
1798 (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1800 (car (setq inst (cdr (cdr inst))))))
1802 (setq inst (cdr inst)
1804 (while (and (setq inst (cdr inst)
1807 (aset math-apply-rw-regs (car inst) (car part)))
1810 (while (eq (car (car (setq pc (cdr pc))))
1812 (setq pc (cdr pc)) ; skip over "func"
1814 (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1815 (setq mark (cdr mark)))))
1822 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1823 (eq (car part) (nth 2 inst))))
1824 (and (= (length part) 2)
1825 (setq part (nth 1 part))))
1827 (setq mark (nth 3 inst))
1828 (aset math-apply-rw-regs (nth 4 inst) part)
1829 (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
1830 (setq pc (cdr pc)) ; skip over "func"
1832 (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1833 (setq mark (cdr mark))))
1834 (setq pc (cdr pc))))
1838 (setq part (aref math-apply-rw-regs (nth 1 inst))))
1839 (Math-zerop (nth 3 inst))
1840 (and (not (Math-zerop (nth 2 inst)))
1842 (setq part (math-mod part (nth 2 inst)))
1843 (or (Math-numberp part)
1844 (setq part (math-rweval
1845 (math-simplify part))))
1846 (Math-equal part (nth 3 inst)))))
1852 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1853 (not (Math-objvecp part))
1854 (not (eq (car part) 'var)))
1856 (aset math-apply-rw-regs (nth 2 inst)
1857 (math-calcFunc-to-var (car part)))
1858 (aset math-apply-rw-regs (nth 3 inst)
1859 (cons 'vec (cdr part)))
1865 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1866 (eq (car part) 'vec)
1869 (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1870 (aset math-apply-rw-regs (nth 3 inst)
1871 (cons 'vec (cdr (cdr part))))
1877 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1878 (eq (car part) 'vec)
1881 (aset math-apply-rw-regs (nth 2 inst) (calcFunc-rhead part))
1882 (aset math-apply-rw-regs (nth 3 inst) (calcFunc-rtail part))
1890 (math-rwapply-replace-regs (nth 1 inst)))))
1895 (aset math-apply-rw-regs (nth 1 inst)
1898 (math-rwapply-replace-regs (nth 2 inst)))))
1902 (aset math-apply-rw-regs (nth 2 inst)
1903 (aref math-apply-rw-regs (nth 1 inst)))
1907 (aset math-apply-rw-regs (nth 2 inst)
1908 (math-rwapply-neg (aref math-apply-rw-regs (nth 1 inst))))
1912 (setq btrack (cons pc btrack)
1916 (while (and btrack (not (eq (car btrack) (nth 1 inst))))
1917 (setq btrack (cdr btrack)))
1918 (setq btrack (cdr btrack)
1922 (setq result (math-rwapply-replace-regs (nth 1 inst)))
1923 (if (or (and (eq (car-safe result) '+)
1924 (eq (nth 2 result) 0))
1925 (and (eq (car-safe result) '*)
1926 (eq (nth 2 result) 1)))
1927 (setq result (nth 1 result)))
1928 (setq part (and (nth 2 inst)
1932 (math-rwapply-replace-regs
1934 (if (or (equal result expr)
1935 (equal (setq result (math-normalize result)) expr))
1937 (if part (math-rwapply-remember expr result))
1941 (t (error "%s is not a valid rewrite opcode" op))))))
1942 (setq rules (cdr rules)))
1945 (defun math-rwapply-neg (expr)
1946 (if (and (consp expr)
1947 (memq (car expr) '(* /)))
1948 (if (Math-objectp (nth 2 expr))
1949 (list (car expr) (nth 1 expr) (math-neg (nth 2 expr)))
1951 (if (Math-objectp (nth 1 expr))
1952 (math-neg (nth 1 expr))
1953 (list '* -1 (nth 1 expr)))
1957 (defun math-rwapply-inv (expr)
1958 (if (and (Math-integerp expr)
1960 (math-make-frac 1 expr)
1963 (defun math-rwapply-replace-regs (expr)
1964 (cond ((Math-primp expr)
1966 ((eq (car expr) 'calcFunc-register)
1967 (setq expr (aref math-apply-rw-regs (nth 1 expr)))
1968 (if (eq (car-safe expr) '*)
1969 (if (eq (nth 1 expr) -1)
1970 (math-neg (nth 2 expr))
1971 (if (eq (nth 1 expr) 1)
1975 ((and (eq (car expr) 'calcFunc-eval)
1976 (= (length expr) 2))
1977 (calc-with-default-simplification
1978 (math-normalize (math-rwapply-replace-regs (nth 1 expr)))))
1979 ((and (eq (car expr) 'calcFunc-evalsimp)
1980 (= (length expr) 2))
1981 (math-simplify (math-rwapply-replace-regs (nth 1 expr))))
1982 ((and (eq (car expr) 'calcFunc-evalextsimp)
1983 (= (length expr) 2))
1984 (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr))))
1985 ((and (eq (car expr) 'calcFunc-apply)
1986 (= (length expr) 3))
1987 (let ((func (math-rwapply-replace-regs (nth 1 expr)))
1988 (args (math-rwapply-replace-regs (nth 2 expr)))
1990 (if (and (math-vectorp args)
1991 (not (eq (car-safe (setq call (math-build-call
1992 (math-var-to-calcFunc func)
1996 (list 'calcFunc-apply func args))))
1997 ((and (eq (car expr) 'calcFunc-cons)
1998 (= (length expr) 3))
1999 (let ((head (math-rwapply-replace-regs (nth 1 expr)))
2000 (tail (math-rwapply-replace-regs (nth 2 expr))))
2001 (if (math-vectorp tail)
2002 (cons 'vec (cons head (cdr tail)))
2003 (list 'calcFunc-cons head tail))))
2004 ((and (eq (car expr) 'calcFunc-rcons)
2005 (= (length expr) 3))
2006 (let ((head (math-rwapply-replace-regs (nth 1 expr)))
2007 (tail (math-rwapply-replace-regs (nth 2 expr))))
2008 (if (math-vectorp head)
2009 (append head (list tail))
2010 (list 'calcFunc-rcons head tail))))
2011 ((and (eq (car expr) 'neg)
2012 (math-rwapply-reg-looks-negp (nth 1 expr)))
2013 (math-rwapply-reg-neg (nth 1 expr)))
2014 ((and (eq (car expr) 'neg)
2015 (eq (car-safe (nth 1 expr)) 'calcFunc-register)
2016 (math-scalarp (aref math-apply-rw-regs (nth 1 (nth 1 expr)))))
2017 (math-neg (math-rwapply-replace-regs (nth 1 expr))))
2018 ((and (eq (car expr) '+)
2019 (math-rwapply-reg-looks-negp (nth 1 expr)))
2020 (list '- (math-rwapply-replace-regs (nth 2 expr))
2021 (math-rwapply-reg-neg (nth 1 expr))))
2022 ((and (eq (car expr) '+)
2023 (math-rwapply-reg-looks-negp (nth 2 expr)))
2024 (list '- (math-rwapply-replace-regs (nth 1 expr))
2025 (math-rwapply-reg-neg (nth 2 expr))))
2026 ((and (eq (car expr) '-)
2027 (math-rwapply-reg-looks-negp (nth 2 expr)))
2028 (list '+ (math-rwapply-replace-regs (nth 1 expr))
2029 (math-rwapply-reg-neg (nth 2 expr))))
2031 (cond ((eq (nth 1 expr) -1)
2032 (if (math-rwapply-reg-looks-negp (nth 2 expr))
2033 (math-rwapply-reg-neg (nth 2 expr))
2034 (math-neg (math-rwapply-replace-regs (nth 2 expr)))))
2035 ((eq (nth 1 expr) 1)
2036 (math-rwapply-replace-regs (nth 2 expr)))
2037 ((eq (nth 2 expr) -1)
2038 (if (math-rwapply-reg-looks-negp (nth 1 expr))
2039 (math-rwapply-reg-neg (nth 1 expr))
2040 (math-neg (math-rwapply-replace-regs (nth 1 expr)))))
2041 ((eq (nth 2 expr) 1)
2042 (math-rwapply-replace-regs (nth 1 expr)))
2044 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
2045 (arg2 (math-rwapply-replace-regs (nth 2 expr))))
2046 (cond ((and (eq (car-safe arg1) '/)
2047 (eq (nth 1 arg1) 1))
2048 (list '/ arg2 (nth 2 arg1)))
2049 ((and (eq (car-safe arg2) '/)
2050 (eq (nth 1 arg2) 1))
2051 (list '/ arg1 (nth 2 arg2)))
2052 (t (list '* arg1 arg2)))))))
2054 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
2055 (arg2 (math-rwapply-replace-regs (nth 2 expr))))
2056 (if (eq (car-safe arg2) '/)
2057 (list '/ (list '* arg1 (nth 2 arg2)) (nth 1 arg2))
2058 (list '/ arg1 arg2))))
2059 ((and (eq (car expr) 'calcFunc-plain)
2060 (= (length expr) 2))
2061 (if (Math-primp (nth 1 expr))
2063 (if (eq (car (nth 1 expr)) 'calcFunc-register)
2064 (aref math-apply-rw-regs (nth 1 (nth 1 expr)))
2065 (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
2066 (cdr (nth 1 expr)))))))
2067 (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))))
2069 (defun math-rwapply-reg-looks-negp (expr)
2070 (if (eq (car-safe expr) 'calcFunc-register)
2071 (math-looks-negp (aref math-apply-rw-regs (nth 1 expr)))
2072 (if (memq (car-safe expr) '(* /))
2073 (or (math-rwapply-reg-looks-negp (nth 1 expr))
2074 (math-rwapply-reg-looks-negp (nth 2 expr))))))
2076 (defun math-rwapply-reg-neg (expr) ; expr must satisfy rwapply-reg-looks-negp
2077 (if (eq (car expr) 'calcFunc-register)
2078 (math-neg (math-rwapply-replace-regs expr))
2079 (if (math-rwapply-reg-looks-negp (nth 1 expr))
2080 (math-rwapply-replace-regs (list (car expr)
2081 (math-rwapply-reg-neg (nth 1 expr))
2083 (math-rwapply-replace-regs (list (car expr)
2085 (math-rwapply-reg-neg (nth 2 expr)))))))
2087 (defun math-rwapply-remember (old new)
2088 (let ((varval (symbol-value (nth 2 (car math-apply-rw-ruleset))))
2089 (rules (assq (car-safe old) math-apply-rw-ruleset)))
2090 (if (and (eq (car-safe varval) 'vec)
2091 (not (memq (car-safe old) '(nil schedule + -)))
2094 (setcdr varval (cons (list 'calcFunc-assign
2095 (if (math-rwcomp-no-vars old)
2097 (list 'calcFunc-quote old))
2100 (setcdr rules (cons (list (vector nil old)
2101 (list (list 'same 0 1)
2102 (list 'done new nil))
2106 (provide 'calc-rewr)
2108 ;;; calc-rewr.el ends here