1 ;;; calc-rewr.el --- rewriting functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Jay Belanger <belanger@truman.edu>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY. No author or distributor
12 ;; accepts responsibility to anyone for the consequences of using it
13 ;; or for whether it serves any particular purpose or works at all,
14 ;; unless he says so in writing. Refer to the GNU Emacs General Public
15 ;; License for full details.
17 ;; Everyone is granted permission to copy, modify and redistribute
18 ;; GNU Emacs, but only under the conditions described in the
19 ;; GNU Emacs General Public License. A copy of this license is
20 ;; supposed to have been given to you along with GNU Emacs so you
21 ;; can know your rights and responsibilities. It should be in a
22 ;; file named COPYING. Among other things, the copyright notice
23 ;; and this notice must be preserved on all copies.
29 ;; This file is autoloaded from calc-ext.el.
34 (defvar math-rewrite-default-iters 100)
36 ;; The variable calc-rewr-sel is local to calc-rewrite-selection and
37 ;; calc-rewrite, but is used by calc-locate-selection-marker.
38 (defvar calc-rewr-sel)
40 (defun calc-rewrite-selection (rules-str &optional many prefix)
41 (interactive "sRewrite rule(s): \np")
44 (let* ((num (max 1 (calc-locate-cursor-element (point))))
48 (entry (calc-top num 'entry))
50 (calc-rewr-sel (calc-auto-selection entry))
51 (math-rewrite-selections t)
52 (math-rewrite-default-iters 1))
53 (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
55 (error "Can't use same stack entry for formula and rules")
56 (setq rules (calc-top-n 1 t)
58 (setq rules (if (stringp rules-str)
59 (math-read-exprs rules-str) rules-str))
60 (if (eq (car-safe rules) 'error)
61 (error "Bad format in expression: %s" (nth 1 rules)))
62 (if (= (length rules) 1)
63 (setq rules (car rules))
64 (setq rules (cons 'vec rules)))
65 (or (memq (car-safe rules) '(vec var calcFunc-assign
67 (let ((rhs (math-read-expr
68 (read-string (concat "Rewrite from: " rules-str
70 (if (eq (car-safe rhs) 'error)
71 (error "Bad format in expression: %s" (nth 1 rhs)))
72 (setq rules (list 'calcFunc-assign rules rhs))))
73 (or (eq (car-safe rules) 'var)
74 (calc-record rules "rule")))
76 (setq many '(var inf var-inf))
77 (if many (setq many (prefix-numeric-value many))))
79 (setq expr (calc-replace-sub-formula (car entry)
81 (list 'calcFunc-select calc-rewr-sel)))
82 (setq expr (car entry)
84 math-rewrite-selections nil))
85 (setq expr (calc-encase-atoms
91 expr (calc-locate-select-marker expr))
92 (or (consp calc-rewr-sel) (setq calc-rewr-sel nil))
93 (if pop-rules (calc-pop-stack 1))
94 (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
95 (- num (if pop-rules 1 0))
96 (list (and reselect calc-rewr-sel))))
99 (defun calc-locate-select-marker (expr)
100 (if (Math-primp expr)
102 (if (and (eq (car expr) 'calcFunc-select)
105 (setq calc-rewr-sel (if calc-rewr-sel t (nth 1 expr)))
108 (mapcar 'calc-locate-select-marker (cdr expr))))))
112 (defun calc-rewrite (rules-str many)
113 (interactive "sRewrite rule(s): \nP")
116 (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
117 (setq expr (calc-top-n 2)
118 rules (calc-top-n 1 t)
120 (setq rules (if (stringp rules-str)
121 (math-read-exprs rules-str) rules-str))
122 (if (eq (car-safe rules) 'error)
123 (error "Bad format in expression: %s" (nth 1 rules)))
124 (if (= (length rules) 1)
125 (setq rules (car rules))
126 (setq rules (cons 'vec rules)))
127 (or (memq (car-safe rules) '(vec var calcFunc-assign
129 (let ((rhs (math-read-expr
130 (read-string (concat "Rewrite from: " rules-str
132 (if (eq (car-safe rhs) 'error)
133 (error "Bad format in expression: %s" (nth 1 rhs)))
134 (setq rules (list 'calcFunc-assign rules rhs))))
135 (or (eq (car-safe rules) 'var)
136 (calc-record rules "rule"))
137 (setq expr (calc-top-n 1)
140 (setq many '(var inf var-inf))
141 (if many (setq many (prefix-numeric-value many))))
142 (setq expr (calc-normalize (math-rewrite expr rules many)))
144 (setq expr (calc-locate-select-marker expr)))
145 (calc-pop-push-record-list n "rwrt" (list expr)))
148 (defun calc-match (pat &optional interactive)
149 (interactive "sPattern: \np")
152 (if (or (null pat) (equal pat "") (equal pat "$"))
153 (setq expr (calc-top-n 2)
156 (if interactive (setq calc-previous-alg-entry pat))
157 (setq pat (if (stringp pat) (math-read-expr pat) pat))
158 (if (eq (car-safe pat) 'error)
159 (error "Bad format in expression: %s" (nth 1 pat)))
160 (if (not (eq (car-safe pat) 'var))
161 (calc-record pat "pat"))
162 (setq expr (calc-top-n 1)
164 (or (math-vectorp expr) (error "Argument must be a vector"))
165 (if (calc-is-inverse)
166 (calc-enter-result n "mtcn" (math-match-patterns pat expr t))
167 (calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))
170 (defvar math-mt-many)
172 ;; The variable math-rewrite-whole-expr is local to math-rewrite,
173 ;; but is used by math-rewrite-phase
174 (defvar math-rewrite-whole-expr)
176 (defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many)
177 (let* ((crules (math-compile-rewrites rules))
178 (heads (math-rewrite-heads math-rewrite-whole-expr))
179 (trace-buffer (get-buffer "*Trace*"))
180 (calc-display-just 'center)
181 (calc-display-origin 39)
182 (calc-line-breaking 78)
183 (calc-line-numbering nil)
184 (calc-show-selections t)
186 (math-mt-func (function
188 (let ((result (math-apply-rewrites x (cdr crules)
193 (let ((fmt (math-format-stack-value
194 (list result nil nil))))
196 (set-buffer trace-buffer)
197 (insert "\nrewrite to\n" fmt "\n"))))
198 (setq heads (math-rewrite-heads result heads t))))
201 (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
203 (set-buffer trace-buffer)
204 (setq truncate-lines t)
205 (goto-char (point-max))
206 (insert "\n\nBegin rewriting\n" fmt "\n"))))
207 (or math-mt-many (setq math-mt-many (or (nth 1 (car crules))
208 math-rewrite-default-iters)))
209 (if (equal math-mt-many '(var inf var-inf)) (setq math-mt-many 1000000))
210 (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000))
211 (math-rewrite-phase (nth 3 (car crules)))
213 (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
215 (set-buffer trace-buffer)
216 (insert "\nDone rewriting"
217 (if (= math-mt-many 0) " (reached iteration limit)" "")
219 math-rewrite-whole-expr))
221 (defun math-rewrite-phase (sched)
222 (while (and sched (/= math-mt-many 0))
223 (if (listp (car sched))
224 (while (let ((save-expr math-rewrite-whole-expr))
225 (math-rewrite-phase (car sched))
226 (not (equal math-rewrite-whole-expr save-expr))))
227 (if (symbolp (car sched))
229 (setq math-rewrite-whole-expr
230 (math-normalize (list (car sched) math-rewrite-whole-expr)))
232 (let ((fmt (math-format-stack-value
233 (list math-rewrite-whole-expr nil nil))))
235 (set-buffer trace-buffer)
237 (substring (symbol-name (car sched)) 9)
239 (let ((math-rewrite-phase (car sched)))
242 (set-buffer trace-buffer)
243 (insert (format "\n(Phase %d)\n" math-rewrite-phase))))
244 (while (let ((save-expr math-rewrite-whole-expr))
245 (setq math-rewrite-whole-expr (math-normalize
246 (math-map-tree-rec math-rewrite-whole-expr)))
247 (not (equal math-rewrite-whole-expr save-expr)))))))
248 (setq sched (cdr sched))))
250 (defun calcFunc-rewrite (expr rules &optional many)
251 (or (null many) (integerp many)
252 (equal many '(var inf var-inf)) (equal many '(neg (var inf var-inf)))
253 (math-reject-arg many 'fixnump))
255 (math-rewrite expr rules (or many 1))
256 (error (math-reject-arg rules (nth 1 err)))))
258 (defun calcFunc-match (pat vec)
259 (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
261 (math-match-patterns pat vec nil)
262 (error (math-reject-arg pat (nth 1 err)))))
264 (defun calcFunc-matchnot (pat vec)
265 (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
267 (math-match-patterns pat vec t)
268 (error (math-reject-arg pat (nth 1 err)))))
270 (defun math-match-patterns (pat vec &optional not-flag)
272 (crules (math-compile-patterns pat)))
273 (while (setq vec (cdr vec))
274 (if (eq (not (math-apply-rewrites (car vec) crules))
276 (setq newvec (cons (car vec) newvec))))
277 (cons 'vec (nreverse newvec))))
279 (defun calcFunc-matches (expr pat)
281 (if (math-apply-rewrites expr (math-compile-patterns pat))
284 (error (math-reject-arg pat (nth 1 err)))))
286 (defun calcFunc-vmatches (expr pat)
288 (or (math-apply-rewrites expr (math-compile-patterns pat))
290 (error (math-reject-arg pat (nth 1 err)))))
294 ;;; A compiled rule set is an a-list of entries whose cars are functors,
295 ;;; and whose cdrs are lists of rules. If there are rules with no
296 ;;; well-defined head functor, they are included on all lists and also
297 ;;; on an extra list whose car is nil.
299 ;;; The first entry in the a-list is of the form (schedule A B C ...).
301 ;;; Rule list entries take the form (regs prog head phases), where:
303 ;;; regs is a vector of match registers.
305 ;;; prog is a match program (see below).
307 ;;; head is a rare function name appearing in the rule body (but not the
308 ;;; head of the whole rule), or nil if none.
310 ;;; phases is a list of phase numbers for which the rule is enabled.
312 ;;; A match program is a list of match instructions.
314 ;;; In the following, "part" is a register number that contains the
315 ;;; subexpression to be operated on.
317 ;;; Register 0 is the whole expression being matched. The others are
318 ;;; meta-variables in the pattern, temporaries used for matching and
319 ;;; backtracking, and constant expressions.
322 ;;; The selected part must be math-equal to the contents of "reg".
324 ;;; (same-neg part reg)
325 ;;; The selected part must be math-equal to the negative of "reg".
328 ;;; The selected part is copied into "reg". (Rarely used.)
330 ;;; (copy-neg part reg)
331 ;;; The negative of the selected part is copied into "reg".
334 ;;; The selected part must be an integer.
337 ;;; The selected part must be a real.
340 ;;; The selected part must be a constant.
343 ;;; The selected part must "look" negative.
345 ;;; (rel part op reg)
346 ;;; The selected part must satisfy "part op reg", where "op"
347 ;;; is one of the 6 relational ops, and "reg" is a register.
349 ;;; (mod part modulo value)
350 ;;; The selected part must satisfy "part % modulo = value", where
351 ;;; "modulo" and "value" are constants.
353 ;;; (func part head reg1 reg2 ... regn)
354 ;;; The selected part must be an n-ary call to function "head".
355 ;;; The arguments are stored in "reg1" through "regn".
357 ;;; (func-def part head defs reg1 reg2 ... regn)
358 ;;; The selected part must be an n-ary call to function "head".
359 ;;; "Defs" is a list of value/register number pairs for default args.
360 ;;; If a match, assign default values to registers and then skip
361 ;;; immediately over any following "func-def" instructions and
362 ;;; the following "func" instruction. If wrong number of arguments,
363 ;;; proceed to the following "func-def" or "func" instruction.
365 ;;; (func-opt part head defs reg1)
366 ;;; Like func-def with "n=1", except that if the selected part is
367 ;;; not a call to "head", then the part itself successfully matches
368 ;;; "reg1" (and the defaults are assigned).
370 ;;; (try part heads mark reg1 [def])
371 ;;; The selected part must be a function of the correct type which is
372 ;;; associative and/or commutative. "Heads" is a list of acceptable
373 ;;; types. An initial assignment of arguments to "reg1" is tried.
374 ;;; If the program later fails, it backtracks to this instruction
375 ;;; and tries other assignments of arguments to "reg1".
376 ;;; If "def" exists and normal matching fails, backtrack and assign
377 ;;; "part" to "reg1", and "def" to "reg2" in the following "try2".
378 ;;; The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
379 ;;; "mark[0]" points to the argument list; "mark[1]" points to the
380 ;;; current argument; "mark[2]" is 0 if there are two arguments,
381 ;;; 1 if reg1 is matching single arguments, 2 if reg2 is matching
382 ;;; single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
383 ;;; 3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
384 ;;; have two arguments, 1 if phase-2 can be skipped, 2 if full
385 ;;; backtracking is necessary; "mark[4]" is t if the arguments have
386 ;;; been switched from the order given in the original pattern.
389 ;;; Every "try" will be followed by a "try2" whose "try" field is
390 ;;; a pointer to the corresponding "try". The arguments which were
391 ;;; not stored in "reg1" by that "try" are now stored in "reg2".
393 ;;; (alt instr nil mark)
394 ;;; Basic backtracking. Execute the instruction sequence "instr".
395 ;;; If this fails, back up and execute following the "alt" instruction.
396 ;;; The "mark" must be the vector "[nil nil 4]". The "instr" sequence
397 ;;; should execute "end-alt" at the end.
400 ;;; Register success of the first alternative of a previous "alt".
401 ;;; "Ptr" is a pointer to the next instruction following that "alt".
403 ;;; (apply part reg1 reg2)
404 ;;; The selected part must be a function call. The functor
405 ;;; (as a variable name) is stored in "reg1"; the arguments
406 ;;; (as a vector) are stored in "reg2".
408 ;;; (cons part reg1 reg2)
409 ;;; The selected part must be a nonempty vector. The first element
410 ;;; of the vector is stored in "reg1"; the rest of the vector
411 ;;; (as another vector) is stored in "reg2".
413 ;;; (rcons part reg1 reg2)
414 ;;; The selected part must be a nonempty vector. The last element
415 ;;; of the vector is stored in "reg2"; the rest of the vector
416 ;;; (as another vector) is stored in "reg1".
418 ;;; (select part reg)
419 ;;; If the selected part is a unary call to function "select", its
420 ;;; argument is stored in "reg"; otherwise (provided this is an `a r'
421 ;;; and not a `g r' command) the selected part is stored in "reg".
424 ;;; The "expr", with registers substituted, must simplify to
425 ;;; a non-zero value.
428 ;;; Evaluate "expr" and store the result in "reg". Always succeeds.
430 ;;; (done rhs remember)
431 ;;; Rewrite the expression to "rhs", with register substituted.
432 ;;; Normalize; if the result is different from the original
433 ;;; expression, the match has succeeded. This is the last
434 ;;; instruction of every program. If "remember" is non-nil,
435 ;;; record the result of the match as a new literal rule.
438 ;;; Pseudo-functions related to rewrites:
440 ;;; In patterns: quote, plain, condition, opt, apply, cons, select
442 ;;; In righthand sides: quote, plain, eval, evalsimp, evalextsimp,
443 ;;; apply, cons, select
445 ;;; In conditions: let + same as for righthand sides
447 ;;; Some optimizations that would be nice to have:
449 ;;; * Merge registers with disjoint lifetimes.
450 ;;; * Merge constant registers with equivalent values.
452 ;;; * If an argument of a commutative op math-depends neither on the
453 ;;; rest of the pattern nor on any of the conditions, then no backtracking
454 ;;; should be done for that argument. (This won't apply to very many
457 ;;; * If top functor is "select", and its argument is a unique function,
458 ;;; add the rule to the lists for both "select" and that function.
459 ;;; (Currently rules like this go on the "nil" list.)
460 ;;; Same for "func-opt" functions. (Though not urgent for these.)
462 ;;; * Shouldn't evaluate a "let" condition until the end, or until it
463 ;;; would enable another condition to be evaluated.
466 ;;; Some additional features to add / things to think about:
468 ;;; * Figure out what happens to "a +/- b" and "a +/- opt(b)".
470 ;;; * Same for interval forms.
472 ;;; * Have a name(v,pat) pattern which matches pat, and gives the
473 ;;; whole match the name v. Beware of circular structures!
476 (defun math-compile-patterns (pats)
477 (if (and (eq (car-safe pats) 'var)
478 (calc-var-value (nth 2 pats)))
479 (let ((prop (get (nth 2 pats) 'math-pattern-cache)))
481 (put (nth 2 pats) 'math-pattern-cache (setq prop (list nil))))
482 (or (eq (car prop) (symbol-value (nth 2 pats)))
484 (setcdr prop (math-compile-patterns
485 (symbol-value (nth 2 pats))))
486 (setcar prop (symbol-value (nth 2 pats)))))
488 (let ((math-rewrite-whole t))
489 (cdr (math-compile-rewrites (cons
491 (mapcar (function (lambda (x)
493 (if (eq (car-safe pats) 'vec)
497 (defvar math-rewrite-whole nil)
498 (defvar math-make-import-list nil)
500 ;; The variable math-import-list is local to part of math-compile-rewrites,
501 ;; but is also used in a different part, and so the local version could
502 ;; be affected by the non-local version when math-compile-rewrites calls itself.
503 (defvar math-import-list nil)
505 ;; The variables math-regs, math-num-regs, math-prog-last, math-bound-vars,
506 ;; math-conds, math-copy-neg, math-rhs, math-pattern, math-remembering and
507 ;; math-aliased-vars are local to math-compile-rewrites,
508 ;; but are used by many functions math-rwcomp-*, which are called by
509 ;; math-compile-rewrites.
511 (defvar math-num-regs)
512 (defvar math-prog-last)
513 (defvar math-bound-vars)
515 (defvar math-copy-neg)
517 (defvar math-pattern)
518 (defvar math-remembering)
519 (defvar math-aliased-vars)
521 (defun math-compile-rewrites (rules &optional name)
522 (if (eq (car-safe rules) 'var)
523 (let ((prop (get (nth 2 rules) 'math-rewrite-cache))
524 (math-import-list nil)
525 (math-make-import-list t)
527 (or (calc-var-value (nth 2 rules))
528 (error "Rules variable %s has no stored value" (nth 1 rules)))
530 (put (nth 2 rules) 'math-rewrite-cache
531 (setq prop (list (list (cons (nth 2 rules) nil))))))
533 (while (and p (eq (symbol-value (car (car p))) (cdr (car p))))
537 (message "Compiling rule set %s..." (nth 1 rules))
538 (setcdr prop (math-compile-rewrites
539 (symbol-value (nth 2 rules))
541 (message "Compiling rule set %s...done" (nth 1 rules))
542 (setcar prop (cons (cons (nth 2 rules)
543 (symbol-value (nth 2 rules)))
546 (if (or (not (eq (car-safe rules) 'vec))
547 (and (memq (length rules) '(3 4))
549 (while (and (setq p (cdr p))
550 (memq (car-safe (car p))
557 calcFunc-iterations))))
559 (setq rules (list rules))
560 (setq rules (cdr rules)))
561 (if (assq 'calcFunc-import rules)
562 (let ((pp (setq rules (copy-sequence rules)))
564 (while (setq p (car (cdr pp)))
565 (if (eq (car-safe p) 'calcFunc-import)
567 (setcdr pp (cdr (cdr pp)))
568 (or (and (eq (car-safe (nth 1 p)) 'var)
569 (setq part (calc-var-value (nth 2 (nth 1 p))))
570 (memq (car-safe part) '(vec
572 calcFunc-condition)))
573 (error "Argument of import() must be a rules variable"))
574 (if math-make-import-list
575 (setq math-import-list
576 (cons (cons (nth 2 (nth 1 p))
577 (symbol-value (nth 2 (nth 1 p))))
579 (while (setq p (cdr (cdr p)))
581 (error "import() must have odd number of arguments"))
582 (setq part (math-rwcomp-substitute part
584 (if (eq (car-safe part) 'vec)
585 (setq part (cdr part))
586 (setq part (list part)))
587 (setcdr pp (append part (cdr pp))))
588 (setq pp (cdr pp))))))
594 (math-iterations nil)
596 (math-all-phases nil)
597 (math-remembering nil)
598 math-pattern math-rhs math-conds)
601 ((and (eq (car-safe (car rules)) 'calcFunc-iterations)
602 (= (length (car rules)) 2))
603 (or (integerp (nth 1 (car rules)))
604 (equal (nth 1 (car rules)) '(var inf var-inf))
605 (equal (nth 1 (car rules)) '(neg (var inf var-inf)))
606 (error "Invalid argument for iterations(n)"))
608 (setq math-iterations (nth 1 (car rules)))))
609 ((eq (car-safe (car rules)) 'calcFunc-schedule)
611 (setq math-schedule (math-parse-schedule (cdr (car rules))))))
612 ((eq (car-safe (car rules)) 'calcFunc-phase)
613 (setq math-phases (cdr (car rules)))
614 (if (equal math-phases '((var all var-all)))
615 (setq math-phases nil))
616 (let ((p math-phases))
618 (or (integerp (car p))
619 (error "Phase numbers must be small integers"))
620 (or (memq (car p) math-all-phases)
621 (setq math-all-phases (cons (car p) math-all-phases)))
623 ((or (and (eq (car-safe (car rules)) 'vec)
624 (cdr (cdr (car rules)))
625 (not (nthcdr 4 (car rules)))
626 (setq math-conds (nth 3 (car rules))
627 math-rhs (nth 2 (car rules))
628 math-pattern (nth 1 (car rules))))
631 math-pattern (car rules))
632 (while (and (eq (car-safe math-pattern) 'calcFunc-condition)
633 (= (length math-pattern) 3))
634 (let ((cond (nth 2 math-pattern)))
635 (setq math-conds (if math-conds
636 (list 'calcFunc-land math-conds cond)
638 math-pattern (nth 1 math-pattern))))
639 (and (eq (car-safe math-pattern) 'calcFunc-assign)
640 (= (length math-pattern) 3)
641 (setq math-rhs (nth 2 math-pattern)
642 math-pattern (nth 1 math-pattern)))))
643 (let* ((math-prog (list nil))
644 (math-prog-last math-prog)
646 (math-regs (list (list nil 0 nil nil)))
647 (math-bound-vars nil)
648 (math-aliased-vars nil)
650 (setq math-conds (and math-conds (math-flatten-lands math-conds)))
651 (math-rwcomp-pattern math-pattern 0)
653 (let ((expr (car math-conds)))
654 (setq math-conds (cdr math-conds))
655 (math-rwcomp-cond-instr expr)))
656 (math-rwcomp-instr 'done
670 (math-rwcomp-register-expr
673 (math-rwcomp-match-vars math-rhs))
675 (setq math-prog (cdr math-prog))
676 (let* ((heads (math-rewrite-heads math-pattern))
679 (mapcar (function (lambda (x) (nth 3 x)))
684 (head (and (not (Math-primp math-pattern))
685 (not (and (eq (car (car math-prog)) 'try)
686 (nth 5 (car math-prog))))
687 (not (memq (car (car math-prog)) '(func-opt
691 (if (memq (car (car math-prog)) '(func
693 (nth 2 (car math-prog))
694 (if (eq (car math-pattern) 'calcFunc-quote)
695 (car-safe (nth 1 math-pattern))
696 (car math-pattern))))))
699 (if (setq found (assq (car heads) all-heads))
700 (setcdr found (1+ (cdr found)))
701 (setq all-heads (cons (cons (car heads) 1) all-heads)))
702 (setq heads (cdr heads))))
703 (if (eq head '-) (setq head '+))
704 (if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec))
707 (nconc (or (assq head rule-set)
708 (car (setq rule-set (cons (cons head
714 (nconc (or (assq '/ rule-set)
715 (car (setq rule-set (cons (cons
721 (setq nil-rules (nconc nil-rules (list rule)))
722 (let ((ptr rule-set))
724 (nconc (car ptr) (list rule))
725 (setq ptr (cdr ptr))))))))
727 (error "Rewrite rule set must be a vector of A := B rules")))
728 (setq rules (cdr rules)))
730 (setq rule-set (cons (cons nil nil-rules) rule-set)))
731 (setq all-heads (mapcar 'car
732 (sort all-heads (function
734 (< (cdr x) (cdr y)))))))
738 (setq rule (cdr (car set)))
740 (if (consp (setq heads (nth 2 (car rule))))
742 (setq heads (delq (car (car set)) heads)
744 (while (and ptr (not (memq (car ptr) heads)))
745 (setq ptr (cdr ptr)))
746 (setcar (nthcdr 2 (car rule)) (car ptr))))
747 (setq rule (cdr rule)))
748 (setq set (cdr set))))
749 (let ((plus (assq '+ rule-set)))
751 (setq rule-set (cons (cons '- (cdr plus)) rule-set))))
752 (cons (list 'schedule math-iterations name
754 (sort math-all-phases '<)
758 (defun math-flatten-lands (expr)
759 (if (eq (car-safe expr) 'calcFunc-land)
760 (append (math-flatten-lands (nth 1 expr))
761 (math-flatten-lands (nth 2 expr)))
764 ;; The variables math-rewrite-heads-heads (i.e.; heads for math-rewrite-heads)
765 ;; math-rewrite-heads-blanks and math-rewrite-heads-skips are local to
766 ;; math-rewrite-heads, but used by math-rewrite-heads-rec, which is called by
767 ;; math-rewrite-heads.
768 (defvar math-rewrite-heads-heads)
769 (defvar math-rewrite-heads-skips)
770 (defvar math-rewrite-heads-blanks)
772 (defun math-rewrite-heads (expr &optional more all)
773 (let ((math-rewrite-heads-heads more)
774 (math-rewrite-heads-skips (and (not all)
775 '(calcFunc-apply calcFunc-condition calcFunc-opt
776 calcFunc-por calcFunc-pnot)))
777 (math-rewrite-heads-blanks (and (not all)
778 '(calcFunc-quote calcFunc-plain calcFunc-select
779 calcFunc-cons calcFunc-rcons
781 (or (Math-primp expr)
782 (math-rewrite-heads-rec expr))
783 math-rewrite-heads-heads))
785 (defun math-rewrite-heads-rec (expr)
786 (or (memq (car expr) math-rewrite-heads-skips)
788 (or (memq (car expr) math-rewrite-heads-heads)
789 (memq (car expr) math-rewrite-heads-blanks)
790 (memq 'algebraic (get (car expr) 'math-rewrite-props))
791 (setq math-rewrite-heads-heads (cons (car expr) math-rewrite-heads-heads)))
792 (while (setq expr (cdr expr))
793 (or (Math-primp (car expr))
794 (math-rewrite-heads-rec (car expr)))))))
796 (defun math-parse-schedule (sched)
802 (math-parse-schedule (cdr s))
803 (if (eq (car-safe s) 'var)
804 (math-var-to-calcFunc s)
805 (error "Improper component in rewrite schedule"))))))
808 (defun math-rwcomp-match-vars (expr)
809 (if (Math-primp expr)
810 (if (eq (car-safe expr) 'var)
811 (let ((entry (assq (nth 2 expr) math-regs)))
813 (math-rwcomp-register-expr (nth 1 entry))
816 (if (and (eq (car expr) 'calcFunc-quote)
818 (math-rwcomp-match-vars (nth 1 expr))
819 (if (and (eq (car expr) 'calcFunc-plain)
821 (not (Math-primp (nth 1 expr))))
823 (cons (car (nth 1 expr))
824 (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
826 (mapcar 'math-rwcomp-match-vars (cdr expr)))))))
828 (defun math-rwcomp-register-expr (num)
829 (let ((entry (nth (1- (- math-num-regs num)) math-regs)))
831 (list 'neg (list 'calcFunc-register (nth 1 entry)))
832 (list 'calcFunc-register (nth 1 entry)))))
834 ;; The variables math-rwcomp-subst-old, math-rwcomp-subst-new,
835 ;; math-rwcomp-subst-old-func and math-rwcomp-subst-new-func
836 ;; are local to math-rwcomp-substitute, but are used by
837 ;; math-rwcomp-subst-rec, which is called by math-rwcomp-substitute.
838 (defvar math-rwcomp-subst-new)
839 (defvar math-rwcomp-subst-old)
840 (defvar math-rwcomp-subst-new-func)
841 (defvar math-rwcomp-subst-old-func)
843 (defun math-rwcomp-substitute (expr math-rwcomp-subst-old math-rwcomp-subst-new)
844 (if (and (eq (car-safe math-rwcomp-subst-old) 'var)
845 (memq (car-safe math-rwcomp-subst-new) '(var calcFunc-lambda)))
846 (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc math-rwcomp-subst-old))
847 (math-rwcomp-subst-new-func (math-var-to-calcFunc math-rwcomp-subst-new)))
848 (math-rwcomp-subst-rec expr))
849 (let ((math-rwcomp-subst-old-func nil))
850 (math-rwcomp-subst-rec expr))))
852 (defun math-rwcomp-subst-rec (expr)
853 (cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new)
854 ((Math-primp expr) expr)
855 (t (if (eq (car expr) math-rwcomp-subst-old-func)
856 (math-build-call math-rwcomp-subst-new-func
857 (mapcar 'math-rwcomp-subst-rec
860 (mapcar 'math-rwcomp-subst-rec (cdr expr)))))))
862 (defvar math-rwcomp-tracing nil)
864 (defun math-rwcomp-trace (instr)
865 (when math-rwcomp-tracing
866 (terpri) (princ instr))
869 (defun math-rwcomp-instr (&rest instr)
870 (setcdr math-prog-last
871 (setq math-prog-last (list (math-rwcomp-trace instr)))))
873 (defun math-rwcomp-multi-instr (tail &rest instr)
874 (setcdr math-prog-last
875 (setq math-prog-last (list (math-rwcomp-trace (append instr tail))))))
877 (defun math-rwcomp-bind-var (reg var)
878 (setcar (math-rwcomp-reg-entry reg) (nth 2 var))
879 (setq math-bound-vars (cons (nth 2 var) math-bound-vars))
880 (math-rwcomp-do-conditions))
882 (defun math-rwcomp-unbind-vars (mark)
883 (while (not (eq math-bound-vars mark))
884 (setcar (assq (car math-bound-vars) math-regs) nil)
885 (setq math-bound-vars (cdr math-bound-vars))))
887 (defun math-rwcomp-do-conditions ()
888 (let ((cond math-conds))
890 (if (math-rwcomp-all-regs-done (car cond))
891 (let ((expr (car cond)))
892 (setq math-conds (delq (car cond) math-conds))
894 (math-rwcomp-cond-instr expr)))
895 (setq cond (cdr cond)))))
897 (defun math-rwcomp-cond-instr (expr)
899 (cond ((and (eq (car-safe expr) 'calcFunc-matches)
901 (eq (car-safe (setq arg (math-rwcomp-match-vars (nth 1 expr))))
903 (math-rwcomp-pattern (nth 2 expr) (nth 1 arg)))
904 ((math-numberp (setq expr (math-rwcomp-match-vars expr)))
905 (if (Math-zerop expr)
906 (math-rwcomp-instr 'backtrack)))
907 ((and (eq (car expr) 'calcFunc-let)
909 (let ((reg (math-rwcomp-reg)))
910 (math-rwcomp-instr 'let reg (nth 2 expr))
911 (math-rwcomp-pattern (nth 1 expr) reg)))
912 ((and (eq (car expr) 'calcFunc-let)
914 (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
915 (= (length (nth 1 expr)) 3))
916 (let ((reg (math-rwcomp-reg)))
917 (math-rwcomp-instr 'let reg (nth 2 (nth 1 expr)))
918 (math-rwcomp-pattern (nth 1 (nth 1 expr)) reg)))
919 ((and (setq op (cdr (assq (car-safe expr)
920 '( (calcFunc-integer . integer)
921 (calcFunc-real . real)
922 (calcFunc-constant . constant)
923 (calcFunc-negative . negative) ))))
925 (or (and (eq (car-safe (nth 1 expr)) 'neg)
926 (memq op '(integer real constant))
927 (setq arg (nth 1 (nth 1 expr))))
928 (setq arg (nth 1 expr)))
929 (eq (car-safe (setq arg (nth 1 expr))) 'calcFunc-register))
930 (math-rwcomp-instr op (nth 1 arg)))
931 ((and (assq (car-safe expr) calc-tweak-eqn-table)
933 (eq (car-safe (nth 1 expr)) 'calcFunc-register))
934 (if (math-constp (nth 2 expr))
935 (let ((reg (math-rwcomp-reg)))
936 (setcar (nthcdr 3 (car math-regs)) (nth 2 expr))
937 (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
939 (if (eq (car (nth 2 expr)) 'calcFunc-register)
940 (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
941 (car expr) (nth 1 (nth 2 expr)))
942 (math-rwcomp-instr 'cond expr))))
943 ((and (eq (car-safe expr) 'calcFunc-eq)
945 (eq (car-safe (nth 1 expr)) '%)
946 (eq (car-safe (nth 1 (nth 1 expr))) 'calcFunc-register)
947 (math-constp (nth 2 (nth 1 expr)))
948 (math-constp (nth 2 expr)))
949 (math-rwcomp-instr 'mod (nth 1 (nth 1 (nth 1 expr)))
950 (nth 2 (nth 1 expr)) (nth 2 expr)))
951 ((equal expr '(var remember var-remember))
952 (setq math-remembering 1))
953 ((and (eq (car-safe expr) 'calcFunc-remember)
955 (setq math-remembering (if math-remembering
957 math-remembering (nth 1 expr))
959 (t (math-rwcomp-instr 'cond expr)))))
961 (defun math-rwcomp-same-instr (reg1 reg2 neg)
962 (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
963 (nth 2 (math-rwcomp-reg-entry reg2)))
969 (defun math-rwcomp-copy-instr (reg1 reg2 neg)
970 (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
971 (nth 2 (math-rwcomp-reg-entry reg2)))
973 (math-rwcomp-instr 'copy-neg reg1 reg2)
975 (math-rwcomp-instr 'copy reg1 reg2))))
977 (defun math-rwcomp-reg ()
980 (setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
981 math-num-regs (1+ math-num-regs))))
983 (defun math-rwcomp-reg-entry (num)
984 (nth (1- (- math-num-regs num)) math-regs))
987 (defun math-rwcomp-pattern (expr part &optional not-direct)
988 (cond ((or (math-rwcomp-no-vars expr)
989 (and (eq (car expr) 'calcFunc-quote)
991 (setq expr (nth 1 expr))))
992 (if (eq (car-safe expr) 'calcFunc-register)
993 (math-rwcomp-same-instr part (nth 1 expr) nil)
994 (let ((reg (math-rwcomp-reg)))
995 (setcar (nthcdr 3 (car math-regs)) expr)
996 (math-rwcomp-same-instr part reg nil))))
997 ((eq (car expr) 'var)
998 (let ((entry (assq (nth 2 expr) math-regs)))
1000 (math-rwcomp-same-instr part (nth 1 entry) nil)
1002 (let ((reg (math-rwcomp-reg)))
1003 (math-rwcomp-pattern expr reg)
1004 (math-rwcomp-copy-instr part reg nil))
1005 (if (setq entry (assq (nth 2 expr) math-aliased-vars))
1007 (setcar (math-rwcomp-reg-entry (nth 1 entry))
1010 (math-rwcomp-copy-instr part (nth 1 entry) nil))
1011 (math-rwcomp-bind-var part expr))))))
1012 ((and (eq (car expr) 'calcFunc-select)
1013 (= (length expr) 2))
1014 (let ((reg (math-rwcomp-reg)))
1015 (math-rwcomp-instr 'select part reg)
1016 (math-rwcomp-pattern (nth 1 expr) reg)))
1017 ((and (eq (car expr) 'calcFunc-opt)
1018 (memq (length expr) '(2 3)))
1019 (error "opt( ) occurs in context where it is not allowed"))
1020 ((eq (car expr) 'neg)
1021 (if (eq (car (nth 1 expr)) 'var)
1022 (let ((entry (assq (nth 2 (nth 1 expr)) math-regs)))
1024 (math-rwcomp-same-instr part (nth 1 entry) t)
1026 (let ((reg (math-rwcomp-best-reg (nth 1 expr))))
1027 (math-rwcomp-copy-instr part reg t)
1028 (math-rwcomp-pattern (nth 1 expr) reg))
1029 (setcar (cdr (cdr (math-rwcomp-reg-entry part))) t)
1030 (math-rwcomp-pattern (nth 1 expr) part))))
1031 (if (math-rwcomp-is-algebraic (nth 1 expr))
1032 (math-rwcomp-cond-instr (list 'calcFunc-eq
1033 (math-rwcomp-register-expr part)
1035 (let ((reg (math-rwcomp-reg)))
1036 (math-rwcomp-instr 'func part 'neg reg)
1037 (math-rwcomp-pattern (nth 1 expr) reg)))))
1038 ((and (eq (car expr) 'calcFunc-apply)
1039 (= (length expr) 3))
1040 (let ((reg1 (math-rwcomp-reg))
1041 (reg2 (math-rwcomp-reg)))
1042 (math-rwcomp-instr 'apply part reg1 reg2)
1043 (math-rwcomp-pattern (nth 1 expr) reg1)
1044 (math-rwcomp-pattern (nth 2 expr) reg2)))
1045 ((and (eq (car expr) 'calcFunc-cons)
1046 (= (length expr) 3))
1047 (let ((reg1 (math-rwcomp-reg))
1048 (reg2 (math-rwcomp-reg)))
1049 (math-rwcomp-instr 'cons part reg1 reg2)
1050 (math-rwcomp-pattern (nth 1 expr) reg1)
1051 (math-rwcomp-pattern (nth 2 expr) reg2)))
1052 ((and (eq (car expr) 'calcFunc-rcons)
1053 (= (length expr) 3))
1054 (let ((reg1 (math-rwcomp-reg))
1055 (reg2 (math-rwcomp-reg)))
1056 (math-rwcomp-instr 'rcons part reg1 reg2)
1057 (math-rwcomp-pattern (nth 1 expr) reg1)
1058 (math-rwcomp-pattern (nth 2 expr) reg2)))
1059 ((and (eq (car expr) 'calcFunc-condition)
1060 (>= (length expr) 3))
1061 (math-rwcomp-pattern (nth 1 expr) part)
1062 (setq expr (cdr expr))
1063 (while (setq expr (cdr expr))
1064 (let ((cond (math-flatten-lands (car expr))))
1066 (if (math-rwcomp-all-regs-done (car cond))
1067 (math-rwcomp-cond-instr (car cond))
1068 (setq math-conds (cons (car cond) math-conds)))
1069 (setq cond (cdr cond))))))
1070 ((and (eq (car expr) 'calcFunc-pand)
1071 (= (length expr) 3))
1072 (math-rwcomp-pattern (nth 1 expr) part)
1073 (math-rwcomp-pattern (nth 2 expr) part))
1074 ((and (eq (car expr) 'calcFunc-por)
1075 (= (length expr) 3))
1076 (math-rwcomp-instr 'alt nil nil [nil nil 4])
1077 (let ((math-conds nil)
1078 (head math-prog-last)
1079 (mark math-bound-vars)
1081 (math-rwcomp-pattern (nth 1 expr) part t)
1082 (let ((amark math-aliased-vars)
1083 (math-aliased-vars math-aliased-vars)
1084 (tail math-prog-last)
1087 (while (not (eq p mark))
1088 (setq entry (assq (car p) math-regs)
1089 math-aliased-vars (cons (list (car p) (nth 1 entry) nil)
1092 (setcar (math-rwcomp-reg-entry (nth 1 entry)) nil))
1093 (setcar (cdr (car head)) (cdr head))
1095 (setq math-prog-last head)
1096 (math-rwcomp-pattern (nth 2 expr) part)
1097 (math-rwcomp-instr 'same 0 0)
1098 (setcdr tail math-prog-last)
1099 (setq p math-aliased-vars)
1100 (while (not (eq p amark))
1102 (setcar (math-rwcomp-reg-entry (nth 1 (car p)))
1105 (math-rwcomp-do-conditions))
1106 ((and (eq (car expr) 'calcFunc-pnot)
1107 (= (length expr) 2))
1108 (math-rwcomp-instr 'alt nil nil [nil nil 4])
1109 (let ((head math-prog-last)
1110 (mark math-bound-vars))
1111 (math-rwcomp-pattern (nth 1 expr) part)
1112 (math-rwcomp-unbind-vars mark)
1113 (math-rwcomp-instr 'end-alt head)
1114 (math-rwcomp-instr 'backtrack)
1115 (setcar (cdr (car head)) (cdr head))
1117 (setq math-prog-last head)))
1118 (t (let ((props (get (car expr) 'math-rewrite-props)))
1119 (if (and (eq (car expr) 'calcFunc-plain)
1121 (not (math-primp (nth 1 expr))))
1122 (setq expr (nth 1 expr))) ; but "props" is still nil
1123 (if (and (memq 'algebraic props)
1124 (math-rwcomp-is-algebraic expr))
1125 (math-rwcomp-cond-instr (list 'calcFunc-eq
1126 (math-rwcomp-register-expr part)
1128 (if (and (memq 'commut props)
1129 (= (length expr) 3))
1130 (let ((arg1 (nth 1 expr))
1132 try1 def code head (flip nil))
1133 (if (eq (car expr) '-)
1134 (setq arg2 (math-rwcomp-neg arg2)))
1135 (setq arg1 (cons arg1 (math-rwcomp-best-reg arg1))
1136 arg2 (cons arg2 (math-rwcomp-best-reg arg2)))
1137 (or (math-rwcomp-order arg1 arg2)
1138 (setq def arg1 arg1 arg2 arg2 def flip t))
1139 (if (math-rwcomp-optional-arg (car expr) arg1)
1140 (error "Too many opt( ) arguments in this context"))
1141 (setq def (math-rwcomp-optional-arg (car expr) arg2)
1142 head (if (memq (car expr) '(+ -))
1144 (if (eq (car expr) '*)
1147 code (if (math-rwcomp-is-constrained
1149 (if (math-rwcomp-is-constrained
1153 (math-rwcomp-multi-instr (and def (list def))
1155 (vector nil nil nil code flip)
1157 (setq try1 (car math-prog-last))
1158 (math-rwcomp-pattern (car arg1) (cdr arg1))
1159 (math-rwcomp-instr 'try2 try1 (cdr arg2))
1160 (if (and (= part 0) (not def) (not math-rewrite-whole)
1161 (not (eq math-rhs t))
1162 (setq def (get (car expr)
1163 'math-rewrite-default)))
1164 (let ((reg1 (math-rwcomp-reg))
1165 (reg2 (math-rwcomp-reg)))
1166 (if (= (aref (nth 3 try1) 3) 0)
1167 (aset (nth 3 try1) 3 1))
1168 (math-rwcomp-instr 'try (cdr arg2)
1169 (if (equal head '(* /))
1176 (setq try1 (car math-prog-last))
1177 (math-rwcomp-pattern (car arg2) reg1)
1178 (math-rwcomp-instr 'try2 try1 reg2)
1179 (setq math-rhs (list (if (eq (car expr) '-)
1182 (list 'calcFunc-register
1184 (math-rwcomp-pattern (car arg2) (cdr arg2))))
1185 (let* ((args (mapcar (function
1187 (cons x (math-rwcomp-best-reg x))))
1189 (args2 (copy-sequence args))
1190 (argp (reverse args2))
1194 (let ((def (math-rwcomp-optional-arg (car expr)
1198 (setq args2 (delq (car argp) args2)
1199 defs (cons (cons def (cdr (car argp)))
1201 (math-rwcomp-multi-instr
1203 (if (or (and (memq 'unary1 props)
1204 (= (length args2) 1)
1205 (eq (car args2) (car args)))
1206 (and (memq 'unary2 props)
1208 (eq (car args2) (nth 1 args))))
1213 (setq argp (cdr argp)))
1214 (math-rwcomp-multi-instr (mapcar 'cdr args)
1215 'func part (car expr))
1216 (setq args (sort args 'math-rwcomp-order))
1218 (math-rwcomp-pattern (car (car args)) (cdr (car args)))
1220 args (cdr args))))))))))
1222 (defun math-rwcomp-best-reg (x)
1223 (or (and (eq (car-safe x) 'var)
1224 (let ((entry (assq (nth 2 x) math-aliased-vars)))
1227 (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry))))
1229 (setcar (cdr (cdr entry)) t)
1233 (defun math-rwcomp-all-regs-done (expr)
1234 (if (Math-primp expr)
1235 (or (not (eq (car-safe expr) 'var))
1236 (assq (nth 2 expr) math-regs)
1237 (eq (nth 2 expr) 'var-remember)
1238 (math-const-var expr))
1239 (if (and (eq (car expr) 'calcFunc-let)
1240 (= (length expr) 3))
1241 (math-rwcomp-all-regs-done (nth 2 expr))
1242 (if (and (eq (car expr) 'calcFunc-let)
1244 (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
1245 (= (length (nth 1 expr)) 3))
1246 (math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
1247 (while (and (setq expr (cdr expr))
1248 (math-rwcomp-all-regs-done (car expr))))
1251 (defun math-rwcomp-no-vars (expr)
1252 (if (Math-primp expr)
1253 (or (not (eq (car-safe expr) 'var))
1254 (math-const-var expr))
1255 (and (not (memq (car expr) '(calcFunc-condition
1256 calcFunc-select calcFunc-quote
1257 calcFunc-plain calcFunc-opt
1258 calcFunc-por calcFunc-pand
1259 calcFunc-pnot calcFunc-apply
1260 calcFunc-cons calcFunc-rcons)))
1262 (while (and (setq expr (cdr expr))
1263 (math-rwcomp-no-vars (car expr))))
1266 (defun math-rwcomp-is-algebraic (expr)
1267 (if (Math-primp expr)
1268 (or (not (eq (car-safe expr) 'var))
1269 (math-const-var expr)
1270 (assq (nth 2 expr) math-regs))
1271 (and (memq 'algebraic (get (car expr) 'math-rewrite-props))
1273 (while (and (setq expr (cdr expr))
1274 (math-rwcomp-is-algebraic (car expr))))
1277 (defun math-rwcomp-is-constrained (expr not-these)
1278 (if (Math-primp expr)
1279 (not (eq (car-safe expr) 'var))
1280 (if (eq (car expr) 'calcFunc-plain)
1281 (math-rwcomp-is-constrained (nth 1 expr) not-these)
1282 (not (or (memq (car expr) '(neg calcFunc-select))
1283 (memq (car expr) not-these)
1284 (and (memq 'commut (get (car expr) 'math-rewrite-props))
1285 (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
1286 (eq (car-safe (nth 2 expr)) 'calcFunc-opt))))))))
1288 (defun math-rwcomp-optional-arg (head argp)
1289 (let ((arg (car argp)))
1290 (if (eq (car-safe arg) 'calcFunc-opt)
1291 (and (memq (length arg) '(2 3))
1293 (or (eq (car-safe (nth 1 arg)) 'var)
1294 (error "First argument of opt( ) must be a variable"))
1295 (setcar argp (nth 1 arg))
1296 (if (= (length arg) 2)
1297 (or (get head 'math-rewrite-default)
1298 (error "opt( ) must include a default in this context"))
1300 (and (eq (car-safe arg) 'neg)
1301 (let* ((part (list (nth 1 arg)))
1302 (partp (math-rwcomp-optional-arg head part)))
1304 (setcar argp (math-rwcomp-neg (car part)))
1305 (math-neg partp)))))))
1307 (defun math-rwcomp-neg (expr)
1308 (if (memq (car-safe expr) '(* /))
1309 (if (eq (car-safe (nth 1 expr)) 'var)
1310 (list (car expr) (list 'neg (nth 1 expr)) (nth 2 expr))
1311 (if (eq (car-safe (nth 2 expr)) 'var)
1312 (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
1316 (defun math-rwcomp-assoc-args (expr)
1317 (if (and (eq (car-safe (nth 1 expr)) (car expr))
1318 (= (length (nth 1 expr)) 3))
1319 (math-rwcomp-assoc-args (nth 1 expr)))
1320 (if (and (eq (car-safe (nth 2 expr)) (car expr))
1321 (= (length (nth 2 expr)) 3))
1322 (math-rwcomp-assoc-args (nth 2 expr))))
1324 (defun math-rwcomp-addsub-args (expr)
1325 (if (memq (car-safe (nth 1 expr)) '(+ -))
1326 (math-rwcomp-addsub-args (nth 1 expr)))
1327 (if (eq (car expr) '-)
1329 (if (eq (car-safe (nth 2 expr)) '+)
1330 (math-rwcomp-addsub-args (nth 2 expr)))))
1332 (defun math-rwcomp-order (a b)
1333 (< (math-rwcomp-priority (car a))
1334 (math-rwcomp-priority (car b))))
1336 ;;; Order of priority: 0 Constants and other exact matches (first)
1337 ;;; 10 Functions (except below)
1338 ;;; 20 Meta-variables which occur more than once
1339 ;;; 30 Algebraic functions
1340 ;;; 40 Commutative/associative functions
1341 ;;; 50 Meta-variables which occur only once
1342 ;;; +100 for every "!!!" (pnot) in the pattern
1343 ;;; 10000 Optional arguments (last)
1345 (defun math-rwcomp-priority (expr)
1346 (+ (math-rwcomp-count-pnots expr)
1347 (cond ((eq (car-safe expr) 'calcFunc-opt)
1349 ((math-rwcomp-no-vars expr)
1351 ((eq (car expr) 'calcFunc-quote)
1353 ((eq (car expr) 'var)
1354 (if (assq (nth 2 expr) math-regs)
1356 (if (= (math-rwcomp-count-refs expr) 1)
1359 (t (let ((props (get (car expr) 'math-rewrite-props)))
1360 (if (or (memq 'commut props)
1361 (memq 'assoc props))
1363 (if (memq 'algebraic props)
1367 (defun math-rwcomp-count-refs (var)
1368 (let ((count (or (math-expr-contains-count math-pattern var) 0))
1371 (if (eq (car-safe (car p)) 'calcFunc-let)
1372 (if (= (length (car p)) 3)
1373 (setq count (+ count
1374 (or (math-expr-contains-count (nth 2 (car p)) var)
1376 (if (and (= (length (car p)) 2)
1377 (eq (car-safe (nth 1 (car p))) 'calcFunc-assign)
1378 (= (length (nth 1 (car p))) 3))
1379 (setq count (+ count
1380 (or (math-expr-contains-count
1381 (nth 2 (nth 1 (car p))) var) 0))))))
1385 (defun math-rwcomp-count-pnots (expr)
1386 (if (Math-primp expr)
1388 (if (eq (car expr) 'calcFunc-pnot)
1391 (while (setq expr (cdr expr))
1392 (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
1395 ;;; In the current implementation, all associative functions must
1396 ;;; also be commutative.
1398 (put '+ 'math-rewrite-props '(algebraic assoc commut))
1399 (put '- 'math-rewrite-props '(algebraic assoc commut)) ; see below
1400 (put '* 'math-rewrite-props '(algebraic assoc commut)) ; see below
1401 (put '/ 'math-rewrite-props '(algebraic unary1))
1402 (put '^ 'math-rewrite-props '(algebraic unary1))
1403 (put '% 'math-rewrite-props '(algebraic))
1404 (put 'neg 'math-rewrite-props '(algebraic))
1405 (put 'calcFunc-idiv 'math-rewrite-props '(algebraic))
1406 (put 'calcFunc-abs 'math-rewrite-props '(algebraic))
1407 (put 'calcFunc-sign 'math-rewrite-props '(algebraic))
1408 (put 'calcFunc-round 'math-rewrite-props '(algebraic))
1409 (put 'calcFunc-rounde 'math-rewrite-props '(algebraic))
1410 (put 'calcFunc-roundu 'math-rewrite-props '(algebraic))
1411 (put 'calcFunc-trunc 'math-rewrite-props '(algebraic))
1412 (put 'calcFunc-floor 'math-rewrite-props '(algebraic))
1413 (put 'calcFunc-ceil 'math-rewrite-props '(algebraic))
1414 (put 'calcFunc-re 'math-rewrite-props '(algebraic))
1415 (put 'calcFunc-im 'math-rewrite-props '(algebraic))
1416 (put 'calcFunc-conj 'math-rewrite-props '(algebraic))
1417 (put 'calcFunc-arg 'math-rewrite-props '(algebraic))
1418 (put 'calcFunc-and 'math-rewrite-props '(assoc commut))
1419 (put 'calcFunc-or 'math-rewrite-props '(assoc commut))
1420 (put 'calcFunc-xor 'math-rewrite-props '(assoc commut))
1421 (put 'calcFunc-eq 'math-rewrite-props '(commut))
1422 (put 'calcFunc-neq 'math-rewrite-props '(commut))
1423 (put 'calcFunc-land 'math-rewrite-props '(assoc commut))
1424 (put 'calcFunc-lor 'math-rewrite-props '(assoc commut))
1425 (put 'calcFunc-beta 'math-rewrite-props '(commut))
1426 (put 'calcFunc-gcd 'math-rewrite-props '(assoc commut))
1427 (put 'calcFunc-lcm 'math-rewrite-props '(assoc commut))
1428 (put 'calcFunc-max 'math-rewrite-props '(algebraic assoc commut))
1429 (put 'calcFunc-min 'math-rewrite-props '(algebraic assoc commut))
1430 (put 'calcFunc-vunion 'math-rewrite-props '(assoc commut))
1431 (put 'calcFunc-vint 'math-rewrite-props '(assoc commut))
1432 (put 'calcFunc-vxor 'math-rewrite-props '(assoc commut))
1434 ;;; Note: "*" is not commutative for matrix args, but we pretend it is.
1435 ;;; Also, "-" is not commutative but the code tweaks things so that it is.
1437 (put '+ 'math-rewrite-default 0)
1438 (put '- 'math-rewrite-default 0)
1439 (put '* 'math-rewrite-default 1)
1440 (put '/ 'math-rewrite-default 1)
1441 (put '^ 'math-rewrite-default 1)
1442 (put 'calcFunc-land 'math-rewrite-default 1)
1443 (put 'calcFunc-lor 'math-rewrite-default 0)
1444 (put 'calcFunc-vunion 'math-rewrite-default '(vec))
1445 (put 'calcFunc-vint 'math-rewrite-default '(vec))
1446 (put 'calcFunc-vdiff 'math-rewrite-default '(vec))
1447 (put 'calcFunc-vxor 'math-rewrite-default '(vec))
1449 (defmacro math-rwfail (&optional back)
1453 '(setq btrack (cdr btrack))
1457 ;;; This monstrosity is necessary because the use of static vectors of
1458 ;;; registers makes rewrite rules non-reentrant. Yucko!
1459 (defmacro math-rweval (form)
1460 (list 'let '((orig (car rules)))
1461 '(setcar rules (quote (nil nil nil no-phase)))
1462 (list 'unwind-protect
1464 '(setcar rules orig))))
1466 (defvar math-rewrite-phase 1)
1468 ;; The variable math-apply-rw-regs is local to math-apply-rewrites,
1469 ;; but is used by math-rwapply-replace-regs and math-rwapply-reg-looks-negp
1470 ;; which are called by math-apply-rewrites.
1471 (defvar math-apply-rw-regs)
1473 ;; The variable math-apply-rw-ruleset is local to math-apply-rewrites,
1474 ;; but is used by math-rwapply-remember.
1475 (defvar math-apply-rw-ruleset)
1477 (defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset)
1479 (setq rules (cdr (or (assq (car-safe expr) rules)
1482 op math-apply-rw-regs inst part pc mark btrack
1483 (tracing math-rwcomp-tracing)
1484 (phase math-rewrite-phase))
1487 (and (setq part (nth 2 (car rules)))
1489 (not (memq part heads)))
1490 (and (setq part (nth 3 (car rules)))
1491 (not (memq phase part)))
1493 (setq math-apply-rw-regs (car (car rules))
1494 pc (nth 1 (car rules))
1496 (aset math-apply-rw-regs 0 expr)
1500 (progn (terpri) (princ (car pc))
1501 (if (and (natnump (nth 1 (car pc)))
1502 (< (nth 1 (car pc)) (length math-apply-rw-regs)))
1504 (format "\n part = %s"
1505 (aref math-apply-rw-regs (nth 1 (car pc))))))))
1507 (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
1509 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1511 (car (setq inst (cdr (cdr inst)))))
1513 (while (and (setq inst (cdr inst)
1516 (aset math-apply-rw-regs (car inst) (car part)))
1517 (not (or inst part))))
1522 (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1523 (setq mark (aref math-apply-rw-regs (nth 2 inst))))
1524 (Math-equal part mark))
1530 (not (eq calc-matrix-mode 'scalar))
1531 (eq (car (nth 2 inst)) '*)
1532 (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1534 (not (math-known-scalarp part)))
1535 (setq mark (nth 3 inst)
1539 (aset math-apply-rw-regs (nth 4 inst) (nth 2 part))
1540 (aset mark 1 (cdr (cdr part))))
1541 (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1542 (aset mark 1 (cdr part)))
1543 (aset mark 0 (cdr part))
1547 (if (and (consp (setq part
1548 (aref math-apply-rw-regs (car (cdr inst)))))
1549 (memq (car part) (nth 2 inst))
1551 (or (not (eq (car part) '/))
1552 (Math-objectp (nth 2 part))))
1555 mark (car (cdr (setq inst (cdr (cdr inst))))))
1557 (memq 'assoc (get (car part) 'math-rewrite-props))
1558 (not (= (aref mark 3) 0))
1559 (while (if (and (consp (nth 1 part))
1560 (memq (car (nth 1 part)) (car inst)))
1561 (setq op (cons (if (eq (car part) '-)
1567 (if (and (consp (nth 2 part))
1568 (memq (car (nth 2 part))
1570 (not (eq (car (nth 2 part)) '-)))
1571 (setq op (cons (nth 1 part) op)
1572 part (nth 2 part))))))
1573 (setq op (cons (nth 1 part)
1574 (cons (if (eq (car part) '-)
1577 (if (eq (car part) '/)
1582 btrack (cons pc btrack)
1584 (aset math-apply-rw-regs (nth 2 inst) (car op))
1587 (aset mark 2 (if (cdr (cdr op)) 1 0)))
1589 (if (and (consp part)
1590 (eq (car part) 'neg)
1591 (eq (car (nth 2 inst)) '*)
1592 (eq (nth 5 inst) 1))
1594 (setq mark (nth 3 inst)
1596 (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1599 (setq mark (nth 3 inst)
1601 (aset math-apply-rw-regs (nth 4 inst) part)
1606 (setq part (nth 1 inst) ; try instr
1610 (aset math-apply-rw-regs (nth 2 inst)
1613 (if (eq (aref mark 0) (aref mark 1))
1614 (nth 1 (aref mark 0))
1615 (car (aref mark 0))))
1617 (setq mark (delq (car (aref mark 1))
1618 (copy-sequence (aref mark 0)))
1619 op (car (nth 2 part)))
1622 (setq mark (nreverse mark)
1623 part (list '* (nth 1 mark) (car mark))
1625 (while (setq mark (cdr mark))
1626 (setq part (list '* (car mark) part))))
1627 (setq part (car mark)
1629 part (if (and (eq op '+)
1631 (eq (car (car mark)) 'neg))
1634 (list op part (car mark))))
1635 (while (setq mark (cdr mark))
1636 (setq part (if (and (eq op '+)
1638 (eq (car (car mark)) 'neg))
1641 (list op part (car mark))))))
1644 (car (aref mark 1)))
1645 ((eq op 3) (nth 5 part))
1646 (t (aref mark 1)))))
1650 (if (and (consp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1651 (eq (car part) 'calcFunc-select))
1652 (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1653 (if math-rewrite-selections
1655 (aset math-apply-rw-regs (nth 2 inst) part))))
1658 (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1659 (setq mark (math-neg
1660 (aref math-apply-rw-regs (nth 2 inst)))))
1661 (Math-equal part mark))
1666 (setq inst (car (car btrack)) ; "try" or "alt" instr
1667 pc (cdr (car btrack))
1668 mark (or (nth 3 inst) [nil nil 4])
1671 (if (setq op (cdr (aref mark 1)))
1672 (aset math-apply-rw-regs (nth 4 inst)
1673 (car (aset mark 1 op)))
1677 (aset math-apply-rw-regs (nth 4 inst)
1678 (aref math-apply-rw-regs (nth 1 inst))))
1681 (if (setq op (cdr (aref mark 1)))
1682 (aset math-apply-rw-regs (nth 4 inst)
1683 (car (aset mark 1 op)))
1684 (if (= (aref mark 3) 1)
1688 (aset math-apply-rw-regs (nth 4 inst)
1689 (aref math-apply-rw-regs (nth 1 inst))))
1692 (aset mark 1 (cons nil (aref mark 0)))
1695 (if (setq op (cdr (aref mark 1)))
1697 (setq mark (delq (car (aset mark 1 op))
1700 op (car (nth 2 inst)))
1703 (setq mark (nreverse mark)
1704 part (list '* (nth 1 mark)
1707 (while (setq mark (cdr mark))
1708 (setq part (list '* (car mark)
1710 (setq part (car mark)
1712 part (if (and (eq op '+)
1714 (eq (car (car mark))
1718 (list op part (car mark))))
1719 (while (setq mark (cdr mark))
1720 (setq part (if (and (eq op '+)
1722 (eq (car (car mark))
1726 (list op part (car mark))))))
1727 (aset math-apply-rw-regs (nth 4 inst) part))
1731 (aset math-apply-rw-regs (nth 4 inst)
1732 (aref math-apply-rw-regs (nth 1 inst))))
1735 (setq btrack (cdr btrack)))
1736 (t (math-rwfail t))))
1739 (if (Math-integerp (setq part
1740 (aref math-apply-rw-regs (nth 1 inst))))
1742 (if (Math-primp part)
1744 (setq part (math-rweval (math-simplify part)))
1745 (if (Math-integerp part)
1750 (if (Math-realp (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-realp part)
1760 (if (math-constp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1762 (if (Math-primp part)
1764 (setq part (math-rweval (math-simplify part)))
1765 (if (math-constp part)
1770 (if (math-looks-negp (setq part
1771 (aref math-apply-rw-regs (nth 1 inst))))
1773 (if (Math-primp part)
1775 (setq part (math-rweval (math-simplify part)))
1776 (if (math-looks-negp part)
1781 (setq part (math-compare (aref math-apply-rw-regs (nth 1 inst))
1782 (aref math-apply-rw-regs (nth 3 inst)))
1785 (setq part (math-rweval
1789 (aref math-apply-rw-regs (nth 1 inst))
1790 (aref math-apply-rw-regs (nth 3 inst))))))))
1791 (if (cond ((eq op 'calcFunc-eq)
1793 ((eq op 'calcFunc-neq)
1794 (memq part '(-1 1)))
1795 ((eq op 'calcFunc-lt)
1797 ((eq op 'calcFunc-leq)
1798 (memq part '(-1 0)))
1799 ((eq op 'calcFunc-gt)
1801 ((eq op 'calcFunc-geq)
1802 (memq part '(0 1))))
1808 (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1810 (car (setq inst (cdr (cdr inst))))))
1812 (setq inst (cdr inst)
1814 (while (and (setq inst (cdr inst)
1817 (aset math-apply-rw-regs (car inst) (car part)))
1820 (while (eq (car (car (setq pc (cdr pc))))
1822 (setq pc (cdr pc)) ; skip over "func"
1824 (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1825 (setq mark (cdr mark)))))
1832 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1833 (eq (car part) (nth 2 inst))))
1834 (and (= (length part) 2)
1835 (setq part (nth 1 part))))
1837 (setq mark (nth 3 inst))
1838 (aset math-apply-rw-regs (nth 4 inst) part)
1839 (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
1840 (setq pc (cdr pc)) ; skip over "func"
1842 (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1843 (setq mark (cdr mark))))
1844 (setq pc (cdr pc))))
1848 (setq part (aref math-apply-rw-regs (nth 1 inst))))
1849 (Math-zerop (nth 3 inst))
1850 (and (not (Math-zerop (nth 2 inst)))
1852 (setq part (math-mod part (nth 2 inst)))
1853 (or (Math-numberp part)
1854 (setq part (math-rweval
1855 (math-simplify part))))
1856 (Math-equal part (nth 3 inst)))))
1862 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1863 (not (Math-objvecp part))
1864 (not (eq (car part) 'var)))
1866 (aset math-apply-rw-regs (nth 2 inst)
1867 (math-calcFunc-to-var (car part)))
1868 (aset math-apply-rw-regs (nth 3 inst)
1869 (cons 'vec (cdr part)))
1875 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1876 (eq (car part) 'vec)
1879 (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1880 (aset math-apply-rw-regs (nth 3 inst)
1881 (cons 'vec (cdr (cdr part))))
1887 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1888 (eq (car part) 'vec)
1891 (aset math-apply-rw-regs (nth 2 inst) (calcFunc-rhead part))
1892 (aset math-apply-rw-regs (nth 3 inst) (calcFunc-rtail part))
1900 (math-rwapply-replace-regs (nth 1 inst)))))
1905 (aset math-apply-rw-regs (nth 1 inst)
1908 (math-rwapply-replace-regs (nth 2 inst)))))
1912 (aset math-apply-rw-regs (nth 2 inst)
1913 (aref math-apply-rw-regs (nth 1 inst)))
1917 (aset math-apply-rw-regs (nth 2 inst)
1918 (math-rwapply-neg (aref math-apply-rw-regs (nth 1 inst))))
1922 (setq btrack (cons pc btrack)
1926 (while (and btrack (not (eq (car btrack) (nth 1 inst))))
1927 (setq btrack (cdr btrack)))
1928 (setq btrack (cdr btrack)
1932 (setq result (math-rwapply-replace-regs (nth 1 inst)))
1933 (if (or (and (eq (car-safe result) '+)
1934 (eq (nth 2 result) 0))
1935 (and (eq (car-safe result) '*)
1936 (eq (nth 2 result) 1)))
1937 (setq result (nth 1 result)))
1938 (setq part (and (nth 2 inst)
1942 (math-rwapply-replace-regs
1944 (if (or (equal result expr)
1945 (equal (setq result (math-normalize result)) expr))
1947 (if part (math-rwapply-remember expr result))
1951 (t (error "%s is not a valid rewrite opcode" op))))))
1952 (setq rules (cdr rules)))
1955 (defun math-rwapply-neg (expr)
1956 (if (and (consp expr)
1957 (memq (car expr) '(* /)))
1958 (if (Math-objectp (nth 2 expr))
1959 (list (car expr) (nth 1 expr) (math-neg (nth 2 expr)))
1961 (if (Math-objectp (nth 1 expr))
1962 (math-neg (nth 1 expr))
1963 (list '* -1 (nth 1 expr)))
1967 (defun math-rwapply-inv (expr)
1968 (if (and (Math-integerp expr)
1970 (math-make-frac 1 expr)
1973 (defun math-rwapply-replace-regs (expr)
1974 (cond ((Math-primp expr)
1976 ((eq (car expr) 'calcFunc-register)
1977 (setq expr (aref math-apply-rw-regs (nth 1 expr)))
1978 (if (eq (car-safe expr) '*)
1979 (if (eq (nth 1 expr) -1)
1980 (math-neg (nth 2 expr))
1981 (if (eq (nth 1 expr) 1)
1985 ((and (eq (car expr) 'calcFunc-eval)
1986 (= (length expr) 2))
1987 (calc-with-default-simplification
1988 (math-normalize (math-rwapply-replace-regs (nth 1 expr)))))
1989 ((and (eq (car expr) 'calcFunc-evalsimp)
1990 (= (length expr) 2))
1991 (math-simplify (math-rwapply-replace-regs (nth 1 expr))))
1992 ((and (eq (car expr) 'calcFunc-evalextsimp)
1993 (= (length expr) 2))
1994 (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr))))
1995 ((and (eq (car expr) 'calcFunc-apply)
1996 (= (length expr) 3))
1997 (let ((func (math-rwapply-replace-regs (nth 1 expr)))
1998 (args (math-rwapply-replace-regs (nth 2 expr)))
2000 (if (and (math-vectorp args)
2001 (not (eq (car-safe (setq call (math-build-call
2002 (math-var-to-calcFunc func)
2006 (list 'calcFunc-apply func args))))
2007 ((and (eq (car expr) 'calcFunc-cons)
2008 (= (length expr) 3))
2009 (let ((head (math-rwapply-replace-regs (nth 1 expr)))
2010 (tail (math-rwapply-replace-regs (nth 2 expr))))
2011 (if (math-vectorp tail)
2012 (cons 'vec (cons head (cdr tail)))
2013 (list 'calcFunc-cons head tail))))
2014 ((and (eq (car expr) 'calcFunc-rcons)
2015 (= (length expr) 3))
2016 (let ((head (math-rwapply-replace-regs (nth 1 expr)))
2017 (tail (math-rwapply-replace-regs (nth 2 expr))))
2018 (if (math-vectorp head)
2019 (append head (list tail))
2020 (list 'calcFunc-rcons head tail))))
2021 ((and (eq (car expr) 'neg)
2022 (math-rwapply-reg-looks-negp (nth 1 expr)))
2023 (math-rwapply-reg-neg (nth 1 expr)))
2024 ((and (eq (car expr) 'neg)
2025 (eq (car-safe (nth 1 expr)) 'calcFunc-register)
2026 (math-scalarp (aref math-apply-rw-regs (nth 1 (nth 1 expr)))))
2027 (math-neg (math-rwapply-replace-regs (nth 1 expr))))
2028 ((and (eq (car expr) '+)
2029 (math-rwapply-reg-looks-negp (nth 1 expr)))
2030 (list '- (math-rwapply-replace-regs (nth 2 expr))
2031 (math-rwapply-reg-neg (nth 1 expr))))
2032 ((and (eq (car expr) '+)
2033 (math-rwapply-reg-looks-negp (nth 2 expr)))
2034 (list '- (math-rwapply-replace-regs (nth 1 expr))
2035 (math-rwapply-reg-neg (nth 2 expr))))
2036 ((and (eq (car expr) '-)
2037 (math-rwapply-reg-looks-negp (nth 2 expr)))
2038 (list '+ (math-rwapply-replace-regs (nth 1 expr))
2039 (math-rwapply-reg-neg (nth 2 expr))))
2041 (cond ((eq (nth 1 expr) -1)
2042 (if (math-rwapply-reg-looks-negp (nth 2 expr))
2043 (math-rwapply-reg-neg (nth 2 expr))
2044 (math-neg (math-rwapply-replace-regs (nth 2 expr)))))
2045 ((eq (nth 1 expr) 1)
2046 (math-rwapply-replace-regs (nth 2 expr)))
2047 ((eq (nth 2 expr) -1)
2048 (if (math-rwapply-reg-looks-negp (nth 1 expr))
2049 (math-rwapply-reg-neg (nth 1 expr))
2050 (math-neg (math-rwapply-replace-regs (nth 1 expr)))))
2051 ((eq (nth 2 expr) 1)
2052 (math-rwapply-replace-regs (nth 1 expr)))
2054 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
2055 (arg2 (math-rwapply-replace-regs (nth 2 expr))))
2056 (cond ((and (eq (car-safe arg1) '/)
2057 (eq (nth 1 arg1) 1))
2058 (list '/ arg2 (nth 2 arg1)))
2059 ((and (eq (car-safe arg2) '/)
2060 (eq (nth 1 arg2) 1))
2061 (list '/ arg1 (nth 2 arg2)))
2062 (t (list '* arg1 arg2)))))))
2064 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
2065 (arg2 (math-rwapply-replace-regs (nth 2 expr))))
2066 (if (eq (car-safe arg2) '/)
2067 (list '/ (list '* arg1 (nth 2 arg2)) (nth 1 arg2))
2068 (list '/ arg1 arg2))))
2069 ((and (eq (car expr) 'calcFunc-plain)
2070 (= (length expr) 2))
2071 (if (Math-primp (nth 1 expr))
2073 (if (eq (car (nth 1 expr)) 'calcFunc-register)
2074 (aref math-apply-rw-regs (nth 1 (nth 1 expr)))
2075 (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
2076 (cdr (nth 1 expr)))))))
2077 (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))))
2079 (defun math-rwapply-reg-looks-negp (expr)
2080 (if (eq (car-safe expr) 'calcFunc-register)
2081 (math-looks-negp (aref math-apply-rw-regs (nth 1 expr)))
2082 (if (memq (car-safe expr) '(* /))
2083 (or (math-rwapply-reg-looks-negp (nth 1 expr))
2084 (math-rwapply-reg-looks-negp (nth 2 expr))))))
2086 (defun math-rwapply-reg-neg (expr) ; expr must satisfy rwapply-reg-looks-negp
2087 (if (eq (car expr) 'calcFunc-register)
2088 (math-neg (math-rwapply-replace-regs expr))
2089 (if (math-rwapply-reg-looks-negp (nth 1 expr))
2090 (math-rwapply-replace-regs (list (car expr)
2091 (math-rwapply-reg-neg (nth 1 expr))
2093 (math-rwapply-replace-regs (list (car expr)
2095 (math-rwapply-reg-neg (nth 2 expr)))))))
2097 (defun math-rwapply-remember (old new)
2098 (let ((varval (symbol-value (nth 2 (car math-apply-rw-ruleset))))
2099 (rules (assq (car-safe old) math-apply-rw-ruleset)))
2100 (if (and (eq (car-safe varval) 'vec)
2101 (not (memq (car-safe old) '(nil schedule + -)))
2104 (setcdr varval (cons (list 'calcFunc-assign
2105 (if (math-rwcomp-no-vars old)
2107 (list 'calcFunc-quote old))
2110 (setcdr rules (cons (list (vector nil old)
2111 (list (list 'same 0 1)
2112 (list 'done new nil))
2116 (provide 'calc-rewr)
2118 ;;; arch-tag: ca8d7b7d-bff1-4535-90f3-e2241f5e786b
2119 ;;; calc-rewr.el ends here