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 (defun calc-Need-calc-rewr () nil)
37 (defvar math-rewrite-default-iters 100)
39 ;; The variable calc-rewr-sel is local to calc-rewrite-selection and
40 ;; calc-rewrite, but is used by calc-locate-selection-marker.
41 (defvar calc-rewr-sel)
43 (defun calc-rewrite-selection (rules-str &optional many prefix)
44 (interactive "sRewrite rule(s): \np")
47 (let* ((num (max 1 (calc-locate-cursor-element (point))))
51 (entry (calc-top num 'entry))
53 (calc-rewr-sel (calc-auto-selection entry))
54 (math-rewrite-selections t)
55 (math-rewrite-default-iters 1))
56 (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
58 (error "Can't use same stack entry for formula and rules")
59 (setq rules (calc-top-n 1 t)
61 (setq rules (if (stringp rules-str)
62 (math-read-exprs rules-str) rules-str))
63 (if (eq (car-safe rules) 'error)
64 (error "Bad format in expression: %s" (nth 1 rules)))
65 (if (= (length rules) 1)
66 (setq rules (car rules))
67 (setq rules (cons 'vec rules)))
68 (or (memq (car-safe rules) '(vec var calcFunc-assign
70 (let ((rhs (math-read-expr
71 (read-string (concat "Rewrite from: " rules-str
73 (if (eq (car-safe rhs) 'error)
74 (error "Bad format in expression: %s" (nth 1 rhs)))
75 (setq rules (list 'calcFunc-assign rules rhs))))
76 (or (eq (car-safe rules) 'var)
77 (calc-record rules "rule")))
79 (setq many '(var inf var-inf))
80 (if many (setq many (prefix-numeric-value many))))
82 (setq expr (calc-replace-sub-formula (car entry)
84 (list 'calcFunc-select calc-rewr-sel)))
85 (setq expr (car entry)
87 math-rewrite-selections nil))
88 (setq expr (calc-encase-atoms
94 expr (calc-locate-select-marker expr))
95 (or (consp calc-rewr-sel) (setq calc-rewr-sel nil))
96 (if pop-rules (calc-pop-stack 1))
97 (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
98 (- num (if pop-rules 1 0))
99 (list (and reselect calc-rewr-sel))))
102 (defun calc-locate-select-marker (expr)
103 (if (Math-primp expr)
105 (if (and (eq (car expr) 'calcFunc-select)
108 (setq calc-rewr-sel (if calc-rewr-sel t (nth 1 expr)))
111 (mapcar 'calc-locate-select-marker (cdr expr))))))
115 (defun calc-rewrite (rules-str many)
116 (interactive "sRewrite rule(s): \nP")
119 (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
120 (setq expr (calc-top-n 2)
121 rules (calc-top-n 1 t)
123 (setq rules (if (stringp rules-str)
124 (math-read-exprs rules-str) rules-str))
125 (if (eq (car-safe rules) 'error)
126 (error "Bad format in expression: %s" (nth 1 rules)))
127 (if (= (length rules) 1)
128 (setq rules (car rules))
129 (setq rules (cons 'vec rules)))
130 (or (memq (car-safe rules) '(vec var calcFunc-assign
132 (let ((rhs (math-read-expr
133 (read-string (concat "Rewrite from: " rules-str
135 (if (eq (car-safe rhs) 'error)
136 (error "Bad format in expression: %s" (nth 1 rhs)))
137 (setq rules (list 'calcFunc-assign rules rhs))))
138 (or (eq (car-safe rules) 'var)
139 (calc-record rules "rule"))
140 (setq expr (calc-top-n 1)
143 (setq many '(var inf var-inf))
144 (if many (setq many (prefix-numeric-value many))))
145 (setq expr (calc-normalize (math-rewrite expr rules many)))
147 (setq expr (calc-locate-select-marker expr)))
148 (calc-pop-push-record-list n "rwrt" (list expr)))
151 (defun calc-match (pat &optional interactive)
152 (interactive "sPattern: \np")
155 (if (or (null pat) (equal pat "") (equal pat "$"))
156 (setq expr (calc-top-n 2)
159 (if interactive (setq calc-previous-alg-entry pat))
160 (setq pat (if (stringp pat) (math-read-expr pat) pat))
161 (if (eq (car-safe pat) 'error)
162 (error "Bad format in expression: %s" (nth 1 pat)))
163 (if (not (eq (car-safe pat) 'var))
164 (calc-record pat "pat"))
165 (setq expr (calc-top-n 1)
167 (or (math-vectorp expr) (error "Argument must be a vector"))
168 (if (calc-is-inverse)
169 (calc-enter-result n "mtcn" (math-match-patterns pat expr t))
170 (calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))
173 (defvar math-mt-many)
175 ;; The variable math-rewrite-whole-expr is local to math-rewrite,
176 ;; but is used by math-rewrite-phase
177 (defvar math-rewrite-whole-expr)
179 (defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many)
180 (let* ((crules (math-compile-rewrites rules))
181 (heads (math-rewrite-heads math-rewrite-whole-expr))
182 (trace-buffer (get-buffer "*Trace*"))
183 (calc-display-just 'center)
184 (calc-display-origin 39)
185 (calc-line-breaking 78)
186 (calc-line-numbering nil)
187 (calc-show-selections t)
189 (math-mt-func (function
191 (let ((result (math-apply-rewrites x (cdr crules)
196 (let ((fmt (math-format-stack-value
197 (list result nil nil))))
199 (set-buffer trace-buffer)
200 (insert "\nrewrite to\n" fmt "\n"))))
201 (setq heads (math-rewrite-heads result heads t))))
204 (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
206 (set-buffer trace-buffer)
207 (setq truncate-lines t)
208 (goto-char (point-max))
209 (insert "\n\nBegin rewriting\n" fmt "\n"))))
210 (or math-mt-many (setq math-mt-many (or (nth 1 (car crules))
211 math-rewrite-default-iters)))
212 (if (equal math-mt-many '(var inf var-inf)) (setq math-mt-many 1000000))
213 (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000))
214 (math-rewrite-phase (nth 3 (car crules)))
216 (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
218 (set-buffer trace-buffer)
219 (insert "\nDone rewriting"
220 (if (= math-mt-many 0) " (reached iteration limit)" "")
222 math-rewrite-whole-expr))
224 (defun math-rewrite-phase (sched)
225 (while (and sched (/= math-mt-many 0))
226 (if (listp (car sched))
227 (while (let ((save-expr math-rewrite-whole-expr))
228 (math-rewrite-phase (car sched))
229 (not (equal math-rewrite-whole-expr save-expr))))
230 (if (symbolp (car sched))
232 (setq math-rewrite-whole-expr
233 (math-normalize (list (car sched) math-rewrite-whole-expr)))
235 (let ((fmt (math-format-stack-value
236 (list math-rewrite-whole-expr nil nil))))
238 (set-buffer trace-buffer)
240 (substring (symbol-name (car sched)) 9)
242 (let ((math-rewrite-phase (car sched)))
245 (set-buffer trace-buffer)
246 (insert (format "\n(Phase %d)\n" math-rewrite-phase))))
247 (while (let ((save-expr math-rewrite-whole-expr))
248 (setq math-rewrite-whole-expr (math-normalize
249 (math-map-tree-rec math-rewrite-whole-expr)))
250 (not (equal math-rewrite-whole-expr save-expr)))))))
251 (setq sched (cdr sched))))
253 (defun calcFunc-rewrite (expr rules &optional many)
254 (or (null many) (integerp many)
255 (equal many '(var inf var-inf)) (equal many '(neg (var inf var-inf)))
256 (math-reject-arg many 'fixnump))
258 (math-rewrite expr rules (or many 1))
259 (error (math-reject-arg rules (nth 1 err)))))
261 (defun calcFunc-match (pat vec)
262 (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
264 (math-match-patterns pat vec nil)
265 (error (math-reject-arg pat (nth 1 err)))))
267 (defun calcFunc-matchnot (pat vec)
268 (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
270 (math-match-patterns pat vec t)
271 (error (math-reject-arg pat (nth 1 err)))))
273 (defun math-match-patterns (pat vec &optional not-flag)
275 (crules (math-compile-patterns pat)))
276 (while (setq vec (cdr vec))
277 (if (eq (not (math-apply-rewrites (car vec) crules))
279 (setq newvec (cons (car vec) newvec))))
280 (cons 'vec (nreverse newvec))))
282 (defun calcFunc-matches (expr pat)
284 (if (math-apply-rewrites expr (math-compile-patterns pat))
287 (error (math-reject-arg pat (nth 1 err)))))
289 (defun calcFunc-vmatches (expr pat)
291 (or (math-apply-rewrites expr (math-compile-patterns pat))
293 (error (math-reject-arg pat (nth 1 err)))))
297 ;;; A compiled rule set is an a-list of entries whose cars are functors,
298 ;;; and whose cdrs are lists of rules. If there are rules with no
299 ;;; well-defined head functor, they are included on all lists and also
300 ;;; on an extra list whose car is nil.
302 ;;; The first entry in the a-list is of the form (schedule A B C ...).
304 ;;; Rule list entries take the form (regs prog head phases), where:
306 ;;; regs is a vector of match registers.
308 ;;; prog is a match program (see below).
310 ;;; head is a rare function name appearing in the rule body (but not the
311 ;;; head of the whole rule), or nil if none.
313 ;;; phases is a list of phase numbers for which the rule is enabled.
315 ;;; A match program is a list of match instructions.
317 ;;; In the following, "part" is a register number that contains the
318 ;;; subexpression to be operated on.
320 ;;; Register 0 is the whole expression being matched. The others are
321 ;;; meta-variables in the pattern, temporaries used for matching and
322 ;;; backtracking, and constant expressions.
325 ;;; The selected part must be math-equal to the contents of "reg".
327 ;;; (same-neg part reg)
328 ;;; The selected part must be math-equal to the negative of "reg".
331 ;;; The selected part is copied into "reg". (Rarely used.)
333 ;;; (copy-neg part reg)
334 ;;; The negative of the selected part is copied into "reg".
337 ;;; The selected part must be an integer.
340 ;;; The selected part must be a real.
343 ;;; The selected part must be a constant.
346 ;;; The selected part must "look" negative.
348 ;;; (rel part op reg)
349 ;;; The selected part must satisfy "part op reg", where "op"
350 ;;; is one of the 6 relational ops, and "reg" is a register.
352 ;;; (mod part modulo value)
353 ;;; The selected part must satisfy "part % modulo = value", where
354 ;;; "modulo" and "value" are constants.
356 ;;; (func part head reg1 reg2 ... regn)
357 ;;; The selected part must be an n-ary call to function "head".
358 ;;; The arguments are stored in "reg1" through "regn".
360 ;;; (func-def part head defs reg1 reg2 ... regn)
361 ;;; The selected part must be an n-ary call to function "head".
362 ;;; "Defs" is a list of value/register number pairs for default args.
363 ;;; If a match, assign default values to registers and then skip
364 ;;; immediately over any following "func-def" instructions and
365 ;;; the following "func" instruction. If wrong number of arguments,
366 ;;; proceed to the following "func-def" or "func" instruction.
368 ;;; (func-opt part head defs reg1)
369 ;;; Like func-def with "n=1", except that if the selected part is
370 ;;; not a call to "head", then the part itself successfully matches
371 ;;; "reg1" (and the defaults are assigned).
373 ;;; (try part heads mark reg1 [def])
374 ;;; The selected part must be a function of the correct type which is
375 ;;; associative and/or commutative. "Heads" is a list of acceptable
376 ;;; types. An initial assignment of arguments to "reg1" is tried.
377 ;;; If the program later fails, it backtracks to this instruction
378 ;;; and tries other assignments of arguments to "reg1".
379 ;;; If "def" exists and normal matching fails, backtrack and assign
380 ;;; "part" to "reg1", and "def" to "reg2" in the following "try2".
381 ;;; The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
382 ;;; "mark[0]" points to the argument list; "mark[1]" points to the
383 ;;; current argument; "mark[2]" is 0 if there are two arguments,
384 ;;; 1 if reg1 is matching single arguments, 2 if reg2 is matching
385 ;;; single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
386 ;;; 3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
387 ;;; have two arguments, 1 if phase-2 can be skipped, 2 if full
388 ;;; backtracking is necessary; "mark[4]" is t if the arguments have
389 ;;; been switched from the order given in the original pattern.
392 ;;; Every "try" will be followed by a "try2" whose "try" field is
393 ;;; a pointer to the corresponding "try". The arguments which were
394 ;;; not stored in "reg1" by that "try" are now stored in "reg2".
396 ;;; (alt instr nil mark)
397 ;;; Basic backtracking. Execute the instruction sequence "instr".
398 ;;; If this fails, back up and execute following the "alt" instruction.
399 ;;; The "mark" must be the vector "[nil nil 4]". The "instr" sequence
400 ;;; should execute "end-alt" at the end.
403 ;;; Register success of the first alternative of a previous "alt".
404 ;;; "Ptr" is a pointer to the next instruction following that "alt".
406 ;;; (apply part reg1 reg2)
407 ;;; The selected part must be a function call. The functor
408 ;;; (as a variable name) is stored in "reg1"; the arguments
409 ;;; (as a vector) are stored in "reg2".
411 ;;; (cons part reg1 reg2)
412 ;;; The selected part must be a nonempty vector. The first element
413 ;;; of the vector is stored in "reg1"; the rest of the vector
414 ;;; (as another vector) is stored in "reg2".
416 ;;; (rcons part reg1 reg2)
417 ;;; The selected part must be a nonempty vector. The last element
418 ;;; of the vector is stored in "reg2"; the rest of the vector
419 ;;; (as another vector) is stored in "reg1".
421 ;;; (select part reg)
422 ;;; If the selected part is a unary call to function "select", its
423 ;;; argument is stored in "reg"; otherwise (provided this is an `a r'
424 ;;; and not a `g r' command) the selected part is stored in "reg".
427 ;;; The "expr", with registers substituted, must simplify to
428 ;;; a non-zero value.
431 ;;; Evaluate "expr" and store the result in "reg". Always succeeds.
433 ;;; (done rhs remember)
434 ;;; Rewrite the expression to "rhs", with register substituted.
435 ;;; Normalize; if the result is different from the original
436 ;;; expression, the match has succeeded. This is the last
437 ;;; instruction of every program. If "remember" is non-nil,
438 ;;; record the result of the match as a new literal rule.
441 ;;; Pseudo-functions related to rewrites:
443 ;;; In patterns: quote, plain, condition, opt, apply, cons, select
445 ;;; In righthand sides: quote, plain, eval, evalsimp, evalextsimp,
446 ;;; apply, cons, select
448 ;;; In conditions: let + same as for righthand sides
450 ;;; Some optimizations that would be nice to have:
452 ;;; * Merge registers with disjoint lifetimes.
453 ;;; * Merge constant registers with equivalent values.
455 ;;; * If an argument of a commutative op math-depends neither on the
456 ;;; rest of the pattern nor on any of the conditions, then no backtracking
457 ;;; should be done for that argument. (This won't apply to very many
460 ;;; * If top functor is "select", and its argument is a unique function,
461 ;;; add the rule to the lists for both "select" and that function.
462 ;;; (Currently rules like this go on the "nil" list.)
463 ;;; Same for "func-opt" functions. (Though not urgent for these.)
465 ;;; * Shouldn't evaluate a "let" condition until the end, or until it
466 ;;; would enable another condition to be evaluated.
469 ;;; Some additional features to add / things to think about:
471 ;;; * Figure out what happens to "a +/- b" and "a +/- opt(b)".
473 ;;; * Same for interval forms.
475 ;;; * Have a name(v,pat) pattern which matches pat, and gives the
476 ;;; whole match the name v. Beware of circular structures!
479 (defun math-compile-patterns (pats)
480 (if (and (eq (car-safe pats) 'var)
481 (calc-var-value (nth 2 pats)))
482 (let ((prop (get (nth 2 pats) 'math-pattern-cache)))
484 (put (nth 2 pats) 'math-pattern-cache (setq prop (list nil))))
485 (or (eq (car prop) (symbol-value (nth 2 pats)))
487 (setcdr prop (math-compile-patterns
488 (symbol-value (nth 2 pats))))
489 (setcar prop (symbol-value (nth 2 pats)))))
491 (let ((math-rewrite-whole t))
492 (cdr (math-compile-rewrites (cons
494 (mapcar (function (lambda (x)
496 (if (eq (car-safe pats) 'vec)
500 (defvar math-rewrite-whole nil)
501 (defvar math-make-import-list nil)
503 ;; The variable math-import-list is local to part of math-compile-rewrites,
504 ;; but is also used in a different part, and so the local version could
505 ;; be affected by the non-local version when math-compile-rewrites calls itself.
506 (defvar math-import-list nil)
508 ;; The variables math-regs, math-num-regs, math-prog-last, math-bound-vars,
509 ;; math-conds, math-copy-neg, math-rhs, math-pattern, math-remembering and
510 ;; math-aliased-vars are local to math-compile-rewrites,
511 ;; but are used by many functions math-rwcomp-*, which are called by
512 ;; math-compile-rewrites.
514 (defvar math-num-regs)
515 (defvar math-prog-last)
516 (defvar math-bound-vars)
518 (defvar math-copy-neg)
520 (defvar math-pattern)
521 (defvar math-remembering)
522 (defvar math-aliased-vars)
524 (defun math-compile-rewrites (rules &optional name)
525 (if (eq (car-safe rules) 'var)
526 (let ((prop (get (nth 2 rules) 'math-rewrite-cache))
527 (math-import-list nil)
528 (math-make-import-list t)
530 (or (calc-var-value (nth 2 rules))
531 (error "Rules variable %s has no stored value" (nth 1 rules)))
533 (put (nth 2 rules) 'math-rewrite-cache
534 (setq prop (list (list (cons (nth 2 rules) nil))))))
536 (while (and p (eq (symbol-value (car (car p))) (cdr (car p))))
540 (message "Compiling rule set %s..." (nth 1 rules))
541 (setcdr prop (math-compile-rewrites
542 (symbol-value (nth 2 rules))
544 (message "Compiling rule set %s...done" (nth 1 rules))
545 (setcar prop (cons (cons (nth 2 rules)
546 (symbol-value (nth 2 rules)))
549 (if (or (not (eq (car-safe rules) 'vec))
550 (and (memq (length rules) '(3 4))
552 (while (and (setq p (cdr p))
553 (memq (car-safe (car p))
560 calcFunc-iterations))))
562 (setq rules (list rules))
563 (setq rules (cdr rules)))
564 (if (assq 'calcFunc-import rules)
565 (let ((pp (setq rules (copy-sequence rules)))
567 (while (setq p (car (cdr pp)))
568 (if (eq (car-safe p) 'calcFunc-import)
570 (setcdr pp (cdr (cdr pp)))
571 (or (and (eq (car-safe (nth 1 p)) 'var)
572 (setq part (calc-var-value (nth 2 (nth 1 p))))
573 (memq (car-safe part) '(vec
575 calcFunc-condition)))
576 (error "Argument of import() must be a rules variable"))
577 (if math-make-import-list
578 (setq math-import-list
579 (cons (cons (nth 2 (nth 1 p))
580 (symbol-value (nth 2 (nth 1 p))))
582 (while (setq p (cdr (cdr p)))
584 (error "import() must have odd number of arguments"))
585 (setq part (math-rwcomp-substitute part
587 (if (eq (car-safe part) 'vec)
588 (setq part (cdr part))
589 (setq part (list part)))
590 (setcdr pp (append part (cdr pp))))
591 (setq pp (cdr pp))))))
597 (math-iterations nil)
599 (math-all-phases nil)
600 (math-remembering nil)
601 math-pattern math-rhs math-conds)
604 ((and (eq (car-safe (car rules)) 'calcFunc-iterations)
605 (= (length (car rules)) 2))
606 (or (integerp (nth 1 (car rules)))
607 (equal (nth 1 (car rules)) '(var inf var-inf))
608 (equal (nth 1 (car rules)) '(neg (var inf var-inf)))
609 (error "Invalid argument for iterations(n)"))
611 (setq math-iterations (nth 1 (car rules)))))
612 ((eq (car-safe (car rules)) 'calcFunc-schedule)
614 (setq math-schedule (math-parse-schedule (cdr (car rules))))))
615 ((eq (car-safe (car rules)) 'calcFunc-phase)
616 (setq math-phases (cdr (car rules)))
617 (if (equal math-phases '((var all var-all)))
618 (setq math-phases nil))
619 (let ((p math-phases))
621 (or (integerp (car p))
622 (error "Phase numbers must be small integers"))
623 (or (memq (car p) math-all-phases)
624 (setq math-all-phases (cons (car p) math-all-phases)))
626 ((or (and (eq (car-safe (car rules)) 'vec)
627 (cdr (cdr (car rules)))
628 (not (nthcdr 4 (car rules)))
629 (setq math-conds (nth 3 (car rules))
630 math-rhs (nth 2 (car rules))
631 math-pattern (nth 1 (car rules))))
634 math-pattern (car rules))
635 (while (and (eq (car-safe math-pattern) 'calcFunc-condition)
636 (= (length math-pattern) 3))
637 (let ((cond (nth 2 math-pattern)))
638 (setq math-conds (if math-conds
639 (list 'calcFunc-land math-conds cond)
641 math-pattern (nth 1 math-pattern))))
642 (and (eq (car-safe math-pattern) 'calcFunc-assign)
643 (= (length math-pattern) 3)
644 (setq math-rhs (nth 2 math-pattern)
645 math-pattern (nth 1 math-pattern)))))
646 (let* ((math-prog (list nil))
647 (math-prog-last math-prog)
649 (math-regs (list (list nil 0 nil nil)))
650 (math-bound-vars nil)
651 (math-aliased-vars nil)
653 (setq math-conds (and math-conds (math-flatten-lands math-conds)))
654 (math-rwcomp-pattern math-pattern 0)
656 (let ((expr (car math-conds)))
657 (setq math-conds (cdr math-conds))
658 (math-rwcomp-cond-instr expr)))
659 (math-rwcomp-instr 'done
673 (math-rwcomp-register-expr
676 (math-rwcomp-match-vars math-rhs))
678 (setq math-prog (cdr math-prog))
679 (let* ((heads (math-rewrite-heads math-pattern))
682 (mapcar (function (lambda (x) (nth 3 x)))
687 (head (and (not (Math-primp math-pattern))
688 (not (and (eq (car (car math-prog)) 'try)
689 (nth 5 (car math-prog))))
690 (not (memq (car (car math-prog)) '(func-opt
694 (if (memq (car (car math-prog)) '(func
696 (nth 2 (car math-prog))
697 (if (eq (car math-pattern) 'calcFunc-quote)
698 (car-safe (nth 1 math-pattern))
699 (car math-pattern))))))
702 (if (setq found (assq (car heads) all-heads))
703 (setcdr found (1+ (cdr found)))
704 (setq all-heads (cons (cons (car heads) 1) all-heads)))
705 (setq heads (cdr heads))))
706 (if (eq head '-) (setq head '+))
707 (if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec))
710 (nconc (or (assq head rule-set)
711 (car (setq rule-set (cons (cons head
717 (nconc (or (assq '/ rule-set)
718 (car (setq rule-set (cons (cons
724 (setq nil-rules (nconc nil-rules (list rule)))
725 (let ((ptr rule-set))
727 (nconc (car ptr) (list rule))
728 (setq ptr (cdr ptr))))))))
730 (error "Rewrite rule set must be a vector of A := B rules")))
731 (setq rules (cdr rules)))
733 (setq rule-set (cons (cons nil nil-rules) rule-set)))
734 (setq all-heads (mapcar 'car
735 (sort all-heads (function
737 (< (cdr x) (cdr y)))))))
741 (setq rule (cdr (car set)))
743 (if (consp (setq heads (nth 2 (car rule))))
745 (setq heads (delq (car (car set)) heads)
747 (while (and ptr (not (memq (car ptr) heads)))
748 (setq ptr (cdr ptr)))
749 (setcar (nthcdr 2 (car rule)) (car ptr))))
750 (setq rule (cdr rule)))
751 (setq set (cdr set))))
752 (let ((plus (assq '+ rule-set)))
754 (setq rule-set (cons (cons '- (cdr plus)) rule-set))))
755 (cons (list 'schedule math-iterations name
757 (sort math-all-phases '<)
761 (defun math-flatten-lands (expr)
762 (if (eq (car-safe expr) 'calcFunc-land)
763 (append (math-flatten-lands (nth 1 expr))
764 (math-flatten-lands (nth 2 expr)))
767 ;; The variables math-rewrite-heads-heads (i.e.; heads for math-rewrite-heads)
768 ;; math-rewrite-heads-blanks and math-rewrite-heads-skips are local to
769 ;; math-rewrite-heads, but used by math-rewrite-heads-rec, which is called by
770 ;; math-rewrite-heads.
771 (defvar math-rewrite-heads-heads)
772 (defvar math-rewrite-heads-skips)
773 (defvar math-rewrite-heads-blanks)
775 (defun math-rewrite-heads (expr &optional more all)
776 (let ((math-rewrite-heads-heads more)
777 (math-rewrite-heads-skips (and (not all)
778 '(calcFunc-apply calcFunc-condition calcFunc-opt
779 calcFunc-por calcFunc-pnot)))
780 (math-rewrite-heads-blanks (and (not all)
781 '(calcFunc-quote calcFunc-plain calcFunc-select
782 calcFunc-cons calcFunc-rcons
784 (or (Math-primp expr)
785 (math-rewrite-heads-rec expr))
786 math-rewrite-heads-heads))
788 (defun math-rewrite-heads-rec (expr)
789 (or (memq (car expr) math-rewrite-heads-skips)
791 (or (memq (car expr) math-rewrite-heads-heads)
792 (memq (car expr) math-rewrite-heads-blanks)
793 (memq 'algebraic (get (car expr) 'math-rewrite-props))
794 (setq math-rewrite-heads-heads (cons (car expr) math-rewrite-heads-heads)))
795 (while (setq expr (cdr expr))
796 (or (Math-primp (car expr))
797 (math-rewrite-heads-rec (car expr)))))))
799 (defun math-parse-schedule (sched)
805 (math-parse-schedule (cdr s))
806 (if (eq (car-safe s) 'var)
807 (math-var-to-calcFunc s)
808 (error "Improper component in rewrite schedule"))))))
811 (defun math-rwcomp-match-vars (expr)
812 (if (Math-primp expr)
813 (if (eq (car-safe expr) 'var)
814 (let ((entry (assq (nth 2 expr) math-regs)))
816 (math-rwcomp-register-expr (nth 1 entry))
819 (if (and (eq (car expr) 'calcFunc-quote)
821 (math-rwcomp-match-vars (nth 1 expr))
822 (if (and (eq (car expr) 'calcFunc-plain)
824 (not (Math-primp (nth 1 expr))))
826 (cons (car (nth 1 expr))
827 (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
829 (mapcar 'math-rwcomp-match-vars (cdr expr)))))))
831 (defun math-rwcomp-register-expr (num)
832 (let ((entry (nth (1- (- math-num-regs num)) math-regs)))
834 (list 'neg (list 'calcFunc-register (nth 1 entry)))
835 (list 'calcFunc-register (nth 1 entry)))))
837 ;; The variables math-rwcomp-subst-old, math-rwcomp-subst-new,
838 ;; math-rwcomp-subst-old-func and math-rwcomp-subst-new-func
839 ;; are local to math-rwcomp-substitute, but are used by
840 ;; math-rwcomp-subst-rec, which is called by math-rwcomp-substitute.
841 (defvar math-rwcomp-subst-new)
842 (defvar math-rwcomp-subst-old)
843 (defvar math-rwcomp-subst-new-func)
844 (defvar math-rwcomp-subst-old-func)
846 (defun math-rwcomp-substitute (expr math-rwcomp-subst-old math-rwcomp-subst-new)
847 (if (and (eq (car-safe math-rwcomp-subst-old) 'var)
848 (memq (car-safe math-rwcomp-subst-new) '(var calcFunc-lambda)))
849 (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc math-rwcomp-subst-old))
850 (math-rwcomp-subst-new-func (math-var-to-calcFunc math-rwcomp-subst-new)))
851 (math-rwcomp-subst-rec expr))
852 (let ((math-rwcomp-subst-old-func nil))
853 (math-rwcomp-subst-rec expr))))
855 (defun math-rwcomp-subst-rec (expr)
856 (cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new)
857 ((Math-primp expr) expr)
858 (t (if (eq (car expr) math-rwcomp-subst-old-func)
859 (math-build-call math-rwcomp-subst-new-func
860 (mapcar 'math-rwcomp-subst-rec
863 (mapcar 'math-rwcomp-subst-rec (cdr expr)))))))
865 (defvar math-rwcomp-tracing nil)
867 (defun math-rwcomp-trace (instr)
868 (when math-rwcomp-tracing
869 (terpri) (princ instr))
872 (defun math-rwcomp-instr (&rest instr)
873 (setcdr math-prog-last
874 (setq math-prog-last (list (math-rwcomp-trace instr)))))
876 (defun math-rwcomp-multi-instr (tail &rest instr)
877 (setcdr math-prog-last
878 (setq math-prog-last (list (math-rwcomp-trace (append instr tail))))))
880 (defun math-rwcomp-bind-var (reg var)
881 (setcar (math-rwcomp-reg-entry reg) (nth 2 var))
882 (setq math-bound-vars (cons (nth 2 var) math-bound-vars))
883 (math-rwcomp-do-conditions))
885 (defun math-rwcomp-unbind-vars (mark)
886 (while (not (eq math-bound-vars mark))
887 (setcar (assq (car math-bound-vars) math-regs) nil)
888 (setq math-bound-vars (cdr math-bound-vars))))
890 (defun math-rwcomp-do-conditions ()
891 (let ((cond math-conds))
893 (if (math-rwcomp-all-regs-done (car cond))
894 (let ((expr (car cond)))
895 (setq math-conds (delq (car cond) math-conds))
897 (math-rwcomp-cond-instr expr)))
898 (setq cond (cdr cond)))))
900 (defun math-rwcomp-cond-instr (expr)
902 (cond ((and (eq (car-safe expr) 'calcFunc-matches)
904 (eq (car-safe (setq arg (math-rwcomp-match-vars (nth 1 expr))))
906 (math-rwcomp-pattern (nth 2 expr) (nth 1 arg)))
907 ((math-numberp (setq expr (math-rwcomp-match-vars expr)))
908 (if (Math-zerop expr)
909 (math-rwcomp-instr 'backtrack)))
910 ((and (eq (car expr) 'calcFunc-let)
912 (let ((reg (math-rwcomp-reg)))
913 (math-rwcomp-instr 'let reg (nth 2 expr))
914 (math-rwcomp-pattern (nth 1 expr) reg)))
915 ((and (eq (car expr) 'calcFunc-let)
917 (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
918 (= (length (nth 1 expr)) 3))
919 (let ((reg (math-rwcomp-reg)))
920 (math-rwcomp-instr 'let reg (nth 2 (nth 1 expr)))
921 (math-rwcomp-pattern (nth 1 (nth 1 expr)) reg)))
922 ((and (setq op (cdr (assq (car-safe expr)
923 '( (calcFunc-integer . integer)
924 (calcFunc-real . real)
925 (calcFunc-constant . constant)
926 (calcFunc-negative . negative) ))))
928 (or (and (eq (car-safe (nth 1 expr)) 'neg)
929 (memq op '(integer real constant))
930 (setq arg (nth 1 (nth 1 expr))))
931 (setq arg (nth 1 expr)))
932 (eq (car-safe (setq arg (nth 1 expr))) 'calcFunc-register))
933 (math-rwcomp-instr op (nth 1 arg)))
934 ((and (assq (car-safe expr) calc-tweak-eqn-table)
936 (eq (car-safe (nth 1 expr)) 'calcFunc-register))
937 (if (math-constp (nth 2 expr))
938 (let ((reg (math-rwcomp-reg)))
939 (setcar (nthcdr 3 (car math-regs)) (nth 2 expr))
940 (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
942 (if (eq (car (nth 2 expr)) 'calcFunc-register)
943 (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
944 (car expr) (nth 1 (nth 2 expr)))
945 (math-rwcomp-instr 'cond expr))))
946 ((and (eq (car-safe expr) 'calcFunc-eq)
948 (eq (car-safe (nth 1 expr)) '%)
949 (eq (car-safe (nth 1 (nth 1 expr))) 'calcFunc-register)
950 (math-constp (nth 2 (nth 1 expr)))
951 (math-constp (nth 2 expr)))
952 (math-rwcomp-instr 'mod (nth 1 (nth 1 (nth 1 expr)))
953 (nth 2 (nth 1 expr)) (nth 2 expr)))
954 ((equal expr '(var remember var-remember))
955 (setq math-remembering 1))
956 ((and (eq (car-safe expr) 'calcFunc-remember)
958 (setq math-remembering (if math-remembering
960 math-remembering (nth 1 expr))
962 (t (math-rwcomp-instr 'cond expr)))))
964 (defun math-rwcomp-same-instr (reg1 reg2 neg)
965 (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
966 (nth 2 (math-rwcomp-reg-entry reg2)))
972 (defun math-rwcomp-copy-instr (reg1 reg2 neg)
973 (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
974 (nth 2 (math-rwcomp-reg-entry reg2)))
976 (math-rwcomp-instr 'copy-neg reg1 reg2)
978 (math-rwcomp-instr 'copy reg1 reg2))))
980 (defun math-rwcomp-reg ()
983 (setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
984 math-num-regs (1+ math-num-regs))))
986 (defun math-rwcomp-reg-entry (num)
987 (nth (1- (- math-num-regs num)) math-regs))
990 (defun math-rwcomp-pattern (expr part &optional not-direct)
991 (cond ((or (math-rwcomp-no-vars expr)
992 (and (eq (car expr) 'calcFunc-quote)
994 (setq expr (nth 1 expr))))
995 (if (eq (car-safe expr) 'calcFunc-register)
996 (math-rwcomp-same-instr part (nth 1 expr) nil)
997 (let ((reg (math-rwcomp-reg)))
998 (setcar (nthcdr 3 (car math-regs)) expr)
999 (math-rwcomp-same-instr part reg nil))))
1000 ((eq (car expr) 'var)
1001 (let ((entry (assq (nth 2 expr) math-regs)))
1003 (math-rwcomp-same-instr part (nth 1 entry) nil)
1005 (let ((reg (math-rwcomp-reg)))
1006 (math-rwcomp-pattern expr reg)
1007 (math-rwcomp-copy-instr part reg nil))
1008 (if (setq entry (assq (nth 2 expr) math-aliased-vars))
1010 (setcar (math-rwcomp-reg-entry (nth 1 entry))
1013 (math-rwcomp-copy-instr part (nth 1 entry) nil))
1014 (math-rwcomp-bind-var part expr))))))
1015 ((and (eq (car expr) 'calcFunc-select)
1016 (= (length expr) 2))
1017 (let ((reg (math-rwcomp-reg)))
1018 (math-rwcomp-instr 'select part reg)
1019 (math-rwcomp-pattern (nth 1 expr) reg)))
1020 ((and (eq (car expr) 'calcFunc-opt)
1021 (memq (length expr) '(2 3)))
1022 (error "opt( ) occurs in context where it is not allowed"))
1023 ((eq (car expr) 'neg)
1024 (if (eq (car (nth 1 expr)) 'var)
1025 (let ((entry (assq (nth 2 (nth 1 expr)) math-regs)))
1027 (math-rwcomp-same-instr part (nth 1 entry) t)
1029 (let ((reg (math-rwcomp-best-reg (nth 1 expr))))
1030 (math-rwcomp-copy-instr part reg t)
1031 (math-rwcomp-pattern (nth 1 expr) reg))
1032 (setcar (cdr (cdr (math-rwcomp-reg-entry part))) t)
1033 (math-rwcomp-pattern (nth 1 expr) part))))
1034 (if (math-rwcomp-is-algebraic (nth 1 expr))
1035 (math-rwcomp-cond-instr (list 'calcFunc-eq
1036 (math-rwcomp-register-expr part)
1038 (let ((reg (math-rwcomp-reg)))
1039 (math-rwcomp-instr 'func part 'neg reg)
1040 (math-rwcomp-pattern (nth 1 expr) reg)))))
1041 ((and (eq (car expr) 'calcFunc-apply)
1042 (= (length expr) 3))
1043 (let ((reg1 (math-rwcomp-reg))
1044 (reg2 (math-rwcomp-reg)))
1045 (math-rwcomp-instr 'apply part reg1 reg2)
1046 (math-rwcomp-pattern (nth 1 expr) reg1)
1047 (math-rwcomp-pattern (nth 2 expr) reg2)))
1048 ((and (eq (car expr) 'calcFunc-cons)
1049 (= (length expr) 3))
1050 (let ((reg1 (math-rwcomp-reg))
1051 (reg2 (math-rwcomp-reg)))
1052 (math-rwcomp-instr 'cons part reg1 reg2)
1053 (math-rwcomp-pattern (nth 1 expr) reg1)
1054 (math-rwcomp-pattern (nth 2 expr) reg2)))
1055 ((and (eq (car expr) 'calcFunc-rcons)
1056 (= (length expr) 3))
1057 (let ((reg1 (math-rwcomp-reg))
1058 (reg2 (math-rwcomp-reg)))
1059 (math-rwcomp-instr 'rcons part reg1 reg2)
1060 (math-rwcomp-pattern (nth 1 expr) reg1)
1061 (math-rwcomp-pattern (nth 2 expr) reg2)))
1062 ((and (eq (car expr) 'calcFunc-condition)
1063 (>= (length expr) 3))
1064 (math-rwcomp-pattern (nth 1 expr) part)
1065 (setq expr (cdr expr))
1066 (while (setq expr (cdr expr))
1067 (let ((cond (math-flatten-lands (car expr))))
1069 (if (math-rwcomp-all-regs-done (car cond))
1070 (math-rwcomp-cond-instr (car cond))
1071 (setq math-conds (cons (car cond) math-conds)))
1072 (setq cond (cdr cond))))))
1073 ((and (eq (car expr) 'calcFunc-pand)
1074 (= (length expr) 3))
1075 (math-rwcomp-pattern (nth 1 expr) part)
1076 (math-rwcomp-pattern (nth 2 expr) part))
1077 ((and (eq (car expr) 'calcFunc-por)
1078 (= (length expr) 3))
1079 (math-rwcomp-instr 'alt nil nil [nil nil 4])
1080 (let ((math-conds nil)
1081 (head math-prog-last)
1082 (mark math-bound-vars)
1084 (math-rwcomp-pattern (nth 1 expr) part t)
1085 (let ((amark math-aliased-vars)
1086 (math-aliased-vars math-aliased-vars)
1087 (tail math-prog-last)
1090 (while (not (eq p mark))
1091 (setq entry (assq (car p) math-regs)
1092 math-aliased-vars (cons (list (car p) (nth 1 entry) nil)
1095 (setcar (math-rwcomp-reg-entry (nth 1 entry)) nil))
1096 (setcar (cdr (car head)) (cdr head))
1098 (setq math-prog-last head)
1099 (math-rwcomp-pattern (nth 2 expr) part)
1100 (math-rwcomp-instr 'same 0 0)
1101 (setcdr tail math-prog-last)
1102 (setq p math-aliased-vars)
1103 (while (not (eq p amark))
1105 (setcar (math-rwcomp-reg-entry (nth 1 (car p)))
1108 (math-rwcomp-do-conditions))
1109 ((and (eq (car expr) 'calcFunc-pnot)
1110 (= (length expr) 2))
1111 (math-rwcomp-instr 'alt nil nil [nil nil 4])
1112 (let ((head math-prog-last)
1113 (mark math-bound-vars))
1114 (math-rwcomp-pattern (nth 1 expr) part)
1115 (math-rwcomp-unbind-vars mark)
1116 (math-rwcomp-instr 'end-alt head)
1117 (math-rwcomp-instr 'backtrack)
1118 (setcar (cdr (car head)) (cdr head))
1120 (setq math-prog-last head)))
1121 (t (let ((props (get (car expr) 'math-rewrite-props)))
1122 (if (and (eq (car expr) 'calcFunc-plain)
1124 (not (math-primp (nth 1 expr))))
1125 (setq expr (nth 1 expr))) ; but "props" is still nil
1126 (if (and (memq 'algebraic props)
1127 (math-rwcomp-is-algebraic expr))
1128 (math-rwcomp-cond-instr (list 'calcFunc-eq
1129 (math-rwcomp-register-expr part)
1131 (if (and (memq 'commut props)
1132 (= (length expr) 3))
1133 (let ((arg1 (nth 1 expr))
1135 try1 def code head (flip nil))
1136 (if (eq (car expr) '-)
1137 (setq arg2 (math-rwcomp-neg arg2)))
1138 (setq arg1 (cons arg1 (math-rwcomp-best-reg arg1))
1139 arg2 (cons arg2 (math-rwcomp-best-reg arg2)))
1140 (or (math-rwcomp-order arg1 arg2)
1141 (setq def arg1 arg1 arg2 arg2 def flip t))
1142 (if (math-rwcomp-optional-arg (car expr) arg1)
1143 (error "Too many opt( ) arguments in this context"))
1144 (setq def (math-rwcomp-optional-arg (car expr) arg2)
1145 head (if (memq (car expr) '(+ -))
1147 (if (eq (car expr) '*)
1150 code (if (math-rwcomp-is-constrained
1152 (if (math-rwcomp-is-constrained
1156 (math-rwcomp-multi-instr (and def (list def))
1158 (vector nil nil nil code flip)
1160 (setq try1 (car math-prog-last))
1161 (math-rwcomp-pattern (car arg1) (cdr arg1))
1162 (math-rwcomp-instr 'try2 try1 (cdr arg2))
1163 (if (and (= part 0) (not def) (not math-rewrite-whole)
1164 (not (eq math-rhs t))
1165 (setq def (get (car expr)
1166 'math-rewrite-default)))
1167 (let ((reg1 (math-rwcomp-reg))
1168 (reg2 (math-rwcomp-reg)))
1169 (if (= (aref (nth 3 try1) 3) 0)
1170 (aset (nth 3 try1) 3 1))
1171 (math-rwcomp-instr 'try (cdr arg2)
1172 (if (equal head '(* /))
1179 (setq try1 (car math-prog-last))
1180 (math-rwcomp-pattern (car arg2) reg1)
1181 (math-rwcomp-instr 'try2 try1 reg2)
1182 (setq math-rhs (list (if (eq (car expr) '-)
1185 (list 'calcFunc-register
1187 (math-rwcomp-pattern (car arg2) (cdr arg2))))
1188 (let* ((args (mapcar (function
1190 (cons x (math-rwcomp-best-reg x))))
1192 (args2 (copy-sequence args))
1193 (argp (reverse args2))
1197 (let ((def (math-rwcomp-optional-arg (car expr)
1201 (setq args2 (delq (car argp) args2)
1202 defs (cons (cons def (cdr (car argp)))
1204 (math-rwcomp-multi-instr
1206 (if (or (and (memq 'unary1 props)
1207 (= (length args2) 1)
1208 (eq (car args2) (car args)))
1209 (and (memq 'unary2 props)
1211 (eq (car args2) (nth 1 args))))
1216 (setq argp (cdr argp)))
1217 (math-rwcomp-multi-instr (mapcar 'cdr args)
1218 'func part (car expr))
1219 (setq args (sort args 'math-rwcomp-order))
1221 (math-rwcomp-pattern (car (car args)) (cdr (car args)))
1223 args (cdr args))))))))))
1225 (defun math-rwcomp-best-reg (x)
1226 (or (and (eq (car-safe x) 'var)
1227 (let ((entry (assq (nth 2 x) math-aliased-vars)))
1230 (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry))))
1232 (setcar (cdr (cdr entry)) t)
1236 (defun math-rwcomp-all-regs-done (expr)
1237 (if (Math-primp expr)
1238 (or (not (eq (car-safe expr) 'var))
1239 (assq (nth 2 expr) math-regs)
1240 (eq (nth 2 expr) 'var-remember)
1241 (math-const-var expr))
1242 (if (and (eq (car expr) 'calcFunc-let)
1243 (= (length expr) 3))
1244 (math-rwcomp-all-regs-done (nth 2 expr))
1245 (if (and (eq (car expr) 'calcFunc-let)
1247 (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
1248 (= (length (nth 1 expr)) 3))
1249 (math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
1250 (while (and (setq expr (cdr expr))
1251 (math-rwcomp-all-regs-done (car expr))))
1254 (defun math-rwcomp-no-vars (expr)
1255 (if (Math-primp expr)
1256 (or (not (eq (car-safe expr) 'var))
1257 (math-const-var expr))
1258 (and (not (memq (car expr) '(calcFunc-condition
1259 calcFunc-select calcFunc-quote
1260 calcFunc-plain calcFunc-opt
1261 calcFunc-por calcFunc-pand
1262 calcFunc-pnot calcFunc-apply
1263 calcFunc-cons calcFunc-rcons)))
1265 (while (and (setq expr (cdr expr))
1266 (math-rwcomp-no-vars (car expr))))
1269 (defun math-rwcomp-is-algebraic (expr)
1270 (if (Math-primp expr)
1271 (or (not (eq (car-safe expr) 'var))
1272 (math-const-var expr)
1273 (assq (nth 2 expr) math-regs))
1274 (and (memq 'algebraic (get (car expr) 'math-rewrite-props))
1276 (while (and (setq expr (cdr expr))
1277 (math-rwcomp-is-algebraic (car expr))))
1280 (defun math-rwcomp-is-constrained (expr not-these)
1281 (if (Math-primp expr)
1282 (not (eq (car-safe expr) 'var))
1283 (if (eq (car expr) 'calcFunc-plain)
1284 (math-rwcomp-is-constrained (nth 1 expr) not-these)
1285 (not (or (memq (car expr) '(neg calcFunc-select))
1286 (memq (car expr) not-these)
1287 (and (memq 'commut (get (car expr) 'math-rewrite-props))
1288 (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
1289 (eq (car-safe (nth 2 expr)) 'calcFunc-opt))))))))
1291 (defun math-rwcomp-optional-arg (head argp)
1292 (let ((arg (car argp)))
1293 (if (eq (car-safe arg) 'calcFunc-opt)
1294 (and (memq (length arg) '(2 3))
1296 (or (eq (car-safe (nth 1 arg)) 'var)
1297 (error "First argument of opt( ) must be a variable"))
1298 (setcar argp (nth 1 arg))
1299 (if (= (length arg) 2)
1300 (or (get head 'math-rewrite-default)
1301 (error "opt( ) must include a default in this context"))
1303 (and (eq (car-safe arg) 'neg)
1304 (let* ((part (list (nth 1 arg)))
1305 (partp (math-rwcomp-optional-arg head part)))
1307 (setcar argp (math-rwcomp-neg (car part)))
1308 (math-neg partp)))))))
1310 (defun math-rwcomp-neg (expr)
1311 (if (memq (car-safe expr) '(* /))
1312 (if (eq (car-safe (nth 1 expr)) 'var)
1313 (list (car expr) (list 'neg (nth 1 expr)) (nth 2 expr))
1314 (if (eq (car-safe (nth 2 expr)) 'var)
1315 (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
1319 (defun math-rwcomp-assoc-args (expr)
1320 (if (and (eq (car-safe (nth 1 expr)) (car expr))
1321 (= (length (nth 1 expr)) 3))
1322 (math-rwcomp-assoc-args (nth 1 expr)))
1323 (if (and (eq (car-safe (nth 2 expr)) (car expr))
1324 (= (length (nth 2 expr)) 3))
1325 (math-rwcomp-assoc-args (nth 2 expr))))
1327 (defun math-rwcomp-addsub-args (expr)
1328 (if (memq (car-safe (nth 1 expr)) '(+ -))
1329 (math-rwcomp-addsub-args (nth 1 expr)))
1330 (if (eq (car expr) '-)
1332 (if (eq (car-safe (nth 2 expr)) '+)
1333 (math-rwcomp-addsub-args (nth 2 expr)))))
1335 (defun math-rwcomp-order (a b)
1336 (< (math-rwcomp-priority (car a))
1337 (math-rwcomp-priority (car b))))
1339 ;;; Order of priority: 0 Constants and other exact matches (first)
1340 ;;; 10 Functions (except below)
1341 ;;; 20 Meta-variables which occur more than once
1342 ;;; 30 Algebraic functions
1343 ;;; 40 Commutative/associative functions
1344 ;;; 50 Meta-variables which occur only once
1345 ;;; +100 for every "!!!" (pnot) in the pattern
1346 ;;; 10000 Optional arguments (last)
1348 (defun math-rwcomp-priority (expr)
1349 (+ (math-rwcomp-count-pnots expr)
1350 (cond ((eq (car-safe expr) 'calcFunc-opt)
1352 ((math-rwcomp-no-vars expr)
1354 ((eq (car expr) 'calcFunc-quote)
1356 ((eq (car expr) 'var)
1357 (if (assq (nth 2 expr) math-regs)
1359 (if (= (math-rwcomp-count-refs expr) 1)
1362 (t (let ((props (get (car expr) 'math-rewrite-props)))
1363 (if (or (memq 'commut props)
1364 (memq 'assoc props))
1366 (if (memq 'algebraic props)
1370 (defun math-rwcomp-count-refs (var)
1371 (let ((count (or (math-expr-contains-count math-pattern var) 0))
1374 (if (eq (car-safe (car p)) 'calcFunc-let)
1375 (if (= (length (car p)) 3)
1376 (setq count (+ count
1377 (or (math-expr-contains-count (nth 2 (car p)) var)
1379 (if (and (= (length (car p)) 2)
1380 (eq (car-safe (nth 1 (car p))) 'calcFunc-assign)
1381 (= (length (nth 1 (car p))) 3))
1382 (setq count (+ count
1383 (or (math-expr-contains-count
1384 (nth 2 (nth 1 (car p))) var) 0))))))
1388 (defun math-rwcomp-count-pnots (expr)
1389 (if (Math-primp expr)
1391 (if (eq (car expr) 'calcFunc-pnot)
1394 (while (setq expr (cdr expr))
1395 (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
1398 ;;; In the current implementation, all associative functions must
1399 ;;; also be commutative.
1401 (put '+ 'math-rewrite-props '(algebraic assoc commut))
1402 (put '- 'math-rewrite-props '(algebraic assoc commut)) ; see below
1403 (put '* 'math-rewrite-props '(algebraic assoc commut)) ; see below
1404 (put '/ 'math-rewrite-props '(algebraic unary1))
1405 (put '^ 'math-rewrite-props '(algebraic unary1))
1406 (put '% 'math-rewrite-props '(algebraic))
1407 (put 'neg 'math-rewrite-props '(algebraic))
1408 (put 'calcFunc-idiv 'math-rewrite-props '(algebraic))
1409 (put 'calcFunc-abs 'math-rewrite-props '(algebraic))
1410 (put 'calcFunc-sign 'math-rewrite-props '(algebraic))
1411 (put 'calcFunc-round 'math-rewrite-props '(algebraic))
1412 (put 'calcFunc-rounde 'math-rewrite-props '(algebraic))
1413 (put 'calcFunc-roundu 'math-rewrite-props '(algebraic))
1414 (put 'calcFunc-trunc 'math-rewrite-props '(algebraic))
1415 (put 'calcFunc-floor 'math-rewrite-props '(algebraic))
1416 (put 'calcFunc-ceil 'math-rewrite-props '(algebraic))
1417 (put 'calcFunc-re 'math-rewrite-props '(algebraic))
1418 (put 'calcFunc-im 'math-rewrite-props '(algebraic))
1419 (put 'calcFunc-conj 'math-rewrite-props '(algebraic))
1420 (put 'calcFunc-arg 'math-rewrite-props '(algebraic))
1421 (put 'calcFunc-and 'math-rewrite-props '(assoc commut))
1422 (put 'calcFunc-or 'math-rewrite-props '(assoc commut))
1423 (put 'calcFunc-xor 'math-rewrite-props '(assoc commut))
1424 (put 'calcFunc-eq 'math-rewrite-props '(commut))
1425 (put 'calcFunc-neq 'math-rewrite-props '(commut))
1426 (put 'calcFunc-land 'math-rewrite-props '(assoc commut))
1427 (put 'calcFunc-lor 'math-rewrite-props '(assoc commut))
1428 (put 'calcFunc-beta 'math-rewrite-props '(commut))
1429 (put 'calcFunc-gcd 'math-rewrite-props '(assoc commut))
1430 (put 'calcFunc-lcm 'math-rewrite-props '(assoc commut))
1431 (put 'calcFunc-max 'math-rewrite-props '(algebraic assoc commut))
1432 (put 'calcFunc-min 'math-rewrite-props '(algebraic assoc commut))
1433 (put 'calcFunc-vunion 'math-rewrite-props '(assoc commut))
1434 (put 'calcFunc-vint 'math-rewrite-props '(assoc commut))
1435 (put 'calcFunc-vxor 'math-rewrite-props '(assoc commut))
1437 ;;; Note: "*" is not commutative for matrix args, but we pretend it is.
1438 ;;; Also, "-" is not commutative but the code tweaks things so that it is.
1440 (put '+ 'math-rewrite-default 0)
1441 (put '- 'math-rewrite-default 0)
1442 (put '* 'math-rewrite-default 1)
1443 (put '/ 'math-rewrite-default 1)
1444 (put '^ 'math-rewrite-default 1)
1445 (put 'calcFunc-land 'math-rewrite-default 1)
1446 (put 'calcFunc-lor 'math-rewrite-default 0)
1447 (put 'calcFunc-vunion 'math-rewrite-default '(vec))
1448 (put 'calcFunc-vint 'math-rewrite-default '(vec))
1449 (put 'calcFunc-vdiff 'math-rewrite-default '(vec))
1450 (put 'calcFunc-vxor 'math-rewrite-default '(vec))
1452 (defmacro math-rwfail (&optional back)
1456 '(setq btrack (cdr btrack))
1460 ;;; This monstrosity is necessary because the use of static vectors of
1461 ;;; registers makes rewrite rules non-reentrant. Yucko!
1462 (defmacro math-rweval (form)
1463 (list 'let '((orig (car rules)))
1464 '(setcar rules (quote (nil nil nil no-phase)))
1465 (list 'unwind-protect
1467 '(setcar rules orig))))
1469 (defvar math-rewrite-phase 1)
1471 ;; The variable math-apply-rw-regs is local to math-apply-rewrites,
1472 ;; but is used by math-rwapply-replace-regs and math-rwapply-reg-looks-negp
1473 ;; which are called by math-apply-rewrites.
1474 (defvar math-apply-rw-regs)
1476 ;; The variable math-apply-rw-ruleset is local to math-apply-rewrites,
1477 ;; but is used by math-rwapply-remember.
1478 (defvar math-apply-rw-ruleset)
1480 (defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset)
1482 (setq rules (cdr (or (assq (car-safe expr) rules)
1485 op math-apply-rw-regs inst part pc mark btrack
1486 (tracing math-rwcomp-tracing)
1487 (phase math-rewrite-phase))
1490 (and (setq part (nth 2 (car rules)))
1492 (not (memq part heads)))
1493 (and (setq part (nth 3 (car rules)))
1494 (not (memq phase part)))
1496 (setq math-apply-rw-regs (car (car rules))
1497 pc (nth 1 (car rules))
1499 (aset math-apply-rw-regs 0 expr)
1503 (progn (terpri) (princ (car pc))
1504 (if (and (natnump (nth 1 (car pc)))
1505 (< (nth 1 (car pc)) (length math-apply-rw-regs)))
1507 (format "\n part = %s"
1508 (aref math-apply-rw-regs (nth 1 (car pc))))))))
1510 (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
1512 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1514 (car (setq inst (cdr (cdr inst)))))
1516 (while (and (setq inst (cdr inst)
1519 (aset math-apply-rw-regs (car inst) (car part)))
1520 (not (or inst part))))
1525 (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1526 (setq mark (aref math-apply-rw-regs (nth 2 inst))))
1527 (Math-equal part mark))
1533 (not (eq calc-matrix-mode 'scalar))
1534 (eq (car (nth 2 inst)) '*)
1535 (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1537 (not (math-known-scalarp part)))
1538 (setq mark (nth 3 inst)
1542 (aset math-apply-rw-regs (nth 4 inst) (nth 2 part))
1543 (aset mark 1 (cdr (cdr part))))
1544 (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1545 (aset mark 1 (cdr part)))
1546 (aset mark 0 (cdr part))
1550 (if (and (consp (setq part
1551 (aref math-apply-rw-regs (car (cdr inst)))))
1552 (memq (car part) (nth 2 inst))
1554 (or (not (eq (car part) '/))
1555 (Math-objectp (nth 2 part))))
1558 mark (car (cdr (setq inst (cdr (cdr inst))))))
1560 (memq 'assoc (get (car part) 'math-rewrite-props))
1561 (not (= (aref mark 3) 0))
1562 (while (if (and (consp (nth 1 part))
1563 (memq (car (nth 1 part)) (car inst)))
1564 (setq op (cons (if (eq (car part) '-)
1570 (if (and (consp (nth 2 part))
1571 (memq (car (nth 2 part))
1573 (not (eq (car (nth 2 part)) '-)))
1574 (setq op (cons (nth 1 part) op)
1575 part (nth 2 part))))))
1576 (setq op (cons (nth 1 part)
1577 (cons (if (eq (car part) '-)
1580 (if (eq (car part) '/)
1585 btrack (cons pc btrack)
1587 (aset math-apply-rw-regs (nth 2 inst) (car op))
1590 (aset mark 2 (if (cdr (cdr op)) 1 0)))
1592 (if (and (consp part)
1593 (eq (car part) 'neg)
1594 (eq (car (nth 2 inst)) '*)
1595 (eq (nth 5 inst) 1))
1597 (setq mark (nth 3 inst)
1599 (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1602 (setq mark (nth 3 inst)
1604 (aset math-apply-rw-regs (nth 4 inst) part)
1609 (setq part (nth 1 inst) ; try instr
1613 (aset math-apply-rw-regs (nth 2 inst)
1616 (if (eq (aref mark 0) (aref mark 1))
1617 (nth 1 (aref mark 0))
1618 (car (aref mark 0))))
1620 (setq mark (delq (car (aref mark 1))
1621 (copy-sequence (aref mark 0)))
1622 op (car (nth 2 part)))
1625 (setq mark (nreverse mark)
1626 part (list '* (nth 1 mark) (car mark))
1628 (while (setq mark (cdr mark))
1629 (setq part (list '* (car mark) part))))
1630 (setq part (car mark)
1632 part (if (and (eq op '+)
1634 (eq (car (car mark)) 'neg))
1637 (list op part (car mark))))
1638 (while (setq mark (cdr mark))
1639 (setq part (if (and (eq op '+)
1641 (eq (car (car mark)) 'neg))
1644 (list op part (car mark))))))
1647 (car (aref mark 1)))
1648 ((eq op 3) (nth 5 part))
1649 (t (aref mark 1)))))
1653 (if (and (consp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1654 (eq (car part) 'calcFunc-select))
1655 (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1656 (if math-rewrite-selections
1658 (aset math-apply-rw-regs (nth 2 inst) part))))
1661 (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1662 (setq mark (math-neg
1663 (aref math-apply-rw-regs (nth 2 inst)))))
1664 (Math-equal part mark))
1669 (setq inst (car (car btrack)) ; "try" or "alt" instr
1670 pc (cdr (car btrack))
1671 mark (or (nth 3 inst) [nil nil 4])
1674 (if (setq op (cdr (aref mark 1)))
1675 (aset math-apply-rw-regs (nth 4 inst)
1676 (car (aset mark 1 op)))
1680 (aset math-apply-rw-regs (nth 4 inst)
1681 (aref math-apply-rw-regs (nth 1 inst))))
1684 (if (setq op (cdr (aref mark 1)))
1685 (aset math-apply-rw-regs (nth 4 inst)
1686 (car (aset mark 1 op)))
1687 (if (= (aref mark 3) 1)
1691 (aset math-apply-rw-regs (nth 4 inst)
1692 (aref math-apply-rw-regs (nth 1 inst))))
1695 (aset mark 1 (cons nil (aref mark 0)))
1698 (if (setq op (cdr (aref mark 1)))
1700 (setq mark (delq (car (aset mark 1 op))
1703 op (car (nth 2 inst)))
1706 (setq mark (nreverse mark)
1707 part (list '* (nth 1 mark)
1710 (while (setq mark (cdr mark))
1711 (setq part (list '* (car mark)
1713 (setq part (car mark)
1715 part (if (and (eq op '+)
1717 (eq (car (car mark))
1721 (list op part (car mark))))
1722 (while (setq mark (cdr mark))
1723 (setq part (if (and (eq op '+)
1725 (eq (car (car mark))
1729 (list op part (car mark))))))
1730 (aset math-apply-rw-regs (nth 4 inst) part))
1734 (aset math-apply-rw-regs (nth 4 inst)
1735 (aref math-apply-rw-regs (nth 1 inst))))
1738 (setq btrack (cdr btrack)))
1739 (t (math-rwfail t))))
1742 (if (Math-integerp (setq part
1743 (aref math-apply-rw-regs (nth 1 inst))))
1745 (if (Math-primp part)
1747 (setq part (math-rweval (math-simplify part)))
1748 (if (Math-integerp part)
1753 (if (Math-realp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1755 (if (Math-primp part)
1757 (setq part (math-rweval (math-simplify part)))
1758 (if (Math-realp part)
1763 (if (math-constp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1765 (if (Math-primp part)
1767 (setq part (math-rweval (math-simplify part)))
1768 (if (math-constp part)
1773 (if (math-looks-negp (setq part
1774 (aref math-apply-rw-regs (nth 1 inst))))
1776 (if (Math-primp part)
1778 (setq part (math-rweval (math-simplify part)))
1779 (if (math-looks-negp part)
1784 (setq part (math-compare (aref math-apply-rw-regs (nth 1 inst))
1785 (aref math-apply-rw-regs (nth 3 inst)))
1788 (setq part (math-rweval
1792 (aref math-apply-rw-regs (nth 1 inst))
1793 (aref math-apply-rw-regs (nth 3 inst))))))))
1794 (if (cond ((eq op 'calcFunc-eq)
1796 ((eq op 'calcFunc-neq)
1797 (memq part '(-1 1)))
1798 ((eq op 'calcFunc-lt)
1800 ((eq op 'calcFunc-leq)
1801 (memq part '(-1 0)))
1802 ((eq op 'calcFunc-gt)
1804 ((eq op 'calcFunc-geq)
1805 (memq part '(0 1))))
1811 (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1813 (car (setq inst (cdr (cdr inst))))))
1815 (setq inst (cdr inst)
1817 (while (and (setq inst (cdr inst)
1820 (aset math-apply-rw-regs (car inst) (car part)))
1823 (while (eq (car (car (setq pc (cdr pc))))
1825 (setq pc (cdr pc)) ; skip over "func"
1827 (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1828 (setq mark (cdr mark)))))
1835 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1836 (eq (car part) (nth 2 inst))))
1837 (and (= (length part) 2)
1838 (setq part (nth 1 part))))
1840 (setq mark (nth 3 inst))
1841 (aset math-apply-rw-regs (nth 4 inst) part)
1842 (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
1843 (setq pc (cdr pc)) ; skip over "func"
1845 (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1846 (setq mark (cdr mark))))
1847 (setq pc (cdr pc))))
1851 (setq part (aref math-apply-rw-regs (nth 1 inst))))
1852 (Math-zerop (nth 3 inst))
1853 (and (not (Math-zerop (nth 2 inst)))
1855 (setq part (math-mod part (nth 2 inst)))
1856 (or (Math-numberp part)
1857 (setq part (math-rweval
1858 (math-simplify part))))
1859 (Math-equal part (nth 3 inst)))))
1865 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1866 (not (Math-objvecp part))
1867 (not (eq (car part) 'var)))
1869 (aset math-apply-rw-regs (nth 2 inst)
1870 (math-calcFunc-to-var (car part)))
1871 (aset math-apply-rw-regs (nth 3 inst)
1872 (cons 'vec (cdr part)))
1878 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1879 (eq (car part) 'vec)
1882 (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1883 (aset math-apply-rw-regs (nth 3 inst)
1884 (cons 'vec (cdr (cdr part))))
1890 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1891 (eq (car part) 'vec)
1894 (aset math-apply-rw-regs (nth 2 inst) (calcFunc-rhead part))
1895 (aset math-apply-rw-regs (nth 3 inst) (calcFunc-rtail part))
1903 (math-rwapply-replace-regs (nth 1 inst)))))
1908 (aset math-apply-rw-regs (nth 1 inst)
1911 (math-rwapply-replace-regs (nth 2 inst)))))
1915 (aset math-apply-rw-regs (nth 2 inst)
1916 (aref math-apply-rw-regs (nth 1 inst)))
1920 (aset math-apply-rw-regs (nth 2 inst)
1921 (math-rwapply-neg (aref math-apply-rw-regs (nth 1 inst))))
1925 (setq btrack (cons pc btrack)
1929 (while (and btrack (not (eq (car btrack) (nth 1 inst))))
1930 (setq btrack (cdr btrack)))
1931 (setq btrack (cdr btrack)
1935 (setq result (math-rwapply-replace-regs (nth 1 inst)))
1936 (if (or (and (eq (car-safe result) '+)
1937 (eq (nth 2 result) 0))
1938 (and (eq (car-safe result) '*)
1939 (eq (nth 2 result) 1)))
1940 (setq result (nth 1 result)))
1941 (setq part (and (nth 2 inst)
1945 (math-rwapply-replace-regs
1947 (if (or (equal result expr)
1948 (equal (setq result (math-normalize result)) expr))
1950 (if part (math-rwapply-remember expr result))
1954 (t (error "%s is not a valid rewrite opcode" op))))))
1955 (setq rules (cdr rules)))
1958 (defun math-rwapply-neg (expr)
1959 (if (and (consp expr)
1960 (memq (car expr) '(* /)))
1961 (if (Math-objectp (nth 2 expr))
1962 (list (car expr) (nth 1 expr) (math-neg (nth 2 expr)))
1964 (if (Math-objectp (nth 1 expr))
1965 (math-neg (nth 1 expr))
1966 (list '* -1 (nth 1 expr)))
1970 (defun math-rwapply-inv (expr)
1971 (if (and (Math-integerp expr)
1973 (math-make-frac 1 expr)
1976 (defun math-rwapply-replace-regs (expr)
1977 (cond ((Math-primp expr)
1979 ((eq (car expr) 'calcFunc-register)
1980 (setq expr (aref math-apply-rw-regs (nth 1 expr)))
1981 (if (eq (car-safe expr) '*)
1982 (if (eq (nth 1 expr) -1)
1983 (math-neg (nth 2 expr))
1984 (if (eq (nth 1 expr) 1)
1988 ((and (eq (car expr) 'calcFunc-eval)
1989 (= (length expr) 2))
1990 (calc-with-default-simplification
1991 (math-normalize (math-rwapply-replace-regs (nth 1 expr)))))
1992 ((and (eq (car expr) 'calcFunc-evalsimp)
1993 (= (length expr) 2))
1994 (math-simplify (math-rwapply-replace-regs (nth 1 expr))))
1995 ((and (eq (car expr) 'calcFunc-evalextsimp)
1996 (= (length expr) 2))
1997 (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr))))
1998 ((and (eq (car expr) 'calcFunc-apply)
1999 (= (length expr) 3))
2000 (let ((func (math-rwapply-replace-regs (nth 1 expr)))
2001 (args (math-rwapply-replace-regs (nth 2 expr)))
2003 (if (and (math-vectorp args)
2004 (not (eq (car-safe (setq call (math-build-call
2005 (math-var-to-calcFunc func)
2009 (list 'calcFunc-apply func args))))
2010 ((and (eq (car expr) 'calcFunc-cons)
2011 (= (length expr) 3))
2012 (let ((head (math-rwapply-replace-regs (nth 1 expr)))
2013 (tail (math-rwapply-replace-regs (nth 2 expr))))
2014 (if (math-vectorp tail)
2015 (cons 'vec (cons head (cdr tail)))
2016 (list 'calcFunc-cons head tail))))
2017 ((and (eq (car expr) 'calcFunc-rcons)
2018 (= (length expr) 3))
2019 (let ((head (math-rwapply-replace-regs (nth 1 expr)))
2020 (tail (math-rwapply-replace-regs (nth 2 expr))))
2021 (if (math-vectorp head)
2022 (append head (list tail))
2023 (list 'calcFunc-rcons head tail))))
2024 ((and (eq (car expr) 'neg)
2025 (math-rwapply-reg-looks-negp (nth 1 expr)))
2026 (math-rwapply-reg-neg (nth 1 expr)))
2027 ((and (eq (car expr) 'neg)
2028 (eq (car-safe (nth 1 expr)) 'calcFunc-register)
2029 (math-scalarp (aref math-apply-rw-regs (nth 1 (nth 1 expr)))))
2030 (math-neg (math-rwapply-replace-regs (nth 1 expr))))
2031 ((and (eq (car expr) '+)
2032 (math-rwapply-reg-looks-negp (nth 1 expr)))
2033 (list '- (math-rwapply-replace-regs (nth 2 expr))
2034 (math-rwapply-reg-neg (nth 1 expr))))
2035 ((and (eq (car expr) '+)
2036 (math-rwapply-reg-looks-negp (nth 2 expr)))
2037 (list '- (math-rwapply-replace-regs (nth 1 expr))
2038 (math-rwapply-reg-neg (nth 2 expr))))
2039 ((and (eq (car expr) '-)
2040 (math-rwapply-reg-looks-negp (nth 2 expr)))
2041 (list '+ (math-rwapply-replace-regs (nth 1 expr))
2042 (math-rwapply-reg-neg (nth 2 expr))))
2044 (cond ((eq (nth 1 expr) -1)
2045 (if (math-rwapply-reg-looks-negp (nth 2 expr))
2046 (math-rwapply-reg-neg (nth 2 expr))
2047 (math-neg (math-rwapply-replace-regs (nth 2 expr)))))
2048 ((eq (nth 1 expr) 1)
2049 (math-rwapply-replace-regs (nth 2 expr)))
2050 ((eq (nth 2 expr) -1)
2051 (if (math-rwapply-reg-looks-negp (nth 1 expr))
2052 (math-rwapply-reg-neg (nth 1 expr))
2053 (math-neg (math-rwapply-replace-regs (nth 1 expr)))))
2054 ((eq (nth 2 expr) 1)
2055 (math-rwapply-replace-regs (nth 1 expr)))
2057 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
2058 (arg2 (math-rwapply-replace-regs (nth 2 expr))))
2059 (cond ((and (eq (car-safe arg1) '/)
2060 (eq (nth 1 arg1) 1))
2061 (list '/ arg2 (nth 2 arg1)))
2062 ((and (eq (car-safe arg2) '/)
2063 (eq (nth 1 arg2) 1))
2064 (list '/ arg1 (nth 2 arg2)))
2065 (t (list '* arg1 arg2)))))))
2067 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
2068 (arg2 (math-rwapply-replace-regs (nth 2 expr))))
2069 (if (eq (car-safe arg2) '/)
2070 (list '/ (list '* arg1 (nth 2 arg2)) (nth 1 arg2))
2071 (list '/ arg1 arg2))))
2072 ((and (eq (car expr) 'calcFunc-plain)
2073 (= (length expr) 2))
2074 (if (Math-primp (nth 1 expr))
2076 (if (eq (car (nth 1 expr)) 'calcFunc-register)
2077 (aref math-apply-rw-regs (nth 1 (nth 1 expr)))
2078 (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
2079 (cdr (nth 1 expr)))))))
2080 (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))))
2082 (defun math-rwapply-reg-looks-negp (expr)
2083 (if (eq (car-safe expr) 'calcFunc-register)
2084 (math-looks-negp (aref math-apply-rw-regs (nth 1 expr)))
2085 (if (memq (car-safe expr) '(* /))
2086 (or (math-rwapply-reg-looks-negp (nth 1 expr))
2087 (math-rwapply-reg-looks-negp (nth 2 expr))))))
2089 (defun math-rwapply-reg-neg (expr) ; expr must satisfy rwapply-reg-looks-negp
2090 (if (eq (car expr) 'calcFunc-register)
2091 (math-neg (math-rwapply-replace-regs expr))
2092 (if (math-rwapply-reg-looks-negp (nth 1 expr))
2093 (math-rwapply-replace-regs (list (car expr)
2094 (math-rwapply-reg-neg (nth 1 expr))
2096 (math-rwapply-replace-regs (list (car expr)
2098 (math-rwapply-reg-neg (nth 2 expr)))))))
2100 (defun math-rwapply-remember (old new)
2101 (let ((varval (symbol-value (nth 2 (car math-apply-rw-ruleset))))
2102 (rules (assq (car-safe old) math-apply-rw-ruleset)))
2103 (if (and (eq (car-safe varval) 'vec)
2104 (not (memq (car-safe old) '(nil schedule + -)))
2107 (setcdr varval (cons (list 'calcFunc-assign
2108 (if (math-rwcomp-no-vars old)
2110 (list 'calcFunc-quote old))
2113 (setcdr rules (cons (list (vector nil old)
2114 (list (list 'same 0 1)
2115 (list 'done new nil))
2119 ;;; arch-tag: ca8d7b7d-bff1-4535-90f3-e2241f5e786b
2120 ;;; calc-rewr.el ends here