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