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 ;; Maintainers: D. Goel <deego@gnufans.org>
7 ;; Colin Walters <walters@debian.org>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is distributed in the hope that it will be useful,
12 ;; but WITHOUT ANY WARRANTY. No author or distributor
13 ;; accepts responsibility to anyone for the consequences of using it
14 ;; or for whether it serves any particular purpose or works at all,
15 ;; unless he says so in writing. Refer to the GNU Emacs General Public
16 ;; License for full details.
18 ;; Everyone is granted permission to copy, modify and redistribute
19 ;; GNU Emacs, but only under the conditions described in the
20 ;; GNU Emacs General Public License. A copy of this license is
21 ;; supposed to have been given to you along with GNU Emacs so you
22 ;; can know your rights and responsibilities. It should be in a
23 ;; file named COPYING. Among other things, the copyright notice
24 ;; and this notice must be preserved on all copies.
30 ;; This file is autoloaded from calc-ext.el.
35 (defun calc-Need-calc-rewr () nil
)
38 (defvar math-rewrite-default-iters
100)
39 (defun calc-rewrite-selection (rules-str &optional many prefix
)
40 (interactive "sRewrite rule(s): \np")
43 (let* ((num (max 1 (calc-locate-cursor-element (point))))
46 (entry (calc-top num
'entry
))
48 (sel (calc-auto-selection entry
))
49 (math-rewrite-selections t
)
50 (math-rewrite-default-iters 1))
51 (if (or (null rules-str
) (equal rules-str
"") (equal rules-str
"$"))
53 (error "Can't use same stack entry for formula and rules")
54 (setq rules
(calc-top-n 1 t
)
56 (setq rules
(if (stringp rules-str
)
57 (math-read-exprs rules-str
) rules-str
))
58 (if (eq (car-safe rules
) 'error
)
59 (error "Bad format in expression: %s" (nth 1 rules
)))
60 (if (= (length rules
) 1)
61 (setq rules
(car rules
))
62 (setq rules
(cons 'vec rules
)))
63 (or (memq (car-safe rules
) '(vec var calcFunc-assign
65 (let ((rhs (math-read-expr
66 (read-string (concat "Rewrite from: " rules-str
68 (if (eq (car-safe rhs
) 'error
)
69 (error "Bad format in expression: %s" (nth 1 rhs
)))
70 (setq rules
(list 'calcFunc-assign rules rhs
))))
71 (or (eq (car-safe rules
) 'var
)
72 (calc-record rules
"rule")))
74 (setq many
'(var inf var-inf
))
75 (if many
(setq many
(prefix-numeric-value many
))))
77 (setq expr
(calc-replace-sub-formula (car entry
)
79 (list 'calcFunc-select sel
)))
80 (setq expr
(car entry
)
82 math-rewrite-selections nil
))
83 (setq expr
(calc-encase-atoms
89 expr
(calc-locate-select-marker expr
))
90 (or (consp sel
) (setq sel nil
))
91 (if pop-rules
(calc-pop-stack 1))
92 (calc-pop-push-record-list 1 (or prefix
"rwrt") (list expr
)
93 (- num
(if pop-rules
1 0))
94 (list (and reselect sel
))))
97 (defun calc-locate-select-marker (expr) ; changes "sel"
100 (if (and (eq (car expr
) 'calcFunc-select
)
103 (setq sel
(if sel t
(nth 1 expr
)))
106 (mapcar 'calc-locate-select-marker
(cdr expr
))))))
110 (defun calc-rewrite (rules-str many
)
111 (interactive "sRewrite rule(s): \nP")
114 (if (or (null rules-str
) (equal rules-str
"") (equal rules-str
"$"))
115 (setq expr
(calc-top-n 2)
116 rules
(calc-top-n 1 t
)
118 (setq rules
(if (stringp rules-str
)
119 (math-read-exprs rules-str
) rules-str
))
120 (if (eq (car-safe rules
) 'error
)
121 (error "Bad format in expression: %s" (nth 1 rules
)))
122 (if (= (length rules
) 1)
123 (setq rules
(car rules
))
124 (setq rules
(cons 'vec rules
)))
125 (or (memq (car-safe rules
) '(vec var calcFunc-assign
127 (let ((rhs (math-read-expr
128 (read-string (concat "Rewrite from: " rules-str
130 (if (eq (car-safe rhs
) 'error
)
131 (error "Bad format in expression: %s" (nth 1 rhs
)))
132 (setq rules
(list 'calcFunc-assign rules rhs
))))
133 (or (eq (car-safe rules
) 'var
)
134 (calc-record rules
"rule"))
135 (setq expr
(calc-top-n 1)
138 (setq many
'(var inf var-inf
))
139 (if many
(setq many
(prefix-numeric-value many
))))
140 (setq expr
(calc-normalize (math-rewrite expr rules many
)))
142 (setq expr
(calc-locate-select-marker expr
)))
143 (calc-pop-push-record-list n
"rwrt" (list expr
)))
146 (defun calc-match (pat)
147 (interactive "sPattern: \n")
150 (if (or (null pat
) (equal pat
"") (equal pat
"$"))
151 (setq expr
(calc-top-n 2)
154 (if (interactive-p) (setq calc-previous-alg-entry pat
))
155 (setq pat
(if (stringp pat
) (math-read-expr pat
) pat
))
156 (if (eq (car-safe pat
) 'error
)
157 (error "Bad format in expression: %s" (nth 1 pat
)))
158 (if (not (eq (car-safe pat
) 'var
))
159 (calc-record pat
"pat"))
160 (setq expr
(calc-top-n 1)
162 (or (math-vectorp expr
) (error "Argument must be a vector"))
163 (if (calc-is-inverse)
164 (calc-enter-result n
"mtcn" (math-match-patterns pat expr t
))
165 (calc-enter-result n
"mtch" (math-match-patterns pat expr nil
))))))
169 (defun math-rewrite (whole-expr rules
&optional mmt-many
)
170 (let ((crules (math-compile-rewrites rules
))
171 (heads (math-rewrite-heads whole-expr
))
172 (trace-buffer (get-buffer "*Trace*"))
173 (calc-display-just 'center
)
174 (calc-display-origin 39)
175 (calc-line-breaking 78)
176 (calc-line-numbering nil
)
177 (calc-show-selections t
)
181 (let ((result (math-apply-rewrites x
(cdr crules
)
186 (let ((fmt (math-format-stack-value
187 (list result nil nil
))))
189 (set-buffer trace-buffer
)
190 (insert "\nrewrite to\n" fmt
"\n"))))
191 (setq heads
(math-rewrite-heads result heads t
))))
194 (let ((fmt (math-format-stack-value (list whole-expr nil nil
))))
196 (set-buffer trace-buffer
)
197 (setq truncate-lines t
)
198 (goto-char (point-max))
199 (insert "\n\nBegin rewriting\n" fmt
"\n"))))
200 (or mmt-many
(setq mmt-many
(or (nth 1 (car crules
))
201 math-rewrite-default-iters
)))
202 (if (equal mmt-many
'(var inf var-inf
)) (setq mmt-many
1000000))
203 (if (equal mmt-many
'(neg (var inf var-inf
))) (setq mmt-many -
1000000))
204 (math-rewrite-phase (nth 3 (car crules
)))
206 (let ((fmt (math-format-stack-value (list whole-expr nil nil
))))
208 (set-buffer trace-buffer
)
209 (insert "\nDone rewriting"
210 (if (= mmt-many
0) " (reached iteration limit)" "")
214 (defun math-rewrite-phase (sched)
215 (while (and sched
(/= mmt-many
0))
216 (if (listp (car sched
))
217 (while (let ((save-expr whole-expr
))
218 (math-rewrite-phase (car sched
))
219 (not (equal whole-expr save-expr
))))
220 (if (symbolp (car sched
))
222 (setq whole-expr
(math-normalize (list (car sched
) whole-expr
)))
224 (let ((fmt (math-format-stack-value
225 (list whole-expr nil nil
))))
227 (set-buffer trace-buffer
)
229 (substring (symbol-name (car sched
)) 9)
231 (let ((math-rewrite-phase (car sched
)))
234 (set-buffer trace-buffer
)
235 (insert (format "\n(Phase %d)\n" math-rewrite-phase
))))
236 (while (let ((save-expr whole-expr
))
237 (setq whole-expr
(math-normalize
238 (math-map-tree-rec whole-expr
)))
239 (not (equal whole-expr save-expr
)))))))
240 (setq sched
(cdr sched
))))
242 (defun calcFunc-rewrite (expr rules
&optional many
)
243 (or (null many
) (integerp many
)
244 (equal many
'(var inf var-inf
)) (equal many
'(neg (var inf var-inf
)))
245 (math-reject-arg many
'fixnump
))
247 (math-rewrite expr rules
(or many
1))
248 (error (math-reject-arg rules
(nth 1 err
)))))
250 (defun calcFunc-match (pat vec
)
251 (or (math-vectorp vec
) (math-reject-arg vec
'vectorp
))
253 (math-match-patterns pat vec nil
)
254 (error (math-reject-arg pat
(nth 1 err
)))))
256 (defun calcFunc-matchnot (pat vec
)
257 (or (math-vectorp vec
) (math-reject-arg vec
'vectorp
))
259 (math-match-patterns pat vec t
)
260 (error (math-reject-arg pat
(nth 1 err
)))))
262 (defun math-match-patterns (pat vec
&optional not-flag
)
264 (crules (math-compile-patterns pat
)))
265 (while (setq vec
(cdr vec
))
266 (if (eq (not (math-apply-rewrites (car vec
) crules
))
268 (setq newvec
(cons (car vec
) newvec
))))
269 (cons 'vec
(nreverse newvec
))))
271 (defun calcFunc-matches (expr pat
)
273 (if (math-apply-rewrites expr
(math-compile-patterns pat
))
276 (error (math-reject-arg pat
(nth 1 err
)))))
278 (defun calcFunc-vmatches (expr pat
)
280 (or (math-apply-rewrites expr
(math-compile-patterns pat
))
282 (error (math-reject-arg pat
(nth 1 err
)))))
286 ;;; A compiled rule set is an a-list of entries whose cars are functors,
287 ;;; and whose cdrs are lists of rules. If there are rules with no
288 ;;; well-defined head functor, they are included on all lists and also
289 ;;; on an extra list whose car is nil.
291 ;;; The first entry in the a-list is of the form (schedule A B C ...).
293 ;;; Rule list entries take the form (regs prog head phases), where:
295 ;;; regs is a vector of match registers.
297 ;;; prog is a match program (see below).
299 ;;; head is a rare function name appearing in the rule body (but not the
300 ;;; head of the whole rule), or nil if none.
302 ;;; phases is a list of phase numbers for which the rule is enabled.
304 ;;; A match program is a list of match instructions.
306 ;;; In the following, "part" is a register number that contains the
307 ;;; subexpression to be operated on.
309 ;;; Register 0 is the whole expression being matched. The others are
310 ;;; meta-variables in the pattern, temporaries used for matching and
311 ;;; backtracking, and constant expressions.
314 ;;; The selected part must be math-equal to the contents of "reg".
316 ;;; (same-neg part reg)
317 ;;; The selected part must be math-equal to the negative of "reg".
320 ;;; The selected part is copied into "reg". (Rarely used.)
322 ;;; (copy-neg part reg)
323 ;;; The negative of the selected part is copied into "reg".
326 ;;; The selected part must be an integer.
329 ;;; The selected part must be a real.
332 ;;; The selected part must be a constant.
335 ;;; The selected part must "look" negative.
337 ;;; (rel part op reg)
338 ;;; The selected part must satisfy "part op reg", where "op"
339 ;;; is one of the 6 relational ops, and "reg" is a register.
341 ;;; (mod part modulo value)
342 ;;; The selected part must satisfy "part % modulo = value", where
343 ;;; "modulo" and "value" are constants.
345 ;;; (func part head reg1 reg2 ... regn)
346 ;;; The selected part must be an n-ary call to function "head".
347 ;;; The arguments are stored in "reg1" through "regn".
349 ;;; (func-def part head defs reg1 reg2 ... regn)
350 ;;; The selected part must be an n-ary call to function "head".
351 ;;; "Defs" is a list of value/register number pairs for default args.
352 ;;; If a match, assign default values to registers and then skip
353 ;;; immediately over any following "func-def" instructions and
354 ;;; the following "func" instruction. If wrong number of arguments,
355 ;;; proceed to the following "func-def" or "func" instruction.
357 ;;; (func-opt part head defs reg1)
358 ;;; Like func-def with "n=1", except that if the selected part is
359 ;;; not a call to "head", then the part itself successfully matches
360 ;;; "reg1" (and the defaults are assigned).
362 ;;; (try part heads mark reg1 [def])
363 ;;; The selected part must be a function of the correct type which is
364 ;;; associative and/or commutative. "Heads" is a list of acceptable
365 ;;; types. An initial assignment of arguments to "reg1" is tried.
366 ;;; If the program later fails, it backtracks to this instruction
367 ;;; and tries other assignments of arguments to "reg1".
368 ;;; If "def" exists and normal matching fails, backtrack and assign
369 ;;; "part" to "reg1", and "def" to "reg2" in the following "try2".
370 ;;; The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
371 ;;; "mark[0]" points to the argument list; "mark[1]" points to the
372 ;;; current argument; "mark[2]" is 0 if there are two arguments,
373 ;;; 1 if reg1 is matching single arguments, 2 if reg2 is matching
374 ;;; single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
375 ;;; 3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
376 ;;; have two arguments, 1 if phase-2 can be skipped, 2 if full
377 ;;; backtracking is necessary; "mark[4]" is t if the arguments have
378 ;;; been switched from the order given in the original pattern.
381 ;;; Every "try" will be followed by a "try2" whose "try" field is
382 ;;; a pointer to the corresponding "try". The arguments which were
383 ;;; not stored in "reg1" by that "try" are now stored in "reg2".
385 ;;; (alt instr nil mark)
386 ;;; Basic backtracking. Execute the instruction sequence "instr".
387 ;;; If this fails, back up and execute following the "alt" instruction.
388 ;;; The "mark" must be the vector "[nil nil 4]". The "instr" sequence
389 ;;; should execute "end-alt" at the end.
392 ;;; Register success of the first alternative of a previous "alt".
393 ;;; "Ptr" is a pointer to the next instruction following that "alt".
395 ;;; (apply part reg1 reg2)
396 ;;; The selected part must be a function call. The functor
397 ;;; (as a variable name) is stored in "reg1"; the arguments
398 ;;; (as a vector) are stored in "reg2".
400 ;;; (cons part reg1 reg2)
401 ;;; The selected part must be a nonempty vector. The first element
402 ;;; of the vector is stored in "reg1"; the rest of the vector
403 ;;; (as another vector) is stored in "reg2".
405 ;;; (rcons part reg1 reg2)
406 ;;; The selected part must be a nonempty vector. The last element
407 ;;; of the vector is stored in "reg2"; the rest of the vector
408 ;;; (as another vector) is stored in "reg1".
410 ;;; (select part reg)
411 ;;; If the selected part is a unary call to function "select", its
412 ;;; argument is stored in "reg"; otherwise (provided this is an `a r'
413 ;;; and not a `g r' command) the selected part is stored in "reg".
416 ;;; The "expr", with registers substituted, must simplify to
417 ;;; a non-zero value.
420 ;;; Evaluate "expr" and store the result in "reg". Always succeeds.
422 ;;; (done rhs remember)
423 ;;; Rewrite the expression to "rhs", with register substituted.
424 ;;; Normalize; if the result is different from the original
425 ;;; expression, the match has succeeded. This is the last
426 ;;; instruction of every program. If "remember" is non-nil,
427 ;;; record the result of the match as a new literal rule.
430 ;;; Pseudo-functions related to rewrites:
432 ;;; In patterns: quote, plain, condition, opt, apply, cons, select
434 ;;; In righthand sides: quote, plain, eval, evalsimp, evalextsimp,
435 ;;; apply, cons, select
437 ;;; In conditions: let + same as for righthand sides
439 ;;; Some optimizations that would be nice to have:
441 ;;; * Merge registers with disjoint lifetimes.
442 ;;; * Merge constant registers with equivalent values.
444 ;;; * If an argument of a commutative op math-depends neither on the
445 ;;; rest of the pattern nor on any of the conditions, then no backtracking
446 ;;; should be done for that argument. (This won't apply to very many
449 ;;; * If top functor is "select", and its argument is a unique function,
450 ;;; add the rule to the lists for both "select" and that function.
451 ;;; (Currently rules like this go on the "nil" list.)
452 ;;; Same for "func-opt" functions. (Though not urgent for these.)
454 ;;; * Shouldn't evaluate a "let" condition until the end, or until it
455 ;;; would enable another condition to be evaluated.
458 ;;; Some additional features to add / things to think about:
460 ;;; * Figure out what happens to "a +/- b" and "a +/- opt(b)".
462 ;;; * Same for interval forms.
464 ;;; * Have a name(v,pat) pattern which matches pat, and gives the
465 ;;; whole match the name v. Beware of circular structures!
468 (defun math-compile-patterns (pats)
469 (if (and (eq (car-safe pats
) 'var
)
470 (calc-var-value (nth 2 pats
)))
471 (let ((prop (get (nth 2 pats
) 'math-pattern-cache
)))
473 (put (nth 2 pats
) 'math-pattern-cache
(setq prop
(list nil
))))
474 (or (eq (car prop
) (symbol-value (nth 2 pats
)))
476 (setcdr prop
(math-compile-patterns
477 (symbol-value (nth 2 pats
))))
478 (setcar prop
(symbol-value (nth 2 pats
)))))
480 (let ((math-rewrite-whole t
))
481 (cdr (math-compile-rewrites (cons
483 (mapcar (function (lambda (x)
485 (if (eq (car-safe pats
) 'vec
)
489 (defvar math-rewrite-whole nil
)
490 (defvar math-make-import-list nil
)
491 (defun math-compile-rewrites (rules &optional name
)
492 (if (eq (car-safe rules
) 'var
)
493 (let ((prop (get (nth 2 rules
) 'math-rewrite-cache
))
494 (math-import-list nil
)
495 (math-make-import-list t
)
497 (or (calc-var-value (nth 2 rules
))
498 (error "Rules variable %s has no stored value" (nth 1 rules
)))
500 (put (nth 2 rules
) 'math-rewrite-cache
501 (setq prop
(list (list (cons (nth 2 rules
) nil
))))))
503 (while (and p
(eq (symbol-value (car (car p
))) (cdr (car p
))))
507 (message "Compiling rule set %s..." (nth 1 rules
))
508 (setcdr prop
(math-compile-rewrites
509 (symbol-value (nth 2 rules
))
511 (message "Compiling rule set %s...done" (nth 1 rules
))
512 (setcar prop
(cons (cons (nth 2 rules
)
513 (symbol-value (nth 2 rules
)))
516 (if (or (not (eq (car-safe rules
) 'vec
))
517 (and (memq (length rules
) '(3 4))
519 (while (and (setq p
(cdr p
))
520 (memq (car-safe (car p
))
527 calcFunc-iterations
))))
529 (setq rules
(list rules
))
530 (setq rules
(cdr rules
)))
531 (if (assq 'calcFunc-import rules
)
532 (let ((pp (setq rules
(copy-sequence rules
)))
534 (while (setq p
(car (cdr pp
)))
535 (if (eq (car-safe p
) 'calcFunc-import
)
537 (setcdr pp
(cdr (cdr pp
)))
538 (or (and (eq (car-safe (nth 1 p
)) 'var
)
539 (setq part
(calc-var-value (nth 2 (nth 1 p
))))
540 (memq (car-safe part
) '(vec
542 calcFunc-condition
)))
543 (error "Argument of import() must be a rules variable"))
544 (if math-make-import-list
545 (setq math-import-list
546 (cons (cons (nth 2 (nth 1 p
))
547 (symbol-value (nth 2 (nth 1 p
))))
549 (while (setq p
(cdr (cdr p
)))
551 (error "import() must have odd number of arguments"))
552 (setq part
(math-rwcomp-substitute part
554 (if (eq (car-safe part
) 'vec
)
555 (setq part
(cdr part
))
556 (setq part
(list part
)))
557 (setcdr pp
(append part
(cdr pp
))))
558 (setq pp
(cdr pp
))))))
564 (math-iterations nil
)
566 (math-all-phases nil
)
567 (math-remembering nil
)
568 math-pattern math-rhs math-conds
)
571 ((and (eq (car-safe (car rules
)) 'calcFunc-iterations
)
572 (= (length (car rules
)) 2))
573 (or (integerp (nth 1 (car rules
)))
574 (equal (nth 1 (car rules
)) '(var inf var-inf
))
575 (equal (nth 1 (car rules
)) '(neg (var inf var-inf
)))
576 (error "Invalid argument for iterations(n)"))
578 (setq math-iterations
(nth 1 (car rules
)))))
579 ((eq (car-safe (car rules
)) 'calcFunc-schedule
)
581 (setq math-schedule
(math-parse-schedule (cdr (car rules
))))))
582 ((eq (car-safe (car rules
)) 'calcFunc-phase
)
583 (setq math-phases
(cdr (car rules
)))
584 (if (equal math-phases
'((var all var-all
)))
585 (setq math-phases nil
))
586 (let ((p math-phases
))
588 (or (integerp (car p
))
589 (error "Phase numbers must be small integers"))
590 (or (memq (car p
) math-all-phases
)
591 (setq math-all-phases
(cons (car p
) math-all-phases
)))
593 ((or (and (eq (car-safe (car rules
)) 'vec
)
594 (cdr (cdr (car rules
)))
595 (not (nthcdr 4 (car rules
)))
596 (setq math-conds
(nth 3 (car rules
))
597 math-rhs
(nth 2 (car rules
))
598 math-pattern
(nth 1 (car rules
))))
601 math-pattern
(car rules
))
602 (while (and (eq (car-safe math-pattern
) 'calcFunc-condition
)
603 (= (length math-pattern
) 3))
604 (let ((cond (nth 2 math-pattern
)))
605 (setq math-conds
(if math-conds
606 (list 'calcFunc-land math-conds cond
)
608 math-pattern
(nth 1 math-pattern
))))
609 (and (eq (car-safe math-pattern
) 'calcFunc-assign
)
610 (= (length math-pattern
) 3)
611 (setq math-rhs
(nth 2 math-pattern
)
612 math-pattern
(nth 1 math-pattern
)))))
613 (let* ((math-prog (list nil
))
614 (math-prog-last math-prog
)
616 (math-regs (list (list nil
0 nil nil
)))
617 (math-bound-vars nil
)
618 (math-aliased-vars nil
)
620 (setq math-conds
(and math-conds
(math-flatten-lands math-conds
)))
621 (math-rwcomp-pattern math-pattern
0)
623 (let ((expr (car math-conds
)))
624 (setq math-conds
(cdr math-conds
))
625 (math-rwcomp-cond-instr expr
)))
626 (math-rwcomp-instr 'done
640 (math-rwcomp-register-expr
643 (math-rwcomp-match-vars math-rhs
))
645 (setq math-prog
(cdr math-prog
))
646 (let* ((heads (math-rewrite-heads math-pattern
))
649 (mapcar (function (lambda (x) (nth 3 x
)))
654 (head (and (not (Math-primp math-pattern
))
655 (not (and (eq (car (car math-prog
)) 'try
)
656 (nth 5 (car math-prog
))))
657 (not (memq (car (car math-prog
)) '(func-opt
661 (if (memq (car (car math-prog
)) '(func
663 (nth 2 (car math-prog
))
664 (if (eq (car math-pattern
) 'calcFunc-quote
)
665 (car-safe (nth 1 math-pattern
))
666 (car math-pattern
))))))
669 (if (setq found
(assq (car heads
) all-heads
))
670 (setcdr found
(1+ (cdr found
)))
671 (setq all-heads
(cons (cons (car heads
) 1) all-heads
)))
672 (setq heads
(cdr heads
))))
673 (if (eq head
'-
) (setq head
'+))
674 (if (memq head
'(calcFunc-cons calcFunc-rcons
)) (setq head
'vec
))
677 (nconc (or (assq head rule-set
)
678 (car (setq rule-set
(cons (cons head
684 (nconc (or (assq '/ rule-set
)
685 (car (setq rule-set
(cons (cons
691 (setq nil-rules
(nconc nil-rules
(list rule
)))
692 (let ((ptr rule-set
))
694 (nconc (car ptr
) (list rule
))
695 (setq ptr
(cdr ptr
))))))))
697 (error "Rewrite rule set must be a vector of A := B rules")))
698 (setq rules
(cdr rules
)))
700 (setq rule-set
(cons (cons nil nil-rules
) rule-set
)))
701 (setq all-heads
(mapcar 'car
702 (sort all-heads
(function
704 (< (cdr x
) (cdr y
)))))))
708 (setq rule
(cdr (car set
)))
710 (if (consp (setq heads
(nth 2 (car rule
))))
712 (setq heads
(delq (car (car set
)) heads
)
714 (while (and ptr
(not (memq (car ptr
) heads
)))
715 (setq ptr
(cdr ptr
)))
716 (setcar (nthcdr 2 (car rule
)) (car ptr
))))
717 (setq rule
(cdr rule
)))
718 (setq set
(cdr set
))))
719 (let ((plus (assq '+ rule-set
)))
721 (setq rule-set
(cons (cons '-
(cdr plus
)) rule-set
))))
722 (cons (list 'schedule math-iterations name
724 (sort math-all-phases
'<)
728 (defun math-flatten-lands (expr)
729 (if (eq (car-safe expr
) 'calcFunc-land
)
730 (append (math-flatten-lands (nth 1 expr
))
731 (math-flatten-lands (nth 2 expr
)))
734 (defun math-rewrite-heads (expr &optional more all
)
736 (skips (and (not all
)
737 '(calcFunc-apply calcFunc-condition calcFunc-opt
738 calcFunc-por calcFunc-pnot
)))
739 (blanks (and (not all
)
740 '(calcFunc-quote calcFunc-plain calcFunc-select
741 calcFunc-cons calcFunc-rcons
743 (or (Math-primp expr
)
744 (math-rewrite-heads-rec expr
))
747 (defun math-rewrite-heads-rec (expr)
748 (or (memq (car expr
) skips
)
750 (or (memq (car expr
) heads
)
751 (memq (car expr
) blanks
)
752 (memq 'algebraic
(get (car expr
) 'math-rewrite-props
))
753 (setq heads
(cons (car expr
) heads
)))
754 (while (setq expr
(cdr expr
))
755 (or (Math-primp (car expr
))
756 (math-rewrite-heads-rec (car expr
)))))))
758 (defun math-parse-schedule (sched)
764 (math-parse-schedule (cdr s
))
765 (if (eq (car-safe s
) 'var
)
766 (math-var-to-calcFunc s
)
767 (error "Improper component in rewrite schedule"))))))
770 (defun math-rwcomp-match-vars (expr)
771 (if (Math-primp expr
)
772 (if (eq (car-safe expr
) 'var
)
773 (let ((entry (assq (nth 2 expr
) math-regs
)))
775 (math-rwcomp-register-expr (nth 1 entry
))
778 (if (and (eq (car expr
) 'calcFunc-quote
)
780 (math-rwcomp-match-vars (nth 1 expr
))
781 (if (and (eq (car expr
) 'calcFunc-plain
)
783 (not (Math-primp (nth 1 expr
))))
785 (cons (car (nth 1 expr
))
786 (mapcar 'math-rwcomp-match-vars
(cdr (nth 1 expr
)))))
788 (mapcar 'math-rwcomp-match-vars
(cdr expr
)))))))
790 (defun math-rwcomp-register-expr (num)
791 (let ((entry (nth (1- (- math-num-regs num
)) math-regs
)))
793 (list 'neg
(list 'calcFunc-register
(nth 1 entry
)))
794 (list 'calcFunc-register
(nth 1 entry
)))))
796 (defun math-rwcomp-substitute (expr old new
)
797 (if (and (eq (car-safe old
) 'var
)
798 (memq (car-safe new
) '(var calcFunc-lambda
)))
799 (let ((old-func (math-var-to-calcFunc old
))
800 (new-func (math-var-to-calcFunc new
)))
801 (math-rwcomp-subst-rec expr
))
802 (let ((old-func nil
))
803 (math-rwcomp-subst-rec expr
))))
805 (defun math-rwcomp-subst-rec (expr)
806 (cond ((equal expr old
) new
)
807 ((Math-primp expr
) expr
)
808 (t (if (eq (car expr
) old-func
)
809 (math-build-call new-func
(mapcar 'math-rwcomp-subst-rec
812 (mapcar 'math-rwcomp-subst-rec
(cdr expr
)))))))
814 (defvar math-rwcomp-tracing nil
)
816 (defun math-rwcomp-trace (instr)
817 (when math-rwcomp-tracing
818 (terpri) (princ instr
))
821 (defun math-rwcomp-instr (&rest instr
)
822 (setcdr math-prog-last
823 (setq math-prog-last
(list (math-rwcomp-trace instr
)))))
825 (defun math-rwcomp-multi-instr (tail &rest instr
)
826 (setcdr math-prog-last
827 (setq math-prog-last
(list (math-rwcomp-trace (append instr tail
))))))
829 (defun math-rwcomp-bind-var (reg var
)
830 (setcar (math-rwcomp-reg-entry reg
) (nth 2 var
))
831 (setq math-bound-vars
(cons (nth 2 var
) math-bound-vars
))
832 (math-rwcomp-do-conditions))
834 (defun math-rwcomp-unbind-vars (mark)
835 (while (not (eq math-bound-vars mark
))
836 (setcar (assq (car math-bound-vars
) math-regs
) nil
)
837 (setq math-bound-vars
(cdr math-bound-vars
))))
839 (defun math-rwcomp-do-conditions ()
840 (let ((cond math-conds
))
842 (if (math-rwcomp-all-regs-done (car cond
))
843 (let ((expr (car cond
)))
844 (setq math-conds
(delq (car cond
) math-conds
))
846 (math-rwcomp-cond-instr expr
)))
847 (setq cond
(cdr cond
)))))
849 (defun math-rwcomp-cond-instr (expr)
851 (cond ((and (eq (car-safe expr
) 'calcFunc-matches
)
853 (eq (car-safe (setq arg
(math-rwcomp-match-vars (nth 1 expr
))))
855 (math-rwcomp-pattern (nth 2 expr
) (nth 1 arg
)))
856 ((math-numberp (setq expr
(math-rwcomp-match-vars expr
)))
857 (if (Math-zerop expr
)
858 (math-rwcomp-instr 'backtrack
)))
859 ((and (eq (car expr
) 'calcFunc-let
)
861 (let ((reg (math-rwcomp-reg)))
862 (math-rwcomp-instr 'let reg
(nth 2 expr
))
863 (math-rwcomp-pattern (nth 1 expr
) reg
)))
864 ((and (eq (car expr
) 'calcFunc-let
)
866 (eq (car-safe (nth 1 expr
)) 'calcFunc-assign
)
867 (= (length (nth 1 expr
)) 3))
868 (let ((reg (math-rwcomp-reg)))
869 (math-rwcomp-instr 'let reg
(nth 2 (nth 1 expr
)))
870 (math-rwcomp-pattern (nth 1 (nth 1 expr
)) reg
)))
871 ((and (setq op
(cdr (assq (car-safe expr
)
872 '( (calcFunc-integer . integer
)
873 (calcFunc-real . real
)
874 (calcFunc-constant . constant
)
875 (calcFunc-negative . negative
) ))))
877 (or (and (eq (car-safe (nth 1 expr
)) 'neg
)
878 (memq op
'(integer real constant
))
879 (setq arg
(nth 1 (nth 1 expr
))))
880 (setq arg
(nth 1 expr
)))
881 (eq (car-safe (setq arg
(nth 1 expr
))) 'calcFunc-register
))
882 (math-rwcomp-instr op
(nth 1 arg
)))
883 ((and (assq (car-safe expr
) calc-tweak-eqn-table
)
885 (eq (car-safe (nth 1 expr
)) 'calcFunc-register
))
886 (if (math-constp (nth 2 expr
))
887 (let ((reg (math-rwcomp-reg)))
888 (setcar (nthcdr 3 (car math-regs
)) (nth 2 expr
))
889 (math-rwcomp-instr 'rel
(nth 1 (nth 1 expr
))
891 (if (eq (car (nth 2 expr
)) 'calcFunc-register
)
892 (math-rwcomp-instr 'rel
(nth 1 (nth 1 expr
))
893 (car expr
) (nth 1 (nth 2 expr
)))
894 (math-rwcomp-instr 'cond expr
))))
895 ((and (eq (car-safe expr
) 'calcFunc-eq
)
897 (eq (car-safe (nth 1 expr
)) '%
)
898 (eq (car-safe (nth 1 (nth 1 expr
))) 'calcFunc-register
)
899 (math-constp (nth 2 (nth 1 expr
)))
900 (math-constp (nth 2 expr
)))
901 (math-rwcomp-instr 'mod
(nth 1 (nth 1 (nth 1 expr
)))
902 (nth 2 (nth 1 expr
)) (nth 2 expr
)))
903 ((equal expr
'(var remember var-remember
))
904 (setq math-remembering
1))
905 ((and (eq (car-safe expr
) 'calcFunc-remember
)
907 (setq math-remembering
(if math-remembering
909 math-remembering
(nth 1 expr
))
911 (t (math-rwcomp-instr 'cond expr
)))))
913 (defun math-rwcomp-same-instr (reg1 reg2 neg
)
914 (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1
))
915 (nth 2 (math-rwcomp-reg-entry reg2
)))
921 (defun math-rwcomp-copy-instr (reg1 reg2 neg
)
922 (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1
))
923 (nth 2 (math-rwcomp-reg-entry reg2
)))
925 (math-rwcomp-instr 'copy-neg reg1 reg2
)
927 (math-rwcomp-instr 'copy reg1 reg2
))))
929 (defun math-rwcomp-reg ()
932 (setq math-regs
(cons (list nil math-num-regs nil
0) math-regs
)
933 math-num-regs
(1+ math-num-regs
))))
935 (defun math-rwcomp-reg-entry (num)
936 (nth (1- (- math-num-regs num
)) math-regs
))
939 (defun math-rwcomp-pattern (expr part
&optional not-direct
)
940 (cond ((or (math-rwcomp-no-vars expr
)
941 (and (eq (car expr
) 'calcFunc-quote
)
943 (setq expr
(nth 1 expr
))))
944 (if (eq (car-safe expr
) 'calcFunc-register
)
945 (math-rwcomp-same-instr part
(nth 1 expr
) nil
)
946 (let ((reg (math-rwcomp-reg)))
947 (setcar (nthcdr 3 (car math-regs
)) expr
)
948 (math-rwcomp-same-instr part reg nil
))))
949 ((eq (car expr
) 'var
)
950 (let ((entry (assq (nth 2 expr
) math-regs
)))
952 (math-rwcomp-same-instr part
(nth 1 entry
) nil
)
954 (let ((reg (math-rwcomp-reg)))
955 (math-rwcomp-pattern expr reg
)
956 (math-rwcomp-copy-instr part reg nil
))
957 (if (setq entry
(assq (nth 2 expr
) math-aliased-vars
))
959 (setcar (math-rwcomp-reg-entry (nth 1 entry
))
962 (math-rwcomp-copy-instr part
(nth 1 entry
) nil
))
963 (math-rwcomp-bind-var part expr
))))))
964 ((and (eq (car expr
) 'calcFunc-select
)
966 (let ((reg (math-rwcomp-reg)))
967 (math-rwcomp-instr 'select part reg
)
968 (math-rwcomp-pattern (nth 1 expr
) reg
)))
969 ((and (eq (car expr
) 'calcFunc-opt
)
970 (memq (length expr
) '(2 3)))
971 (error "opt( ) occurs in context where it is not allowed"))
972 ((eq (car expr
) 'neg
)
973 (if (eq (car (nth 1 expr
)) 'var
)
974 (let ((entry (assq (nth 2 (nth 1 expr
)) math-regs
)))
976 (math-rwcomp-same-instr part
(nth 1 entry
) t
)
978 (let ((reg (math-rwcomp-best-reg (nth 1 expr
))))
979 (math-rwcomp-copy-instr part reg t
)
980 (math-rwcomp-pattern (nth 1 expr
) reg
))
981 (setcar (cdr (cdr (math-rwcomp-reg-entry part
))) t
)
982 (math-rwcomp-pattern (nth 1 expr
) part
))))
983 (if (math-rwcomp-is-algebraic (nth 1 expr
))
984 (math-rwcomp-cond-instr (list 'calcFunc-eq
985 (math-rwcomp-register-expr part
)
987 (let ((reg (math-rwcomp-reg)))
988 (math-rwcomp-instr 'func part
'neg reg
)
989 (math-rwcomp-pattern (nth 1 expr
) reg
)))))
990 ((and (eq (car expr
) 'calcFunc-apply
)
992 (let ((reg1 (math-rwcomp-reg))
993 (reg2 (math-rwcomp-reg)))
994 (math-rwcomp-instr 'apply part reg1 reg2
)
995 (math-rwcomp-pattern (nth 1 expr
) reg1
)
996 (math-rwcomp-pattern (nth 2 expr
) reg2
)))
997 ((and (eq (car expr
) 'calcFunc-cons
)
999 (let ((reg1 (math-rwcomp-reg))
1000 (reg2 (math-rwcomp-reg)))
1001 (math-rwcomp-instr 'cons part reg1 reg2
)
1002 (math-rwcomp-pattern (nth 1 expr
) reg1
)
1003 (math-rwcomp-pattern (nth 2 expr
) reg2
)))
1004 ((and (eq (car expr
) 'calcFunc-rcons
)
1005 (= (length expr
) 3))
1006 (let ((reg1 (math-rwcomp-reg))
1007 (reg2 (math-rwcomp-reg)))
1008 (math-rwcomp-instr 'rcons part reg1 reg2
)
1009 (math-rwcomp-pattern (nth 1 expr
) reg1
)
1010 (math-rwcomp-pattern (nth 2 expr
) reg2
)))
1011 ((and (eq (car expr
) 'calcFunc-condition
)
1012 (>= (length expr
) 3))
1013 (math-rwcomp-pattern (nth 1 expr
) part
)
1014 (setq expr
(cdr expr
))
1015 (while (setq expr
(cdr expr
))
1016 (let ((cond (math-flatten-lands (car expr
))))
1018 (if (math-rwcomp-all-regs-done (car cond
))
1019 (math-rwcomp-cond-instr (car cond
))
1020 (setq math-conds
(cons (car cond
) math-conds
)))
1021 (setq cond
(cdr cond
))))))
1022 ((and (eq (car expr
) 'calcFunc-pand
)
1023 (= (length expr
) 3))
1024 (math-rwcomp-pattern (nth 1 expr
) part
)
1025 (math-rwcomp-pattern (nth 2 expr
) part
))
1026 ((and (eq (car expr
) 'calcFunc-por
)
1027 (= (length expr
) 3))
1028 (math-rwcomp-instr 'alt nil nil
[nil nil
4])
1029 (let ((math-conds nil
)
1030 (head math-prog-last
)
1031 (mark math-bound-vars
)
1033 (math-rwcomp-pattern (nth 1 expr
) part t
)
1034 (let ((amark math-aliased-vars
)
1035 (math-aliased-vars math-aliased-vars
)
1036 (tail math-prog-last
)
1039 (while (not (eq p mark
))
1040 (setq entry
(assq (car p
) math-regs
)
1041 math-aliased-vars
(cons (list (car p
) (nth 1 entry
) nil
)
1044 (setcar (math-rwcomp-reg-entry (nth 1 entry
)) nil
))
1045 (setcar (cdr (car head
)) (cdr head
))
1047 (setq math-prog-last head
)
1048 (math-rwcomp-pattern (nth 2 expr
) part
)
1049 (math-rwcomp-instr 'same
0 0)
1050 (setcdr tail math-prog-last
)
1051 (setq p math-aliased-vars
)
1052 (while (not (eq p amark
))
1054 (setcar (math-rwcomp-reg-entry (nth 1 (car p
)))
1057 (math-rwcomp-do-conditions))
1058 ((and (eq (car expr
) 'calcFunc-pnot
)
1059 (= (length expr
) 2))
1060 (math-rwcomp-instr 'alt nil nil
[nil nil
4])
1061 (let ((head math-prog-last
)
1062 (mark math-bound-vars
))
1063 (math-rwcomp-pattern (nth 1 expr
) part
)
1064 (math-rwcomp-unbind-vars mark
)
1065 (math-rwcomp-instr 'end-alt head
)
1066 (math-rwcomp-instr 'backtrack
)
1067 (setcar (cdr (car head
)) (cdr head
))
1069 (setq math-prog-last head
)))
1070 (t (let ((props (get (car expr
) 'math-rewrite-props
)))
1071 (if (and (eq (car expr
) 'calcFunc-plain
)
1073 (not (math-primp (nth 1 expr
))))
1074 (setq expr
(nth 1 expr
))) ; but "props" is still nil
1075 (if (and (memq 'algebraic props
)
1076 (math-rwcomp-is-algebraic expr
))
1077 (math-rwcomp-cond-instr (list 'calcFunc-eq
1078 (math-rwcomp-register-expr part
)
1080 (if (and (memq 'commut props
)
1081 (= (length expr
) 3))
1082 (let ((arg1 (nth 1 expr
))
1084 try1 def code head
(flip nil
))
1085 (if (eq (car expr
) '-
)
1086 (setq arg2
(math-rwcomp-neg arg2
)))
1087 (setq arg1
(cons arg1
(math-rwcomp-best-reg arg1
))
1088 arg2
(cons arg2
(math-rwcomp-best-reg arg2
)))
1089 (or (math-rwcomp-order arg1 arg2
)
1090 (setq def arg1 arg1 arg2 arg2 def flip t
))
1091 (if (math-rwcomp-optional-arg (car expr
) arg1
)
1092 (error "Too many opt( ) arguments in this context"))
1093 (setq def
(math-rwcomp-optional-arg (car expr
) arg2
)
1094 head
(if (memq (car expr
) '(+ -
))
1096 (if (eq (car expr
) '*)
1099 code
(if (math-rwcomp-is-constrained
1101 (if (math-rwcomp-is-constrained
1105 (math-rwcomp-multi-instr (and def
(list def
))
1107 (vector nil nil nil code flip
)
1109 (setq try1
(car math-prog-last
))
1110 (math-rwcomp-pattern (car arg1
) (cdr arg1
))
1111 (math-rwcomp-instr 'try2 try1
(cdr arg2
))
1112 (if (and (= part
0) (not def
) (not math-rewrite-whole
)
1113 (not (eq math-rhs t
))
1114 (setq def
(get (car expr
)
1115 'math-rewrite-default
)))
1116 (let ((reg1 (math-rwcomp-reg))
1117 (reg2 (math-rwcomp-reg)))
1118 (if (= (aref (nth 3 try1
) 3) 0)
1119 (aset (nth 3 try1
) 3 1))
1120 (math-rwcomp-instr 'try
(cdr arg2
)
1121 (if (equal head
'(* /))
1128 (setq try1
(car math-prog-last
))
1129 (math-rwcomp-pattern (car arg2
) reg1
)
1130 (math-rwcomp-instr 'try2 try1 reg2
)
1131 (setq math-rhs
(list (if (eq (car expr
) '-
)
1134 (list 'calcFunc-register
1136 (math-rwcomp-pattern (car arg2
) (cdr arg2
))))
1137 (let* ((args (mapcar (function
1139 (cons x
(math-rwcomp-best-reg x
))))
1141 (args2 (copy-sequence args
))
1142 (argp (reverse args2
))
1146 (let ((def (math-rwcomp-optional-arg (car expr
)
1150 (setq args2
(delq (car argp
) args2
)
1151 defs
(cons (cons def
(cdr (car argp
)))
1153 (math-rwcomp-multi-instr
1155 (if (or (and (memq 'unary1 props
)
1156 (= (length args2
) 1)
1157 (eq (car args2
) (car args
)))
1158 (and (memq 'unary2 props
)
1160 (eq (car args2
) (nth 1 args
))))
1165 (setq argp
(cdr argp
)))
1166 (math-rwcomp-multi-instr (mapcar 'cdr args
)
1167 'func part
(car expr
))
1168 (setq args
(sort args
'math-rwcomp-order
))
1170 (math-rwcomp-pattern (car (car args
)) (cdr (car args
)))
1172 args
(cdr args
))))))))))
1174 (defun math-rwcomp-best-reg (x)
1175 (or (and (eq (car-safe x
) 'var
)
1176 (let ((entry (assq (nth 2 x
) math-aliased-vars
)))
1179 (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry
))))
1181 (setcar (cdr (cdr entry
)) t
)
1185 (defun math-rwcomp-all-regs-done (expr)
1186 (if (Math-primp expr
)
1187 (or (not (eq (car-safe expr
) 'var
))
1188 (assq (nth 2 expr
) math-regs
)
1189 (eq (nth 2 expr
) 'var-remember
)
1190 (math-const-var expr
))
1191 (if (and (eq (car expr
) 'calcFunc-let
)
1192 (= (length expr
) 3))
1193 (math-rwcomp-all-regs-done (nth 2 expr
))
1194 (if (and (eq (car expr
) 'calcFunc-let
)
1196 (eq (car-safe (nth 1 expr
)) 'calcFunc-assign
)
1197 (= (length (nth 1 expr
)) 3))
1198 (math-rwcomp-all-regs-done (nth 2 (nth 1 expr
)))
1199 (while (and (setq expr
(cdr expr
))
1200 (math-rwcomp-all-regs-done (car expr
))))
1203 (defun math-rwcomp-no-vars (expr)
1204 (if (Math-primp expr
)
1205 (or (not (eq (car-safe expr
) 'var
))
1206 (math-const-var expr
))
1207 (and (not (memq (car expr
) '(calcFunc-condition
1208 calcFunc-select calcFunc-quote
1209 calcFunc-plain calcFunc-opt
1210 calcFunc-por calcFunc-pand
1211 calcFunc-pnot calcFunc-apply
1212 calcFunc-cons calcFunc-rcons
)))
1214 (while (and (setq expr
(cdr expr
))
1215 (math-rwcomp-no-vars (car expr
))))
1218 (defun math-rwcomp-is-algebraic (expr)
1219 (if (Math-primp expr
)
1220 (or (not (eq (car-safe expr
) 'var
))
1221 (math-const-var expr
)
1222 (assq (nth 2 expr
) math-regs
))
1223 (and (memq 'algebraic
(get (car expr
) 'math-rewrite-props
))
1225 (while (and (setq expr
(cdr expr
))
1226 (math-rwcomp-is-algebraic (car expr
))))
1229 (defun math-rwcomp-is-constrained (expr not-these
)
1230 (if (Math-primp expr
)
1231 (not (eq (car-safe expr
) 'var
))
1232 (if (eq (car expr
) 'calcFunc-plain
)
1233 (math-rwcomp-is-constrained (nth 1 expr
) not-these
)
1234 (not (or (memq (car expr
) '(neg calcFunc-select
))
1235 (memq (car expr
) not-these
)
1236 (and (memq 'commut
(get (car expr
) 'math-rewrite-props
))
1237 (or (eq (car-safe (nth 1 expr
)) 'calcFunc-opt
)
1238 (eq (car-safe (nth 2 expr
)) 'calcFunc-opt
))))))))
1240 (defun math-rwcomp-optional-arg (head argp
)
1241 (let ((arg (car argp
)))
1242 (if (eq (car-safe arg
) 'calcFunc-opt
)
1243 (and (memq (length arg
) '(2 3))
1245 (or (eq (car-safe (nth 1 arg
)) 'var
)
1246 (error "First argument of opt( ) must be a variable"))
1247 (setcar argp
(nth 1 arg
))
1248 (if (= (length arg
) 2)
1249 (or (get head
'math-rewrite-default
)
1250 (error "opt( ) must include a default in this context"))
1252 (and (eq (car-safe arg
) 'neg
)
1253 (let* ((part (list (nth 1 arg
)))
1254 (partp (math-rwcomp-optional-arg head part
)))
1256 (setcar argp
(math-rwcomp-neg (car part
)))
1257 (math-neg partp
)))))))
1259 (defun math-rwcomp-neg (expr)
1260 (if (memq (car-safe expr
) '(* /))
1261 (if (eq (car-safe (nth 1 expr
)) 'var
)
1262 (list (car expr
) (list 'neg
(nth 1 expr
)) (nth 2 expr
))
1263 (if (eq (car-safe (nth 2 expr
)) 'var
)
1264 (list (car expr
) (nth 1 expr
) (list 'neg
(nth 2 expr
)))
1268 (defun math-rwcomp-assoc-args (expr)
1269 (if (and (eq (car-safe (nth 1 expr
)) (car expr
))
1270 (= (length (nth 1 expr
)) 3))
1271 (math-rwcomp-assoc-args (nth 1 expr
))
1272 (setq math-args
(cons (nth 1 expr
) math-args
)))
1273 (if (and (eq (car-safe (nth 2 expr
)) (car expr
))
1274 (= (length (nth 2 expr
)) 3))
1275 (math-rwcomp-assoc-args (nth 2 expr
))
1276 (setq math-args
(cons (nth 2 expr
) math-args
))))
1278 (defun math-rwcomp-addsub-args (expr)
1279 (if (memq (car-safe (nth 1 expr
)) '(+ -
))
1280 (math-rwcomp-addsub-args (nth 1 expr
))
1281 (setq math-args
(cons (nth 1 expr
) math-args
)))
1282 (if (eq (car expr
) '-
)
1283 (setq math-args
(cons (math-rwcomp-neg (nth 2 expr
)) math-args
))
1284 (if (eq (car-safe (nth 2 expr
)) '+)
1285 (math-rwcomp-addsub-args (nth 2 expr
))
1286 (setq math-args
(cons (nth 2 expr
) math-args
)))))
1288 (defun math-rwcomp-order (a b
)
1289 (< (math-rwcomp-priority (car a
))
1290 (math-rwcomp-priority (car b
))))
1292 ;;; Order of priority: 0 Constants and other exact matches (first)
1293 ;;; 10 Functions (except below)
1294 ;;; 20 Meta-variables which occur more than once
1295 ;;; 30 Algebraic functions
1296 ;;; 40 Commutative/associative functions
1297 ;;; 50 Meta-variables which occur only once
1298 ;;; +100 for every "!!!" (pnot) in the pattern
1299 ;;; 10000 Optional arguments (last)
1301 (defun math-rwcomp-priority (expr)
1302 (+ (math-rwcomp-count-pnots expr
)
1303 (cond ((eq (car-safe expr
) 'calcFunc-opt
)
1305 ((math-rwcomp-no-vars expr
)
1307 ((eq (car expr
) 'calcFunc-quote
)
1309 ((eq (car expr
) 'var
)
1310 (if (assq (nth 2 expr
) math-regs
)
1312 (if (= (math-rwcomp-count-refs expr
) 1)
1315 (t (let ((props (get (car expr
) 'math-rewrite-props
)))
1316 (if (or (memq 'commut props
)
1317 (memq 'assoc props
))
1319 (if (memq 'algebraic props
)
1323 (defun math-rwcomp-count-refs (var)
1324 (let ((count (or (math-expr-contains-count math-pattern var
) 0))
1327 (if (eq (car-safe (car p
)) 'calcFunc-let
)
1328 (if (= (length (car p
)) 3)
1329 (setq count
(+ count
1330 (or (math-expr-contains-count (nth 2 (car p
)) var
)
1332 (if (and (= (length (car p
)) 2)
1333 (eq (car-safe (nth 1 (car p
))) 'calcFunc-assign
)
1334 (= (length (nth 1 (car p
))) 3))
1335 (setq count
(+ count
1336 (or (math-expr-contains-count
1337 (nth 2 (nth 1 (car p
))) var
) 0))))))
1341 (defun math-rwcomp-count-pnots (expr)
1342 (if (Math-primp expr
)
1344 (if (eq (car expr
) 'calcFunc-pnot
)
1347 (while (setq expr
(cdr expr
))
1348 (setq count
(+ count
(math-rwcomp-count-pnots (car expr
)))))
1351 ;;; In the current implementation, all associative functions must
1352 ;;; also be commutative.
1354 (put '+ 'math-rewrite-props
'(algebraic assoc commut
))
1355 (put '-
'math-rewrite-props
'(algebraic assoc commut
)) ; see below
1356 (put '* 'math-rewrite-props
'(algebraic assoc commut
)) ; see below
1357 (put '/ 'math-rewrite-props
'(algebraic unary1
))
1358 (put '^
'math-rewrite-props
'(algebraic unary1
))
1359 (put '%
'math-rewrite-props
'(algebraic))
1360 (put 'neg
'math-rewrite-props
'(algebraic))
1361 (put 'calcFunc-idiv
'math-rewrite-props
'(algebraic))
1362 (put 'calcFunc-abs
'math-rewrite-props
'(algebraic))
1363 (put 'calcFunc-sign
'math-rewrite-props
'(algebraic))
1364 (put 'calcFunc-round
'math-rewrite-props
'(algebraic))
1365 (put 'calcFunc-rounde
'math-rewrite-props
'(algebraic))
1366 (put 'calcFunc-roundu
'math-rewrite-props
'(algebraic))
1367 (put 'calcFunc-trunc
'math-rewrite-props
'(algebraic))
1368 (put 'calcFunc-floor
'math-rewrite-props
'(algebraic))
1369 (put 'calcFunc-ceil
'math-rewrite-props
'(algebraic))
1370 (put 'calcFunc-re
'math-rewrite-props
'(algebraic))
1371 (put 'calcFunc-im
'math-rewrite-props
'(algebraic))
1372 (put 'calcFunc-conj
'math-rewrite-props
'(algebraic))
1373 (put 'calcFunc-arg
'math-rewrite-props
'(algebraic))
1374 (put 'calcFunc-and
'math-rewrite-props
'(assoc commut
))
1375 (put 'calcFunc-or
'math-rewrite-props
'(assoc commut
))
1376 (put 'calcFunc-xor
'math-rewrite-props
'(assoc commut
))
1377 (put 'calcFunc-eq
'math-rewrite-props
'(commut))
1378 (put 'calcFunc-neq
'math-rewrite-props
'(commut))
1379 (put 'calcFunc-land
'math-rewrite-props
'(assoc commut
))
1380 (put 'calcFunc-lor
'math-rewrite-props
'(assoc commut
))
1381 (put 'calcFunc-beta
'math-rewrite-props
'(commut))
1382 (put 'calcFunc-gcd
'math-rewrite-props
'(assoc commut
))
1383 (put 'calcFunc-lcm
'math-rewrite-props
'(assoc commut
))
1384 (put 'calcFunc-max
'math-rewrite-props
'(algebraic assoc commut
))
1385 (put 'calcFunc-min
'math-rewrite-props
'(algebraic assoc commut
))
1386 (put 'calcFunc-vunion
'math-rewrite-props
'(assoc commut
))
1387 (put 'calcFunc-vint
'math-rewrite-props
'(assoc commut
))
1388 (put 'calcFunc-vxor
'math-rewrite-props
'(assoc commut
))
1390 ;;; Note: "*" is not commutative for matrix args, but we pretend it is.
1391 ;;; Also, "-" is not commutative but the code tweaks things so that it is.
1393 (put '+ 'math-rewrite-default
0)
1394 (put '-
'math-rewrite-default
0)
1395 (put '* 'math-rewrite-default
1)
1396 (put '/ 'math-rewrite-default
1)
1397 (put '^
'math-rewrite-default
1)
1398 (put 'calcFunc-land
'math-rewrite-default
1)
1399 (put 'calcFunc-lor
'math-rewrite-default
0)
1400 (put 'calcFunc-vunion
'math-rewrite-default
'(vec))
1401 (put 'calcFunc-vint
'math-rewrite-default
'(vec))
1402 (put 'calcFunc-vdiff
'math-rewrite-default
'(vec))
1403 (put 'calcFunc-vxor
'math-rewrite-default
'(vec))
1405 (defmacro math-rwfail
(&optional back
)
1409 '(setq btrack
(cdr btrack
))
1413 ;;; This monstrosity is necessary because the use of static vectors of
1414 ;;; registers makes rewrite rules non-reentrant. Yucko!
1415 (defmacro math-rweval
(form)
1416 (list 'let
'((orig (car rules
)))
1417 '(setcar rules
(quote (nil nil nil no-phase
)))
1418 (list 'unwind-protect
1420 '(setcar rules orig
))))
1422 (setq math-rewrite-phase
1)
1424 (defun math-apply-rewrites (expr rules
&optional heads ruleset
)
1426 (setq rules
(cdr (or (assq (car-safe expr
) rules
)
1429 op regs inst part pc mark btrack
1430 (tracing math-rwcomp-tracing
)
1431 (phase math-rewrite-phase
))
1434 (and (setq part
(nth 2 (car rules
)))
1436 (not (memq part heads
)))
1437 (and (setq part
(nth 3 (car rules
)))
1438 (not (memq phase part
)))
1440 (setq regs
(car (car rules
))
1441 pc
(nth 1 (car rules
))
1447 (progn (terpri) (princ (car pc
))
1448 (if (and (natnump (nth 1 (car pc
)))
1449 (< (nth 1 (car pc
)) (length regs
)))
1450 (princ (format "\n part = %s"
1451 (aref regs
(nth 1 (car pc
))))))))
1453 (cond ((eq (setq op
(car (setq inst
(car pc
)))) 'func
)
1454 (if (and (consp (setq part
(aref regs
(car (cdr inst
)))))
1456 (car (setq inst
(cdr (cdr inst
)))))
1458 (while (and (setq inst
(cdr inst
)
1461 (aset regs
(car inst
) (car part
)))
1462 (not (or inst part
))))
1467 (if (or (equal (setq part
(aref regs
(nth 1 inst
)))
1468 (setq mark
(aref regs
(nth 2 inst
))))
1469 (Math-equal part mark
))
1475 (not (eq calc-matrix-mode
'scalar
))
1476 (eq (car (nth 2 inst
)) '*)
1477 (consp (setq part
(aref regs
(car (cdr inst
)))))
1479 (not (math-known-scalarp part
)))
1480 (setq mark
(nth 3 inst
)
1484 (aset regs
(nth 4 inst
) (nth 2 part
))
1485 (aset mark
1 (cdr (cdr part
))))
1486 (aset regs
(nth 4 inst
) (nth 1 part
))
1487 (aset mark
1 (cdr part
)))
1488 (aset mark
0 (cdr part
))
1492 (if (and (consp (setq part
(aref regs
(car (cdr inst
)))))
1493 (memq (car part
) (nth 2 inst
))
1495 (or (not (eq (car part
) '/))
1496 (Math-objectp (nth 2 part
))))
1499 mark
(car (cdr (setq inst
(cdr (cdr inst
))))))
1501 (memq 'assoc
(get (car part
) 'math-rewrite-props
))
1502 (not (= (aref mark
3) 0))
1503 (while (if (and (consp (nth 1 part
))
1504 (memq (car (nth 1 part
)) (car inst
)))
1505 (setq op
(cons (if (eq (car part
) '-
)
1511 (if (and (consp (nth 2 part
))
1512 (memq (car (nth 2 part
))
1514 (not (eq (car (nth 2 part
)) '-
)))
1515 (setq op
(cons (nth 1 part
) op
)
1516 part
(nth 2 part
))))))
1517 (setq op
(cons (nth 1 part
)
1518 (cons (if (eq (car part
) '-
)
1521 (if (eq (car part
) '/)
1526 btrack
(cons pc btrack
)
1528 (aset regs
(nth 2 inst
) (car op
))
1531 (aset mark
2 (if (cdr (cdr op
)) 1 0)))
1533 (if (and (consp part
)
1534 (eq (car part
) 'neg
)
1535 (eq (car (nth 2 inst
)) '*)
1536 (eq (nth 5 inst
) 1))
1538 (setq mark
(nth 3 inst
)
1540 (aset regs
(nth 4 inst
) (nth 1 part
))
1543 (setq mark
(nth 3 inst
)
1545 (aset regs
(nth 4 inst
) part
)
1550 (setq part
(nth 1 inst
) ; try instr
1554 (aset regs
(nth 2 inst
)
1557 (if (eq (aref mark
0) (aref mark
1))
1558 (nth 1 (aref mark
0))
1559 (car (aref mark
0))))
1561 (setq mark
(delq (car (aref mark
1))
1562 (copy-sequence (aref mark
0)))
1563 op
(car (nth 2 part
)))
1566 (setq mark
(nreverse mark
)
1567 part
(list '* (nth 1 mark
) (car mark
))
1569 (while (setq mark
(cdr mark
))
1570 (setq part
(list '* (car mark
) part
))))
1571 (setq part
(car mark
)
1573 part
(if (and (eq op
'+)
1575 (eq (car (car mark
)) 'neg
))
1578 (list op part
(car mark
))))
1579 (while (setq mark
(cdr mark
))
1580 (setq part
(if (and (eq op
'+)
1582 (eq (car (car mark
)) 'neg
))
1585 (list op part
(car mark
))))))
1588 (car (aref mark
1)))
1589 ((eq op
3) (nth 5 part
))
1590 (t (aref mark
1)))))
1594 (if (and (consp (setq part
(aref regs
(nth 1 inst
))))
1595 (eq (car part
) 'calcFunc-select
))
1596 (aset regs
(nth 2 inst
) (nth 1 part
))
1597 (if math-rewrite-selections
1599 (aset regs
(nth 2 inst
) part
))))
1602 (if (or (equal (setq part
(aref regs
(nth 1 inst
)))
1603 (setq mark
(math-neg
1604 (aref regs
(nth 2 inst
)))))
1605 (Math-equal part mark
))
1610 (setq inst
(car (car btrack
)) ; "try" or "alt" instr
1611 pc
(cdr (car btrack
))
1612 mark
(or (nth 3 inst
) [nil nil
4])
1615 (if (setq op
(cdr (aref mark
1)))
1616 (aset regs
(nth 4 inst
) (car (aset mark
1 op
)))
1620 (aset regs
(nth 4 inst
)
1621 (aref regs
(nth 1 inst
))))
1624 (if (setq op
(cdr (aref mark
1)))
1625 (aset regs
(nth 4 inst
) (car (aset mark
1 op
)))
1626 (if (= (aref mark
3) 1)
1630 (aset regs
(nth 4 inst
)
1631 (aref regs
(nth 1 inst
))))
1634 (aset mark
1 (cons nil
(aref mark
0)))
1637 (if (setq op
(cdr (aref mark
1)))
1639 (setq mark
(delq (car (aset mark
1 op
))
1642 op
(car (nth 2 inst
)))
1645 (setq mark
(nreverse mark
)
1646 part
(list '* (nth 1 mark
)
1649 (while (setq mark
(cdr mark
))
1650 (setq part
(list '* (car mark
)
1652 (setq part
(car mark
)
1654 part
(if (and (eq op
'+)
1656 (eq (car (car mark
))
1660 (list op part
(car mark
))))
1661 (while (setq mark
(cdr mark
))
1662 (setq part
(if (and (eq op
'+)
1664 (eq (car (car mark
))
1668 (list op part
(car mark
))))))
1669 (aset regs
(nth 4 inst
) part
))
1673 (aset regs
(nth 4 inst
)
1674 (aref regs
(nth 1 inst
))))
1677 (setq btrack
(cdr btrack
)))
1678 (t (math-rwfail t
))))
1681 (if (Math-integerp (setq part
(aref regs
(nth 1 inst
))))
1683 (if (Math-primp part
)
1685 (setq part
(math-rweval (math-simplify part
)))
1686 (if (Math-integerp part
)
1691 (if (Math-realp (setq part
(aref regs
(nth 1 inst
))))
1693 (if (Math-primp part
)
1695 (setq part
(math-rweval (math-simplify part
)))
1696 (if (Math-realp part
)
1701 (if (math-constp (setq part
(aref regs
(nth 1 inst
))))
1703 (if (Math-primp part
)
1705 (setq part
(math-rweval (math-simplify part
)))
1706 (if (math-constp part
)
1711 (if (math-looks-negp (setq part
(aref regs
(nth 1 inst
))))
1713 (if (Math-primp part
)
1715 (setq part
(math-rweval (math-simplify part
)))
1716 (if (math-looks-negp part
)
1721 (setq part
(math-compare (aref regs
(nth 1 inst
))
1722 (aref regs
(nth 3 inst
)))
1725 (setq part
(math-rweval
1728 (math-sub (aref regs
(nth 1 inst
))
1729 (aref regs
(nth 3 inst
))))))))
1730 (if (cond ((eq op
'calcFunc-eq
)
1732 ((eq op
'calcFunc-neq
)
1733 (memq part
'(-1 1)))
1734 ((eq op
'calcFunc-lt
)
1736 ((eq op
'calcFunc-leq
)
1737 (memq part
'(-1 0)))
1738 ((eq op
'calcFunc-gt
)
1740 ((eq op
'calcFunc-geq
)
1741 (memq part
'(0 1))))
1746 (if (and (consp (setq part
(aref regs
(car (cdr inst
)))))
1748 (car (setq inst
(cdr (cdr inst
))))))
1750 (setq inst
(cdr inst
)
1752 (while (and (setq inst
(cdr inst
)
1755 (aset regs
(car inst
) (car part
)))
1758 (while (eq (car (car (setq pc
(cdr pc
))))
1760 (setq pc
(cdr pc
)) ; skip over "func"
1762 (aset regs
(cdr (car mark
)) (car (car mark
)))
1763 (setq mark
(cdr mark
)))))
1767 (if (or (not (and (consp
1768 (setq part
(aref regs
(car (cdr inst
)))))
1769 (eq (car part
) (nth 2 inst
))))
1770 (and (= (length part
) 2)
1771 (setq part
(nth 1 part
))))
1773 (setq mark
(nth 3 inst
))
1774 (aset regs
(nth 4 inst
) part
)
1775 (while (eq (car (car (setq pc
(cdr pc
)))) 'func-def
))
1776 (setq pc
(cdr pc
)) ; skip over "func"
1778 (aset regs
(cdr (car mark
)) (car (car mark
)))
1779 (setq mark
(cdr mark
))))
1780 (setq pc
(cdr pc
))))
1783 (if (if (Math-zerop (setq part
(aref regs
(nth 1 inst
))))
1784 (Math-zerop (nth 3 inst
))
1785 (and (not (Math-zerop (nth 2 inst
)))
1787 (setq part
(math-mod part
(nth 2 inst
)))
1788 (or (Math-numberp part
)
1789 (setq part
(math-rweval
1790 (math-simplify part
))))
1791 (Math-equal part
(nth 3 inst
)))))
1796 (if (and (consp (setq part
(aref regs
(car (cdr inst
)))))
1797 (not (Math-objvecp part
))
1798 (not (eq (car part
) 'var
)))
1800 (aset regs
(nth 2 inst
)
1801 (math-calcFunc-to-var (car part
)))
1802 (aset regs
(nth 3 inst
)
1803 (cons 'vec
(cdr part
)))
1808 (if (and (consp (setq part
(aref regs
(car (cdr inst
)))))
1809 (eq (car part
) 'vec
)
1812 (aset regs
(nth 2 inst
) (nth 1 part
))
1813 (aset regs
(nth 3 inst
) (cons 'vec
(cdr (cdr part
))))
1818 (if (and (consp (setq part
(aref regs
(car (cdr inst
)))))
1819 (eq (car part
) 'vec
)
1822 (aset regs
(nth 2 inst
) (calcFunc-rhead part
))
1823 (aset regs
(nth 3 inst
) (calcFunc-rtail part
))
1831 (math-rwapply-replace-regs (nth 1 inst
)))))
1836 (aset regs
(nth 1 inst
)
1839 (math-rwapply-replace-regs (nth 2 inst
)))))
1843 (aset regs
(nth 2 inst
) (aref regs
(nth 1 inst
)))
1847 (aset regs
(nth 2 inst
)
1848 (math-rwapply-neg (aref regs
(nth 1 inst
))))
1852 (setq btrack
(cons pc btrack
)
1856 (while (and btrack
(not (eq (car btrack
) (nth 1 inst
))))
1857 (setq btrack
(cdr btrack
)))
1858 (setq btrack
(cdr btrack
)
1862 (setq result
(math-rwapply-replace-regs (nth 1 inst
)))
1863 (if (or (and (eq (car-safe result
) '+)
1864 (eq (nth 2 result
) 0))
1865 (and (eq (car-safe result
) '*)
1866 (eq (nth 2 result
) 1)))
1867 (setq result
(nth 1 result
)))
1868 (setq part
(and (nth 2 inst
)
1872 (math-rwapply-replace-regs
1874 (if (or (equal result expr
)
1875 (equal (setq result
(math-normalize result
)) expr
))
1877 (if part
(math-rwapply-remember expr result
))
1881 (t (error "%s is not a valid rewrite opcode" op
))))))
1882 (setq rules
(cdr rules
)))
1885 (defun math-rwapply-neg (expr)
1886 (if (and (consp expr
)
1887 (memq (car expr
) '(* /)))
1888 (if (Math-objectp (nth 2 expr
))
1889 (list (car expr
) (nth 1 expr
) (math-neg (nth 2 expr
)))
1891 (if (Math-objectp (nth 1 expr
))
1892 (math-neg (nth 1 expr
))
1893 (list '* -
1 (nth 1 expr
)))
1897 (defun math-rwapply-inv (expr)
1898 (if (and (Math-integerp expr
)
1900 (math-make-frac 1 expr
)
1903 (defun math-rwapply-replace-regs (expr)
1904 (cond ((Math-primp expr
)
1906 ((eq (car expr
) 'calcFunc-register
)
1907 (setq expr
(aref regs
(nth 1 expr
)))
1908 (if (eq (car-safe expr
) '*)
1909 (if (eq (nth 1 expr
) -
1)
1910 (math-neg (nth 2 expr
))
1911 (if (eq (nth 1 expr
) 1)
1915 ((and (eq (car expr
) 'calcFunc-eval
)
1916 (= (length expr
) 2))
1917 (calc-with-default-simplification
1918 (math-normalize (math-rwapply-replace-regs (nth 1 expr
)))))
1919 ((and (eq (car expr
) 'calcFunc-evalsimp
)
1920 (= (length expr
) 2))
1921 (math-simplify (math-rwapply-replace-regs (nth 1 expr
))))
1922 ((and (eq (car expr
) 'calcFunc-evalextsimp
)
1923 (= (length expr
) 2))
1924 (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr
))))
1925 ((and (eq (car expr
) 'calcFunc-apply
)
1926 (= (length expr
) 3))
1927 (let ((func (math-rwapply-replace-regs (nth 1 expr
)))
1928 (args (math-rwapply-replace-regs (nth 2 expr
)))
1930 (if (and (math-vectorp args
)
1931 (not (eq (car-safe (setq call
(math-build-call
1932 (math-var-to-calcFunc func
)
1936 (list 'calcFunc-apply func args
))))
1937 ((and (eq (car expr
) 'calcFunc-cons
)
1938 (= (length expr
) 3))
1939 (let ((head (math-rwapply-replace-regs (nth 1 expr
)))
1940 (tail (math-rwapply-replace-regs (nth 2 expr
))))
1941 (if (math-vectorp tail
)
1942 (cons 'vec
(cons head
(cdr tail
)))
1943 (list 'calcFunc-cons head tail
))))
1944 ((and (eq (car expr
) 'calcFunc-rcons
)
1945 (= (length expr
) 3))
1946 (let ((head (math-rwapply-replace-regs (nth 1 expr
)))
1947 (tail (math-rwapply-replace-regs (nth 2 expr
))))
1948 (if (math-vectorp head
)
1949 (append head
(list tail
))
1950 (list 'calcFunc-rcons head tail
))))
1951 ((and (eq (car expr
) 'neg
)
1952 (math-rwapply-reg-looks-negp (nth 1 expr
)))
1953 (math-rwapply-reg-neg (nth 1 expr
)))
1954 ((and (eq (car expr
) 'neg
)
1955 (eq (car-safe (nth 1 expr
)) 'calcFunc-register
)
1956 (math-scalarp (aref regs
(nth 1 (nth 1 expr
)))))
1957 (math-neg (math-rwapply-replace-regs (nth 1 expr
))))
1958 ((and (eq (car expr
) '+)
1959 (math-rwapply-reg-looks-negp (nth 1 expr
)))
1960 (list '-
(math-rwapply-replace-regs (nth 2 expr
))
1961 (math-rwapply-reg-neg (nth 1 expr
))))
1962 ((and (eq (car expr
) '+)
1963 (math-rwapply-reg-looks-negp (nth 2 expr
)))
1964 (list '-
(math-rwapply-replace-regs (nth 1 expr
))
1965 (math-rwapply-reg-neg (nth 2 expr
))))
1966 ((and (eq (car expr
) '-
)
1967 (math-rwapply-reg-looks-negp (nth 2 expr
)))
1968 (list '+ (math-rwapply-replace-regs (nth 1 expr
))
1969 (math-rwapply-reg-neg (nth 2 expr
))))
1971 (cond ((eq (nth 1 expr
) -
1)
1972 (if (math-rwapply-reg-looks-negp (nth 2 expr
))
1973 (math-rwapply-reg-neg (nth 2 expr
))
1974 (math-neg (math-rwapply-replace-regs (nth 2 expr
)))))
1975 ((eq (nth 1 expr
) 1)
1976 (math-rwapply-replace-regs (nth 2 expr
)))
1977 ((eq (nth 2 expr
) -
1)
1978 (if (math-rwapply-reg-looks-negp (nth 1 expr
))
1979 (math-rwapply-reg-neg (nth 1 expr
))
1980 (math-neg (math-rwapply-replace-regs (nth 1 expr
)))))
1981 ((eq (nth 2 expr
) 1)
1982 (math-rwapply-replace-regs (nth 1 expr
)))
1984 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr
)))
1985 (arg2 (math-rwapply-replace-regs (nth 2 expr
))))
1986 (cond ((and (eq (car-safe arg1
) '/)
1987 (eq (nth 1 arg1
) 1))
1988 (list '/ arg2
(nth 2 arg1
)))
1989 ((and (eq (car-safe arg2
) '/)
1990 (eq (nth 1 arg2
) 1))
1991 (list '/ arg1
(nth 2 arg2
)))
1992 (t (list '* arg1 arg2
)))))))
1994 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr
)))
1995 (arg2 (math-rwapply-replace-regs (nth 2 expr
))))
1996 (if (eq (car-safe arg2
) '/)
1997 (list '/ (list '* arg1
(nth 2 arg2
)) (nth 1 arg2
))
1998 (list '/ arg1 arg2
))))
1999 ((and (eq (car expr
) 'calcFunc-plain
)
2000 (= (length expr
) 2))
2001 (if (Math-primp (nth 1 expr
))
2003 (if (eq (car (nth 1 expr
)) 'calcFunc-register
)
2004 (aref regs
(nth 1 (nth 1 expr
)))
2005 (cons (car (nth 1 expr
)) (mapcar 'math-rwapply-replace-regs
2006 (cdr (nth 1 expr
)))))))
2007 (t (cons (car expr
) (mapcar 'math-rwapply-replace-regs
(cdr expr
))))))
2009 (defun math-rwapply-reg-looks-negp (expr)
2010 (if (eq (car-safe expr
) 'calcFunc-register
)
2011 (math-looks-negp (aref regs
(nth 1 expr
)))
2012 (if (memq (car-safe expr
) '(* /))
2013 (or (math-rwapply-reg-looks-negp (nth 1 expr
))
2014 (math-rwapply-reg-looks-negp (nth 2 expr
))))))
2016 (defun math-rwapply-reg-neg (expr) ; expr must satisfy rwapply-reg-looks-negp
2017 (if (eq (car expr
) 'calcFunc-register
)
2018 (math-neg (math-rwapply-replace-regs expr
))
2019 (if (math-rwapply-reg-looks-negp (nth 1 expr
))
2020 (math-rwapply-replace-regs (list (car expr
)
2021 (math-rwapply-reg-neg (nth 1 expr
))
2023 (math-rwapply-replace-regs (list (car expr
)
2025 (math-rwapply-reg-neg (nth 2 expr
)))))))
2027 (defun math-rwapply-remember (old new
)
2028 (let ((varval (symbol-value (nth 2 (car ruleset
))))
2029 (rules (assq (car-safe old
) ruleset
)))
2030 (if (and (eq (car-safe varval
) 'vec
)
2031 (not (memq (car-safe old
) '(nil schedule
+ -
)))
2034 (setcdr varval
(cons (list 'calcFunc-assign
2035 (if (math-rwcomp-no-vars old
)
2037 (list 'calcFunc-quote old
))
2040 (setcdr rules
(cons (list (vector nil old
)
2041 (list (list 'same
0 1)
2042 (list 'done new nil
))
2046 ;;; arch-tag: ca8d7b7d-bff1-4535-90f3-e2241f5e786b
2047 ;;; calc-rewr.el ends here
