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