?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Fix reference in Emacs manual
[emacs.git] / lisp / calc / calc-rewr.el
blobcc68272a5cf88ecfafe7be44d717218703084b90
1 ;;; calc-rewr.el --- rewriting functions for Calc
2
3 ;; Copyright (C) 1990-1993, 2001-2018 Free Software Foundation, Inc.
4
5 ;; Author: David Gillespie <daveg@synaptics.com>
6
7 ;; This file is part of GNU Emacs.
8
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
13
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
21
22 ;;; Commentary:
23
24 ;;; Code:
25
26 ;; This file is autoloaded from calc-ext.el.
27
28 (require 'calc-ext)
29 (require 'calc-macs)
30
31 (defvar math-rewrite-default-iters 100)
32
33 ;; The variable calc-rewr-sel is local to calc-rewrite-selection and
34 ;; calc-rewrite, but is used by calc-locate-selection-marker.
35 (defvar calc-rewr-sel)
36
37 (defun calc-rewrite-selection (rules-str &optional many prefix)
38 (interactive "sRewrite rule(s): \np")
39 (calc-slow-wrapper
40 (calc-preserve-point)
41 (let* ((num (max 1 (calc-locate-cursor-element (point))))
42 (reselect t)
43 (pop-rules nil)
44 rules
45 (entry (calc-top num 'entry))
46 (expr (car entry))
47 (calc-rewr-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 "$"))
51 (if (= num 1)
52 (error "Can't use same stack entry for formula and rules")
53 (setq rules (calc-top-n 1 t)
54 pop-rules 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
63 calcFunc-condition))
64 (let ((rhs (math-read-expr
65 (read-string (concat "Rewrite from: " rules-str
66 " to: ")))))
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")))
72 (if (eq many 0)
73 (setq many '(var inf var-inf))
74 (if many (setq many (prefix-numeric-value many))))
75 (if calc-rewr-sel
76 (setq expr (calc-replace-sub-formula (car entry)
77 calc-rewr-sel
78 (list 'calcFunc-select calc-rewr-sel)))
79 (setq expr (car entry)
80 reselect nil
81 math-rewrite-selections nil))
82 (setq expr (calc-encase-atoms
83 (calc-normalize
84 (math-rewrite
85 (calc-normalize expr)
86 rules many)))
87 calc-rewr-sel nil
88 expr (calc-locate-select-marker expr))
89 (or (consp calc-rewr-sel) (setq calc-rewr-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 calc-rewr-sel))))
94 (calc-handle-whys)))
95
96 (defun calc-locate-select-marker (expr)
97 (if (Math-primp expr)
98 expr
99 (if (and (eq (car expr) 'calcFunc-select)
100 (= (length expr) 2))
101 (progn
102 (setq calc-rewr-sel (if calc-rewr-sel t (nth 1 expr)))
103 (nth 1 expr))
104 (cons (car expr)
105 (mapcar 'calc-locate-select-marker (cdr expr))))))
106
107
108
109 (defun calc-rewrite (rules-str many)
110 (interactive "sRewrite rule(s): \nP")
111 (calc-slow-wrapper
112 (let (n rules expr)
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)
116 n 2)
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
125 calcFunc-condition))
126 (let ((rhs (math-read-expr
127 (read-string (concat "Rewrite from: " rules-str
128 " to: ")))))
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)
135 n 1))
136 (if (eq many 0)
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)))
140 (let (calc-rewr-sel)
141 (setq expr (calc-locate-select-marker expr)))
142 (calc-pop-push-record-list n "rwrt" (list expr)))
143 (calc-handle-whys)))
144
145 (defun calc-match (pat &optional interactive)
146 (interactive "sPattern: \np")
147 (calc-slow-wrapper
148 (let (n expr)
149 (if (or (null pat) (equal pat "") (equal pat "$"))
150 (setq expr (calc-top-n 2)
151 pat (calc-top-n 1)
152 n 2)
153 (setq pat (if (stringp pat) (math-read-expr pat) pat))
154 (if (eq (car-safe pat) 'error)
155 (error "Bad format in expression: %s" (nth 1 pat)))
156 (if (not (eq (car-safe pat) 'var))
157 (calc-record pat "pat"))
158 (setq expr (calc-top-n 1)
159 n 1))
160 (or (math-vectorp expr) (error "Argument must be a vector"))
161 (if (calc-is-inverse)
162 (calc-enter-result n "mtcn" (math-match-patterns pat expr t))
163 (calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))
164
165
166 (defvar math-mt-many)
167
168 ;; The variable math-rewrite-whole-expr is local to math-rewrite,
169 ;; but is used by math-rewrite-phase
170 (defvar math-rewrite-whole-expr)
171
172 (defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many)
173 (let* ((crules (math-compile-rewrites rules))
174 (heads (math-rewrite-heads math-rewrite-whole-expr))
175 (trace-buffer (get-buffer "*Trace*"))
176 (calc-display-just 'center)
177 (calc-display-origin 39)
178 (calc-line-breaking 78)
179 (calc-line-numbering nil)
180 (calc-show-selections t)
181 (calc-why nil)
182 (math-mt-func (function
183 (lambda (x)
184 (let ((result (math-apply-rewrites x (cdr crules)
185 heads crules)))
186 (if result
187 (progn
188 (if trace-buffer
189 (let ((fmt (math-format-stack-value
190 (list result nil nil))))
191 (with-current-buffer trace-buffer
192 (insert "\nrewrite to\n" fmt "\n"))))
193 (setq heads (math-rewrite-heads result heads t))))
194 result)))))
195 (if trace-buffer
196 (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
197 (with-current-buffer trace-buffer
198 (setq truncate-lines t)
199 (goto-char (point-max))
200 (insert "\n\nBegin rewriting\n" fmt "\n"))))
201 (or math-mt-many (setq math-mt-many (or (nth 1 (car crules))
202 math-rewrite-default-iters)))
203 (if (equal math-mt-many '(var inf var-inf)) (setq math-mt-many 1000000))
204 (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000))
205 (math-rewrite-phase (nth 3 (car crules)))
206 (if trace-buffer
207 (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
208 (with-current-buffer trace-buffer
209 (insert "\nDone rewriting"
210 (if (= math-mt-many 0) " (reached iteration limit)" "")
211 ":\n" fmt "\n"))))
212 math-rewrite-whole-expr))
213
214 (defun math-rewrite-phase (sched)
215 (while (and sched (/= math-mt-many 0))
216 (if (listp (car sched))
217 (while (let ((save-expr math-rewrite-whole-expr))
218 (math-rewrite-phase (car sched))
219 (not (equal math-rewrite-whole-expr save-expr))))
220 (if (symbolp (car sched))
221 (progn
222 (setq math-rewrite-whole-expr
223 (math-normalize (list (car sched) math-rewrite-whole-expr)))
224 (if trace-buffer
225 (let ((fmt (math-format-stack-value
226 (list math-rewrite-whole-expr nil nil))))
227 (with-current-buffer trace-buffer
228 (insert "\ncall "
229 (substring (symbol-name (car sched)) 9)
230 ":\n" fmt "\n")))))
231 (let ((math-rewrite-phase (car sched)))
232 (if trace-buffer
233 (with-current-buffer trace-buffer
234 (insert (format "\n(Phase %d)\n" math-rewrite-phase))))
235 (while (let ((save-expr math-rewrite-whole-expr))
236 (setq math-rewrite-whole-expr (math-normalize
237 (math-map-tree-rec math-rewrite-whole-expr)))
238 (not (equal math-rewrite-whole-expr save-expr)))))))
239 (setq sched (cdr sched))))
240
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))
245 (condition-case err
246 (math-rewrite expr rules (or many 1))
247 (error (math-reject-arg rules (nth 1 err)))))
248
249 (defun calcFunc-match (pat vec)
250 (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
251 (condition-case err
252 (math-match-patterns pat vec nil)
253 (error (math-reject-arg pat (nth 1 err)))))
254
255 (defun calcFunc-matchnot (pat vec)
256 (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
257 (condition-case err
258 (math-match-patterns pat vec t)
259 (error (math-reject-arg pat (nth 1 err)))))
260
261 (defun math-match-patterns (pat vec &optional not-flag)
262 (let ((newvec nil)
263 (crules (math-compile-patterns pat)))
264 (while (setq vec (cdr vec))
265 (if (eq (not (math-apply-rewrites (car vec) crules))
266 not-flag)
267 (setq newvec (cons (car vec) newvec))))
268 (cons 'vec (nreverse newvec))))
269
270 (defun calcFunc-matches (expr pat)
271 (condition-case err
272 (if (math-apply-rewrites expr (math-compile-patterns pat))
273 1
274 0)
275 (error (math-reject-arg pat (nth 1 err)))))
276
277 (defun calcFunc-vmatches (expr pat)
278 (condition-case err
279 (or (math-apply-rewrites expr (math-compile-patterns pat))
280 0)
281 (error (math-reject-arg pat (nth 1 err)))))
282
283
284
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.
289 ;;
290 ;; The first entry in the a-list is of the form (schedule A B C ...).
291 ;;
292 ;; Rule list entries take the form (regs prog head phases), where:
293 ;;
294 ;; regs is a vector of match registers.
295 ;;
296 ;; prog is a match program (see below).
297 ;;
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.
300 ;;
301 ;; phases is a list of phase numbers for which the rule is enabled.
302 ;;
303 ;; A match program is a list of match instructions.
304 ;;
305 ;; In the following, "part" is a register number that contains the
306 ;; subexpression to be operated on.
307 ;;
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.
311 ;;
312 ;; (same part reg)
313 ;; The selected part must be math-equal to the contents of "reg".
314 ;;
315 ;; (same-neg part reg)
316 ;; The selected part must be math-equal to the negative of "reg".
317 ;;
318 ;; (copy part reg)
319 ;; The selected part is copied into "reg". (Rarely used.)
320 ;;
321 ;; (copy-neg part reg)
322 ;; The negative of the selected part is copied into "reg".
323 ;;
324 ;; (integer part)
325 ;; The selected part must be an integer.
326 ;;
327 ;; (real part)
328 ;; The selected part must be a real.
329 ;;
330 ;; (constant part)
331 ;; The selected part must be a constant.
332 ;;
333 ;; (negative part)
334 ;; The selected part must "look" negative.
335 ;;
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.
339 ;;
340 ;; (mod part modulo value)
341 ;; The selected part must satisfy "part % modulo = value", where
342 ;; "modulo" and "value" are constants.
343 ;;
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".
347 ;;
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.
355 ;;
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).
360 ;;
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.
378 ;;
379 ;; (try2 try reg2)
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".
383 ;;
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.
389 ;;
390 ;; (end-alt ptr)
391 ;; Register success of the first alternative of a previous "alt".
392 ;; "Ptr" is a pointer to the next instruction following that "alt".
393 ;;
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".
398 ;;
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".
403 ;;
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".
408 ;;
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".
413 ;;
414 ;; (cond expr)
415 ;; The "expr", with registers substituted, must simplify to
416 ;; a non-zero value.
417 ;;
418 ;; (let reg expr)
419 ;; Evaluate "expr" and store the result in "reg". Always succeeds.
420 ;;
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.
427
428
429 ;; Pseudo-functions related to rewrites:
430 ;;
431 ;; In patterns: quote, plain, condition, opt, apply, cons, select
432 ;;
433 ;; In righthand sides: quote, plain, eval, evalsimp, evalextsimp,
434 ;; apply, cons, select
435 ;;
436 ;; In conditions: let + same as for righthand sides
437
438 ;; Some optimizations that would be nice to have:
439 ;;
440 ;; * Merge registers with disjoint lifetimes.
441 ;; * Merge constant registers with equivalent values.
442 ;;
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
446 ;; cases.)
447 ;;
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.)
452 ;;
453 ;; * Shouldn't evaluate a "let" condition until the end, or until it
454 ;; would enable another condition to be evaluated.
455 ;;
456
457 ;; Some additional features to add / things to think about:
458 ;;;
459 ;;; * Figure out what happens to "a +/- b" and "a +/- opt(b)".
460 ;;;
461 ;;; * Same for interval forms.
462 ;;;
463 ;;; * Have a name(v,pat) pattern which matches pat, and gives the
464 ;;; whole match the name v. Beware of circular structures!
465 ;;;
466
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)))
471 (or prop
472 (put (nth 2 pats) 'math-pattern-cache (setq prop (list nil))))
473 (or (eq (car prop) (symbol-value (nth 2 pats)))
474 (progn
475 (setcdr prop (math-compile-patterns
476 (symbol-value (nth 2 pats))))
477 (setcar prop (symbol-value (nth 2 pats)))))
478 (cdr prop))
479 (let ((math-rewrite-whole t))
480 (cdr (math-compile-rewrites (cons
481 'vec
482 (mapcar (function (lambda (x)
483 (list 'vec x t)))
484 (if (eq (car-safe pats) 'vec)
485 (cdr pats)
486 (list pats)))))))))
487
488 (defvar math-rewrite-whole nil)
489 (defvar math-make-import-list nil)
490
491 ;; The variable math-import-list is local to part of math-compile-rewrites,
492 ;; but is also used in a different part, and so the local version could
493 ;; be affected by the non-local version when math-compile-rewrites calls itself.
494 (defvar math-import-list nil)
495
496 ;; The variables math-regs, math-num-regs, math-prog-last, math-bound-vars,
497 ;; math-conds, math-copy-neg, math-rhs, math-pattern, math-remembering and
498 ;; math-aliased-vars are local to math-compile-rewrites,
499 ;; but are used by many functions math-rwcomp-*, which are called by
500 ;; math-compile-rewrites.
501 (defvar math-regs)
502 (defvar math-num-regs)
503 (defvar math-prog-last)
504 (defvar math-bound-vars)
505 (defvar math-conds)
506 (defvar math-copy-neg)
507 (defvar math-rhs)
508 (defvar math-pattern)
509 (defvar math-remembering)
510 (defvar math-aliased-vars)
511
512 (defun math-compile-rewrites (rules &optional name)
513 (if (eq (car-safe rules) 'var)
514 (let ((prop (get (nth 2 rules) 'math-rewrite-cache))
515 (math-import-list nil)
516 (math-make-import-list t)
517 p)
518 (or (calc-var-value (nth 2 rules))
519 (error "Rules variable %s has no stored value" (nth 1 rules)))
520 (or prop
521 (put (nth 2 rules) 'math-rewrite-cache
522 (setq prop (list (list (cons (nth 2 rules) nil))))))
523 (setq p (car prop))
524 (while (and p (eq (symbol-value (car (car p))) (cdr (car p))))
525 (setq p (cdr p)))
526 (or (null p)
527 (progn
528 (message "Compiling rule set %s..." (nth 1 rules))
529 (setcdr prop (math-compile-rewrites
530 (symbol-value (nth 2 rules))
531 (nth 2 rules)))
532 (message "Compiling rule set %s...done" (nth 1 rules))
533 (setcar prop (cons (cons (nth 2 rules)
534 (symbol-value (nth 2 rules)))
535 math-import-list))))
536 (cdr prop))
537 (if (or (not (eq (car-safe rules) 'vec))
538 (and (memq (length rules) '(3 4))
539 (let ((p rules))
540 (while (and (setq p (cdr p))
541 (memq (car-safe (car p))
542 '(vec
543 calcFunc-assign
544 calcFunc-condition
545 calcFunc-import
546 calcFunc-phase
547 calcFunc-schedule
548 calcFunc-iterations))))
549 p)))
550 (setq rules (list rules))
551 (setq rules (cdr rules)))
552 (if (assq 'calcFunc-import rules)
553 (let ((pp (setq rules (copy-sequence rules)))
554 p part)
555 (while (setq p (car (cdr pp)))
556 (if (eq (car-safe p) 'calcFunc-import)
557 (progn
558 (setcdr pp (cdr (cdr pp)))
559 (or (and (eq (car-safe (nth 1 p)) 'var)
560 (setq part (calc-var-value (nth 2 (nth 1 p))))
561 (memq (car-safe part) '(vec
562 calcFunc-assign
563 calcFunc-condition)))
564 (error "Argument of import() must be a rules variable"))
565 (if math-make-import-list
566 (setq math-import-list
567 (cons (cons (nth 2 (nth 1 p))
568 (symbol-value (nth 2 (nth 1 p))))
569 math-import-list)))
570 (while (setq p (cdr (cdr p)))
571 (or (cdr p)
572 (error "import() must have odd number of arguments"))
573 (setq part (math-rwcomp-substitute part
574 (car p) (nth 1 p))))
575 (if (eq (car-safe part) 'vec)
576 (setq part (cdr part))
577 (setq part (list part)))
578 (setcdr pp (append part (cdr pp))))
579 (setq pp (cdr pp))))))
580 (let ((rule-set nil)
581 (all-heads nil)
582 (nil-rules nil)
583 (rule-count 0)
584 (math-schedule nil)
585 (math-iterations nil)
586 (math-phases nil)
587 (math-all-phases nil)
588 (math-remembering nil)
589 math-pattern math-rhs math-conds)
590 (while rules
591 (cond
592 ((and (eq (car-safe (car rules)) 'calcFunc-iterations)
593 (= (length (car rules)) 2))
594 (or (integerp (nth 1 (car rules)))
595 (equal (nth 1 (car rules)) '(var inf var-inf))
596 (equal (nth 1 (car rules)) '(neg (var inf var-inf)))
597 (error "Invalid argument for iterations(n)"))
598 (or math-iterations
599 (setq math-iterations (nth 1 (car rules)))))
600 ((eq (car-safe (car rules)) 'calcFunc-schedule)
601 (or math-schedule
602 (setq math-schedule (math-parse-schedule (cdr (car rules))))))
603 ((eq (car-safe (car rules)) 'calcFunc-phase)
604 (setq math-phases (cdr (car rules)))
605 (if (equal math-phases '((var all var-all)))
606 (setq math-phases nil))
607 (let ((p math-phases))
608 (while p
609 (or (integerp (car p))
610 (error "Phase numbers must be small integers"))
611 (or (memq (car p) math-all-phases)
612 (setq math-all-phases (cons (car p) math-all-phases)))
613 (setq p (cdr p)))))
614 ((or (and (eq (car-safe (car rules)) 'vec)
615 (cdr (cdr (car rules)))
616 (not (nthcdr 4 (car rules)))
617 (setq math-conds (nth 3 (car rules))
618 math-rhs (nth 2 (car rules))
619 math-pattern (nth 1 (car rules))))
620 (progn
621 (setq math-conds nil
622 math-pattern (car rules))
623 (while (and (eq (car-safe math-pattern) 'calcFunc-condition)
624 (= (length math-pattern) 3))
625 (let ((cond (nth 2 math-pattern)))
626 (setq math-conds (if math-conds
627 (list 'calcFunc-land math-conds cond)
628 cond)
629 math-pattern (nth 1 math-pattern))))
630 (and (eq (car-safe math-pattern) 'calcFunc-assign)
631 (= (length math-pattern) 3)
632 (setq math-rhs (nth 2 math-pattern)
633 math-pattern (nth 1 math-pattern)))))
634 (let* ((math-prog (list nil))
635 (math-prog-last math-prog)
636 (math-num-regs 1)
637 (math-regs (list (list nil 0 nil nil)))
638 (math-bound-vars nil)
639 (math-aliased-vars nil)
640 (math-copy-neg nil))
641 (setq math-conds (and math-conds (math-flatten-lands math-conds)))
642 (math-rwcomp-pattern math-pattern 0)
643 (while math-conds
644 (let ((expr (car math-conds)))
645 (setq math-conds (cdr math-conds))
646 (math-rwcomp-cond-instr expr)))
647 (math-rwcomp-instr 'done
648 (if (eq math-rhs t)
649 (cons 'vec
650 (delq
651 nil
652 (nreverse
653 (mapcar
654 (function
655 (lambda (v)
656 (and (car v)
657 (list
658 'calcFunc-assign
659 (math-build-var-name
660 (car v))
661 (math-rwcomp-register-expr
662 (nth 1 v))))))
663 math-regs))))
664 (math-rwcomp-match-vars math-rhs))
665 math-remembering)
666 (setq math-prog (cdr math-prog))
667 (let* ((heads (math-rewrite-heads math-pattern))
668 (rule (list (vconcat
669 (nreverse
670 (mapcar (function (lambda (x) (nth 3 x)))
671 math-regs)))
672 math-prog
673 heads
674 math-phases))
675 (head (and (not (Math-primp math-pattern))
676 (not (and (eq (car (car math-prog)) 'try)
677 (nth 5 (car math-prog))))
678 (not (memq (car (car math-prog)) '(func-opt
679 apply
680 select
681 alt)))
682 (if (memq (car (car math-prog)) '(func
683 func-def))
684 (nth 2 (car math-prog))
685 (if (eq (car math-pattern) 'calcFunc-quote)
686 (car-safe (nth 1 math-pattern))
687 (car math-pattern))))))
688 (let (found)
689 (while heads
690 (if (setq found (assq (car heads) all-heads))
691 (setcdr found (1+ (cdr found)))
692 (setq all-heads (cons (cons (car heads) 1) all-heads)))
693 (setq heads (cdr heads))))
694 (if (eq head '-) (setq head '+))
695 (if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec))
696 (if head
697 (progn
698 (nconc (or (assq head rule-set)
699 (car (setq rule-set (cons (cons head
700 (copy-sequence
701 nil-rules))
702 rule-set))))
703 (list rule))
704 (if (eq head '*)
705 (nconc (or (assq '/ rule-set)
706 (car (setq rule-set (cons (cons
707 '/
708 (copy-sequence
709 nil-rules))
710 rule-set))))
711 (list rule))))
712 (setq nil-rules (nconc nil-rules (list rule)))
713 (let ((ptr rule-set))
714 (while ptr
715 (nconc (car ptr) (list rule))
716 (setq ptr (cdr ptr))))))))
717 (t
718 (error "Rewrite rule set must be a vector of A := B rules")))
719 (setq rules (cdr rules)))
720 (if nil-rules
721 (setq rule-set (cons (cons nil nil-rules) rule-set)))
722 (setq all-heads (mapcar 'car
723 (sort all-heads (function
724 (lambda (x y)
725 (< (cdr x) (cdr y)))))))
726 (let ((set rule-set)
727 rule heads ptr)
728 (while set
729 (setq rule (cdr (car set)))
730 (while rule
731 (if (consp (setq heads (nth 2 (car rule))))
732 (progn
733 (setq heads (delq (car (car set)) heads)
734 ptr all-heads)
735 (while (and ptr (not (memq (car ptr) heads)))
736 (setq ptr (cdr ptr)))
737 (setcar (nthcdr 2 (car rule)) (car ptr))))
738 (setq rule (cdr rule)))
739 (setq set (cdr set))))
740 (let ((plus (assq '+ rule-set)))
741 (if plus
742 (setq rule-set (cons (cons '- (cdr plus)) rule-set))))
743 (cons (list 'schedule math-iterations name
744 (or math-schedule
745 (sort math-all-phases '<)
746 (list 1)))
747 rule-set))))
748
749 (defun math-flatten-lands (expr)
750 (if (eq (car-safe expr) 'calcFunc-land)
751 (append (math-flatten-lands (nth 1 expr))
752 (math-flatten-lands (nth 2 expr)))
753 (list expr)))
754
755 ;; The variables math-rewrite-heads-heads (i.e.; heads for math-rewrite-heads)
756 ;; math-rewrite-heads-blanks and math-rewrite-heads-skips are local to
757 ;; math-rewrite-heads, but used by math-rewrite-heads-rec, which is called by
758 ;; math-rewrite-heads.
759 (defvar math-rewrite-heads-heads)
760 (defvar math-rewrite-heads-skips)
761 (defvar math-rewrite-heads-blanks)
762
763 (defun math-rewrite-heads (expr &optional more all)
764 (let ((math-rewrite-heads-heads more)
765 (math-rewrite-heads-skips (and (not all)
766 '(calcFunc-apply calcFunc-condition calcFunc-opt
767 calcFunc-por calcFunc-pnot)))
768 (math-rewrite-heads-blanks (and (not all)
769 '(calcFunc-quote calcFunc-plain calcFunc-select
770 calcFunc-cons calcFunc-rcons
771 calcFunc-pand))))
772 (or (Math-primp expr)
773 (math-rewrite-heads-rec expr))
774 math-rewrite-heads-heads))
775
776 (defun math-rewrite-heads-rec (expr)
777 (or (memq (car expr) math-rewrite-heads-skips)
778 (progn
779 (or (memq (car expr) math-rewrite-heads-heads)
780 (memq (car expr) math-rewrite-heads-blanks)
781 (memq 'algebraic (get (car expr) 'math-rewrite-props))
782 (setq math-rewrite-heads-heads (cons (car expr) math-rewrite-heads-heads)))
783 (while (setq expr (cdr expr))
784 (or (Math-primp (car expr))
785 (math-rewrite-heads-rec (car expr)))))))
786
787 (defun math-parse-schedule (sched)
788 (mapcar (function
789 (lambda (s)
790 (if (integerp s)
791 s
792 (if (math-vectorp s)
793 (math-parse-schedule (cdr s))
794 (if (eq (car-safe s) 'var)
795 (math-var-to-calcFunc s)
796 (error "Improper component in rewrite schedule"))))))
797 sched))
798
799 (defun math-rwcomp-match-vars (expr)
800 (if (Math-primp expr)
801 (if (eq (car-safe expr) 'var)
802 (let ((entry (assq (nth 2 expr) math-regs)))
803 (if entry
804 (math-rwcomp-register-expr (nth 1 entry))
805 expr))
806 expr)
807 (if (and (eq (car expr) 'calcFunc-quote)
808 (= (length expr) 2))
809 (math-rwcomp-match-vars (nth 1 expr))
810 (if (and (eq (car expr) 'calcFunc-plain)
811 (= (length expr) 2)
812 (not (Math-primp (nth 1 expr))))
813 (list (car expr)
814 (cons (car (nth 1 expr))
815 (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
816 (cons (car expr)
817 (mapcar 'math-rwcomp-match-vars (cdr expr)))))))
818
819 (defun math-rwcomp-register-expr (num)
820 (let ((entry (nth (1- (- math-num-regs num)) math-regs)))
821 (if (nth 2 entry)
822 (list 'neg (list 'calcFunc-register (nth 1 entry)))
823 (list 'calcFunc-register (nth 1 entry)))))
824
825 ;; The variables math-rwcomp-subst-old, math-rwcomp-subst-new,
826 ;; math-rwcomp-subst-old-func and math-rwcomp-subst-new-func
827 ;; are local to math-rwcomp-substitute, but are used by
828 ;; math-rwcomp-subst-rec, which is called by math-rwcomp-substitute.
829 (defvar math-rwcomp-subst-new)
830 (defvar math-rwcomp-subst-old)
831 (defvar math-rwcomp-subst-new-func)
832 (defvar math-rwcomp-subst-old-func)
833
834 (defun math-rwcomp-substitute (expr math-rwcomp-subst-old math-rwcomp-subst-new)
835 (if (and (eq (car-safe math-rwcomp-subst-old) 'var)
836 (memq (car-safe math-rwcomp-subst-new) '(var calcFunc-lambda)))
837 (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc math-rwcomp-subst-old))
838 (math-rwcomp-subst-new-func (math-var-to-calcFunc math-rwcomp-subst-new)))
839 (math-rwcomp-subst-rec expr))
840 (let ((math-rwcomp-subst-old-func nil))
841 (math-rwcomp-subst-rec expr))))
842
843 (defun math-rwcomp-subst-rec (expr)
844 (cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new)
845 ((Math-primp expr) expr)
846 (t (if (eq (car expr) math-rwcomp-subst-old-func)
847 (math-build-call math-rwcomp-subst-new-func
848 (mapcar 'math-rwcomp-subst-rec
849 (cdr expr)))
850 (cons (car expr)
851 (mapcar 'math-rwcomp-subst-rec (cdr expr)))))))
852
853 (defvar math-rwcomp-tracing nil)
854
855 (defun math-rwcomp-trace (instr)
856 (when math-rwcomp-tracing
857 (terpri) (princ instr))
858 instr)
859
860 (defun math-rwcomp-instr (&rest instr)
861 (setcdr math-prog-last
862 (setq math-prog-last (list (math-rwcomp-trace instr)))))
863
864 (defun math-rwcomp-multi-instr (tail &rest instr)
865 (setcdr math-prog-last
866 (setq math-prog-last (list (math-rwcomp-trace (append instr tail))))))
867
868 (defun math-rwcomp-bind-var (reg var)
869 (setcar (math-rwcomp-reg-entry reg) (nth 2 var))
870 (setq math-bound-vars (cons (nth 2 var) math-bound-vars))
871 (math-rwcomp-do-conditions))
872
873 (defun math-rwcomp-unbind-vars (mark)
874 (while (not (eq math-bound-vars mark))
875 (setcar (assq (car math-bound-vars) math-regs) nil)
876 (setq math-bound-vars (cdr math-bound-vars))))
877
878 (defun math-rwcomp-do-conditions ()
879 (let ((cond math-conds))
880 (while cond
881 (if (math-rwcomp-all-regs-done (car cond))
882 (let ((expr (car cond)))
883 (setq math-conds (delq (car cond) math-conds))
884 (setcar cond 1)
885 (math-rwcomp-cond-instr expr)))
886 (setq cond (cdr cond)))))
887
888 (defun math-rwcomp-cond-instr (expr)
889 (let (op arg)
890 (cond ((and (eq (car-safe expr) 'calcFunc-matches)
891 (= (length expr) 3)
892 (eq (car-safe (setq arg (math-rwcomp-match-vars (nth 1 expr))))
893 'calcFunc-register))
894 (math-rwcomp-pattern (nth 2 expr) (nth 1 arg)))
895 ((math-numberp (setq expr (math-rwcomp-match-vars expr)))
896 (if (Math-zerop expr)
897 (math-rwcomp-instr 'backtrack)))
898 ((and (eq (car expr) 'calcFunc-let)
899 (= (length expr) 3))
900 (let ((reg (math-rwcomp-reg)))
901 (math-rwcomp-instr 'let reg (nth 2 expr))
902 (math-rwcomp-pattern (nth 1 expr) reg)))
903 ((and (eq (car expr) 'calcFunc-let)
904 (= (length expr) 2)
905 (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
906 (= (length (nth 1 expr)) 3))
907 (let ((reg (math-rwcomp-reg)))
908 (math-rwcomp-instr 'let reg (nth 2 (nth 1 expr)))
909 (math-rwcomp-pattern (nth 1 (nth 1 expr)) reg)))
910 ((and (setq op (cdr (assq (car-safe expr)
911 '( (calcFunc-integer . integer)
912 (calcFunc-real . real)
913 (calcFunc-constant . constant)
914 (calcFunc-negative . negative) ))))
915 (= (length expr) 2)
916 (or (and (eq (car-safe (nth 1 expr)) 'neg)
917 (memq op '(integer real constant))
918 (setq arg (nth 1 (nth 1 expr))))
919 (setq arg (nth 1 expr)))
920 (eq (car-safe (setq arg (nth 1 expr))) 'calcFunc-register))
921 (math-rwcomp-instr op (nth 1 arg)))
922 ((and (assq (car-safe expr) calc-tweak-eqn-table)
923 (= (length expr) 3)
924 (eq (car-safe (nth 1 expr)) 'calcFunc-register))
925 (if (math-constp (nth 2 expr))
926 (let ((reg (math-rwcomp-reg)))
927 (setcar (nthcdr 3 (car math-regs)) (nth 2 expr))
928 (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
929 (car expr) reg))
930 (if (eq (car (nth 2 expr)) 'calcFunc-register)
931 (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
932 (car expr) (nth 1 (nth 2 expr)))
933 (math-rwcomp-instr 'cond expr))))
934 ((and (eq (car-safe expr) 'calcFunc-eq)
935 (= (length expr) 3)
936 (eq (car-safe (nth 1 expr)) '%)
937 (eq (car-safe (nth 1 (nth 1 expr))) 'calcFunc-register)
938 (math-constp (nth 2 (nth 1 expr)))
939 (math-constp (nth 2 expr)))
940 (math-rwcomp-instr 'mod (nth 1 (nth 1 (nth 1 expr)))
941 (nth 2 (nth 1 expr)) (nth 2 expr)))
942 ((equal expr '(var remember var-remember))
943 (setq math-remembering 1))
944 ((and (eq (car-safe expr) 'calcFunc-remember)
945 (= (length expr) 2))
946 (setq math-remembering (if math-remembering
947 (list 'calcFunc-lor
948 math-remembering (nth 1 expr))
949 (nth 1 expr))))
950 (t (math-rwcomp-instr 'cond expr)))))
951
952 (defun math-rwcomp-same-instr (reg1 reg2 neg)
953 (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
954 (nth 2 (math-rwcomp-reg-entry reg2)))
955 neg)
956 'same-neg
957 'same)
958 reg1 reg2))
959
960 (defun math-rwcomp-copy-instr (reg1 reg2 neg)
961 (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
962 (nth 2 (math-rwcomp-reg-entry reg2)))
963 neg)
964 (math-rwcomp-instr 'copy-neg reg1 reg2)
965 (or (eq reg1 reg2)
966 (math-rwcomp-instr 'copy reg1 reg2))))
967
968 (defun math-rwcomp-reg ()
969 (prog1
970 math-num-regs
971 (setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
972 math-num-regs (1+ math-num-regs))))
973
974 (defun math-rwcomp-reg-entry (num)
975 (nth (1- (- math-num-regs num)) math-regs))
976
977
978 (defun math-rwcomp-pattern (expr part &optional not-direct)
979 (cond ((or (math-rwcomp-no-vars expr)
980 (and (eq (car expr) 'calcFunc-quote)
981 (= (length expr) 2)
982 (setq expr (nth 1 expr))))
983 (if (eq (car-safe expr) 'calcFunc-register)
984 (math-rwcomp-same-instr part (nth 1 expr) nil)
985 (let ((reg (math-rwcomp-reg)))
986 (setcar (nthcdr 3 (car math-regs)) expr)
987 (math-rwcomp-same-instr part reg nil))))
988 ((eq (car expr) 'var)
989 (let ((entry (assq (nth 2 expr) math-regs)))
990 (if entry
991 (math-rwcomp-same-instr part (nth 1 entry) nil)
992 (if not-direct
993 (let ((reg (math-rwcomp-reg)))
994 (math-rwcomp-pattern expr reg)
995 (math-rwcomp-copy-instr part reg nil))
996 (if (setq entry (assq (nth 2 expr) math-aliased-vars))
997 (progn
998 (setcar (math-rwcomp-reg-entry (nth 1 entry))
999 (nth 2 expr))
1000 (setcar entry nil)
1001 (math-rwcomp-copy-instr part (nth 1 entry) nil))
1002 (math-rwcomp-bind-var part expr))))))
1003 ((and (eq (car expr) 'calcFunc-select)
1004 (= (length expr) 2))
1005 (let ((reg (math-rwcomp-reg)))
1006 (math-rwcomp-instr 'select part reg)
1007 (math-rwcomp-pattern (nth 1 expr) reg)))
1008 ((and (eq (car expr) 'calcFunc-opt)
1009 (memq (length expr) '(2 3)))
1010 (error "opt( ) occurs in context where it is not allowed"))
1011 ((eq (car expr) 'neg)
1012 (if (eq (car (nth 1 expr)) 'var)
1013 (let ((entry (assq (nth 2 (nth 1 expr)) math-regs)))
1014 (if entry
1015 (math-rwcomp-same-instr part (nth 1 entry) t)
1016 (if math-copy-neg
1017 (let ((reg (math-rwcomp-best-reg (nth 1 expr))))
1018 (math-rwcomp-copy-instr part reg t)
1019 (math-rwcomp-pattern (nth 1 expr) reg))
1020 (setcar (cdr (cdr (math-rwcomp-reg-entry part))) t)
1021 (math-rwcomp-pattern (nth 1 expr) part))))
1022 (if (math-rwcomp-is-algebraic (nth 1 expr))
1023 (math-rwcomp-cond-instr (list 'calcFunc-eq
1024 (math-rwcomp-register-expr part)
1025 expr))
1026 (let ((reg (math-rwcomp-reg)))
1027 (math-rwcomp-instr 'func part 'neg reg)
1028 (math-rwcomp-pattern (nth 1 expr) reg)))))
1029 ((and (eq (car expr) 'calcFunc-apply)
1030 (= (length expr) 3))
1031 (let ((reg1 (math-rwcomp-reg))
1032 (reg2 (math-rwcomp-reg)))
1033 (math-rwcomp-instr 'apply part reg1 reg2)
1034 (math-rwcomp-pattern (nth 1 expr) reg1)
1035 (math-rwcomp-pattern (nth 2 expr) reg2)))
1036 ((and (eq (car expr) 'calcFunc-cons)
1037 (= (length expr) 3))
1038 (let ((reg1 (math-rwcomp-reg))
1039 (reg2 (math-rwcomp-reg)))
1040 (math-rwcomp-instr 'cons part reg1 reg2)
1041 (math-rwcomp-pattern (nth 1 expr) reg1)
1042 (math-rwcomp-pattern (nth 2 expr) reg2)))
1043 ((and (eq (car expr) 'calcFunc-rcons)
1044 (= (length expr) 3))
1045 (let ((reg1 (math-rwcomp-reg))
1046 (reg2 (math-rwcomp-reg)))
1047 (math-rwcomp-instr 'rcons part reg1 reg2)
1048 (math-rwcomp-pattern (nth 1 expr) reg1)
1049 (math-rwcomp-pattern (nth 2 expr) reg2)))
1050 ((and (eq (car expr) 'calcFunc-condition)
1051 (>= (length expr) 3))
1052 (math-rwcomp-pattern (nth 1 expr) part)
1053 (setq expr (cdr expr))
1054 (while (setq expr (cdr expr))
1055 (let ((cond (math-flatten-lands (car expr))))
1056 (while cond
1057 (if (math-rwcomp-all-regs-done (car cond))
1058 (math-rwcomp-cond-instr (car cond))
1059 (setq math-conds (cons (car cond) math-conds)))
1060 (setq cond (cdr cond))))))
1061 ((and (eq (car expr) 'calcFunc-pand)
1062 (= (length expr) 3))
1063 (math-rwcomp-pattern (nth 1 expr) part)
1064 (math-rwcomp-pattern (nth 2 expr) part))
1065 ((and (eq (car expr) 'calcFunc-por)
1066 (= (length expr) 3))
1067 (math-rwcomp-instr 'alt nil nil [nil nil 4])
1068 (let ((math-conds nil)
1069 (head math-prog-last)
1070 (mark math-bound-vars)
1071 (math-copy-neg t))
1072 (math-rwcomp-pattern (nth 1 expr) part t)
1073 (let ((amark math-aliased-vars)
1074 (math-aliased-vars math-aliased-vars)
1075 (tail math-prog-last)
1076 (p math-bound-vars)
1077 entry)
1078 (while (not (eq p mark))
1079 (setq entry (assq (car p) math-regs)
1080 math-aliased-vars (cons (list (car p) (nth 1 entry) nil)
1081 math-aliased-vars)
1082 p (cdr p))
1083 (setcar (math-rwcomp-reg-entry (nth 1 entry)) nil))
1084 (setcar (cdr (car head)) (cdr head))
1085 (setcdr head nil)
1086 (setq math-prog-last head)
1087 (math-rwcomp-pattern (nth 2 expr) part)
1088 (math-rwcomp-instr 'same 0 0)
1089 (setcdr tail math-prog-last)
1090 (setq p math-aliased-vars)
1091 (while (not (eq p amark))
1092 (if (car (car p))
1093 (setcar (math-rwcomp-reg-entry (nth 1 (car p)))
1094 (car (car p))))
1095 (setq p (cdr p)))))
1096 (math-rwcomp-do-conditions))
1097 ((and (eq (car expr) 'calcFunc-pnot)
1098 (= (length expr) 2))
1099 (math-rwcomp-instr 'alt nil nil [nil nil 4])
1100 (let ((head math-prog-last)
1101 (mark math-bound-vars))
1102 (math-rwcomp-pattern (nth 1 expr) part)
1103 (math-rwcomp-unbind-vars mark)
1104 (math-rwcomp-instr 'end-alt head)
1105 (math-rwcomp-instr 'backtrack)
1106 (setcar (cdr (car head)) (cdr head))
1107 (setcdr head nil)
1108 (setq math-prog-last head)))
1109 (t (let ((props (get (car expr) 'math-rewrite-props)))
1110 (if (and (eq (car expr) 'calcFunc-plain)
1111 (= (length expr) 2)
1112 (not (math-primp (nth 1 expr))))
1113 (setq expr (nth 1 expr))) ; but "props" is still nil
1114 (if (and (memq 'algebraic props)
1115 (math-rwcomp-is-algebraic expr))
1116 (math-rwcomp-cond-instr (list 'calcFunc-eq
1117 (math-rwcomp-register-expr part)
1118 expr))
1119 (if (and (memq 'commut props)
1120 (= (length expr) 3))
1121 (let ((arg1 (nth 1 expr))
1122 (arg2 (nth 2 expr))
1123 try1 def code head (flip nil))
1124 (if (eq (car expr) '-)
1125 (setq arg2 (math-rwcomp-neg arg2)))
1126 (setq arg1 (cons arg1 (math-rwcomp-best-reg arg1))
1127 arg2 (cons arg2 (math-rwcomp-best-reg arg2)))
1128 (or (math-rwcomp-order arg1 arg2)
1129 (setq def arg1 arg1 arg2 arg2 def flip t))
1130 (if (math-rwcomp-optional-arg (car expr) arg1)
1131 (error "Too many opt( ) arguments in this context"))
1132 (setq def (math-rwcomp-optional-arg (car expr) arg2)
1133 head (if (memq (car expr) '(+ -))
1134 '(+ -)
1135 (if (eq (car expr) '*)
1136 '(* /)
1137 (list (car expr))))
1138 code (if (math-rwcomp-is-constrained
1139 (car arg1) head)
1140 (if (math-rwcomp-is-constrained
1141 (car arg2) head)
1142 0 1)
1143 2))
1144 (math-rwcomp-multi-instr (and def (list def))
1145 'try part head
1146 (vector nil nil nil code flip)
1147 (cdr arg1))
1148 (setq try1 (car math-prog-last))
1149 (math-rwcomp-pattern (car arg1) (cdr arg1))
1150 (math-rwcomp-instr 'try2 try1 (cdr arg2))
1151 (if (and (= part 0) (not def) (not math-rewrite-whole)
1152 (not (eq math-rhs t))
1153 (setq def (get (car expr)
1154 'math-rewrite-default)))
1155 (let ((reg1 (math-rwcomp-reg))
1156 (reg2 (math-rwcomp-reg)))
1157 (if (= (aref (nth 3 try1) 3) 0)
1158 (aset (nth 3 try1) 3 1))
1159 (math-rwcomp-instr 'try (cdr arg2)
1160 (if (equal head '(* /))
1161 '(*) head)
1162 (vector nil nil nil
1163 (if (= code 0)
1164 1 2)
1165 nil)
1166 reg1 def)
1167 (setq try1 (car math-prog-last))
1168 (math-rwcomp-pattern (car arg2) reg1)
1169 (math-rwcomp-instr 'try2 try1 reg2)
1170 (setq math-rhs (list (if (eq (car expr) '-)
1171 '+ (car expr))
1172 math-rhs
1173 (list 'calcFunc-register
1174 reg2))))
1175 (math-rwcomp-pattern (car arg2) (cdr arg2))))
1176 (let* ((args (mapcar (function
1177 (lambda (x)
1178 (cons x (math-rwcomp-best-reg x))))
1179 (cdr expr)))
1180 (args2 (copy-sequence args))
1181 (argp (reverse args2))
1182 (defs nil)
1183 (num 1))
1184 (while argp
1185 (let ((def (math-rwcomp-optional-arg (car expr)
1186 (car argp))))
1187 (if def
1188 (progn
1189 (setq args2 (delq (car argp) args2)
1190 defs (cons (cons def (cdr (car argp)))
1191 defs))
1192 (math-rwcomp-multi-instr
1193 (mapcar 'cdr args2)
1194 (if (or (and (memq 'unary1 props)
1195 (= (length args2) 1)
1196 (eq (car args2) (car args)))
1197 (and (memq 'unary2 props)
1198 (= (length args) 2)
1199 (eq (car args2) (nth 1 args))))
1200 'func-opt
1201 'func-def)
1202 part (car expr)
1203 defs))))
1204 (setq argp (cdr argp)))
1205 (math-rwcomp-multi-instr (mapcar 'cdr args)
1206 'func part (car expr))
1207 (setq args (sort args 'math-rwcomp-order))
1208 (while args
1209 (math-rwcomp-pattern (car (car args)) (cdr (car args)))
1210 (setq num (1+ num)
1211 args (cdr args))))))))))
1212
1213 (defun math-rwcomp-best-reg (x)
1214 (or (and (eq (car-safe x) 'var)
1215 (let ((entry (assq (nth 2 x) math-aliased-vars)))
1216 (and entry
1217 (not (nth 2 entry))
1218 (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry))))
1219 (progn
1220 (setcar (cdr (cdr entry)) t)
1221 (nth 1 entry)))))
1222 (math-rwcomp-reg)))
1223
1224 (defun math-rwcomp-all-regs-done (expr)
1225 (if (Math-primp expr)
1226 (or (not (eq (car-safe expr) 'var))
1227 (assq (nth 2 expr) math-regs)
1228 (eq (nth 2 expr) 'var-remember)
1229 (math-const-var expr))
1230 (if (and (eq (car expr) 'calcFunc-let)
1231 (= (length expr) 3))
1232 (math-rwcomp-all-regs-done (nth 2 expr))
1233 (if (and (eq (car expr) 'calcFunc-let)
1234 (= (length expr) 2)
1235 (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
1236 (= (length (nth 1 expr)) 3))
1237 (math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
1238 (while (and (setq expr (cdr expr))
1239 (math-rwcomp-all-regs-done (car expr))))
1240 (null expr)))))
1241
1242 (defun math-rwcomp-no-vars (expr)
1243 (if (Math-primp expr)
1244 (or (not (eq (car-safe expr) 'var))
1245 (math-const-var expr))
1246 (and (not (memq (car expr) '(calcFunc-condition
1247 calcFunc-select calcFunc-quote
1248 calcFunc-plain calcFunc-opt
1249 calcFunc-por calcFunc-pand
1250 calcFunc-pnot calcFunc-apply
1251 calcFunc-cons calcFunc-rcons)))
1252 (progn
1253 (while (and (setq expr (cdr expr))
1254 (math-rwcomp-no-vars (car expr))))
1255 (null expr)))))
1256
1257 (defun math-rwcomp-is-algebraic (expr)
1258 (if (Math-primp expr)
1259 (or (not (eq (car-safe expr) 'var))
1260 (math-const-var expr)
1261 (assq (nth 2 expr) math-regs))
1262 (and (memq 'algebraic (get (car expr) 'math-rewrite-props))
1263 (progn
1264 (while (and (setq expr (cdr expr))
1265 (math-rwcomp-is-algebraic (car expr))))
1266 (null expr)))))
1267
1268 (defun math-rwcomp-is-constrained (expr not-these)
1269 (if (Math-primp expr)
1270 (not (eq (car-safe expr) 'var))
1271 (if (eq (car expr) 'calcFunc-plain)
1272 (math-rwcomp-is-constrained (nth 1 expr) not-these)
1273 (not (or (memq (car expr) '(neg calcFunc-select))
1274 (memq (car expr) not-these)
1275 (and (memq 'commut (get (car expr) 'math-rewrite-props))
1276 (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
1277 (eq (car-safe (nth 2 expr)) 'calcFunc-opt))))))))
1278
1279 (defun math-rwcomp-optional-arg (head argp)
1280 (let ((arg (car argp)))
1281 (if (eq (car-safe arg) 'calcFunc-opt)
1282 (and (memq (length arg) '(2 3))
1283 (progn
1284 (or (eq (car-safe (nth 1 arg)) 'var)
1285 (error "First argument of opt( ) must be a variable"))
1286 (setcar argp (nth 1 arg))
1287 (if (= (length arg) 2)
1288 (or (get head 'math-rewrite-default)
1289 (error "opt( ) must include a default in this context"))
1290 (nth 2 arg))))
1291 (and (eq (car-safe arg) 'neg)
1292 (let* ((part (list (nth 1 arg)))
1293 (partp (math-rwcomp-optional-arg head part)))
1294 (and partp
1295 (setcar argp (math-rwcomp-neg (car part)))
1296 (math-neg partp)))))))
1297
1298 (defun math-rwcomp-neg (expr)
1299 (if (memq (car-safe expr) '(* /))
1300 (if (eq (car-safe (nth 1 expr)) 'var)
1301 (list (car expr) (list 'neg (nth 1 expr)) (nth 2 expr))
1302 (if (eq (car-safe (nth 2 expr)) 'var)
1303 (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
1304 (math-neg expr)))
1305 (math-neg expr)))
1306
1307 (defun math-rwcomp-assoc-args (expr)
1308 (if (and (eq (car-safe (nth 1 expr)) (car expr))
1309 (= (length (nth 1 expr)) 3))
1310 (math-rwcomp-assoc-args (nth 1 expr)))
1311 (if (and (eq (car-safe (nth 2 expr)) (car expr))
1312 (= (length (nth 2 expr)) 3))
1313 (math-rwcomp-assoc-args (nth 2 expr))))
1314
1315 (defun math-rwcomp-addsub-args (expr)
1316 (if (memq (car-safe (nth 1 expr)) '(+ -))
1317 (math-rwcomp-addsub-args (nth 1 expr)))
1318 (if (eq (car expr) '-)
1319 ()
1320 (if (eq (car-safe (nth 2 expr)) '+)
1321 (math-rwcomp-addsub-args (nth 2 expr)))))
1322
1323 (defun math-rwcomp-order (a b)
1324 (< (math-rwcomp-priority (car a))
1325 (math-rwcomp-priority (car b))))
1326
1327 ;; Order of priority: 0 Constants and other exact matches (first)
1328 ;; 10 Functions (except below)
1329 ;; 20 Meta-variables which occur more than once
1330 ;; 30 Algebraic functions
1331 ;; 40 Commutative/associative functions
1332 ;; 50 Meta-variables which occur only once
1333 ;; +100 for every "!!!" (pnot) in the pattern
1334 ;; 10000 Optional arguments (last)
1335
1336 (defun math-rwcomp-priority (expr)
1337 (+ (math-rwcomp-count-pnots expr)
1338 (cond ((eq (car-safe expr) 'calcFunc-opt)
1339 10000)
1340 ((math-rwcomp-no-vars expr)
1341 0)
1342 ((eq (car expr) 'calcFunc-quote)
1343 0)
1344 ((eq (car expr) 'var)
1345 (if (assq (nth 2 expr) math-regs)
1346 0
1347 (if (= (math-rwcomp-count-refs expr) 1)
1348 50
1349 20)))
1350 (t (let ((props (get (car expr) 'math-rewrite-props)))
1351 (if (or (memq 'commut props)
1352 (memq 'assoc props))
1353 40
1354 (if (memq 'algebraic props)
1355 30
1356 10)))))))
1357
1358 (defun math-rwcomp-count-refs (var)
1359 (let ((count (or (math-expr-contains-count math-pattern var) 0))
1360 (p math-conds))
1361 (while p
1362 (if (eq (car-safe (car p)) 'calcFunc-let)
1363 (if (= (length (car p)) 3)
1364 (setq count (+ count
1365 (or (math-expr-contains-count (nth 2 (car p)) var)
1366 0)))
1367 (if (and (= (length (car p)) 2)
1368 (eq (car-safe (nth 1 (car p))) 'calcFunc-assign)
1369 (= (length (nth 1 (car p))) 3))
1370 (setq count (+ count
1371 (or (math-expr-contains-count
1372 (nth 2 (nth 1 (car p))) var) 0))))))
1373 (setq p (cdr p)))
1374 count))
1375
1376 (defun math-rwcomp-count-pnots (expr)
1377 (if (Math-primp expr)
1378 0
1379 (if (eq (car expr) 'calcFunc-pnot)
1380 100
1381 (let ((count 0))
1382 (while (setq expr (cdr expr))
1383 (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
1384 count))))
1385
1386 ;; In the current implementation, all associative functions must
1387 ;; also be commutative.
1388
1389 (put '+ 'math-rewrite-props '(algebraic assoc commut))
1390 (put '- 'math-rewrite-props '(algebraic assoc commut)) ; see below
1391 (put '* 'math-rewrite-props '(algebraic assoc commut)) ; see below
1392 (put '/ 'math-rewrite-props '(algebraic unary1))
1393 (put '^ 'math-rewrite-props '(algebraic unary1))
1394 (put '% 'math-rewrite-props '(algebraic))
1395 (put 'neg 'math-rewrite-props '(algebraic))
1396 (put 'calcFunc-idiv 'math-rewrite-props '(algebraic))
1397 (put 'calcFunc-abs 'math-rewrite-props '(algebraic))
1398 (put 'calcFunc-sign 'math-rewrite-props '(algebraic))
1399 (put 'calcFunc-round 'math-rewrite-props '(algebraic))
1400 (put 'calcFunc-rounde 'math-rewrite-props '(algebraic))
1401 (put 'calcFunc-roundu 'math-rewrite-props '(algebraic))
1402 (put 'calcFunc-trunc 'math-rewrite-props '(algebraic))
1403 (put 'calcFunc-floor 'math-rewrite-props '(algebraic))
1404 (put 'calcFunc-ceil 'math-rewrite-props '(algebraic))
1405 (put 'calcFunc-re 'math-rewrite-props '(algebraic))
1406 (put 'calcFunc-im 'math-rewrite-props '(algebraic))
1407 (put 'calcFunc-conj 'math-rewrite-props '(algebraic))
1408 (put 'calcFunc-arg 'math-rewrite-props '(algebraic))
1409 (put 'calcFunc-and 'math-rewrite-props '(assoc commut))
1410 (put 'calcFunc-or 'math-rewrite-props '(assoc commut))
1411 (put 'calcFunc-xor 'math-rewrite-props '(assoc commut))
1412 (put 'calcFunc-eq 'math-rewrite-props '(commut))
1413 (put 'calcFunc-neq 'math-rewrite-props '(commut))
1414 (put 'calcFunc-land 'math-rewrite-props '(assoc commut))
1415 (put 'calcFunc-lor 'math-rewrite-props '(assoc commut))
1416 (put 'calcFunc-beta 'math-rewrite-props '(commut))
1417 (put 'calcFunc-gcd 'math-rewrite-props '(assoc commut))
1418 (put 'calcFunc-lcm 'math-rewrite-props '(assoc commut))
1419 (put 'calcFunc-max 'math-rewrite-props '(algebraic assoc commut))
1420 (put 'calcFunc-min 'math-rewrite-props '(algebraic assoc commut))
1421 (put 'calcFunc-vunion 'math-rewrite-props '(assoc commut))
1422 (put 'calcFunc-vint 'math-rewrite-props '(assoc commut))
1423 (put 'calcFunc-vxor 'math-rewrite-props '(assoc commut))
1424
1425 ;; Note: "*" is not commutative for matrix args, but we pretend it is.
1426 ;; Also, "-" is not commutative but the code tweaks things so that it is.
1427
1428 (put '+ 'math-rewrite-default 0)
1429 (put '- 'math-rewrite-default 0)
1430 (put '* 'math-rewrite-default 1)
1431 (put '/ 'math-rewrite-default 1)
1432 (put '^ 'math-rewrite-default 1)
1433 (put 'calcFunc-land 'math-rewrite-default 1)
1434 (put 'calcFunc-lor 'math-rewrite-default 0)
1435 (put 'calcFunc-vunion 'math-rewrite-default '(vec))
1436 (put 'calcFunc-vint 'math-rewrite-default '(vec))
1437 (put 'calcFunc-vdiff 'math-rewrite-default '(vec))
1438 (put 'calcFunc-vxor 'math-rewrite-default '(vec))
1439
1440 (defmacro math-rwfail (&optional back)
1441 `(setq pc (and ,(if back
1442 '(setq btrack (cdr btrack))
1443 'btrack)
1444 '((backtrack)))))
1445
1446 ;; This monstrosity is necessary because the use of static vectors of
1447 ;; registers makes rewrite rules non-reentrant. Yucko!
1448 (defmacro math-rweval (form)
1449 `(let ((orig (car rules)))
1450 (setcar rules '(nil nil nil no-phase))
1451 (unwind-protect
1452 ,form
1453 (setcar rules orig))))
1454
1455 (defvar math-rewrite-phase 1)
1456
1457 ;; The variable math-apply-rw-regs is local to math-apply-rewrites,
1458 ;; but is used by math-rwapply-replace-regs and math-rwapply-reg-looks-negp
1459 ;; which are called by math-apply-rewrites.
1460 (defvar math-apply-rw-regs)
1461
1462 ;; The variable math-apply-rw-ruleset is local to math-apply-rewrites,
1463 ;; but is used by math-rwapply-remember.
1464 (defvar math-apply-rw-ruleset)
1465
1466 (defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset)
1467 (and
1468 (setq rules (cdr (or (assq (car-safe expr) rules)
1469 (assq nil rules))))
1470 (let ((result nil)
1471 op math-apply-rw-regs inst part pc mark btrack
1472 (tracing math-rwcomp-tracing)
1473 (phase math-rewrite-phase))
1474 (while rules
1475 (or
1476 (and (setq part (nth 2 (car rules)))
1477 heads
1478 (not (memq part heads)))
1479 (and (setq part (nth 3 (car rules)))
1480 (not (memq phase part)))
1481 (progn
1482 (setq math-apply-rw-regs (car (car rules))
1483 pc (nth 1 (car rules))
1484 btrack nil)
1485 (aset math-apply-rw-regs 0 expr)
1486 (while pc
1487
1488 (and tracing
1489 (progn (terpri) (princ (car pc))
1490 (if (and (natnump (nth 1 (car pc)))
1491 (< (nth 1 (car pc)) (length math-apply-rw-regs)))
1492 (princ
1493 (format "\n part = %s"
1494 (aref math-apply-rw-regs (nth 1 (car pc))))))))
1495
1496 (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
1497 (if (and (consp
1498 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1499 (eq (car part)
1500 (car (setq inst (cdr (cdr inst)))))
1501 (progn
1502 (while (and (setq inst (cdr inst)
1503 part (cdr part))
1504 inst)
1505 (aset math-apply-rw-regs (car inst) (car part)))
1506 (not (or inst part))))
1507 (setq pc (cdr pc))
1508 (math-rwfail)))
1509
1510 ((eq op 'same)
1511 (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1512 (setq mark (aref math-apply-rw-regs (nth 2 inst))))
1513 (Math-equal part mark))
1514 (setq pc (cdr pc))
1515 (math-rwfail)))
1516
1517 ((and (eq op 'try)
1518 calc-matrix-mode
1519 (not (eq calc-matrix-mode 'scalar))
1520 (eq (car (nth 2 inst)) '*)
1521 (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1522 (eq (car part) '*)
1523 (not (math-known-scalarp part)))
1524 (setq mark (nth 3 inst)
1525 pc (cdr pc))
1526 (if (aref mark 4)
1527 (progn
1528 (aset math-apply-rw-regs (nth 4 inst) (nth 2 part))
1529 (aset mark 1 (cdr (cdr part))))
1530 (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1531 (aset mark 1 (cdr part)))
1532 (aset mark 0 (cdr part))
1533 (aset mark 2 0))
1534
1535 ((eq op 'try)
1536 (if (and (consp (setq part
1537 (aref math-apply-rw-regs (car (cdr inst)))))
1538 (memq (car part) (nth 2 inst))
1539 (= (length part) 3)
1540 (or (not (eq (car part) '/))
1541 (Math-objectp (nth 2 part))))
1542 (progn
1543 (setq op nil
1544 mark (car (cdr (setq inst (cdr (cdr inst))))))
1545 (and
1546 (memq 'assoc (get (car part) 'math-rewrite-props))
1547 (not (= (aref mark 3) 0))
1548 (while (if (and (consp (nth 1 part))
1549 (memq (car (nth 1 part)) (car inst)))
1550 (setq op (cons (if (eq (car part) '-)
1551 (math-rwapply-neg
1552 (nth 2 part))
1553 (nth 2 part))
1554 op)
1555 part (nth 1 part))
1556 (if (and (consp (nth 2 part))
1557 (memq (car (nth 2 part))
1558 (car inst))
1559 (not (eq (car (nth 2 part)) '-)))
1560 (setq op (cons (nth 1 part) op)
1561 part (nth 2 part))))))
1562 (setq op (cons (nth 1 part)
1563 (cons (if (eq (car part) '-)
1564 (math-rwapply-neg
1565 (nth 2 part))
1566 (if (eq (car part) '/)
1567 (math-rwapply-inv
1568 (nth 2 part))
1569 (nth 2 part)))
1570 op))
1571 btrack (cons pc btrack)
1572 pc (cdr pc))
1573 (aset math-apply-rw-regs (nth 2 inst) (car op))
1574 (aset mark 0 op)
1575 (aset mark 1 op)
1576 (aset mark 2 (if (cdr (cdr op)) 1 0)))
1577 (if (nth 5 inst)
1578 (if (and (consp part)
1579 (eq (car part) 'neg)
1580 (eq (car (nth 2 inst)) '*)
1581 (eq (nth 5 inst) 1))
1582 (progn
1583 (setq mark (nth 3 inst)
1584 pc (cdr pc))
1585 (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1586 (aset mark 1 -1)
1587 (aset mark 2 4))
1588 (setq mark (nth 3 inst)
1589 pc (cdr pc))
1590 (aset math-apply-rw-regs (nth 4 inst) part)
1591 (aset mark 2 3))
1592 (math-rwfail))))
1593
1594 ((eq op 'try2)
1595 (setq part (nth 1 inst) ; try instr
1596 mark (nth 3 part)
1597 op (aref mark 2)
1598 pc (cdr pc))
1599 (aset math-apply-rw-regs (nth 2 inst)
1600 (cond
1601 ((eq op 0)
1602 (if (eq (aref mark 0) (aref mark 1))
1603 (nth 1 (aref mark 0))
1604 (car (aref mark 0))))
1605 ((eq op 1)
1606 (setq mark (delq (car (aref mark 1))
1607 (copy-sequence (aref mark 0)))
1608 op (car (nth 2 part)))
1609 (if (eq op '*)
1610 (progn
1611 (setq mark (nreverse mark)
1612 part (list '* (nth 1 mark) (car mark))
1613 mark (cdr mark))
1614 (while (setq mark (cdr mark))
1615 (setq part (list '* (car mark) part))))
1616 (setq part (car mark)
1617 mark (cdr mark)
1618 part (if (and (eq op '+)
1619 (consp (car mark))
1620 (eq (car (car mark)) 'neg))
1621 (list '- part
1622 (nth 1 (car mark)))
1623 (list op part (car mark))))
1624 (while (setq mark (cdr mark))
1625 (setq part (if (and (eq op '+)
1626 (consp (car mark))
1627 (eq (car (car mark)) 'neg))
1628 (list '- part
1629 (nth 1 (car mark)))
1630 (list op part (car mark))))))
1631 part)
1632 ((eq op 2)
1633 (car (aref mark 1)))
1634 ((eq op 3) (nth 5 part))
1635 (t (aref mark 1)))))
1636
1637 ((eq op 'select)
1638 (setq pc (cdr pc))
1639 (if (and (consp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1640 (eq (car part) 'calcFunc-select))
1641 (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1642 (if math-rewrite-selections
1643 (math-rwfail)
1644 (aset math-apply-rw-regs (nth 2 inst) part))))
1645
1646 ((eq op 'same-neg)
1647 (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1648 (setq mark (math-neg
1649 (aref math-apply-rw-regs (nth 2 inst)))))
1650 (Math-equal part mark))
1651 (setq pc (cdr pc))
1652 (math-rwfail)))
1653
1654 ((eq op 'backtrack)
1655 (setq inst (car (car btrack)) ; "try" or "alt" instr
1656 pc (cdr (car btrack))
1657 mark (or (nth 3 inst) [nil nil 4])
1658 op (aref mark 2))
1659 (cond ((eq op 0)
1660 (if (setq op (cdr (aref mark 1)))
1661 (aset math-apply-rw-regs (nth 4 inst)
1662 (car (aset mark 1 op)))
1663 (if (nth 5 inst)
1664 (progn
1665 (aset mark 2 3)
1666 (aset math-apply-rw-regs (nth 4 inst)
1667 (aref math-apply-rw-regs (nth 1 inst))))
1668 (math-rwfail t))))
1669 ((eq op 1)
1670 (if (setq op (cdr (aref mark 1)))
1671 (aset math-apply-rw-regs (nth 4 inst)
1672 (car (aset mark 1 op)))
1673 (if (= (aref mark 3) 1)
1674 (if (nth 5 inst)
1675 (progn
1676 (aset mark 2 3)
1677 (aset math-apply-rw-regs (nth 4 inst)
1678 (aref math-apply-rw-regs (nth 1 inst))))
1679 (math-rwfail t))
1680 (aset mark 2 2)
1681 (aset mark 1 (cons nil (aref mark 0)))
1682 (math-rwfail))))
1683 ((eq op 2)
1684 (if (setq op (cdr (aref mark 1)))
1685 (progn
1686 (setq mark (delq (car (aset mark 1 op))
1687 (copy-sequence
1688 (aref mark 0)))
1689 op (car (nth 2 inst)))
1690 (if (eq op '*)
1691 (progn
1692 (setq mark (nreverse mark)
1693 part (list '* (nth 1 mark)
1694 (car mark))
1695 mark (cdr mark))
1696 (while (setq mark (cdr mark))
1697 (setq part (list '* (car mark)
1698 part))))
1699 (setq part (car mark)
1700 mark (cdr mark)
1701 part (if (and (eq op '+)
1702 (consp (car mark))
1703 (eq (car (car mark))
1704 'neg))
1705 (list '- part
1706 (nth 1 (car mark)))
1707 (list op part (car mark))))
1708 (while (setq mark (cdr mark))
1709 (setq part (if (and (eq op '+)
1710 (consp (car mark))
1711 (eq (car (car mark))
1712 'neg))
1713 (list '- part
1714 (nth 1 (car mark)))
1715 (list op part (car mark))))))
1716 (aset math-apply-rw-regs (nth 4 inst) part))
1717 (if (nth 5 inst)
1718 (progn
1719 (aset mark 2 3)
1720 (aset math-apply-rw-regs (nth 4 inst)
1721 (aref math-apply-rw-regs (nth 1 inst))))
1722 (math-rwfail t))))
1723 ((eq op 4)
1724 (setq btrack (cdr btrack)))
1725 (t (math-rwfail t))))
1726
1727 ((eq op 'integer)
1728 (if (Math-integerp (setq part
1729 (aref math-apply-rw-regs (nth 1 inst))))
1730 (setq pc (cdr pc))
1731 (if (Math-primp part)
1732 (math-rwfail)
1733 (setq part (math-rweval (math-simplify part)))
1734 (if (Math-integerp part)
1735 (setq pc (cdr pc))
1736 (math-rwfail)))))
1737
1738 ((eq op 'real)
1739 (if (Math-realp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1740 (setq pc (cdr pc))
1741 (if (Math-primp part)
1742 (math-rwfail)
1743 (setq part (math-rweval (math-simplify part)))
1744 (if (Math-realp part)
1745 (setq pc (cdr pc))
1746 (math-rwfail)))))
1747
1748 ((eq op 'constant)
1749 (if (math-constp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1750 (setq pc (cdr pc))
1751 (if (Math-primp part)
1752 (math-rwfail)
1753 (setq part (math-rweval (math-simplify part)))
1754 (if (math-constp part)
1755 (setq pc (cdr pc))
1756 (math-rwfail)))))
1757
1758 ((eq op 'negative)
1759 (if (math-looks-negp (setq part
1760 (aref math-apply-rw-regs (nth 1 inst))))
1761 (setq pc (cdr pc))
1762 (if (Math-primp part)
1763 (math-rwfail)
1764 (setq part (math-rweval (math-simplify part)))
1765 (if (math-looks-negp part)
1766 (setq pc (cdr pc))
1767 (math-rwfail)))))
1768
1769 ((eq op 'rel)
1770 (setq part (math-compare (aref math-apply-rw-regs (nth 1 inst))
1771 (aref math-apply-rw-regs (nth 3 inst)))
1772 op (nth 2 inst))
1773 (if (= part 2)
1774 (setq part (math-rweval
1775 (math-simplify
1776 (calcFunc-sign
1777 (math-sub
1778 (aref math-apply-rw-regs (nth 1 inst))
1779 (aref math-apply-rw-regs (nth 3 inst))))))))
1780 (if (cond ((eq op 'calcFunc-eq)
1781 (eq part 0))
1782 ((eq op 'calcFunc-neq)
1783 (memq part '(-1 1)))
1784 ((eq op 'calcFunc-lt)
1785 (eq part -1))
1786 ((eq op 'calcFunc-leq)
1787 (memq part '(-1 0)))
1788 ((eq op 'calcFunc-gt)
1789 (eq part 1))
1790 ((eq op 'calcFunc-geq)
1791 (memq part '(0 1))))
1792 (setq pc (cdr pc))
1793 (math-rwfail)))
1794
1795 ((eq op 'func-def)
1796 (if (and
1797 (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1798 (eq (car part)
1799 (car (setq inst (cdr (cdr inst))))))
1800 (progn
1801 (setq inst (cdr inst)
1802 mark (car inst))
1803 (while (and (setq inst (cdr inst)
1804 part (cdr part))
1805 inst)
1806 (aset math-apply-rw-regs (car inst) (car part)))
1807 (if (or inst part)
1808 (setq pc (cdr pc))
1809 (while (eq (car (car (setq pc (cdr pc))))
1810 'func-def))
1811 (setq pc (cdr pc)) ; skip over "func"
1812 (while mark
1813 (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1814 (setq mark (cdr mark)))))
1815 (math-rwfail)))
1816
1817 ((eq op 'func-opt)
1818 (if (or (not
1819 (and
1820 (consp
1821 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1822 (eq (car part) (nth 2 inst))))
1823 (and (= (length part) 2)
1824 (setq part (nth 1 part))))
1825 (progn
1826 (setq mark (nth 3 inst))
1827 (aset math-apply-rw-regs (nth 4 inst) part)
1828 (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
1829 (setq pc (cdr pc)) ; skip over "func"
1830 (while mark
1831 (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1832 (setq mark (cdr mark))))
1833 (setq pc (cdr pc))))
1834
1835 ((eq op 'mod)
1836 (if (if (Math-zerop
1837 (setq part (aref math-apply-rw-regs (nth 1 inst))))
1838 (Math-zerop (nth 3 inst))
1839 (and (not (Math-zerop (nth 2 inst)))
1840 (progn
1841 (setq part (math-mod part (nth 2 inst)))
1842 (or (Math-numberp part)
1843 (setq part (math-rweval
1844 (math-simplify part))))
1845 (Math-equal part (nth 3 inst)))))
1846 (setq pc (cdr pc))
1847 (math-rwfail)))
1848
1849 ((eq op 'apply)
1850 (if (and (consp
1851 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1852 (not (Math-objvecp part))
1853 (not (eq (car part) 'var)))
1854 (progn
1855 (aset math-apply-rw-regs (nth 2 inst)
1856 (math-calcFunc-to-var (car part)))
1857 (aset math-apply-rw-regs (nth 3 inst)
1858 (cons 'vec (cdr part)))
1859 (setq pc (cdr pc)))
1860 (math-rwfail)))
1861
1862 ((eq op 'cons)
1863 (if (and (consp
1864 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1865 (eq (car part) 'vec)
1866 (cdr part))
1867 (progn
1868 (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1869 (aset math-apply-rw-regs (nth 3 inst)
1870 (cons 'vec (cdr (cdr part))))
1871 (setq pc (cdr pc)))
1872 (math-rwfail)))
1873
1874 ((eq op 'rcons)
1875 (if (and (consp
1876 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1877 (eq (car part) 'vec)
1878 (cdr part))
1879 (progn
1880 (aset math-apply-rw-regs (nth 2 inst) (calcFunc-rhead part))
1881 (aset math-apply-rw-regs (nth 3 inst) (calcFunc-rtail part))
1882 (setq pc (cdr pc)))
1883 (math-rwfail)))
1884
1885 ((eq op 'cond)
1886 (if (math-is-true
1887 (math-rweval
1888 (math-simplify
1889 (math-rwapply-replace-regs (nth 1 inst)))))
1890 (setq pc (cdr pc))
1891 (math-rwfail)))
1892
1893 ((eq op 'let)
1894 (aset math-apply-rw-regs (nth 1 inst)
1895 (math-rweval
1896 (math-normalize
1897 (math-rwapply-replace-regs (nth 2 inst)))))
1898 (setq pc (cdr pc)))
1899
1900 ((eq op 'copy)
1901 (aset math-apply-rw-regs (nth 2 inst)
1902 (aref math-apply-rw-regs (nth 1 inst)))
1903 (setq pc (cdr pc)))
1904
1905 ((eq op 'copy-neg)
1906 (aset math-apply-rw-regs (nth 2 inst)
1907 (math-rwapply-neg (aref math-apply-rw-regs (nth 1 inst))))
1908 (setq pc (cdr pc)))
1909
1910 ((eq op 'alt)
1911 (setq btrack (cons pc btrack)
1912 pc (nth 1 inst)))
1913
1914 ((eq op 'end-alt)
1915 (while (and btrack (not (eq (car btrack) (nth 1 inst))))
1916 (setq btrack (cdr btrack)))
1917 (setq btrack (cdr btrack)
1918 pc (cdr pc)))
1919
1920 ((eq op 'done)
1921 (setq result (math-rwapply-replace-regs (nth 1 inst)))
1922 (if (or (and (eq (car-safe result) '+)
1923 (eq (nth 2 result) 0))
1924 (and (eq (car-safe result) '*)
1925 (eq (nth 2 result) 1)))
1926 (setq result (nth 1 result)))
1927 (setq part (and (nth 2 inst)
1928 (math-is-true
1929 (math-rweval
1930 (math-simplify
1931 (math-rwapply-replace-regs
1932 (nth 2 inst)))))))
1933 (if (or (equal result expr)
1934 (equal (setq result (math-normalize result)) expr))
1935 (setq result nil)
1936 (if part (math-rwapply-remember expr result))
1937 (setq rules nil))
1938 (setq pc nil))
1939
1940 (t (error "%s is not a valid rewrite opcode" op))))))
1941 (setq rules (cdr rules)))
1942 result)))
1943
1944 (defun math-rwapply-neg (expr)
1945 (if (and (consp expr)
1946 (memq (car expr) '(* /)))
1947 (if (Math-objectp (nth 2 expr))
1948 (list (car expr) (nth 1 expr) (math-neg (nth 2 expr)))
1949 (list (car expr)
1950 (if (Math-objectp (nth 1 expr))
1951 (math-neg (nth 1 expr))
1952 (list '* -1 (nth 1 expr)))
1953 (nth 2 expr)))
1954 (math-neg expr)))
1955
1956 (defun math-rwapply-inv (expr)
1957 (if (and (Math-integerp expr)
1958 calc-prefer-frac)
1959 (math-make-frac 1 expr)
1960 (list '/ 1 expr)))
1961
1962 (defun math-rwapply-replace-regs (expr)
1963 (cond ((Math-primp expr)
1964 expr)
1965 ((eq (car expr) 'calcFunc-register)
1966 (setq expr (aref math-apply-rw-regs (nth 1 expr)))
1967 (if (eq (car-safe expr) '*)
1968 (if (eq (nth 1 expr) -1)
1969 (math-neg (nth 2 expr))
1970 (if (eq (nth 1 expr) 1)
1971 (nth 2 expr)
1972 expr))
1973 expr))
1974 ((and (eq (car expr) 'calcFunc-eval)
1975 (= (length expr) 2))
1976 (calc-with-default-simplification
1977 (math-normalize (math-rwapply-replace-regs (nth 1 expr)))))
1978 ((and (eq (car expr) 'calcFunc-evalsimp)
1979 (= (length expr) 2))
1980 (math-simplify (math-rwapply-replace-regs (nth 1 expr))))
1981 ((and (eq (car expr) 'calcFunc-evalextsimp)
1982 (= (length expr) 2))
1983 (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr))))
1984 ((and (eq (car expr) 'calcFunc-apply)
1985 (= (length expr) 3))
1986 (let ((func (math-rwapply-replace-regs (nth 1 expr)))
1987 (args (math-rwapply-replace-regs (nth 2 expr)))
1988 call)
1989 (if (and (math-vectorp args)
1990 (not (eq (car-safe (setq call (math-build-call
1991 (math-var-to-calcFunc func)
1992 (cdr args))))
1993 'calcFunc-call)))
1994 call
1995 (list 'calcFunc-apply func args))))
1996 ((and (eq (car expr) 'calcFunc-cons)
1997 (= (length expr) 3))
1998 (let ((head (math-rwapply-replace-regs (nth 1 expr)))
1999 (tail (math-rwapply-replace-regs (nth 2 expr))))
2000 (if (math-vectorp tail)
2001 (cons 'vec (cons head (cdr tail)))
2002 (list 'calcFunc-cons head tail))))
2003 ((and (eq (car expr) 'calcFunc-rcons)
2004 (= (length expr) 3))
2005 (let ((head (math-rwapply-replace-regs (nth 1 expr)))
2006 (tail (math-rwapply-replace-regs (nth 2 expr))))
2007 (if (math-vectorp head)
2008 (append head (list tail))
2009 (list 'calcFunc-rcons head tail))))
2010 ((and (eq (car expr) 'neg)
2011 (math-rwapply-reg-looks-negp (nth 1 expr)))
2012 (math-rwapply-reg-neg (nth 1 expr)))
2013 ((and (eq (car expr) 'neg)
2014 (eq (car-safe (nth 1 expr)) 'calcFunc-register)
2015 (math-scalarp (aref math-apply-rw-regs (nth 1 (nth 1 expr)))))
2016 (math-neg (math-rwapply-replace-regs (nth 1 expr))))
2017 ((and (eq (car expr) '+)
2018 (math-rwapply-reg-looks-negp (nth 1 expr)))
2019 (list '- (math-rwapply-replace-regs (nth 2 expr))
2020 (math-rwapply-reg-neg (nth 1 expr))))
2021 ((and (eq (car expr) '+)
2022 (math-rwapply-reg-looks-negp (nth 2 expr)))
2023 (list '- (math-rwapply-replace-regs (nth 1 expr))
2024 (math-rwapply-reg-neg (nth 2 expr))))
2025 ((and (eq (car expr) '-)
2026 (math-rwapply-reg-looks-negp (nth 2 expr)))
2027 (list '+ (math-rwapply-replace-regs (nth 1 expr))
2028 (math-rwapply-reg-neg (nth 2 expr))))
2029 ((eq (car expr) '*)
2030 (cond ((eq (nth 1 expr) -1)
2031 (if (math-rwapply-reg-looks-negp (nth 2 expr))
2032 (math-rwapply-reg-neg (nth 2 expr))
2033 (math-neg (math-rwapply-replace-regs (nth 2 expr)))))
2034 ((eq (nth 1 expr) 1)
2035 (math-rwapply-replace-regs (nth 2 expr)))
2036 ((eq (nth 2 expr) -1)
2037 (if (math-rwapply-reg-looks-negp (nth 1 expr))
2038 (math-rwapply-reg-neg (nth 1 expr))
2039 (math-neg (math-rwapply-replace-regs (nth 1 expr)))))
2040 ((eq (nth 2 expr) 1)
2041 (math-rwapply-replace-regs (nth 1 expr)))
2042 (t
2043 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
2044 (arg2 (math-rwapply-replace-regs (nth 2 expr))))
2045 (cond ((and (eq (car-safe arg1) '/)
2046 (eq (nth 1 arg1) 1))
2047 (list '/ arg2 (nth 2 arg1)))
2048 ((and (eq (car-safe arg2) '/)
2049 (eq (nth 1 arg2) 1))
2050 (list '/ arg1 (nth 2 arg2)))
2051 (t (list '* arg1 arg2)))))))
2052 ((eq (car expr) '/)
2053 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
2054 (arg2 (math-rwapply-replace-regs (nth 2 expr))))
2055 (if (eq (car-safe arg2) '/)
2056 (list '/ (list '* arg1 (nth 2 arg2)) (nth 1 arg2))
2057 (list '/ arg1 arg2))))
2058 ((and (eq (car expr) 'calcFunc-plain)
2059 (= (length expr) 2))
2060 (if (Math-primp (nth 1 expr))
2061 (nth 1 expr)
2062 (if (eq (car (nth 1 expr)) 'calcFunc-register)
2063 (aref math-apply-rw-regs (nth 1 (nth 1 expr)))
2064 (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
2065 (cdr (nth 1 expr)))))))
2066 (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))))
2067
2068 (defun math-rwapply-reg-looks-negp (expr)
2069 (if (eq (car-safe expr) 'calcFunc-register)
2070 (math-looks-negp (aref math-apply-rw-regs (nth 1 expr)))
2071 (if (memq (car-safe expr) '(* /))
2072 (or (math-rwapply-reg-looks-negp (nth 1 expr))
2073 (math-rwapply-reg-looks-negp (nth 2 expr))))))
2074
2075 (defun math-rwapply-reg-neg (expr) ; expr must satisfy rwapply-reg-looks-negp
2076 (if (eq (car expr) 'calcFunc-register)
2077 (math-neg (math-rwapply-replace-regs expr))
2078 (if (math-rwapply-reg-looks-negp (nth 1 expr))
2079 (math-rwapply-replace-regs (list (car expr)
2080 (math-rwapply-reg-neg (nth 1 expr))
2081 (nth 2 expr)))
2082 (math-rwapply-replace-regs (list (car expr)
2083 (nth 1 expr)
2084 (math-rwapply-reg-neg (nth 2 expr)))))))
2085
2086 (defun math-rwapply-remember (old new)
2087 (let ((varval (symbol-value (nth 2 (car math-apply-rw-ruleset))))
2088 (rules (assq (car-safe old) math-apply-rw-ruleset)))
2089 (if (and (eq (car-safe varval) 'vec)
2090 (not (memq (car-safe old) '(nil schedule + -)))
2091 rules)
2092 (progn
2093 (setcdr varval (cons (list 'calcFunc-assign
2094 (if (math-rwcomp-no-vars old)
2095 old
2096 (list 'calcFunc-quote old))
2097 new)
2098 (cdr varval)))
2099 (setcdr rules (cons (list (vector nil old)
2100 (list (list 'same 0 1)
2101 (list 'done new nil))
2102 nil nil)
2103 (cdr rules)))))))
2104
2105 (provide 'calc-rewr)
2106
2107 ;;; calc-rewr.el ends here
Emacs repository mirror