-;; Calculator for GNU Emacs, part II [calc-rewr.el]
-;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
-;; Written by Dave Gillespie, daveg@synaptics.com.
+;;; calc-rewr.el --- rewriting functions for Calc
+
+;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
+
+;; Author: David Gillespie <daveg@synaptics.com>
+;; Maintainer: Colin Walters <walters@debian.org>
;; This file is part of GNU Emacs.
;; file named COPYING. Among other things, the copyright notice
;; and this notice must be preserved on all copies.
+;;; Commentary:
+;;; Code:
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
(defun calc-Need-calc-rewr () nil)
+(defvar math-rewrite-default-iters 100)
(defun calc-rewrite-selection (rules-str &optional many prefix)
(interactive "sRewrite rule(s): \np")
(calc-slow-wrapper
(math-rewrite-default-iters 1))
(if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
(if (= num 1)
- (error "Can't use same stack entry for formula and rules.")
+ (error "Can't use same stack entry for formula and rules")
(setq rules (calc-top-n 1 t)
pop-rules t))
(setq rules (if (stringp rules-str)
(calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
(- num (if pop-rules 1 0))
(list (and reselect sel))))
- (calc-handle-whys))
-)
+ (calc-handle-whys)))
(defun calc-locate-select-marker (expr) ; changes "sel"
(if (Math-primp expr)
(setq sel (if sel t (nth 1 expr)))
(nth 1 expr))
(cons (car expr)
- (mapcar 'calc-locate-select-marker (cdr expr)))))
-)
+ (mapcar 'calc-locate-select-marker (cdr expr))))))
(let (sel)
(setq expr (calc-locate-select-marker expr)))
(calc-pop-push-record-list n "rwrt" (list expr)))
- (calc-handle-whys))
-)
+ (calc-handle-whys)))
(defun calc-match (pat)
(interactive "sPattern: \n")
(or (math-vectorp expr) (error "Argument must be a vector"))
(if (calc-is-inverse)
(calc-enter-result n "mtcn" (math-match-patterns pat expr t))
- (calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))
-)
+ (calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))
(insert "\nDone rewriting"
(if (= mmt-many 0) " (reached iteration limit)" "")
":\n" fmt "\n"))))
- whole-expr)
-)
-(setq math-rewrite-default-iters 100)
+ whole-expr))
(defun math-rewrite-phase (sched)
(while (and sched (/= mmt-many 0))
(setq whole-expr (math-normalize
(math-map-tree-rec whole-expr)))
(not (equal whole-expr save-expr)))))))
- (setq sched (cdr sched)))
-)
+ (setq sched (cdr sched))))
(defun calcFunc-rewrite (expr rules &optional many)
(or (null many) (integerp many)
(math-reject-arg many 'fixnump))
(condition-case err
(math-rewrite expr rules (or many 1))
- (error (math-reject-arg rules (nth 1 err))))
-)
+ (error (math-reject-arg rules (nth 1 err)))))
(defun calcFunc-match (pat vec)
(or (math-vectorp vec) (math-reject-arg vec 'vectorp))
(condition-case err
(math-match-patterns pat vec nil)
- (error (math-reject-arg pat (nth 1 err))))
-)
+ (error (math-reject-arg pat (nth 1 err)))))
(defun calcFunc-matchnot (pat vec)
(or (math-vectorp vec) (math-reject-arg vec 'vectorp))
(condition-case err
(math-match-patterns pat vec t)
- (error (math-reject-arg pat (nth 1 err))))
-)
+ (error (math-reject-arg pat (nth 1 err)))))
(defun math-match-patterns (pat vec &optional not-flag)
(let ((newvec nil)
(if (eq (not (math-apply-rewrites (car vec) crules))
not-flag)
(setq newvec (cons (car vec) newvec))))
- (cons 'vec (nreverse newvec)))
-)
+ (cons 'vec (nreverse newvec))))
(defun calcFunc-matches (expr pat)
(condition-case err
(if (math-apply-rewrites expr (math-compile-patterns pat))
1
0)
- (error (math-reject-arg pat (nth 1 err))))
-)
+ (error (math-reject-arg pat (nth 1 err)))))
(defun calcFunc-vmatches (expr pat)
(condition-case err
(or (math-apply-rewrites expr (math-compile-patterns pat))
0)
- (error (math-reject-arg pat (nth 1 err))))
-)
+ (error (math-reject-arg pat (nth 1 err)))))
(list 'vec x t)))
(if (eq (car-safe pats) 'vec)
(cdr pats)
- (list pats))))))))
-)
-(setq math-rewrite-whole nil)
-(setq math-make-import-list nil)
+ (list pats)))))))))
+(defvar math-rewrite-whole nil)
+(defvar math-make-import-list nil)
(defun math-compile-rewrites (rules &optional name)
(if (eq (car-safe rules) 'var)
(let ((prop (get (nth 2 rules) 'math-rewrite-cache))
(or math-schedule
(sort math-all-phases '<)
(list 1)))
- rule-set)))
-)
+ rule-set))))
(defun math-flatten-lands (expr)
(if (eq (car-safe expr) 'calcFunc-land)
(append (math-flatten-lands (nth 1 expr))
(math-flatten-lands (nth 2 expr)))
- (list expr))
-)
+ (list expr)))
(defun math-rewrite-heads (expr &optional more all)
(let ((heads more)
calcFunc-pand))))
(or (Math-primp expr)
(math-rewrite-heads-rec expr))
- heads)
-)
+ heads))
(defun math-rewrite-heads-rec (expr)
(or (memq (car expr) skips)
(setq heads (cons (car expr) heads)))
(while (setq expr (cdr expr))
(or (Math-primp (car expr))
- (math-rewrite-heads-rec (car expr))))))
-)
+ (math-rewrite-heads-rec (car expr)))))))
(defun math-parse-schedule (sched)
(mapcar (function
(if (eq (car-safe s) 'var)
(math-var-to-calcFunc s)
(error "Improper component in rewrite schedule"))))))
- sched)
-)
+ sched))
(defun math-rwcomp-match-vars (expr)
(if (Math-primp expr)
(cons (car (nth 1 expr))
(mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
(cons (car expr)
- (mapcar 'math-rwcomp-match-vars (cdr expr))))))
-)
+ (mapcar 'math-rwcomp-match-vars (cdr expr)))))))
(defun math-rwcomp-register-expr (num)
(let ((entry (nth (1- (- math-num-regs num)) math-regs)))
(if (nth 2 entry)
(list 'neg (list 'calcFunc-register (nth 1 entry)))
- (list 'calcFunc-register (nth 1 entry))))
-)
+ (list 'calcFunc-register (nth 1 entry)))))
(defun math-rwcomp-substitute (expr old new)
(if (and (eq (car-safe old) 'var)
(new-func (math-var-to-calcFunc new)))
(math-rwcomp-subst-rec expr))
(let ((old-func nil))
- (math-rwcomp-subst-rec expr)))
-)
+ (math-rwcomp-subst-rec expr))))
(defun math-rwcomp-subst-rec (expr)
(cond ((equal expr old) new)
(math-build-call new-func (mapcar 'math-rwcomp-subst-rec
(cdr expr)))
(cons (car expr)
- (mapcar 'math-rwcomp-subst-rec (cdr expr))))))
-)
+ (mapcar 'math-rwcomp-subst-rec (cdr expr)))))))
-(setq math-rwcomp-tracing nil)
+(defvar math-rwcomp-tracing nil)
(defun math-rwcomp-trace (instr)
- (if math-rwcomp-tracing (progn (terpri) (princ instr)))
- instr
-)
+ (when math-rwcomp-tracing
+ (terpri) (princ instr))
+ instr)
(defun math-rwcomp-instr (&rest instr)
(setcdr math-prog-last
- (setq math-prog-last (list (math-rwcomp-trace instr))))
-)
+ (setq math-prog-last (list (math-rwcomp-trace instr)))))
(defun math-rwcomp-multi-instr (tail &rest instr)
(setcdr math-prog-last
- (setq math-prog-last (list (math-rwcomp-trace (append instr tail)))))
-)
+ (setq math-prog-last (list (math-rwcomp-trace (append instr tail))))))
(defun math-rwcomp-bind-var (reg var)
(setcar (math-rwcomp-reg-entry reg) (nth 2 var))
(setq math-bound-vars (cons (nth 2 var) math-bound-vars))
- (math-rwcomp-do-conditions)
-)
+ (math-rwcomp-do-conditions))
(defun math-rwcomp-unbind-vars (mark)
(while (not (eq math-bound-vars mark))
(setcar (assq (car math-bound-vars) math-regs) nil)
- (setq math-bound-vars (cdr math-bound-vars)))
-)
+ (setq math-bound-vars (cdr math-bound-vars))))
(defun math-rwcomp-do-conditions ()
(let ((cond math-conds))
(setq math-conds (delq (car cond) math-conds))
(setcar cond 1)
(math-rwcomp-cond-instr expr)))
- (setq cond (cdr cond))))
-)
+ (setq cond (cdr cond)))))
(defun math-rwcomp-cond-instr (expr)
(let (op arg)
(list 'calcFunc-lor
math-remembering (nth 1 expr))
(nth 1 expr))))
- (t (math-rwcomp-instr 'cond expr))))
-)
+ (t (math-rwcomp-instr 'cond expr)))))
(defun math-rwcomp-same-instr (reg1 reg2 neg)
(math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
neg)
'same-neg
'same)
- reg1 reg2)
-)
+ reg1 reg2))
(defun math-rwcomp-copy-instr (reg1 reg2 neg)
(if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
neg)
(math-rwcomp-instr 'copy-neg reg1 reg2)
(or (eq reg1 reg2)
- (math-rwcomp-instr 'copy reg1 reg2)))
-)
+ (math-rwcomp-instr 'copy reg1 reg2))))
(defun math-rwcomp-reg ()
(prog1
math-num-regs
(setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
- math-num-regs (1+ math-num-regs)))
-)
+ math-num-regs (1+ math-num-regs))))
(defun math-rwcomp-reg-entry (num)
- (nth (1- (- math-num-regs num)) math-regs)
-)
+ (nth (1- (- math-num-regs num)) math-regs))
(defun math-rwcomp-pattern (expr part &optional not-direct)
(while args
(math-rwcomp-pattern (car (car args)) (cdr (car args)))
(setq num (1+ num)
- args (cdr args)))))))))
-)
+ args (cdr args))))))))))
(defun math-rwcomp-best-reg (x)
(or (and (eq (car-safe x) 'var)
(progn
(setcar (cdr (cdr entry)) t)
(nth 1 entry)))))
- (math-rwcomp-reg))
-)
+ (math-rwcomp-reg)))
(defun math-rwcomp-all-regs-done (expr)
(if (Math-primp expr)
(math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
(while (and (setq expr (cdr expr))
(math-rwcomp-all-regs-done (car expr))))
- (null expr))))
-)
+ (null expr)))))
(defun math-rwcomp-no-vars (expr)
(if (Math-primp expr)
(progn
(while (and (setq expr (cdr expr))
(math-rwcomp-no-vars (car expr))))
- (null expr))))
-)
+ (null expr)))))
(defun math-rwcomp-is-algebraic (expr)
(if (Math-primp expr)
(progn
(while (and (setq expr (cdr expr))
(math-rwcomp-is-algebraic (car expr))))
- (null expr))))
-)
+ (null expr)))))
(defun math-rwcomp-is-constrained (expr not-these)
(if (Math-primp expr)
(memq (car expr) not-these)
(and (memq 'commut (get (car expr) 'math-rewrite-props))
(or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
- (eq (car-safe (nth 2 expr)) 'calcFunc-opt)))))))
-)
+ (eq (car-safe (nth 2 expr)) 'calcFunc-opt))))))))
(defun math-rwcomp-optional-arg (head argp)
(let ((arg (car argp)))
(partp (math-rwcomp-optional-arg head part)))
(and partp
(setcar argp (math-rwcomp-neg (car part)))
- (math-neg partp))))))
-)
+ (math-neg partp)))))))
(defun math-rwcomp-neg (expr)
(if (memq (car-safe expr) '(* /))
(if (eq (car-safe (nth 2 expr)) 'var)
(list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
(math-neg expr)))
- (math-neg expr))
-)
+ (math-neg expr)))
(defun math-rwcomp-assoc-args (expr)
(if (and (eq (car-safe (nth 1 expr)) (car expr))
(if (and (eq (car-safe (nth 2 expr)) (car expr))
(= (length (nth 2 expr)) 3))
(math-rwcomp-assoc-args (nth 2 expr))
- (setq math-args (cons (nth 2 expr) math-args)))
-)
+ (setq math-args (cons (nth 2 expr) math-args))))
(defun math-rwcomp-addsub-args (expr)
(if (memq (car-safe (nth 1 expr)) '(+ -))
(setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args))
(if (eq (car-safe (nth 2 expr)) '+)
(math-rwcomp-addsub-args (nth 2 expr))
- (setq math-args (cons (nth 2 expr) math-args))))
-)
+ (setq math-args (cons (nth 2 expr) math-args)))))
(defun math-rwcomp-order (a b)
(< (math-rwcomp-priority (car a))
- (math-rwcomp-priority (car b)))
-)
+ (math-rwcomp-priority (car b))))
;;; Order of priority: 0 Constants and other exact matches (first)
;;; 10 Functions (except below)
40
(if (memq 'algebraic props)
30
- 10))))))
-)
+ 10)))))))
(defun math-rwcomp-count-refs (var)
(let ((count (or (math-expr-contains-count math-pattern var) 0))
(or (math-expr-contains-count
(nth 2 (nth 1 (car p))) var) 0))))))
(setq p (cdr p)))
- count)
-)
+ count))
(defun math-rwcomp-count-pnots (expr)
(if (Math-primp expr)
(let ((count 0))
(while (setq expr (cdr expr))
(setq count (+ count (math-rwcomp-count-pnots (car expr)))))
- count)))
-)
+ count))))
;;; In the current implementation, all associative functions must
;;; also be commutative.
(if back
'(setq btrack (cdr btrack))
'btrack)
- ''((backtrack))))
-)
+ ''((backtrack)))))
;;; This monstrosity is necessary because the use of static vectors of
;;; registers makes rewrite rules non-reentrant. Yucko!
'(setcar rules (quote (nil nil nil no-phase)))
(list 'unwind-protect
form
- '(setcar rules orig)))
-)
+ '(setcar rules orig))))
(setq math-rewrite-phase 1)
(t (error "%s is not a valid rewrite opcode" op))))))
(setq rules (cdr rules)))
- result))
-)
+ result)))
(defun math-rwapply-neg (expr)
(if (and (consp expr)
(math-neg (nth 1 expr))
(list '* -1 (nth 1 expr)))
(nth 2 expr)))
- (math-neg expr))
-)
+ (math-neg expr)))
(defun math-rwapply-inv (expr)
(if (and (Math-integerp expr)
calc-prefer-frac)
(math-make-frac 1 expr)
- (list '/ 1 expr))
-)
+ (list '/ 1 expr)))
(defun math-rwapply-replace-regs (expr)
(cond ((Math-primp expr)
(aref regs (nth 1 (nth 1 expr)))
(cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
(cdr (nth 1 expr)))))))
- (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr)))))
-)
+ (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))))
(defun math-rwapply-reg-looks-negp (expr)
(if (eq (car-safe expr) 'calcFunc-register)
(math-looks-negp (aref regs (nth 1 expr)))
(if (memq (car-safe expr) '(* /))
(or (math-rwapply-reg-looks-negp (nth 1 expr))
- (math-rwapply-reg-looks-negp (nth 2 expr)))))
-)
+ (math-rwapply-reg-looks-negp (nth 2 expr))))))
(defun math-rwapply-reg-neg (expr) ; expr must satisfy rwapply-reg-looks-negp
(if (eq (car expr) 'calcFunc-register)
(nth 2 expr)))
(math-rwapply-replace-regs (list (car expr)
(nth 1 expr)
- (math-rwapply-reg-neg (nth 2 expr))))))
-)
+ (math-rwapply-reg-neg (nth 2 expr)))))))
(defun math-rwapply-remember (old new)
(let ((varval (symbol-value (nth 2 (car ruleset))))
(list (list 'same 0 1)
(list 'done new nil))
nil nil)
- (cdr rules))))))
-)
-
-
-
+ (cdr rules)))))))
+;;; calc-rewr.el ends here