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: Colin Walters <walters@debian.org>
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)
38 (defun calc-rewrite-selection (rules-str &optional many prefix
)
39 (interactive "sRewrite rule(s): \np")
42 (let* ((num (max 1 (calc-locate-cursor-element (point))))
45 (entry (calc-top num
'entry
))
47 (sel (calc-auto-selection entry
))
48 (math-rewrite-selections t
)
49 (math-rewrite-default-iters 1))
50 (if (or (null rules-str
) (equal rules-str
"") (equal rules-str
"$"))
52 (error "Can't use same stack entry for formula and rules")
53 (setq rules
(calc-top-n 1 t
)
55 (setq rules
(if (stringp rules-str
)
56 (math-read-exprs rules-str
) rules-str
))
57 (if (eq (car-safe rules
) 'error
)
58 (error "Bad format in expression: %s" (nth 1 rules
)))
59 (if (= (length rules
) 1)
60 (setq rules
(car rules
))
61 (setq rules
(cons 'vec rules
)))
62 (or (memq (car-safe rules
) '(vec var calcFunc-assign
64 (let ((rhs (math-read-expr
65 (read-string (concat "Rewrite from: " rules-str
67 (if (eq (car-safe rhs
) 'error
)
68 (error "Bad format in expression: %s" (nth 1 rhs
)))
69 (setq rules
(list 'calcFunc-assign rules rhs
))))
70 (or (eq (car-safe rules
) 'var
)
71 (calc-record rules
"rule")))
73 (setq many
'(var inf var-inf
))
74 (if many
(setq many
(prefix-numeric-value many
))))
76 (setq expr
(calc-replace-sub-formula (car entry
)
78 (list 'calcFunc-select sel
)))
79 (setq expr
(car entry
)
81 math-rewrite-selections nil
))
82 (setq expr
(calc-encase-atoms
88 expr
(calc-locate-select-marker expr
))
89 (or (consp sel
) (setq sel nil
))
90 (if pop-rules
(calc-pop-stack 1))
91 (calc-pop-push-record-list 1 (or prefix
"rwrt") (list expr
)
92 (- num
(if pop-rules
1 0))
93 (list (and reselect sel
))))
96 (defun calc-locate-select-marker (expr) ; changes "sel"
99 (if (and (eq (car expr
) 'calcFunc-select
)
102 (setq sel
(if sel t
(nth 1 expr
)))
105 (mapcar 'calc-locate-select-marker
(cdr expr
))))))
109 (defun calc-rewrite (rules-str many
)
110 (interactive "sRewrite rule(s): \nP")
113 (if (or (null rules-str
) (equal rules-str
"") (equal rules-str
"$"))
114 (setq expr
(calc-top-n 2)
115 rules
(calc-top-n 1 t
)
117 (setq rules
(if (stringp rules-str
)
118 (math-read-exprs rules-str
) rules-str
))
119 (if (eq (car-safe rules
) 'error
)
120 (error "Bad format in expression: %s" (nth 1 rules
)))
121 (if (= (length rules
) 1)
122 (setq rules
(car rules
))
123 (setq rules
(cons 'vec rules
)))
124 (or (memq (car-safe rules
) '(vec var calcFunc-assign
126 (let ((rhs (math-read-expr
127 (read-string (concat "Rewrite from: " rules-str
129 (if (eq (car-safe rhs
) 'error
)
130 (error "Bad format in expression: %s" (nth 1 rhs
)))
131 (setq rules
(list 'calcFunc-assign rules rhs
))))
132 (or (eq (car-safe rules
) 'var
)
133 (calc-record rules
"rule"))
134 (setq expr
(calc-top-n 1)
137 (setq many
'(var inf var-inf
))
138 (if many
(setq many
(prefix-numeric-value many
))))
139 (setq expr
(calc-normalize (math-rewrite expr rules many
)))
141 (setq expr
(calc-locate-select-marker expr
)))
142 (calc-pop-push-record-list n
"rwrt" (list expr
)))
145 (defun calc-match (pat)
146 (interactive "sPattern: \n")
149 (if (or (null pat
) (equal pat
"") (equal pat
"$"))
150 (setq expr
(calc-top-n 2)
153 (if (interactive-p) (setq calc-previous-alg-entry pat
))
154 (setq pat
(if (stringp pat
) (math-read-expr pat
) pat
))
155 (if (eq (car-safe pat
) 'error
)
156 (error "Bad format in expression: %s" (nth 1 pat
)))
157 (if (not (eq (car-safe pat
) 'var
))
158 (calc-record pat
"pat"))
159 (setq expr
(calc-top-n 1)
161 (or (math-vectorp expr
) (error "Argument must be a vector"))
162 (if (calc-is-inverse)
163 (calc-enter-result n
"mtcn" (math-match-patterns pat expr t
))
164 (calc-enter-result n
"mtch" (math-match-patterns pat expr nil
))))))
168 (defun math-rewrite (whole-expr rules
&optional mmt-many
)
169 (let ((crules (math-compile-rewrites rules
))
170 (heads (math-rewrite-heads whole-expr
))
171 (trace-buffer (get-buffer "*Trace*"))
172 (calc-display-just 'center
)
173 (calc-display-origin 39)
174 (calc-line-breaking 78)
175 (calc-line-numbering nil
)
176 (calc-show-selections t
)
180 (let ((result (math-apply-rewrites x
(cdr crules
)
185 (let ((fmt (math-format-stack-value
186 (list result nil nil
))))
188 (set-buffer trace-buffer
)
189 (insert "\nrewrite to\n" fmt
"\n"))))
190 (setq heads
(math-rewrite-heads result heads t
))))
193 (let ((fmt (math-format-stack-value (list whole-expr nil nil
))))
195 (set-buffer trace-buffer
)
196 (setq truncate-lines t
)
197 (goto-char (point-max))
198 (insert "\n\nBegin rewriting\n" fmt
"\n"))))
199 (or mmt-many
(setq mmt-many
(or (nth 1 (car crules
))
200 math-rewrite-default-iters
)))
201 (if (equal mmt-many
'(var inf var-inf
)) (setq mmt-many
1000000))
202 (if (equal mmt-many
'(neg (var inf var-inf
))) (setq mmt-many -
1000000))
203 (math-rewrite-phase (nth 3 (car crules
)))
205 (let ((fmt (math-format-stack-value (list whole-expr nil nil
))))
207 (set-buffer trace-buffer
)
208 (insert "\nDone rewriting"
209 (if (= mmt-many
0) " (reached iteration limit)" "")
213 (defun math-rewrite-phase (sched)
214 (while (and sched
(/= mmt-many
0))
215 (if (listp (car sched
))
216 (while (let ((save-expr whole-expr
))
217 (math-rewrite-phase (car sched
))
218 (not (equal whole-expr save-expr
))))
219 (if (symbolp (car sched
))
221 (setq whole-expr
(math-normalize (list (car sched
) whole-expr
)))
223 (let ((fmt (math-format-stack-value
224 (list whole-expr nil nil
))))
226 (set-buffer trace-buffer
)
228 (substring (symbol-name (car sched
)) 9)
230 (let ((math-rewrite-phase (car sched
)))
233 (set-buffer trace-buffer
)
234 (insert (format "\n(Phase %d)\n" math-rewrite-phase
))))
235 (while (let ((save-expr whole-expr
))
236 (setq whole-expr
(math-normalize
237 (math-map-tree-rec whole-expr
)))
238 (not (equal whole-expr save-expr
)))))))
239 (setq sched
(cdr sched
))))
241 (defun calcFunc-rewrite (expr rules
&optional many
)
242 (or (null many
) (integerp many
)
243 (equal many
'(var inf var-inf
)) (equal many
'(neg (var inf var-inf
)))
244 (math-reject-arg many
'fixnump
))
246 (math-rewrite expr rules
(or many
1))
247 (error (math-reject-arg rules
(nth 1 err
)))))
249 (defun calcFunc-match (pat vec
)
250 (or (math-vectorp vec
) (math-reject-arg vec
'vectorp
))
252 (math-match-patterns pat vec nil
)
253 (error (math-reject-arg pat
(nth 1 err
)))))
255 (defun calcFunc-matchnot (pat vec
)
256 (or (math-vectorp vec
) (math-reject-arg vec
'vectorp
))
258 (math-match-patterns pat vec t
)
259 (error (math-reject-arg pat
(nth 1 err
)))))
261 (defun math-match-patterns (pat vec
&optional not-flag
)
263 (crules (math-compile-patterns pat
)))
264 (while (setq vec
(cdr vec
))
265 (if (eq (not (math-apply-rewrites (car vec
) crules
))
267 (setq newvec
(cons (car vec
) newvec
))))
268 (cons 'vec
(nreverse newvec
))))
270 (defun calcFunc-matches (expr pat
)
272 (if (math-apply-rewrites expr
(math-compile-patterns pat
))
275 (error (math-reject-arg pat
(nth 1 err
)))))
277 (defun calcFunc-vmatches (expr pat
)
279 (or (math-apply-rewrites expr
(math-compile-patterns pat
))
281 (error (math-reject-arg pat
(nth 1 err
)))))
285 ;;; A compiled rule set is an a-list of entries whose cars are functors,
286 ;;; and whose cdrs are lists of rules. If there are rules with no
287 ;;; well-defined head functor, they are included on all lists and also
288 ;;; on an extra list whose car is nil.
290 ;;; The first entry in the a-list is of the form (schedule A B C ...).
292 ;;; Rule list entries take the form (regs prog head phases), where:
294 ;;; regs is a vector of match registers.
296 ;;; prog is a match program (see below).
298 ;;; head is a rare function name appearing in the rule body (but not the
299 ;;; head of the whole rule), or nil if none.
301 ;;; phases is a list of phase numbers for which the rule is enabled.
303 ;;; A match program is a list of match instructions.
305 ;;; In the following, "part" is a register number that contains the
306 ;;; subexpression to be operated on.
308 ;;; Register 0 is the whole expression being matched. The others are
309 ;;; meta-variables in the pattern, temporaries used for matching and
310 ;;; backtracking, and constant expressions.
313 ;;; The selected part must be math-equal to the contents of "reg".
315 ;;; (same-neg part reg)
316 ;;; The selected part must be math-equal to the negative of "reg".
319 ;;; The selected part is copied into "reg". (Rarely used.)
321 ;;; (copy-neg part reg)
322 ;;; The negative of the selected part is copied into "reg".
325 ;;; The selected part must be an integer.
328 ;;; The selected part must be a real.
331 ;;; The selected part must be a constant.
334 ;;; The selected part must "look" negative.
336 ;;; (rel part op reg)
337 ;;; The selected part must satisfy "part op reg", where "op"
338 ;;; is one of the 6 relational ops, and "reg" is a register.
340 ;;; (mod part modulo value)
341 ;;; The selected part must satisfy "part % modulo = value", where
342 ;;; "modulo" and "value" are constants.
344 ;;; (func part head reg1 reg2 ... regn)
345 ;;; The selected part must be an n-ary call to function "head".
346 ;;; The arguments are stored in "reg1" through "regn".
348 ;;; (func-def part head defs reg1 reg2 ... regn)
349 ;;; The selected part must be an n-ary call to function "head".
350 ;;; "Defs" is a list of value/register number pairs for default args.
351 ;;; If a match, assign default values to registers and then skip
352 ;;; immediately over any following "func-def" instructions and
353 ;;; the following "func" instruction. If wrong number of arguments,
354 ;;; proceed to the following "func-def" or "func" instruction.
356 ;;; (func-opt part head defs reg1)
357 ;;; Like func-def with "n=1", except that if the selected part is
358 ;;; not a call to "head", then the part itself successfully matches
359 ;;; "reg1" (and the defaults are assigned).
361 ;;; (try part heads mark reg1 [def])
362 ;;; The selected part must be a function of the correct type which is
363 ;;; associative and/or commutative. "Heads" is a list of acceptable
364 ;;; types. An initial assignment of arguments to "reg1" is tried.
365 ;;; If the program later fails, it backtracks to this instruction
366 ;;; and tries other assignments of arguments to "reg1".
367 ;;; If "def" exists and normal matching fails, backtrack and assign
368 ;;; "part" to "reg1", and "def" to "reg2" in the following "try2".
369 ;;; The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
370 ;;; "mark[0]" points to the argument list; "mark[1]" points to the
371 ;;; current argument; "mark[2]" is 0 if there are two arguments,
372 ;;; 1 if reg1 is matching single arguments, 2 if reg2 is matching
373 ;;; single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
374 ;;; 3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
375 ;;; have two arguments, 1 if phase-2 can be skipped, 2 if full
376 ;;; backtracking is necessary; "mark[4]" is t if the arguments have
377 ;;; been switched from the order given in the original pattern.
380 ;;; Every "try" will be followed by a "try2" whose "try" field is
381 ;;; a pointer to the corresponding "try". The arguments which were
382 ;;; not stored in "reg1" by that "try" are now stored in "reg2".
384 ;;; (alt instr nil mark)
385 ;;; Basic backtracking. Execute the instruction sequence "instr".
386 ;;; If this fails, back up and execute following the "alt" instruction.
387 ;;; The "mark" must be the vector "[nil nil 4]". The "instr" sequence
388 ;;; should execute "end-alt" at the end.
391 ;;; Register success of the first alternative of a previous "alt".
392 ;;; "Ptr" is a pointer to the next instruction following that "alt".
394 ;;; (apply part reg1 reg2)
395 ;;; The selected part must be a function call. The functor
396 ;;; (as a variable name) is stored in "reg1"; the arguments
397 ;;; (as a vector) are stored in "reg2".
399 ;;; (cons part reg1 reg2)
400 ;;; The selected part must be a nonempty vector. The first element
401 ;;; of the vector is stored in "reg1"; the rest of the vector
402 ;;; (as another vector) is stored in "reg2".
404 ;;; (rcons part reg1 reg2)
405 ;;; The selected part must be a nonempty vector. The last element
406 ;;; of the vector is stored in "reg2"; the rest of the vector
407 ;;; (as another vector) is stored in "reg1".
409 ;;; (select part reg)
410 ;;; If the selected part is a unary call to function "select", its
411 ;;; argument is stored in "reg"; otherwise (provided this is an `a r'
412 ;;; and not a `g r' command) the selected part is stored in "reg".
415 ;;; The "expr", with registers substituted, must simplify to
416 ;;; a non-zero value.
419 ;;; Evaluate "expr" and store the result in "reg". Always succeeds.
421 ;;; (done rhs remember)
422 ;;; Rewrite the expression to "rhs", with register substituted.
423 ;;; Normalize; if the result is different from the original
424 ;;; expression, the match has succeeded. This is the last
425 ;;; instruction of every program. If "remember" is non-nil,
426 ;;; record the result of the match as a new literal rule.
429 ;;; Pseudo-functions related to rewrites:
431 ;;; In patterns: quote, plain, condition, opt, apply, cons, select
433 ;;; In righthand sides: quote, plain, eval, evalsimp, evalextsimp,
434 ;;; apply, cons, select
436 ;;; In conditions: let + same as for righthand sides
438 ;;; Some optimizations that would be nice to have:
440 ;;; * Merge registers with disjoint lifetimes.
441 ;;; * Merge constant registers with equivalent values.
443 ;;; * If an argument of a commutative op math-depends neither on the
444 ;;; rest of the pattern nor on any of the conditions, then no backtracking
445 ;;; should be done for that argument. (This won't apply to very many
448 ;;; * If top functor is "select", and its argument is a unique function,
449 ;;; add the rule to the lists for both "select" and that function.
450 ;;; (Currently rules like this go on the "nil" list.)
451 ;;; Same for "func-opt" functions. (Though not urgent for these.)
453 ;;; * Shouldn't evaluate a "let" condition until the end, or until it
454 ;;; would enable another condition to be evaluated.
457 ;;; Some additional features to add / things to think about:
459 ;;; * Figure out what happens to "a +/- b" and "a +/- opt(b)".
461 ;;; * Same for interval forms.
463 ;;; * Have a name(v,pat) pattern which matches pat, and gives the
464 ;;; whole match the name v. Beware of circular structures!
467 (defun math-compile-patterns (pats)
468 (if (and (eq (car-safe pats
) 'var
)
469 (calc-var-value (nth 2 pats
)))
470 (let ((prop (get (nth 2 pats
) 'math-pattern-cache
)))
472 (put (nth 2 pats
) 'math-pattern-cache
(setq prop
(list nil
))))
473 (or (eq (car prop
) (symbol-value (nth 2 pats
)))
475 (setcdr prop
(math-compile-patterns
476 (symbol-value (nth 2 pats
))))
477 (setcar prop
(symbol-value (nth 2 pats
)))))
479 (let ((math-rewrite-whole t
))
480 (cdr (math-compile-rewrites (cons
482 (mapcar (function (lambda (x)
484 (if (eq (car-safe pats
) 'vec
)
488 (defvar math-rewrite-whole nil
)
489 (defvar math-make-import-list nil
)
490 (defun math-compile-rewrites (rules &optional name
)
491 (if (eq (car-safe rules
) 'var
)
492 (let ((prop (get (nth 2 rules
) 'math-rewrite-cache
))
493 (math-import-list nil
)
494 (math-make-import-list t
)
496 (or (calc-var-value (nth 2 rules
))
497 (error "Rules variable %s has no stored value" (nth 1 rules
)))
499 (put (nth 2 rules
) 'math-rewrite-cache
500 (setq prop
(list (list (cons (nth 2 rules
) nil
))))))
502 (while (and p
(eq (symbol-value (car (car p
))) (cdr (car p
))))
506 (message "Compiling rule set %s..." (nth 1 rules
))
507 (setcdr prop
(math-compile-rewrites
508 (symbol-value (nth 2 rules
))
510 (message "Compiling rule set %s...done" (nth 1 rules
))
511 (setcar prop
(cons (cons (nth 2 rules
)
512 (symbol-value (nth 2 rules
)))
515 (if (or (not (eq (car-safe rules
) 'vec
))
516 (and (memq (length rules
) '(3 4))
518 (while (and (setq p
(cdr p
))
519 (memq (car-safe (car p
))
526 calcFunc-iterations
))))
528 (setq rules
(list rules
))
529 (setq rules
(cdr rules
)))
530 (if (assq 'calcFunc-import rules
)
531 (let ((pp (setq rules
(copy-sequence rules
)))
533 (while (setq p
(car (cdr pp
)))
534 (if (eq (car-safe p
) 'calcFunc-import
)
536 (setcdr pp
(cdr (cdr pp
)))
537 (or (and (eq (car-safe (nth 1 p
)) 'var
)
538 (setq part
(calc-var-value (nth 2 (nth 1 p
))))
539 (memq (car-safe part
) '(vec
541 calcFunc-condition
)))
542 (error "Argument of import() must be a rules variable"))
543 (if math-make-import-list
544 (setq math-import-list
545 (cons (cons (nth 2 (nth 1 p
))
546 (symbol-value (nth 2 (nth 1 p
))))
548 (while (setq p
(cdr (cdr p
)))
550 (error "import() must have odd number of arguments"))
551 (setq part
(math-rwcomp-substitute part
553 (if (eq (car-safe part
) 'vec
)
554 (setq part
(cdr part
))
555 (setq part
(list part
)))
556 (setcdr pp
(append part
(cdr pp
))))
557 (setq pp
(cdr pp
))))))
563 (math-iterations nil
)
565 (math-all-phases nil
)
566 (math-remembering nil
)
567 math-pattern math-rhs math-conds
)
570 ((and (eq (car-safe (car rules
)) 'calcFunc-iterations
)
571 (= (length (car rules
)) 2))
572 (or (integerp (nth 1 (car rules
)))
573 (equal (nth 1 (car rules
)) '(var inf var-inf
))
574 (equal (nth 1 (car rules
)) '(neg (var inf var-inf
)))
575 (error "Invalid argument for iterations(n)"))
577 (setq math-iterations
(nth 1 (car rules
)))))
578 ((eq (car-safe (car rules
)) 'calcFunc-schedule
)
580 (setq math-schedule
(math-parse-schedule (cdr (car rules
))))))
581 ((eq (car-safe (car rules
)) 'calcFunc-phase
)
582 (setq math-phases
(cdr (car rules
)))
583 (if (equal math-phases
'((var all var-all
)))
584 (setq math-phases nil
))
585 (let ((p math-phases
))
587 (or (integerp (car p
))
588 (error "Phase numbers must be small integers"))
589 (or (memq (car p
) math-all-phases
)
590 (setq math-all-phases
(cons (car p
) math-all-phases
)))
592 ((or (and (eq (car-safe (car rules
)) 'vec
)
593 (cdr (cdr (car rules
)))
594 (not (nthcdr 4 (car rules
)))
595 (setq math-conds
(nth 3 (car rules
))
596 math-rhs
(nth 2 (car rules
))
597 math-pattern
(nth 1 (car rules
))))
600 math-pattern
(car rules
))
601 (while (and (eq (car-safe math-pattern
) 'calcFunc-condition
)
602 (= (length math-pattern
) 3))
603 (let ((cond (nth 2 math-pattern
)))
604 (setq math-conds
(if math-conds
605 (list 'calcFunc-land math-conds cond
)
607 math-pattern
(nth 1 math-pattern
))))
608 (and (eq (car-safe math-pattern
) 'calcFunc-assign
)
609 (= (length math-pattern
) 3)
610 (setq math-rhs
(nth 2 math-pattern
)
611 math-pattern
(nth 1 math-pattern
)))))
612 (let* ((math-prog (list nil
))
613 (math-prog-last math-prog
)
615 (math-regs (list (list nil
0 nil nil
)))
616 (math-bound-vars nil
)
617 (math-aliased-vars nil
)
619 (setq math-conds
(and math-conds
(math-flatten-lands math-conds
)))
620 (math-rwcomp-pattern math-pattern
0)
622 (let ((expr (car math-conds
)))
623 (setq math-conds
(cdr math-conds
))
624 (math-rwcomp-cond-instr expr
)))
625 (math-rwcomp-instr 'done
639 (math-rwcomp-register-expr
642 (math-rwcomp-match-vars math-rhs
))
644 (setq math-prog
(cdr math-prog
))
645 (let* ((heads (math-rewrite-heads math-pattern
))
648 (mapcar (function (lambda (x) (nth 3 x
)))
653 (head (and (not (Math-primp math-pattern
))
654 (not (and (eq (car (car math-prog
)) 'try
)
655 (nth 5 (car math-prog
))))
656 (not (memq (car (car math-prog
)) '(func-opt
660 (if (memq (car (car math-prog
)) '(func
662 (nth 2 (car math-prog
))
663 (if (eq (car math-pattern
) 'calcFunc-quote
)
664 (car-safe (nth 1 math-pattern
))
665 (car math-pattern
))))))
668 (if (setq found
(assq (car heads
) all-heads
))
669 (setcdr found
(1+ (cdr found
)))
670 (setq all-heads
(cons (cons (car heads
) 1) all-heads
)))
671 (setq heads
(cdr heads
))))
672 (if (eq head
'-
) (setq head
'+))
673 (if (memq head
'(calcFunc-cons calcFunc-rcons
)) (setq head
'vec
))
676 (nconc (or (assq head rule-set
)
677 (car (setq rule-set
(cons (cons head
683 (nconc (or (assq '/ rule-set
)
684 (car (setq rule-set
(cons (cons
690 (setq nil-rules
(nconc nil-rules
(list rule
)))
691 (let ((ptr rule-set
))
693 (nconc (car ptr
) (list rule
))
694 (setq ptr
(cdr ptr
))))))))
696 (error "Rewrite rule set must be a vector of A := B rules")))
697 (setq rules
(cdr rules
)))
699 (setq rule-set
(cons (cons nil nil-rules
) rule-set
)))
700 (setq all-heads
(mapcar 'car
701 (sort all-heads
(function
703 (< (cdr x
) (cdr y
)))))))
707 (setq rule
(cdr (car set
)))
709 (if (consp (setq heads
(nth 2 (car rule
))))
711 (setq heads
(delq (car (car set
)) heads
)
713 (while (and ptr
(not (memq (car ptr
) heads
)))
714 (setq ptr
(cdr ptr
)))
715 (setcar (nthcdr 2 (car rule
)) (car ptr
))))
716 (setq rule
(cdr rule
)))
717 (setq set
(cdr set
))))
718 (let ((plus (assq '+ rule-set
)))
720 (setq rule-set
(cons (cons '-
(cdr plus
)) rule-set
))))
721 (cons (list 'schedule math-iterations name
723 (sort math-all-phases
'<)
727 (defun math-flatten-lands (expr)
728 (if (eq (car-safe expr
) 'calcFunc-land
)
729 (append (math-flatten-lands (nth 1 expr
))
730 (math-flatten-lands (nth 2 expr
)))
733 (defun math-rewrite-heads (expr &optional more all
)
735 (skips (and (not all
)
736 '(calcFunc-apply calcFunc-condition calcFunc-opt
737 calcFunc-por calcFunc-pnot
)))
738 (blanks (and (not all
)
739 '(calcFunc-quote calcFunc-plain calcFunc-select
740 calcFunc-cons calcFunc-rcons
742 (or (Math-primp expr
)
743 (math-rewrite-heads-rec expr
))
746 (defun math-rewrite-heads-rec (expr)
747 (or (memq (car expr
) skips
)
749 (or (memq (car expr
) heads
)
750 (memq (car expr
) blanks
)
751 (memq 'algebraic
(get (car expr
) 'math-rewrite-props
))
752 (setq heads
(cons (car expr
) heads
)))
753 (while (setq expr
(cdr expr
))
754 (or (Math-primp (car expr
))
755 (math-rewrite-heads-rec (car expr
)))))))
757 (defun math-parse-schedule (sched)
763 (math-parse-schedule (cdr s
))
764 (if (eq (car-safe s
) 'var
)
765 (math-var-to-calcFunc s
)
766 (error "Improper component in rewrite schedule"))))))
769 (defun math-rwcomp-match-vars (expr)
770 (if (Math-primp expr
)
771 (if (eq (car-safe expr
) 'var
)
772 (let ((entry (assq (nth 2 expr
) math-regs
)))
774 (math-rwcomp-register-expr (nth 1 entry
))
777 (if (and (eq (car expr
) 'calcFunc-quote
)
779 (math-rwcomp-match-vars (nth 1 expr
))
780 (if (and (eq (car expr
) 'calcFunc-plain
)
782 (not (Math-primp (nth 1 expr
))))
784 (cons (car (nth 1 expr
))
785 (mapcar 'math-rwcomp-match-vars
(cdr (nth 1 expr
)))))
787 (mapcar 'math-rwcomp-match-vars
(cdr expr
)))))))
789 (defun math-rwcomp-register-expr (num)
790 (let ((entry (nth (1- (- math-num-regs num
)) math-regs
)))
792 (list 'neg
(list 'calcFunc-register
(nth 1 entry
)))
793 (list 'calcFunc-register
(nth 1 entry
)))))
795 (defun math-rwcomp-substitute (expr old new
)
796 (if (and (eq (car-safe old
) 'var
)
797 (memq (car-safe new
) '(var calcFunc-lambda
)))
798 (let ((old-func (math-var-to-calcFunc old
))
799 (new-func (math-var-to-calcFunc new
)))
800 (math-rwcomp-subst-rec expr
))
801 (let ((old-func nil
))
802 (math-rwcomp-subst-rec expr
))))
804 (defun math-rwcomp-subst-rec (expr)
805 (cond ((equal expr old
) new
)
806 ((Math-primp expr
) expr
)
807 (t (if (eq (car expr
) old-func
)
808 (math-build-call new-func
(mapcar 'math-rwcomp-subst-rec
811 (mapcar 'math-rwcomp-subst-rec
(cdr expr
)))))))
813 (defvar math-rwcomp-tracing nil
)
815 (defun math-rwcomp-trace (instr)
816 (when math-rwcomp-tracing
817 (terpri) (princ instr
))
820 (defun math-rwcomp-instr (&rest instr
)
821 (setcdr math-prog-last
822 (setq math-prog-last
(list (math-rwcomp-trace instr
)))))
824 (defun math-rwcomp-multi-instr (tail &rest instr
)
825 (setcdr math-prog-last
826 (setq math-prog-last
(list (math-rwcomp-trace (append instr tail
))))))
828 (defun math-rwcomp-bind-var (reg var
)
829 (setcar (math-rwcomp-reg-entry reg
) (nth 2 var
))
830 (setq math-bound-vars
(cons (nth 2 var
) math-bound-vars
))
831 (math-rwcomp-do-conditions))
833 (defun math-rwcomp-unbind-vars (mark)
834 (while (not (eq math-bound-vars mark
))
835 (setcar (assq (car math-bound-vars
) math-regs
) nil
)
836 (setq math-bound-vars
(cdr math-bound-vars
))))
838 (defun math-rwcomp-do-conditions ()
839 (let ((cond math-conds
))
841 (if (math-rwcomp-all-regs-done (car cond
))
842 (let ((expr (car cond
)))
843 (setq math-conds
(delq (car cond
) math-conds
))
845 (math-rwcomp-cond-instr expr
)))
846 (setq cond
(cdr cond
)))))
848 (defun math-rwcomp-cond-instr (expr)
850 (cond ((and (eq (car-safe expr
) 'calcFunc-matches
)
852 (eq (car-safe (setq arg
(math-rwcomp-match-vars (nth 1 expr
))))
854 (math-rwcomp-pattern (nth 2 expr
) (nth 1 arg
)))
855 ((math-numberp (setq expr
(math-rwcomp-match-vars expr
)))
856 (if (Math-zerop expr
)
857 (math-rwcomp-instr 'backtrack
)))
858 ((and (eq (car expr
) 'calcFunc-let
)
860 (let ((reg (math-rwcomp-reg)))
861 (math-rwcomp-instr 'let reg
(nth 2 expr
))
862 (math-rwcomp-pattern (nth 1 expr
) reg
)))
863 ((and (eq (car expr
) 'calcFunc-let
)
865 (eq (car-safe (nth 1 expr
)) 'calcFunc-assign
)
866 (= (length (nth 1 expr
)) 3))
867 (let ((reg (math-rwcomp-reg)))
868 (math-rwcomp-instr 'let reg
(nth 2 (nth 1 expr
)))
869 (math-rwcomp-pattern (nth 1 (nth 1 expr
)) reg
)))
870 ((and (setq op
(cdr (assq (car-safe expr
)
871 '( (calcFunc-integer . integer
)
872 (calcFunc-real . real
)
873 (calcFunc-constant . constant
)
874 (calcFunc-negative . negative
) ))))
876 (or (and (eq (car-safe (nth 1 expr
)) 'neg
)
877 (memq op
'(integer real constant
))
878 (setq arg
(nth 1 (nth 1 expr
))))
879 (setq arg
(nth 1 expr
)))
880 (eq (car-safe (setq arg
(nth 1 expr
))) 'calcFunc-register
))
881 (math-rwcomp-instr op
(nth 1 arg
)))
882 ((and (assq (car-safe expr
) calc-tweak-eqn-table
)
884 (eq (car-safe (nth 1 expr
)) 'calcFunc-register
))
885 (if (math-constp (nth 2 expr
))
886 (let ((reg (math-rwcomp-reg)))
887 (setcar (nthcdr 3 (car math-regs
)) (nth 2 expr
))
888 (math-rwcomp-instr 'rel
(nth 1 (nth 1 expr
))
890 (if (eq (car (nth 2 expr
)) 'calcFunc-register
)
891 (math-rwcomp-instr 'rel
(nth 1 (nth 1 expr
))
892 (car expr
) (nth 1 (nth 2 expr
)))
893 (math-rwcomp-instr 'cond expr
))))
894 ((and (eq (car-safe expr
) 'calcFunc-eq
)
896 (eq (car-safe (nth 1 expr
)) '%
)
897 (eq (car-safe (nth 1 (nth 1 expr
))) 'calcFunc-register
)
898 (math-constp (nth 2 (nth 1 expr
)))
899 (math-constp (nth 2 expr
)))
900 (math-rwcomp-instr 'mod
(nth 1 (nth 1 (nth 1 expr
)))
901 (nth 2 (nth 1 expr
)) (nth 2 expr
)))
902 ((equal expr
'(var remember var-remember
))
903 (setq math-remembering
1))
904 ((and (eq (car-safe expr
) 'calcFunc-remember
)
906 (setq math-remembering
(if math-remembering
908 math-remembering
(nth 1 expr
))
910 (t (math-rwcomp-instr 'cond expr
)))))
912 (defun math-rwcomp-same-instr (reg1 reg2 neg
)
913 (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1
))
914 (nth 2 (math-rwcomp-reg-entry reg2
)))
920 (defun math-rwcomp-copy-instr (reg1 reg2 neg
)
921 (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1
))
922 (nth 2 (math-rwcomp-reg-entry reg2
)))
924 (math-rwcomp-instr 'copy-neg reg1 reg2
)
926 (math-rwcomp-instr 'copy reg1 reg2
))))
928 (defun math-rwcomp-reg ()
931 (setq math-regs
(cons (list nil math-num-regs nil
0) math-regs
)
932 math-num-regs
(1+ math-num-regs
))))
934 (defun math-rwcomp-reg-entry (num)
935 (nth (1- (- math-num-regs num
)) math-regs
))
938 (defun math-rwcomp-pattern (expr part
&optional not-direct
)
939 (cond ((or (math-rwcomp-no-vars expr
)
940 (and (eq (car expr
) 'calcFunc-quote
)
942 (setq expr
(nth 1 expr
))))
943 (if (eq (car-safe expr
) 'calcFunc-register
)
944 (math-rwcomp-same-instr part
(nth 1 expr
) nil
)
945 (let ((reg (math-rwcomp-reg)))
946 (setcar (nthcdr 3 (car math-regs
)) expr
)
947 (math-rwcomp-same-instr part reg nil
))))
948 ((eq (car expr
) 'var
)
949 (let ((entry (assq (nth 2 expr
) math-regs
)))
951 (math-rwcomp-same-instr part
(nth 1 entry
) nil
)
953 (let ((reg (math-rwcomp-reg)))
954 (math-rwcomp-pattern expr reg
)
955 (math-rwcomp-copy-instr part reg nil
))
956 (if (setq entry
(assq (nth 2 expr
) math-aliased-vars
))
958 (setcar (math-rwcomp-reg-entry (nth 1 entry
))
961 (math-rwcomp-copy-instr part
(nth 1 entry
) nil
))
962 (math-rwcomp-bind-var part expr
))))))
963 ((and (eq (car expr
) 'calcFunc-select
)
965 (let ((reg (math-rwcomp-reg)))
966 (math-rwcomp-instr 'select part reg
)
967 (math-rwcomp-pattern (nth 1 expr
) reg
)))
968 ((and (eq (car expr
) 'calcFunc-opt
)
969 (memq (length expr
) '(2 3)))
970 (error "opt( ) occurs in context where it is not allowed"))
971 ((eq (car expr
) 'neg
)
972 (if (eq (car (nth 1 expr
)) 'var
)
973 (let ((entry (assq (nth 2 (nth 1 expr
)) math-regs
)))
975 (math-rwcomp-same-instr part
(nth 1 entry
) t
)
977 (let ((reg (math-rwcomp-best-reg (nth 1 expr
))))
978 (math-rwcomp-copy-instr part reg t
)
979 (math-rwcomp-pattern (nth 1 expr
) reg
))
980 (setcar (cdr (cdr (math-rwcomp-reg-entry part
))) t
)
981 (math-rwcomp-pattern (nth 1 expr
) part
))))
982 (if (math-rwcomp-is-algebraic (nth 1 expr
))
983 (math-rwcomp-cond-instr (list 'calcFunc-eq
984 (math-rwcomp-register-expr part
)
986 (let ((reg (math-rwcomp-reg)))
987 (math-rwcomp-instr 'func part
'neg reg
)
988 (math-rwcomp-pattern (nth 1 expr
) reg
)))))
989 ((and (eq (car expr
) 'calcFunc-apply
)
991 (let ((reg1 (math-rwcomp-reg))
992 (reg2 (math-rwcomp-reg)))
993 (math-rwcomp-instr 'apply part reg1 reg2
)
994 (math-rwcomp-pattern (nth 1 expr
) reg1
)
995 (math-rwcomp-pattern (nth 2 expr
) reg2
)))
996 ((and (eq (car expr
) 'calcFunc-cons
)
998 (let ((reg1 (math-rwcomp-reg))
999 (reg2 (math-rwcomp-reg)))
1000 (math-rwcomp-instr 'cons part reg1 reg2
)
1001 (math-rwcomp-pattern (nth 1 expr
) reg1
)
1002 (math-rwcomp-pattern (nth 2 expr
) reg2
)))
1003 ((and (eq (car expr
) 'calcFunc-rcons
)
1004 (= (length expr
) 3))
1005 (let ((reg1 (math-rwcomp-reg))
1006 (reg2 (math-rwcomp-reg)))
1007 (math-rwcomp-instr 'rcons part reg1 reg2
)
1008 (math-rwcomp-pattern (nth 1 expr
) reg1
)
1009 (math-rwcomp-pattern (nth 2 expr
) reg2
)))
1010 ((and (eq (car expr
) 'calcFunc-condition
)
1011 (>= (length expr
) 3))
1012 (math-rwcomp-pattern (nth 1 expr
) part
)
1013 (setq expr
(cdr expr
))
1014 (while (setq expr
(cdr expr
))
1015 (let ((cond (math-flatten-lands (car expr
))))
1017 (if (math-rwcomp-all-regs-done (car cond
))
1018 (math-rwcomp-cond-instr (car cond
))
1019 (setq math-conds
(cons (car cond
) math-conds
)))
1020 (setq cond
(cdr cond
))))))
1021 ((and (eq (car expr
) 'calcFunc-pand
)
1022 (= (length expr
) 3))
1023 (math-rwcomp-pattern (nth 1 expr
) part
)
1024 (math-rwcomp-pattern (nth 2 expr
) part
))
1025 ((and (eq (car expr
) 'calcFunc-por
)
1026 (= (length expr
) 3))
1027 (math-rwcomp-instr 'alt nil nil
[nil nil
4])
1028 (let ((math-conds nil
)
1029 (head math-prog-last
)
1030 (mark math-bound-vars
)
1032 (math-rwcomp-pattern (nth 1 expr
) part t
)
1033 (let ((amark math-aliased-vars
)
1034 (math-aliased-vars math-aliased-vars
)
1035 (tail math-prog-last
)
1038 (while (not (eq p mark
))
1039 (setq entry
(assq (car p
) math-regs
)
1040 math-aliased-vars
(cons (list (car p
) (nth 1 entry
) nil
)
1043 (setcar (math-rwcomp-reg-entry (nth 1 entry
)) nil
))
1044 (setcar (cdr (car head
)) (cdr head
))
1046 (setq math-prog-last head
)
1047 (math-rwcomp-pattern (nth 2 expr
) part
)
1048 (math-rwcomp-instr 'same
0 0)
1049 (setcdr tail math-prog-last
)
1050 (setq p math-aliased-vars
)
1051 (while (not (eq p amark
))
1053 (setcar (math-rwcomp-reg-entry (nth 1 (car p
)))
1056 (math-rwcomp-do-conditions))
1057 ((and (eq (car expr
) 'calcFunc-pnot
)
1058 (= (length expr
) 2))
1059 (math-rwcomp-instr 'alt nil nil
[nil nil
4])
1060 (let ((head math-prog-last
)
1061 (mark math-bound-vars
))
1062 (math-rwcomp-pattern (nth 1 expr
) part
)
1063 (math-rwcomp-unbind-vars mark
)
1064 (math-rwcomp-instr 'end-alt head
)
1065 (math-rwcomp-instr 'backtrack
)
1066 (setcar (cdr (car head
)) (cdr head
))
1068 (setq math-prog-last head
)))
1069 (t (let ((props (get (car expr
) 'math-rewrite-props
)))
1070 (if (and (eq (car expr
) 'calcFunc-plain
)
1072 (not (math-primp (nth 1 expr
))))
1073 (setq expr
(nth 1 expr
))) ; but "props" is still nil
1074 (if (and (memq 'algebraic props
)
1075 (math-rwcomp-is-algebraic expr
))
1076 (math-rwcomp-cond-instr (list 'calcFunc-eq
1077 (math-rwcomp-register-expr part
)
1079 (if (and (memq 'commut props
)
1080 (= (length expr
) 3))
1081 (let ((arg1 (nth 1 expr
))
1083 try1 def code head
(flip nil
))
1084 (if (eq (car expr
) '-
)
1085 (setq arg2
(math-rwcomp-neg arg2
)))
1086 (setq arg1
(cons arg1
(math-rwcomp-best-reg arg1
))
1087 arg2
(cons arg2
(math-rwcomp-best-reg arg2
)))
1088 (or (math-rwcomp-order arg1 arg2
)
1089 (setq def arg1 arg1 arg2 arg2 def flip t
))
1090 (if (math-rwcomp-optional-arg (car expr
) arg1
)
1091 (error "Too many opt( ) arguments in this context"))
1092 (setq def
(math-rwcomp-optional-arg (car expr
) arg2
)
1093 head
(if (memq (car expr
) '(+ -
))
1095 (if (eq (car expr
) '*)
1098 code
(if (math-rwcomp-is-constrained
1100 (if (math-rwcomp-is-constrained
1104 (math-rwcomp-multi-instr (and def
(list def
))
1106 (vector nil nil nil code flip
)
1108 (setq try1
(car math-prog-last
))
1109 (math-rwcomp-pattern (car arg1
) (cdr arg1
))
1110 (math-rwcomp-instr 'try2 try1
(cdr arg2
))
1111 (if (and (= part
0) (not def
) (not math-rewrite-whole
)
1112 (not (eq math-rhs t
))
1113 (setq def
(get (car expr
)
1114 'math-rewrite-default
)))
1115 (let ((reg1 (math-rwcomp-reg))
1116 (reg2 (math-rwcomp-reg)))
1117 (if (= (aref (nth 3 try1
) 3) 0)
1118 (aset (nth 3 try1
) 3 1))
1119 (math-rwcomp-instr 'try
(cdr arg2
)
1120 (if (equal head
'(* /))
1127 (setq try1
(car math-prog-last
))
1128 (math-rwcomp-pattern (car arg2
) reg1
)
1129 (math-rwcomp-instr 'try2 try1 reg2
)
1130 (setq math-rhs
(list (if (eq (car expr
) '-
)
1133 (list 'calcFunc-register
1135 (math-rwcomp-pattern (car arg2
) (cdr arg2
))))
1136 (let* ((args (mapcar (function
1138 (cons x
(math-rwcomp-best-reg x
))))
1140 (args2 (copy-sequence args
))
1141 (argp (reverse args2
))
1145 (let ((def (math-rwcomp-optional-arg (car expr
)
1149 (setq args2
(delq (car argp
) args2
)
1150 defs
(cons (cons def
(cdr (car argp
)))
1152 (math-rwcomp-multi-instr
1154 (if (or (and (memq 'unary1 props
)
1155 (= (length args2
) 1)
1156 (eq (car args2
) (car args
)))
1157 (and (memq 'unary2 props
)
1159 (eq (car args2
) (nth 1 args
))))
1164 (setq argp
(cdr argp
)))
1165 (math-rwcomp-multi-instr (mapcar 'cdr args
)
1166 'func part
(car expr
))
1167 (setq args
(sort args
'math-rwcomp-order
))
1169 (math-rwcomp-pattern (car (car args
)) (cdr (car args
)))
1171 args
(cdr args
))))))))))
1173 (defun math-rwcomp-best-reg (x)
1174 (or (and (eq (car-safe x
) 'var
)
1175 (let ((entry (assq (nth 2 x
) math-aliased-vars
)))
1178 (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry
))))
1180 (setcar (cdr (cdr entry
)) t
)
1184 (defun math-rwcomp-all-regs-done (expr)
1185 (if (Math-primp expr
)
1186 (or (not (eq (car-safe expr
) 'var
))
1187 (assq (nth 2 expr
) math-regs
)
1188 (eq (nth 2 expr
) 'var-remember
)
1189 (math-const-var expr
))
1190 (if (and (eq (car expr
) 'calcFunc-let
)
1191 (= (length expr
) 3))
1192 (math-rwcomp-all-regs-done (nth 2 expr
))
1193 (if (and (eq (car expr
) 'calcFunc-let
)
1195 (eq (car-safe (nth 1 expr
)) 'calcFunc-assign
)
1196 (= (length (nth 1 expr
)) 3))
1197 (math-rwcomp-all-regs-done (nth 2 (nth 1 expr
)))
1198 (while (and (setq expr
(cdr expr
))
1199 (math-rwcomp-all-regs-done (car expr
))))
1202 (defun math-rwcomp-no-vars (expr)
1203 (if (Math-primp expr
)
1204 (or (not (eq (car-safe expr
) 'var
))
1205 (math-const-var expr
))
1206 (and (not (memq (car expr
) '(calcFunc-condition
1207 calcFunc-select calcFunc-quote
1208 calcFunc-plain calcFunc-opt
1209 calcFunc-por calcFunc-pand
1210 calcFunc-pnot calcFunc-apply
1211 calcFunc-cons calcFunc-rcons
)))
1213 (while (and (setq expr
(cdr expr
))
1214 (math-rwcomp-no-vars (car expr
))))
1217 (defun math-rwcomp-is-algebraic (expr)
1218 (if (Math-primp expr
)
1219 (or (not (eq (car-safe expr
) 'var
))
1220 (math-const-var expr
)
1221 (assq (nth 2 expr
) math-regs
))
1222 (and (memq 'algebraic
(get (car expr
) 'math-rewrite-props
))
1224 (while (and (setq expr
(cdr expr
))
1225 (math-rwcomp-is-algebraic (car expr
))))
1228 (defun math-rwcomp-is-constrained (expr not-these
)
1229 (if (Math-primp expr
)
1230 (not (eq (car-safe expr
) 'var
))
1231 (if (eq (car expr
) 'calcFunc-plain
)
1232 (math-rwcomp-is-constrained (nth 1 expr
) not-these
)
1233 (not (or (memq (car expr
) '(neg calcFunc-select
))
1234 (memq (car expr
) not-these
)
1235 (and (memq 'commut
(get (car expr
) 'math-rewrite-props
))
1236 (or (eq (car-safe (nth 1 expr
)) 'calcFunc-opt
)
1237 (eq (car-safe (nth 2 expr
)) 'calcFunc-opt
))))))))
1239 (defun math-rwcomp-optional-arg (head argp
)
1240 (let ((arg (car argp
)))
1241 (if (eq (car-safe arg
) 'calcFunc-opt
)
1242 (and (memq (length arg
) '(2 3))
1244 (or (eq (car-safe (nth 1 arg
)) 'var
)
1245 (error "First argument of opt( ) must be a variable"))
1246 (setcar argp
(nth 1 arg
))
1247 (if (= (length arg
) 2)
1248 (or (get head
'math-rewrite-default
)
1249 (error "opt( ) must include a default in this context"))
1251 (and (eq (car-safe arg
) 'neg
)
1252 (let* ((part (list (nth 1 arg
)))
1253 (partp (math-rwcomp-optional-arg head part
)))
1255 (setcar argp
(math-rwcomp-neg (car part
)))
1256 (math-neg partp
)))))))
1258 (defun math-rwcomp-neg (expr)
1259 (if (memq (car-safe expr
) '(* /))
1260 (if (eq (car-safe (nth 1 expr
)) 'var
)
1261 (list (car expr
) (list 'neg
(nth 1 expr
)) (nth 2 expr
))
1262 (if (eq (car-safe (nth 2 expr
)) 'var
)
1263 (list (car expr
) (nth 1 expr
) (list 'neg
(nth 2 expr
)))
1267 (defun math-rwcomp-assoc-args (expr)
1268 (if (and (eq (car-safe (nth 1 expr
)) (car expr
))
1269 (= (length (nth 1 expr
)) 3))
1270 (math-rwcomp-assoc-args (nth 1 expr
))
1271 (setq math-args
(cons (nth 1 expr
) math-args
)))
1272 (if (and (eq (car-safe (nth 2 expr
)) (car expr
))
1273 (= (length (nth 2 expr
)) 3))
1274 (math-rwcomp-assoc-args (nth 2 expr
))
1275 (setq math-args
(cons (nth 2 expr
) math-args
))))
1277 (defun math-rwcomp-addsub-args (expr)
1278 (if (memq (car-safe (nth 1 expr
)) '(+ -
))
1279 (math-rwcomp-addsub-args (nth 1 expr
))
1280 (setq math-args
(cons (nth 1 expr
) math-args
)))
1281 (if (eq (car expr
) '-
)
1282 (setq math-args
(cons (math-rwcomp-neg (nth 2 expr
)) math-args
))
1283 (if (eq (car-safe (nth 2 expr
)) '+)
1284 (math-rwcomp-addsub-args (nth 2 expr
))
1285 (setq math-args
(cons (nth 2 expr
) math-args
)))))
1287 (defun math-rwcomp-order (a b
)
1288 (< (math-rwcomp-priority (car a
))
1289 (math-rwcomp-priority (car b
))))
1291 ;;; Order of priority: 0 Constants and other exact matches (first)
1292 ;;; 10 Functions (except below)
1293 ;;; 20 Meta-variables which occur more than once
1294 ;;; 30 Algebraic functions
1295 ;;; 40 Commutative/associative functions
1296 ;;; 50 Meta-variables which occur only once
1297 ;;; +100 for every "!!!" (pnot) in the pattern
1298 ;;; 10000 Optional arguments (last)
1300 (defun math-rwcomp-priority (expr)
1301 (+ (math-rwcomp-count-pnots expr
)
1302 (cond ((eq (car-safe expr
) 'calcFunc-opt
)
1304 ((math-rwcomp-no-vars expr
)
1306 ((eq (car expr
) 'calcFunc-quote
)
1308 ((eq (car expr
) 'var
)
1309 (if (assq (nth 2 expr
) math-regs
)
1311 (if (= (math-rwcomp-count-refs expr
) 1)
1314 (t (let ((props (get (car expr
) 'math-rewrite-props
)))
1315 (if (or (memq 'commut props
)
1316 (memq 'assoc props
))
1318 (if (memq 'algebraic props
)
1322 (defun math-rwcomp-count-refs (var)
1323 (let ((count (or (math-expr-contains-count math-pattern var
) 0))
1326 (if (eq (car-safe (car p
)) 'calcFunc-let
)
1327 (if (= (length (car p
)) 3)
1328 (setq count
(+ count
1329 (or (math-expr-contains-count (nth 2 (car p
)) var
)
1331 (if (and (= (length (car p
)) 2)
1332 (eq (car-safe (nth 1 (car p
))) 'calcFunc-assign
)
1333 (= (length (nth 1 (car p
))) 3))
1334 (setq count
(+ count
1335 (or (math-expr-contains-count
1336 (nth 2 (nth 1 (car p
))) var
) 0))))))
1340 (defun math-rwcomp-count-pnots (expr)
1341 (if (Math-primp expr
)
1343 (if (eq (car expr
) 'calcFunc-pnot
)
1346 (while (setq expr
(cdr expr
))
1347 (setq count
(+ count
(math-rwcomp-count-pnots (car expr
)))))
1350 ;;; In the current implementation, all associative functions must
1351 ;;; also be commutative.
1353 (put '+ 'math-rewrite-props
'(algebraic assoc commut
))
1354 (put '-
'math-rewrite-props
'(algebraic assoc commut
)) ; see below
1355 (put '* 'math-rewrite-props
'(algebraic assoc commut
)) ; see below
1356 (put '/ 'math-rewrite-props
'(algebraic unary1
))
1357 (put '^
'math-rewrite-props
'(algebraic unary1
))
1358 (put '%
'math-rewrite-props
'(algebraic))
1359 (put 'neg
'math-rewrite-props
'(algebraic))
1360 (put 'calcFunc-idiv
'math-rewrite-props
'(algebraic))
1361 (put 'calcFunc-abs
'math-rewrite-props
'(algebraic))
1362 (put 'calcFunc-sign
'math-rewrite-props
'(algebraic))
1363 (put 'calcFunc-round
'math-rewrite-props
'(algebraic))
1364 (put 'calcFunc-rounde
'math-rewrite-props
'(algebraic))
1365 (put 'calcFunc-roundu
'math-rewrite-props
'(algebraic))
1366 (put 'calcFunc-trunc
'math-rewrite-props
'(algebraic))
1367 (put 'calcFunc-floor
'math-rewrite-props
'(algebraic))
1368 (put 'calcFunc-ceil
'math-rewrite-props
'(algebraic))
1369 (put 'calcFunc-re
'math-rewrite-props
'(algebraic))
1370 (put 'calcFunc-im
'math-rewrite-props
'(algebraic))
1371 (put 'calcFunc-conj
'math-rewrite-props
'(algebraic))
1372 (put 'calcFunc-arg
'math-rewrite-props
'(algebraic))
1373 (put 'calcFunc-and
'math-rewrite-props
'(assoc commut
))
1374 (put 'calcFunc-or
'math-rewrite-props
'(assoc commut
))
1375 (put 'calcFunc-xor
'math-rewrite-props
'(assoc commut
))
1376 (put 'calcFunc-eq
'math-rewrite-props
'(commut))
1377 (put 'calcFunc-neq
'math-rewrite-props
'(commut))
1378 (put 'calcFunc-land
'math-rewrite-props
'(assoc commut
))
1379 (put 'calcFunc-lor
'math-rewrite-props
'(assoc commut
))
1380 (put 'calcFunc-beta
'math-rewrite-props
'(commut))
1381 (put 'calcFunc-gcd
'math-rewrite-props
'(assoc commut
))
1382 (put 'calcFunc-lcm
'math-rewrite-props
'(assoc commut
))
1383 (put 'calcFunc-max
'math-rewrite-props
'(algebraic assoc commut
))
1384 (put 'calcFunc-min
'math-rewrite-props
'(algebraic assoc commut
))
1385 (put 'calcFunc-vunion
'math-rewrite-props
'(assoc commut
))
1386 (put 'calcFunc-vint
'math-rewrite-props
'(assoc commut
))
1387 (put 'calcFunc-vxor
'math-rewrite-props
'(assoc commut
))
1389 ;;; Note: "*" is not commutative for matrix args, but we pretend it is.
1390 ;;; Also, "-" is not commutative but the code tweaks things so that it is.
1392 (put '+ 'math-rewrite-default
0)
1393 (put '-
'math-rewrite-default
0)
1394 (put '* 'math-rewrite-default
1)
1395 (put '/ 'math-rewrite-default
1)
1396 (put '^
'math-rewrite-default
1)
1397 (put 'calcFunc-land
'math-rewrite-default
1)
1398 (put 'calcFunc-lor
'math-rewrite-default
0)
1399 (put 'calcFunc-vunion
'math-rewrite-default
'(vec))
1400 (put 'calcFunc-vint
'math-rewrite-default
'(vec))
1401 (put 'calcFunc-vdiff
'math-rewrite-default
'(vec))
1402 (put 'calcFunc-vxor
'math-rewrite-default
'(vec))
1404 (defmacro math-rwfail
(&optional back
)
1408 '(setq btrack
(cdr btrack
))
1412 ;;; This monstrosity is necessary because the use of static vectors of
1413 ;;; registers makes rewrite rules non-reentrant. Yucko!
1414 (defmacro math-rweval
(form)
1415 (list 'let
'((orig (car rules
)))
1416 '(setcar rules
(quote (nil nil nil no-phase
)))
1417 (list 'unwind-protect
1419 '(setcar rules orig
))))
1421 (setq math-rewrite-phase
1)
1423 (defun math-apply-rewrites (expr rules
&optional heads ruleset
)
1425 (setq rules
(cdr (or (assq (car-safe expr
) rules
)
1428 op regs inst part pc mark btrack
1429 (tracing math-rwcomp-tracing
)
1430 (phase math-rewrite-phase
))
1433 (and (setq part
(nth 2 (car rules
)))
1435 (not (memq part heads
)))
1436 (and (setq part
(nth 3 (car rules
)))
1437 (not (memq phase part
)))
1439 (setq regs
(car (car rules
))
1440 pc
(nth 1 (car rules
))
1446 (progn (terpri) (princ (car pc
))
1447 (if (and (natnump (nth 1 (car pc
)))
1448 (< (nth 1 (car pc
)) (length regs
)))
1449 (princ (format "\n part = %s"
1450 (aref regs
(nth 1 (car pc
))))))))
1452 (cond ((eq (setq op
(car (setq inst
(car pc
)))) 'func
)
1453 (if (and (consp (setq part
(aref regs
(car (cdr inst
)))))
1455 (car (setq inst
(cdr (cdr inst
)))))
1457 (while (and (setq inst
(cdr inst
)
1460 (aset regs
(car inst
) (car part
)))
1461 (not (or inst part
))))
1466 (if (or (equal (setq part
(aref regs
(nth 1 inst
)))
1467 (setq mark
(aref regs
(nth 2 inst
))))
1468 (Math-equal part mark
))
1474 (not (eq calc-matrix-mode
'scalar
))
1475 (eq (car (nth 2 inst
)) '*)
1476 (consp (setq part
(aref regs
(car (cdr inst
)))))
1478 (not (math-known-scalarp part
)))
1479 (setq mark
(nth 3 inst
)
1483 (aset regs
(nth 4 inst
) (nth 2 part
))
1484 (aset mark
1 (cdr (cdr part
))))
1485 (aset regs
(nth 4 inst
) (nth 1 part
))
1486 (aset mark
1 (cdr part
)))
1487 (aset mark
0 (cdr part
))
1491 (if (and (consp (setq part
(aref regs
(car (cdr inst
)))))
1492 (memq (car part
) (nth 2 inst
))
1494 (or (not (eq (car part
) '/))
1495 (Math-objectp (nth 2 part
))))
1498 mark
(car (cdr (setq inst
(cdr (cdr inst
))))))
1500 (memq 'assoc
(get (car part
) 'math-rewrite-props
))
1501 (not (= (aref mark
3) 0))
1502 (while (if (and (consp (nth 1 part
))
1503 (memq (car (nth 1 part
)) (car inst
)))
1504 (setq op
(cons (if (eq (car part
) '-
)
1510 (if (and (consp (nth 2 part
))
1511 (memq (car (nth 2 part
))
1513 (not (eq (car (nth 2 part
)) '-
)))
1514 (setq op
(cons (nth 1 part
) op
)
1515 part
(nth 2 part
))))))
1516 (setq op
(cons (nth 1 part
)
1517 (cons (if (eq (car part
) '-
)
1520 (if (eq (car part
) '/)
1525 btrack
(cons pc btrack
)
1527 (aset regs
(nth 2 inst
) (car op
))
1530 (aset mark
2 (if (cdr (cdr op
)) 1 0)))
1532 (if (and (consp part
)
1533 (eq (car part
) 'neg
)
1534 (eq (car (nth 2 inst
)) '*)
1535 (eq (nth 5 inst
) 1))
1537 (setq mark
(nth 3 inst
)
1539 (aset regs
(nth 4 inst
) (nth 1 part
))
1542 (setq mark
(nth 3 inst
)
1544 (aset regs
(nth 4 inst
) part
)
1549 (setq part
(nth 1 inst
) ; try instr
1553 (aset regs
(nth 2 inst
)
1556 (if (eq (aref mark
0) (aref mark
1))
1557 (nth 1 (aref mark
0))
1558 (car (aref mark
0))))
1560 (setq mark
(delq (car (aref mark
1))
1561 (copy-sequence (aref mark
0)))
1562 op
(car (nth 2 part
)))
1565 (setq mark
(nreverse mark
)
1566 part
(list '* (nth 1 mark
) (car mark
))
1568 (while (setq mark
(cdr mark
))
1569 (setq part
(list '* (car mark
) part
))))
1570 (setq part
(car mark
)
1572 part
(if (and (eq op
'+)
1574 (eq (car (car mark
)) 'neg
))
1577 (list op part
(car mark
))))
1578 (while (setq mark
(cdr mark
))
1579 (setq part
(if (and (eq op
'+)
1581 (eq (car (car mark
)) 'neg
))
1584 (list op part
(car mark
))))))
1587 (car (aref mark
1)))
1588 ((eq op
3) (nth 5 part
))
1589 (t (aref mark
1)))))
1593 (if (and (consp (setq part
(aref regs
(nth 1 inst
))))
1594 (eq (car part
) 'calcFunc-select
))
1595 (aset regs
(nth 2 inst
) (nth 1 part
))
1596 (if math-rewrite-selections
1598 (aset regs
(nth 2 inst
) part
))))
1601 (if (or (equal (setq part
(aref regs
(nth 1 inst
)))
1602 (setq mark
(math-neg
1603 (aref regs
(nth 2 inst
)))))
1604 (Math-equal part mark
))
1609 (setq inst
(car (car btrack
)) ; "try" or "alt" instr
1610 pc
(cdr (car btrack
))
1611 mark
(or (nth 3 inst
) [nil nil
4])
1614 (if (setq op
(cdr (aref mark
1)))
1615 (aset regs
(nth 4 inst
) (car (aset mark
1 op
)))
1619 (aset regs
(nth 4 inst
)
1620 (aref regs
(nth 1 inst
))))
1623 (if (setq op
(cdr (aref mark
1)))
1624 (aset regs
(nth 4 inst
) (car (aset mark
1 op
)))
1625 (if (= (aref mark
3) 1)
1629 (aset regs
(nth 4 inst
)
1630 (aref regs
(nth 1 inst
))))
1633 (aset mark
1 (cons nil
(aref mark
0)))
1636 (if (setq op
(cdr (aref mark
1)))
1638 (setq mark
(delq (car (aset mark
1 op
))
1641 op
(car (nth 2 inst
)))
1644 (setq mark
(nreverse mark
)
1645 part
(list '* (nth 1 mark
)
1648 (while (setq mark
(cdr mark
))
1649 (setq part
(list '* (car mark
)
1651 (setq part
(car mark
)
1653 part
(if (and (eq op
'+)
1655 (eq (car (car mark
))
1659 (list op part
(car mark
))))
1660 (while (setq mark
(cdr mark
))
1661 (setq part
(if (and (eq op
'+)
1663 (eq (car (car mark
))
1667 (list op part
(car mark
))))))
1668 (aset regs
(nth 4 inst
) part
))
1672 (aset regs
(nth 4 inst
)
1673 (aref regs
(nth 1 inst
))))
1676 (setq btrack
(cdr btrack
)))
1677 (t (math-rwfail t
))))
1680 (if (Math-integerp (setq part
(aref regs
(nth 1 inst
))))
1682 (if (Math-primp part
)
1684 (setq part
(math-rweval (math-simplify part
)))
1685 (if (Math-integerp part
)
1690 (if (Math-realp (setq part
(aref regs
(nth 1 inst
))))
1692 (if (Math-primp part
)
1694 (setq part
(math-rweval (math-simplify part
)))
1695 (if (Math-realp part
)
1700 (if (math-constp (setq part
(aref regs
(nth 1 inst
))))
1702 (if (Math-primp part
)
1704 (setq part
(math-rweval (math-simplify part
)))
1705 (if (math-constp part
)
1710 (if (math-looks-negp (setq part
(aref regs
(nth 1 inst
))))
1712 (if (Math-primp part
)
1714 (setq part
(math-rweval (math-simplify part
)))
1715 (if (math-looks-negp part
)
1720 (setq part
(math-compare (aref regs
(nth 1 inst
))
1721 (aref regs
(nth 3 inst
)))
1724 (setq part
(math-rweval
1727 (math-sub (aref regs
(nth 1 inst
))
1728 (aref regs
(nth 3 inst
))))))))
1729 (if (cond ((eq op
'calcFunc-eq
)
1731 ((eq op
'calcFunc-neq
)
1732 (memq part
'(-1 1)))
1733 ((eq op
'calcFunc-lt
)
1735 ((eq op
'calcFunc-leq
)
1736 (memq part
'(-1 0)))
1737 ((eq op
'calcFunc-gt
)
1739 ((eq op
'calcFunc-geq
)
1740 (memq part
'(0 1))))
1745 (if (and (consp (setq part
(aref regs
(car (cdr inst
)))))
1747 (car (setq inst
(cdr (cdr inst
))))))
1749 (setq inst
(cdr inst
)
1751 (while (and (setq inst
(cdr inst
)
1754 (aset regs
(car inst
) (car part
)))
1757 (while (eq (car (car (setq pc
(cdr pc
))))
1759 (setq pc
(cdr pc
)) ; skip over "func"
1761 (aset regs
(cdr (car mark
)) (car (car mark
)))
1762 (setq mark
(cdr mark
)))))
1766 (if (or (not (and (consp
1767 (setq part
(aref regs
(car (cdr inst
)))))
1768 (eq (car part
) (nth 2 inst
))))
1769 (and (= (length part
) 2)
1770 (setq part
(nth 1 part
))))
1772 (setq mark
(nth 3 inst
))
1773 (aset regs
(nth 4 inst
) part
)
1774 (while (eq (car (car (setq pc
(cdr pc
)))) 'func-def
))
1775 (setq pc
(cdr pc
)) ; skip over "func"
1777 (aset regs
(cdr (car mark
)) (car (car mark
)))
1778 (setq mark
(cdr mark
))))
1779 (setq pc
(cdr pc
))))
1782 (if (if (Math-zerop (setq part
(aref regs
(nth 1 inst
))))
1783 (Math-zerop (nth 3 inst
))
1784 (and (not (Math-zerop (nth 2 inst
)))
1786 (setq part
(math-mod part
(nth 2 inst
)))
1787 (or (Math-numberp part
)
1788 (setq part
(math-rweval
1789 (math-simplify part
))))
1790 (Math-equal part
(nth 3 inst
)))))
1795 (if (and (consp (setq part
(aref regs
(car (cdr inst
)))))
1796 (not (Math-objvecp part
))
1797 (not (eq (car part
) 'var
)))
1799 (aset regs
(nth 2 inst
)
1800 (math-calcFunc-to-var (car part
)))
1801 (aset regs
(nth 3 inst
)
1802 (cons 'vec
(cdr part
)))
1807 (if (and (consp (setq part
(aref regs
(car (cdr inst
)))))
1808 (eq (car part
) 'vec
)
1811 (aset regs
(nth 2 inst
) (nth 1 part
))
1812 (aset regs
(nth 3 inst
) (cons 'vec
(cdr (cdr part
))))
1817 (if (and (consp (setq part
(aref regs
(car (cdr inst
)))))
1818 (eq (car part
) 'vec
)
1821 (aset regs
(nth 2 inst
) (calcFunc-rhead part
))
1822 (aset regs
(nth 3 inst
) (calcFunc-rtail part
))
1830 (math-rwapply-replace-regs (nth 1 inst
)))))
1835 (aset regs
(nth 1 inst
)
1838 (math-rwapply-replace-regs (nth 2 inst
)))))
1842 (aset regs
(nth 2 inst
) (aref regs
(nth 1 inst
)))
1846 (aset regs
(nth 2 inst
)
1847 (math-rwapply-neg (aref regs
(nth 1 inst
))))
1851 (setq btrack
(cons pc btrack
)
1855 (while (and btrack
(not (eq (car btrack
) (nth 1 inst
))))
1856 (setq btrack
(cdr btrack
)))
1857 (setq btrack
(cdr btrack
)
1861 (setq result
(math-rwapply-replace-regs (nth 1 inst
)))
1862 (if (or (and (eq (car-safe result
) '+)
1863 (eq (nth 2 result
) 0))
1864 (and (eq (car-safe result
) '*)
1865 (eq (nth 2 result
) 1)))
1866 (setq result
(nth 1 result
)))
1867 (setq part
(and (nth 2 inst
)
1871 (math-rwapply-replace-regs
1873 (if (or (equal result expr
)
1874 (equal (setq result
(math-normalize result
)) expr
))
1876 (if part
(math-rwapply-remember expr result
))
1880 (t (error "%s is not a valid rewrite opcode" op
))))))
1881 (setq rules
(cdr rules
)))
1884 (defun math-rwapply-neg (expr)
1885 (if (and (consp expr
)
1886 (memq (car expr
) '(* /)))
1887 (if (Math-objectp (nth 2 expr
))
1888 (list (car expr
) (nth 1 expr
) (math-neg (nth 2 expr
)))
1890 (if (Math-objectp (nth 1 expr
))
1891 (math-neg (nth 1 expr
))
1892 (list '* -
1 (nth 1 expr
)))
1896 (defun math-rwapply-inv (expr)
1897 (if (and (Math-integerp expr
)
1899 (math-make-frac 1 expr
)
1902 (defun math-rwapply-replace-regs (expr)
1903 (cond ((Math-primp expr
)
1905 ((eq (car expr
) 'calcFunc-register
)
1906 (setq expr
(aref regs
(nth 1 expr
)))
1907 (if (eq (car-safe expr
) '*)
1908 (if (eq (nth 1 expr
) -
1)
1909 (math-neg (nth 2 expr
))
1910 (if (eq (nth 1 expr
) 1)
1914 ((and (eq (car expr
) 'calcFunc-eval
)
1915 (= (length expr
) 2))
1916 (calc-with-default-simplification
1917 (math-normalize (math-rwapply-replace-regs (nth 1 expr
)))))
1918 ((and (eq (car expr
) 'calcFunc-evalsimp
)
1919 (= (length expr
) 2))
1920 (math-simplify (math-rwapply-replace-regs (nth 1 expr
))))
1921 ((and (eq (car expr
) 'calcFunc-evalextsimp
)
1922 (= (length expr
) 2))
1923 (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr
))))
1924 ((and (eq (car expr
) 'calcFunc-apply
)
1925 (= (length expr
) 3))
1926 (let ((func (math-rwapply-replace-regs (nth 1 expr
)))
1927 (args (math-rwapply-replace-regs (nth 2 expr
)))
1929 (if (and (math-vectorp args
)
1930 (not (eq (car-safe (setq call
(math-build-call
1931 (math-var-to-calcFunc func
)
1935 (list 'calcFunc-apply func args
))))
1936 ((and (eq (car expr
) 'calcFunc-cons
)
1937 (= (length expr
) 3))
1938 (let ((head (math-rwapply-replace-regs (nth 1 expr
)))
1939 (tail (math-rwapply-replace-regs (nth 2 expr
))))
1940 (if (math-vectorp tail
)
1941 (cons 'vec
(cons head
(cdr tail
)))
1942 (list 'calcFunc-cons head tail
))))
1943 ((and (eq (car expr
) 'calcFunc-rcons
)
1944 (= (length expr
) 3))
1945 (let ((head (math-rwapply-replace-regs (nth 1 expr
)))
1946 (tail (math-rwapply-replace-regs (nth 2 expr
))))
1947 (if (math-vectorp head
)
1948 (append head
(list tail
))
1949 (list 'calcFunc-rcons head tail
))))
1950 ((and (eq (car expr
) 'neg
)
1951 (math-rwapply-reg-looks-negp (nth 1 expr
)))
1952 (math-rwapply-reg-neg (nth 1 expr
)))
1953 ((and (eq (car expr
) 'neg
)
1954 (eq (car-safe (nth 1 expr
)) 'calcFunc-register
)
1955 (math-scalarp (aref regs
(nth 1 (nth 1 expr
)))))
1956 (math-neg (math-rwapply-replace-regs (nth 1 expr
))))
1957 ((and (eq (car expr
) '+)
1958 (math-rwapply-reg-looks-negp (nth 1 expr
)))
1959 (list '-
(math-rwapply-replace-regs (nth 2 expr
))
1960 (math-rwapply-reg-neg (nth 1 expr
))))
1961 ((and (eq (car expr
) '+)
1962 (math-rwapply-reg-looks-negp (nth 2 expr
)))
1963 (list '-
(math-rwapply-replace-regs (nth 1 expr
))
1964 (math-rwapply-reg-neg (nth 2 expr
))))
1965 ((and (eq (car expr
) '-
)
1966 (math-rwapply-reg-looks-negp (nth 2 expr
)))
1967 (list '+ (math-rwapply-replace-regs (nth 1 expr
))
1968 (math-rwapply-reg-neg (nth 2 expr
))))
1970 (cond ((eq (nth 1 expr
) -
1)
1971 (if (math-rwapply-reg-looks-negp (nth 2 expr
))
1972 (math-rwapply-reg-neg (nth 2 expr
))
1973 (math-neg (math-rwapply-replace-regs (nth 2 expr
)))))
1974 ((eq (nth 1 expr
) 1)
1975 (math-rwapply-replace-regs (nth 2 expr
)))
1976 ((eq (nth 2 expr
) -
1)
1977 (if (math-rwapply-reg-looks-negp (nth 1 expr
))
1978 (math-rwapply-reg-neg (nth 1 expr
))
1979 (math-neg (math-rwapply-replace-regs (nth 1 expr
)))))
1980 ((eq (nth 2 expr
) 1)
1981 (math-rwapply-replace-regs (nth 1 expr
)))
1983 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr
)))
1984 (arg2 (math-rwapply-replace-regs (nth 2 expr
))))
1985 (cond ((and (eq (car-safe arg1
) '/)
1986 (eq (nth 1 arg1
) 1))
1987 (list '/ arg2
(nth 2 arg1
)))
1988 ((and (eq (car-safe arg2
) '/)
1989 (eq (nth 1 arg2
) 1))
1990 (list '/ arg1
(nth 2 arg2
)))
1991 (t (list '* arg1 arg2
)))))))
1993 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr
)))
1994 (arg2 (math-rwapply-replace-regs (nth 2 expr
))))
1995 (if (eq (car-safe arg2
) '/)
1996 (list '/ (list '* arg1
(nth 2 arg2
)) (nth 1 arg2
))
1997 (list '/ arg1 arg2
))))
1998 ((and (eq (car expr
) 'calcFunc-plain
)
1999 (= (length expr
) 2))
2000 (if (Math-primp (nth 1 expr
))
2002 (if (eq (car (nth 1 expr
)) 'calcFunc-register
)
2003 (aref regs
(nth 1 (nth 1 expr
)))
2004 (cons (car (nth 1 expr
)) (mapcar 'math-rwapply-replace-regs
2005 (cdr (nth 1 expr
)))))))
2006 (t (cons (car expr
) (mapcar 'math-rwapply-replace-regs
(cdr expr
))))))
2008 (defun math-rwapply-reg-looks-negp (expr)
2009 (if (eq (car-safe expr
) 'calcFunc-register
)
2010 (math-looks-negp (aref regs
(nth 1 expr
)))
2011 (if (memq (car-safe expr
) '(* /))
2012 (or (math-rwapply-reg-looks-negp (nth 1 expr
))
2013 (math-rwapply-reg-looks-negp (nth 2 expr
))))))
2015 (defun math-rwapply-reg-neg (expr) ; expr must satisfy rwapply-reg-looks-negp
2016 (if (eq (car expr
) 'calcFunc-register
)
2017 (math-neg (math-rwapply-replace-regs expr
))
2018 (if (math-rwapply-reg-looks-negp (nth 1 expr
))
2019 (math-rwapply-replace-regs (list (car expr
)
2020 (math-rwapply-reg-neg (nth 1 expr
))
2022 (math-rwapply-replace-regs (list (car expr
)
2024 (math-rwapply-reg-neg (nth 2 expr
)))))))
2026 (defun math-rwapply-remember (old new
)
2027 (let ((varval (symbol-value (nth 2 (car ruleset
))))
2028 (rules (assq (car-safe old
) ruleset
)))
2029 (if (and (eq (car-safe varval
) 'vec
)
2030 (not (memq (car-safe old
) '(nil schedule
+ -
)))
2033 (setcdr varval
(cons (list 'calcFunc-assign
2034 (if (math-rwcomp-no-vars old
)
2036 (list 'calcFunc-quote old
))
2039 (setcdr rules
(cons (list (vector nil old
)
2040 (list (list 'same
0 1)
2041 (list 'done new nil
))
2045 ;;; calc-rewr.el ends here