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