comparison lisp/calc/calc-rewr.el @ 105792:2c12fbae77c2

* calc/calc.el (calc, calc-refresh, calc-trail-buffer, calc-record) (calcDigit-nondigit): * calc/calc-yank.el (calc-copy-to-buffer): * calc/calc-units.el (calc-invalidate-units-table): * calc/calc-trail.el (calc-trail-yank): * calc/calc-store.el (calc-insert-variables): * calc/calc-rewr.el (math-rewrite, math-rewrite-phase): * calc/calc-prog.el (calc-read-parse-table): * calc/calc-keypd.el (calc-do-keypad, calc-keypad-right-click): * calc/calc-help.el (calc-describe-bindings, calc-describe-key): * calc/calc-graph.el (calc-graph-delete, calc-graph-add-curve) (calc-graph-juggle, calc-graph-count-curves, calc-graph-plot) (calc-graph-plot, calc-graph-format-data, calc-graph-set-styles) (calc-graph-name, calc-graph-find-command, calc-graph-view) (calc-graph-view, calc-gnuplot-command, calc-graph-init): * calc/calc-ext.el (calc-realign): * calc/calc-embed.el (calc-do-embedded, calc-do-embedded) (calc-embedded-finish-edit, calc-embedded-make-info) (calc-embedded-finish-command, calc-embedded-stack-change): * calc/calc-aent.el (calcAlg-enter): Use with-current-buffer.

105791:84d7bc7104ac

                            (if result
                                (progn
                                  (if trace-buffer
                                      (let ((fmt (math-format-stack-value
                                                  (list result nil nil))))
                                        (save-excursion
                                          (set-buffer trace-buffer)
                                          (insert "\nrewrite to\n" fmt "\n"))))
                                  (setq heads (math-rewrite-heads result heads t))))
                            result)))))
    (if trace-buffer
	(let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
	  (save-excursion
	    (set-buffer trace-buffer)
	    (setq truncate-lines t)
	    (goto-char (point-max))
	    (insert "\n\nBegin rewriting\n" fmt "\n"))))
    (or math-mt-many (setq math-mt-many (or (nth 1 (car crules))
				    math-rewrite-default-iters)))
    (if (equal math-mt-many '(var inf var-inf)) (setq math-mt-many 1000000))
    (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000))
    (math-rewrite-phase (nth 3 (car crules)))
    (if trace-buffer
	(let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
	  (save-excursion
	    (set-buffer trace-buffer)
	    (insert "\nDone rewriting"
		    (if (= math-mt-many 0) " (reached iteration limit)" "")
		    ":\n" fmt "\n"))))
    math-rewrite-whole-expr))

	    (setq math-rewrite-whole-expr 
                  (math-normalize (list (car sched) math-rewrite-whole-expr)))
	    (if trace-buffer
		(let ((fmt (math-format-stack-value
			    (list math-rewrite-whole-expr nil nil))))
		  (save-excursion
		    (set-buffer trace-buffer)
		    (insert "\ncall "
			    (substring (symbol-name (car sched)) 9)
			    ":\n" fmt "\n")))))
	(let ((math-rewrite-phase (car sched)))
	  (if trace-buffer
	      (save-excursion
		(set-buffer trace-buffer)
		(insert (format "\n(Phase %d)\n" math-rewrite-phase))))
	  (while (let ((save-expr math-rewrite-whole-expr))
		   (setq math-rewrite-whole-expr (math-normalize
				     (math-map-tree-rec math-rewrite-whole-expr)))
		   (not (equal math-rewrite-whole-expr save-expr)))))))

	  0)
    (error (math-reject-arg pat (nth 1 err)))))



;;; A compiled rule set is an a-list of entries whose cars are functors,
;;; and whose cdrs are lists of rules.  If there are rules with no
;;; well-defined head functor, they are included on all lists and also
;;; on an extra list whose car is nil.
;;;
;;; The first entry in the a-list is of the form (schedule A B C ...).
;;;
;;; Rule list entries take the form (regs prog head phases), where:
;;;
;;;   regs   is a vector of match registers.
;;;
;;;   prog   is a match program (see below).
;;;
;;;   head   is a rare function name appearing in the rule body (but not the
;;;	     head of the whole rule), or nil if none.
;;;
;;;   phases is a list of phase numbers for which the rule is enabled.
;;;
;;; A match program is a list of match instructions.
;;;
;;; In the following, "part" is a register number that contains the
;;; subexpression to be operated on.
;;;
;;; Register 0 is the whole expression being matched.  The others are
;;; meta-variables in the pattern, temporaries used for matching and
;;; backtracking, and constant expressions.
;;;
;;; (same part reg)
;;;         The selected part must be math-equal to the contents of "reg".
;;;
;;; (same-neg part reg)
;;;         The selected part must be math-equal to the negative of "reg".
;;;
;;; (copy part reg)
;;;	    The selected part is copied into "reg".  (Rarely used.)
;;;
;;; (copy-neg part reg)
;;;	    The negative of the selected part is copied into "reg".
;;;
;;; (integer part)
;;;         The selected part must be an integer.
;;;
;;; (real part)
;;;         The selected part must be a real.
;;;
;;; (constant part)
;;;         The selected part must be a constant.
;;;
;;; (negative part)
;;;	    The selected part must "look" negative.
;;;
;;; (rel part op reg)
;;;         The selected part must satisfy "part op reg", where "op"
;;;	    is one of the 6 relational ops, and "reg" is a register.
;;;
;;; (mod part modulo value)
;;;         The selected part must satisfy "part % modulo = value", where
;;;         "modulo" and "value" are constants.
;;;
;;; (func part head reg1 reg2 ... regn)
;;;         The selected part must be an n-ary call to function "head".
;;;         The arguments are stored in "reg1" through "regn".
;;;
;;; (func-def part head defs reg1 reg2 ... regn)
;;;	    The selected part must be an n-ary call to function "head".
;;;	    "Defs" is a list of value/register number pairs for default args.
;;;	    If a match, assign default values to registers and then skip
;;;	    immediately over any following "func-def" instructions and
;;;	    the following "func" instruction.  If wrong number of arguments,
;;;	    proceed to the following "func-def" or "func" instruction.
;;;
;;; (func-opt part head defs reg1)
;;;	    Like func-def with "n=1", except that if the selected part is
;;;	    not a call to "head", then the part itself successfully matches
;;;	    "reg1" (and the defaults are assigned).
;;;
;;; (try part heads mark reg1 [def])
;;;         The selected part must be a function of the correct type which is
;;;         associative and/or commutative.  "Heads" is a list of acceptable
;;;         types.  An initial assignment of arguments to "reg1" is tried.
;;;	    If the program later fails, it backtracks to this instruction
;;;	    and tries other assignments of arguments to "reg1".
;;;	    If "def" exists and normal matching fails, backtrack and assign
;;;	    "part" to "reg1", and "def" to "reg2" in the following "try2".
;;;	    The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
;;;	    "mark[0]" points to the argument list; "mark[1]" points to the
;;;	    current argument; "mark[2]" is 0 if there are two arguments,
;;;	    1 if reg1 is matching single arguments, 2 if reg2 is matching
;;;	    single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
;;;         3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
;;;	    have two arguments, 1 if phase-2 can be skipped, 2 if full
;;;	    backtracking is necessary; "mark[4]" is t if the arguments have
;;;	    been switched from the order given in the original pattern.
;;;
;;; (try2 try reg2)
;;;         Every "try" will be followed by a "try2" whose "try" field is
;;;	    a pointer to the corresponding "try".  The arguments which were
;;;	    not stored in "reg1" by that "try" are now stored in "reg2".
;;;
;;; (alt instr nil mark)
;;;	    Basic backtracking.  Execute the instruction sequence "instr".
;;;	    If this fails, back up and execute following the "alt" instruction.
;;;	    The "mark" must be the vector "[nil nil 4]".  The "instr" sequence
;;;	    should execute "end-alt" at the end.
;;;
;;; (end-alt ptr)
;;; 	    Register success of the first alternative of a previous "alt".
;;;	    "Ptr" is a pointer to the next instruction following that "alt".
;;;
;;; (apply part reg1 reg2)
;;;         The selected part must be a function call.  The functor
;;;	    (as a variable name) is stored in "reg1"; the arguments
;;;	    (as a vector) are stored in "reg2".
;;;
;;; (cons part reg1 reg2)
;;;	    The selected part must be a nonempty vector.  The first element
;;;	    of the vector is stored in "reg1"; the rest of the vector
;;;	    (as another vector) is stored in "reg2".
;;;
;;; (rcons part reg1 reg2)
;;;	    The selected part must be a nonempty vector.  The last element
;;;	    of the vector is stored in "reg2"; the rest of the vector
;;;	    (as another vector) is stored in "reg1".
;;;
;;; (select part reg)
;;;         If the selected part is a unary call to function "select", its
;;;         argument is stored in "reg"; otherwise (provided this is an `a r'
;;;         and not a `g r' command) the selected part is stored in "reg".
;;;
;;; (cond expr)
;;;         The "expr", with registers substituted, must simplify to
;;;         a non-zero value.
;;;
;;; (let reg expr)
;;;         Evaluate "expr" and store the result in "reg".  Always succeeds.
;;;
;;; (done rhs remember)
;;;         Rewrite the expression to "rhs", with register substituted.
;;;	    Normalize; if the result is different from the original
;;;	    expression, the match has succeeded.  This is the last
;;;	    instruction of every program.  If "remember" is non-nil,
;;;         record the result of the match as a new literal rule.


;;; Pseudo-functions related to rewrites:
;;;
;;;  In patterns:  quote, plain, condition, opt, apply, cons, select
;;;
;;;  In righthand sides:  quote, plain, eval, evalsimp, evalextsimp,
;;;                       apply, cons, select
;;;
;;;  In conditions:  let + same as for righthand sides

;;; Some optimizations that would be nice to have:
;;;
;;;  * Merge registers with disjoint lifetimes.
;;;  * Merge constant registers with equivalent values.
;;;
;;;  * If an argument of a commutative op math-depends neither on the
;;;    rest of the pattern nor on any of the conditions, then no backtracking
;;;    should be done for that argument.  (This won't apply to very many
;;;    cases.)
;;;
;;;  * If top functor is "select", and its argument is a unique function,
;;;    add the rule to the lists for both "select" and that function.
;;;    (Currently rules like this go on the "nil" list.)
;;;    Same for "func-opt" functions.  (Though not urgent for these.)
;;;
;;;  * Shouldn't evaluate a "let" condition until the end, or until it
;;;    would enable another condition to be evaluated.
;;;

;;; Some additional features to add / things to think about:
;;;
;;;  * Figure out what happens to "a +/- b" and "a +/- opt(b)".
;;;
;;;  * Same for interval forms.
;;;

(defun math-rwcomp-order (a b)
  (< (math-rwcomp-priority (car a))
     (math-rwcomp-priority (car b))))

;;; Order of priority:    0 Constants and other exact matches (first)
;;;                      10 Functions (except below)
;;;			 20 Meta-variables which occur more than once
;;;			 30 Algebraic functions
;;;			 40 Commutative/associative functions
;;;			 50 Meta-variables which occur only once
;;;		       +100 for every "!!!" (pnot) in the pattern
;;;		      10000 Optional arguments (last)

(defun math-rwcomp-priority (expr)
  (+ (math-rwcomp-count-pnots expr)
     (cond ((eq (car-safe expr) 'calcFunc-opt)
	    10000)

      (let ((count 0))
	(while (setq expr (cdr expr))
	  (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
	count))))

;;; In the current implementation, all associative functions must
;;; also be commutative.

(put '+		     'math-rewrite-props '(algebraic assoc commut))
(put '-		     'math-rewrite-props '(algebraic assoc commut)) ; see below
(put '*		     'math-rewrite-props '(algebraic assoc commut)) ; see below
(put '/		     'math-rewrite-props '(algebraic unary1))

(put 'calcFunc-min   'math-rewrite-props '(algebraic assoc commut))
(put 'calcFunc-vunion 'math-rewrite-props '(assoc commut))
(put 'calcFunc-vint  'math-rewrite-props '(assoc commut))
(put 'calcFunc-vxor  'math-rewrite-props '(assoc commut))

;;; Note: "*" is not commutative for matrix args, but we pretend it is.
;;; Also, "-" is not commutative but the code tweaks things so that it is.

(put '+		     'math-rewrite-default  0)
(put '-		     'math-rewrite-default  0)
(put '*		     'math-rewrite-default  1)
(put '/		     'math-rewrite-default  1)

	      (if back
		  '(setq btrack (cdr btrack))
		'btrack)
	      ''((backtrack)))))

;;; This monstrosity is necessary because the use of static vectors of
;;; registers makes rewrite rules non-reentrant.  Yucko!
(defmacro math-rweval (form)
  (list 'let '((orig (car rules)))
	'(setcar rules (quote (nil nil nil no-phase)))
	(list 'unwind-protect
	      form

105792:2c12fbae77c2

                            (if result
                                (progn
                                  (if trace-buffer
                                      (let ((fmt (math-format-stack-value
                                                  (list result nil nil))))
                                        (with-current-buffer trace-buffer
                                          (insert "\nrewrite to\n" fmt "\n"))))
                                  (setq heads (math-rewrite-heads result heads t))))
                            result)))))
    (if trace-buffer
	(let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
	  (with-current-buffer trace-buffer
	    (setq truncate-lines t)
	    (goto-char (point-max))
	    (insert "\n\nBegin rewriting\n" fmt "\n"))))
    (or math-mt-many (setq math-mt-many (or (nth 1 (car crules))
				    math-rewrite-default-iters)))
    (if (equal math-mt-many '(var inf var-inf)) (setq math-mt-many 1000000))
    (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000))
    (math-rewrite-phase (nth 3 (car crules)))
    (if trace-buffer
	(let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
	  (with-current-buffer trace-buffer
	    (insert "\nDone rewriting"
		    (if (= math-mt-many 0) " (reached iteration limit)" "")
		    ":\n" fmt "\n"))))
    math-rewrite-whole-expr))

	    (setq math-rewrite-whole-expr 
                  (math-normalize (list (car sched) math-rewrite-whole-expr)))
	    (if trace-buffer
		(let ((fmt (math-format-stack-value
			    (list math-rewrite-whole-expr nil nil))))
		  (with-current-buffer trace-buffer
		    (insert "\ncall "
			    (substring (symbol-name (car sched)) 9)
			    ":\n" fmt "\n")))))
	(let ((math-rewrite-phase (car sched)))
	  (if trace-buffer
	      (with-current-buffer trace-buffer
		(insert (format "\n(Phase %d)\n" math-rewrite-phase))))
	  (while (let ((save-expr math-rewrite-whole-expr))
		   (setq math-rewrite-whole-expr (math-normalize
				     (math-map-tree-rec math-rewrite-whole-expr)))
		   (not (equal math-rewrite-whole-expr save-expr)))))))

	  0)
    (error (math-reject-arg pat (nth 1 err)))))



;; A compiled rule set is an a-list of entries whose cars are functors,
;; and whose cdrs are lists of rules.  If there are rules with no
;; well-defined head functor, they are included on all lists and also
;; on an extra list whose car is nil.
;;
;; The first entry in the a-list is of the form (schedule A B C ...).
;;
;; Rule list entries take the form (regs prog head phases), where:
;;
;;   regs   is a vector of match registers.
;;
;;   prog   is a match program (see below).
;;
;;   head   is a rare function name appearing in the rule body (but not the
;;	     head of the whole rule), or nil if none.
;;
;;   phases is a list of phase numbers for which the rule is enabled.
;;
;; A match program is a list of match instructions.
;;
;; In the following, "part" is a register number that contains the
;; subexpression to be operated on.
;;
;; Register 0 is the whole expression being matched.  The others are
;; meta-variables in the pattern, temporaries used for matching and
;; backtracking, and constant expressions.
;;
;; (same part reg)
;;         The selected part must be math-equal to the contents of "reg".
;;
;; (same-neg part reg)
;;         The selected part must be math-equal to the negative of "reg".
;;
;; (copy part reg)
;;	    The selected part is copied into "reg".  (Rarely used.)
;;
;; (copy-neg part reg)
;;	    The negative of the selected part is copied into "reg".
;;
;; (integer part)
;;         The selected part must be an integer.
;;
;; (real part)
;;         The selected part must be a real.
;;
;; (constant part)
;;         The selected part must be a constant.
;;
;; (negative part)
;;	    The selected part must "look" negative.
;;
;; (rel part op reg)
;;         The selected part must satisfy "part op reg", where "op"
;;	    is one of the 6 relational ops, and "reg" is a register.
;;
;; (mod part modulo value)
;;         The selected part must satisfy "part % modulo = value", where
;;         "modulo" and "value" are constants.
;;
;; (func part head reg1 reg2 ... regn)
;;         The selected part must be an n-ary call to function "head".
;;         The arguments are stored in "reg1" through "regn".
;;
;; (func-def part head defs reg1 reg2 ... regn)
;;	    The selected part must be an n-ary call to function "head".
;;	    "Defs" is a list of value/register number pairs for default args.
;;	    If a match, assign default values to registers and then skip
;;	    immediately over any following "func-def" instructions and
;;	    the following "func" instruction.  If wrong number of arguments,
;;	    proceed to the following "func-def" or "func" instruction.
;;
;; (func-opt part head defs reg1)
;;	    Like func-def with "n=1", except that if the selected part is
;;	    not a call to "head", then the part itself successfully matches
;;	    "reg1" (and the defaults are assigned).
;;
;; (try part heads mark reg1 [def])
;;         The selected part must be a function of the correct type which is
;;         associative and/or commutative.  "Heads" is a list of acceptable
;;         types.  An initial assignment of arguments to "reg1" is tried.
;;	    If the program later fails, it backtracks to this instruction
;;	    and tries other assignments of arguments to "reg1".
;;	    If "def" exists and normal matching fails, backtrack and assign
;;	    "part" to "reg1", and "def" to "reg2" in the following "try2".
;;	    The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
;;	    "mark[0]" points to the argument list; "mark[1]" points to the
;;	    current argument; "mark[2]" is 0 if there are two arguments,
;;	    1 if reg1 is matching single arguments, 2 if reg2 is matching
;;	    single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
;;         3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
;;	    have two arguments, 1 if phase-2 can be skipped, 2 if full
;;	    backtracking is necessary; "mark[4]" is t if the arguments have
;;	    been switched from the order given in the original pattern.
;;
;; (try2 try reg2)
;;         Every "try" will be followed by a "try2" whose "try" field is
;;	    a pointer to the corresponding "try".  The arguments which were
;;	    not stored in "reg1" by that "try" are now stored in "reg2".
;;
;; (alt instr nil mark)
;;	    Basic backtracking.  Execute the instruction sequence "instr".
;;	    If this fails, back up and execute following the "alt" instruction.
;;	    The "mark" must be the vector "[nil nil 4]".  The "instr" sequence
;;	    should execute "end-alt" at the end.
;;
;; (end-alt ptr)
;; 	    Register success of the first alternative of a previous "alt".
;;	    "Ptr" is a pointer to the next instruction following that "alt".
;;
;; (apply part reg1 reg2)
;;         The selected part must be a function call.  The functor
;;	    (as a variable name) is stored in "reg1"; the arguments
;;	    (as a vector) are stored in "reg2".
;;
;; (cons part reg1 reg2)
;;	    The selected part must be a nonempty vector.  The first element
;;	    of the vector is stored in "reg1"; the rest of the vector
;;	    (as another vector) is stored in "reg2".
;;
;; (rcons part reg1 reg2)
;;	    The selected part must be a nonempty vector.  The last element
;;	    of the vector is stored in "reg2"; the rest of the vector
;;	    (as another vector) is stored in "reg1".
;;
;; (select part reg)
;;         If the selected part is a unary call to function "select", its
;;         argument is stored in "reg"; otherwise (provided this is an `a r'
;;         and not a `g r' command) the selected part is stored in "reg".
;;
;; (cond expr)
;;         The "expr", with registers substituted, must simplify to
;;         a non-zero value.
;;
;; (let reg expr)
;;         Evaluate "expr" and store the result in "reg".  Always succeeds.
;;
;; (done rhs remember)
;;         Rewrite the expression to "rhs", with register substituted.
;;	    Normalize; if the result is different from the original
;;	    expression, the match has succeeded.  This is the last
;;	    instruction of every program.  If "remember" is non-nil,
;;         record the result of the match as a new literal rule.


;; Pseudo-functions related to rewrites:
;;
;;  In patterns:  quote, plain, condition, opt, apply, cons, select
;;
;;  In righthand sides:  quote, plain, eval, evalsimp, evalextsimp,
;;                       apply, cons, select
;;
;;  In conditions:  let + same as for righthand sides

;; Some optimizations that would be nice to have:
;;
;;  * Merge registers with disjoint lifetimes.
;;  * Merge constant registers with equivalent values.
;;
;;  * If an argument of a commutative op math-depends neither on the
;;    rest of the pattern nor on any of the conditions, then no backtracking
;;    should be done for that argument.  (This won't apply to very many
;;    cases.)
;;
;;  * If top functor is "select", and its argument is a unique function,
;;    add the rule to the lists for both "select" and that function.
;;    (Currently rules like this go on the "nil" list.)
;;    Same for "func-opt" functions.  (Though not urgent for these.)
;;
;;  * Shouldn't evaluate a "let" condition until the end, or until it
;;    would enable another condition to be evaluated.
;;

;; Some additional features to add / things to think about:
;;;
;;;  * Figure out what happens to "a +/- b" and "a +/- opt(b)".
;;;
;;;  * Same for interval forms.
;;;

(defun math-rwcomp-order (a b)
  (< (math-rwcomp-priority (car a))
     (math-rwcomp-priority (car b))))

;; Order of priority:    0 Constants and other exact matches (first)
;;			 10 Functions (except below)
;;			 20 Meta-variables which occur more than once
;;			 30 Algebraic functions
;;			 40 Commutative/associative functions
;;			 50 Meta-variables which occur only once
;;		       +100 for every "!!!" (pnot) in the pattern
;;		      10000 Optional arguments (last)

(defun math-rwcomp-priority (expr)
  (+ (math-rwcomp-count-pnots expr)
     (cond ((eq (car-safe expr) 'calcFunc-opt)
	    10000)

      (let ((count 0))
	(while (setq expr (cdr expr))
	  (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
	count))))

;; In the current implementation, all associative functions must
;; also be commutative.

(put '+		     'math-rewrite-props '(algebraic assoc commut))
(put '-		     'math-rewrite-props '(algebraic assoc commut)) ; see below
(put '*		     'math-rewrite-props '(algebraic assoc commut)) ; see below
(put '/		     'math-rewrite-props '(algebraic unary1))

(put 'calcFunc-min   'math-rewrite-props '(algebraic assoc commut))
(put 'calcFunc-vunion 'math-rewrite-props '(assoc commut))
(put 'calcFunc-vint  'math-rewrite-props '(assoc commut))
(put 'calcFunc-vxor  'math-rewrite-props '(assoc commut))

;; Note: "*" is not commutative for matrix args, but we pretend it is.
;; Also, "-" is not commutative but the code tweaks things so that it is.

(put '+		     'math-rewrite-default  0)
(put '-		     'math-rewrite-default  0)
(put '*		     'math-rewrite-default  1)
(put '/		     'math-rewrite-default  1)

	      (if back
		  '(setq btrack (cdr btrack))
		'btrack)
	      ''((backtrack)))))

;; This monstrosity is necessary because the use of static vectors of
;; registers makes rewrite rules non-reentrant.  Yucko!
(defmacro math-rweval (form)
  (list 'let '((orig (car rules)))
	'(setcar rules (quote (nil nil nil no-phase)))
	(list 'unwind-protect
	      form