Function: math-apply-rewrites

math-apply-rewrites is an autoloaded and byte-compiled function defined in calc-rewr.el.gz.

Signature

(math-apply-rewrites EXPR RULES &optional HEADS APPLY-RW-RULESET)

Source Code

;; Defined in /usr/src/emacs/lisp/calc/calc-rewr.el.gz
(defun math-apply-rewrites (expr rules &optional heads apply-rw-ruleset)
  (and
   (setq rules (cdr (or (assq (car-safe expr) rules)
			(assq nil rules))))
   (let ((math-apply-rw-ruleset apply-rw-ruleset)
	 (result nil)
	 op math-apply-rw-regs inst part pc mark btrack
	 (tracing math-rwcomp-tracing)
	 (phase math-rewrite-phase))
     (while rules
       (or
	(and (setq part (nth 2 (car rules)))
	     heads
	     (not (memq part heads)))
	(and (setq part (nth 3 (car rules)))
	     (not (memq phase part)))
	(progn
	  (setq math-apply-rw-regs (car (car rules))
		pc (nth 1 (car rules))
		btrack nil)
	  (aset math-apply-rw-regs 0 expr)
	  (while pc

	    (and tracing
		 (progn (terpri) (princ (car pc))
			(if (and (natnump (nth 1 (car pc)))
				 (< (nth 1 (car pc)) (length math-apply-rw-regs)))
			    (princ
                             (format "\n  part = %s"
                                     (aref math-apply-rw-regs (nth 1 (car pc))))))))

	    (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
		   (if (and (consp
                             (setq part (aref math-apply-rw-regs (car (cdr inst)))))
			    (eq (car part)
				(car (setq inst (cdr (cdr inst)))))
			    (progn
			      (while (and (setq inst (cdr inst)
						part (cdr part))
					  inst)
				(aset math-apply-rw-regs (car inst) (car part)))
			      (not (or inst part))))
		       (setq pc (cdr pc))
		     (math-rwfail)))

		  ((eq op 'same)
		   (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
				  (setq mark (aref math-apply-rw-regs (nth 2 inst))))
			   (Math-equal part mark))
		       (setq pc (cdr pc))
		     (math-rwfail)))

		  ((and (eq op 'try)
			calc-matrix-mode
			(not (eq calc-matrix-mode 'scalar))
			(eq (car (nth 2 inst)) '*)
			(consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
			(eq (car part) '*)
			(not (math-known-scalarp part)))
		   (setq mark (nth 3 inst)
			 pc (cdr pc))
		   (if (aref mark 4)
		       (progn
			 (aset math-apply-rw-regs (nth 4 inst) (nth 2 part))
			 (aset mark 1 (cdr (cdr part))))
		     (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
		     (aset mark 1 (cdr part)))
		   (aset mark 0 (cdr part))
		   (aset mark 2 0))

		  ((eq op 'try)
		   (if (and (consp (setq part
                                         (aref math-apply-rw-regs (car (cdr inst)))))
			    (memq (car part) (nth 2 inst))
			    (= (length part) 3)
			    (or (not (eq (car part) '/))
				(Math-objectp (nth 2 part))))
		       (progn
			 (setq op nil
			       mark (car (cdr (setq inst (cdr (cdr inst))))))
			 (and
			  (memq 'assoc (get (car part) 'math-rewrite-props))
			  (not (= (aref mark 3) 0))
			  (while (if (and (consp (nth 1 part))
					  (memq (car (nth 1 part)) (car inst)))
				     (setq op (cons (if (eq (car part) '-)
							(math-rwapply-neg
							 (nth 2 part))
						      (nth 2 part))
						    op)
					   part (nth 1 part))
				   (if (and (consp (nth 2 part))
					    (memq (car (nth 2 part))
						  (car inst))
					    (not (eq (car (nth 2 part)) '-)))
				       (setq op (cons (nth 1 part) op)
					     part (nth 2 part))))))
			 (setq op (cons (nth 1 part)
					(cons (if (eq (car part) '-)
						  (math-rwapply-neg
						   (nth 2 part))
						(if (eq (car part) '/)
						    (math-rwapply-inv
						     (nth 2 part))
						  (nth 2 part)))
					      op))
			       btrack (cons pc btrack)
			       pc (cdr pc))
			 (aset math-apply-rw-regs (nth 2 inst) (car op))
			 (aset mark 0 op)
			 (aset mark 1 op)
			 (aset mark 2 (if (cdr (cdr op)) 1 0)))
		     (if (nth 5 inst)
			 (if (and (consp part)
				  (eq (car part) 'neg)
				  (eq (car (nth 2 inst)) '*)
				  (eq (nth 5 inst) 1))
			     (progn
			       (setq mark (nth 3 inst)
				     pc (cdr pc))
			       (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
			       (aset mark 1 -1)
			       (aset mark 2 4))
			   (setq mark (nth 3 inst)
				 pc (cdr pc))
			   (aset math-apply-rw-regs (nth 4 inst) part)
			   (aset mark 2 3))
		       (math-rwfail))))

		  ((eq op 'try2)
		   (setq part (nth 1 inst)   ; try instr
			 mark (nth 3 part)
			 op (aref mark 2)
			 pc (cdr pc))
		   (aset math-apply-rw-regs (nth 2 inst)
			 (cond
			  ((eq op 0)
			   (if (eq (aref mark 0) (aref mark 1))
			       (nth 1 (aref mark 0))
			     (car (aref mark 0))))
			  ((eq op 1)
			   (setq mark (delq (car (aref mark 1))
					    (copy-sequence (aref mark 0)))
				 op (car (nth 2 part)))
			   (if (eq op '*)
			       (progn
				 (setq mark (nreverse mark)
				       part (list '* (nth 1 mark) (car mark))
				       mark (cdr mark))
				 (while (setq mark (cdr mark))
				   (setq part (list '* (car mark) part))))
			     (setq part (car mark)
				   mark (cdr mark)
				   part (if (and (eq op '+)
						 (consp (car mark))
						 (eq (car (car mark)) 'neg))
					    (list '- part
						  (nth 1 (car mark)))
					  (list op part (car mark))))
			     (while (setq mark (cdr mark))
			       (setq part (if (and (eq op '+)
						   (consp (car mark))
						   (eq (car (car mark)) 'neg))
					      (list '- part
						    (nth 1 (car mark)))
					    (list op part (car mark))))))
			   part)
			  ((eq op 2)
			   (car (aref mark 1)))
			  ((eq op 3) (nth 5 part))
			  (t (aref mark 1)))))

		  ((eq op 'select)
		   (setq pc (cdr pc))
		   (if (and (consp (setq part (aref math-apply-rw-regs (nth 1 inst))))
			    (eq (car part) 'calcFunc-select))
		       (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
		     (if math-rewrite-selections
			 (math-rwfail)
		       (aset math-apply-rw-regs (nth 2 inst) part))))

		  ((eq op 'same-neg)
		   (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
				  (setq mark (math-neg
					      (aref math-apply-rw-regs (nth 2 inst)))))
			   (Math-equal part mark))
		       (setq pc (cdr pc))
		     (math-rwfail)))

		  ((eq op 'backtrack)
		   (setq inst (car (car btrack))   ; "try" or "alt" instr
			 pc (cdr (car btrack))
			 mark (or (nth 3 inst) [nil nil 4])
			 op (aref mark 2))
		   (cond ((eq op 0)
			  (if (setq op (cdr (aref mark 1)))
			      (aset math-apply-rw-regs (nth 4 inst)
                                    (car (aset mark 1 op)))
			    (if (nth 5 inst)
				(progn
				  (aset mark 2 3)
				  (aset math-apply-rw-regs (nth 4 inst)
					(aref math-apply-rw-regs (nth 1 inst))))
			      (math-rwfail t))))
			 ((eq op 1)
			  (if (setq op (cdr (aref mark 1)))
			      (aset math-apply-rw-regs (nth 4 inst)
                                    (car (aset mark 1 op)))
			    (if (= (aref mark 3) 1)
				(if (nth 5 inst)
				    (progn
				      (aset mark 2 3)
				      (aset math-apply-rw-regs (nth 4 inst)
					    (aref math-apply-rw-regs (nth 1 inst))))
				  (math-rwfail t))
			      (aset mark 2 2)
			      (aset mark 1 (cons nil (aref mark 0)))
			      (math-rwfail))))
			 ((eq op 2)
			  (if (setq op (cdr (aref mark 1)))
			      (progn
				(setq mark (delq (car (aset mark 1 op))
						 (copy-sequence
						  (aref mark 0)))
				      op (car (nth 2 inst)))
				(if (eq op '*)
				    (progn
				      (setq mark (nreverse mark)
					    part (list '* (nth 1 mark)
						       (car mark))
					    mark (cdr mark))
				      (while (setq mark (cdr mark))
					(setq part (list '* (car mark)
							 part))))
				  (setq part (car mark)
					mark (cdr mark)
					part (if (and (eq op '+)
						      (consp (car mark))
						      (eq (car (car mark))
							  'neg))
						 (list '- part
						       (nth 1 (car mark)))
					       (list op part (car mark))))
				  (while (setq mark (cdr mark))
				    (setq part (if (and (eq op '+)
							(consp (car mark))
							(eq (car (car mark))
							    'neg))
						   (list '- part
							 (nth 1 (car mark)))
						 (list op part (car mark))))))
				(aset math-apply-rw-regs (nth 4 inst) part))
			    (if (nth 5 inst)
				(progn
				  (aset mark 2 3)
				  (aset math-apply-rw-regs (nth 4 inst)
					(aref math-apply-rw-regs (nth 1 inst))))
			      (math-rwfail t))))
			 ((eq op 4)
			  (setq btrack (cdr btrack)))
			 (t (math-rwfail t))))

		  ((eq op 'integer)
		   (if (Math-integerp (setq part
                                            (aref math-apply-rw-regs (nth 1 inst))))
		       (setq pc (cdr pc))
		     (if (Math-primp part)
			 (math-rwfail)
		       (setq part (math-rweval (math-simplify part)))
		       (if (Math-integerp part)
			   (setq pc (cdr pc))
			 (math-rwfail)))))

		  ((eq op 'real)
		   (if (Math-realp (setq part (aref math-apply-rw-regs (nth 1 inst))))
		       (setq pc (cdr pc))
		     (if (Math-primp part)
			 (math-rwfail)
		       (setq part (math-rweval (math-simplify part)))
		       (if (Math-realp part)
			   (setq pc (cdr pc))
			 (math-rwfail)))))

		  ((eq op 'constant)
		   (if (math-constp (setq part (aref math-apply-rw-regs (nth 1 inst))))
		       (setq pc (cdr pc))
		     (if (Math-primp part)
			 (math-rwfail)
		       (setq part (math-rweval (math-simplify part)))
		       (if (math-constp part)
			   (setq pc (cdr pc))
			 (math-rwfail)))))

		  ((eq op 'negative)
		   (if (math-looks-negp (setq part
                                              (aref math-apply-rw-regs (nth 1 inst))))
		       (setq pc (cdr pc))
		     (if (Math-primp part)
			 (math-rwfail)
		       (setq part (math-rweval (math-simplify part)))
		       (if (math-looks-negp part)
			   (setq pc (cdr pc))
			 (math-rwfail)))))

		  ((eq op 'rel)
		   (setq part (math-compare (aref math-apply-rw-regs (nth 1 inst))
					    (aref math-apply-rw-regs (nth 3 inst)))
			 op (nth 2 inst))
		   (if (= part 2)
		       (setq part (math-rweval
				   (math-simplify
				    (calcFunc-sign
				     (math-sub
                                      (aref math-apply-rw-regs (nth 1 inst))
                                      (aref math-apply-rw-regs (nth 3 inst))))))))
		   (if (cond ((eq op 'calcFunc-eq)
			      (eq part 0))
			     ((eq op 'calcFunc-neq)
			      (memq part '(-1 1)))
			     ((eq op 'calcFunc-lt)
			      (eq part -1))
			     ((eq op 'calcFunc-leq)
			      (memq part '(-1 0)))
			     ((eq op 'calcFunc-gt)
			      (eq part 1))
			     ((eq op 'calcFunc-geq)
			      (memq part '(0 1))))
		       (setq pc (cdr pc))
		     (math-rwfail)))

		  ((eq op 'func-def)
		   (if (and
                        (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
                        (eq (car part)
                            (car (setq inst (cdr (cdr inst))))))
		       (progn
			 (setq inst (cdr inst)
			       mark (car inst))
			 (while (and (setq inst (cdr inst)
					   part (cdr part))
				     inst)
			   (aset math-apply-rw-regs (car inst) (car part)))
			 (if (or inst part)
			     (setq pc (cdr pc))
			   (while (eq (car (car (setq pc (cdr pc))))
				      'func-def))
			   (setq pc (cdr pc))   ; skip over "func"
			   (while mark
			     (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
			     (setq mark (cdr mark)))))
		     (math-rwfail)))

		  ((eq op 'func-opt)
		   (if (or (not
                            (and
                             (consp
                              (setq part (aref math-apply-rw-regs (car (cdr inst)))))
                             (eq (car part) (nth 2 inst))))
			   (and (= (length part) 2)
				(setq part (nth 1 part))))
		       (progn
			 (setq mark (nth 3 inst))
			 (aset math-apply-rw-regs (nth 4 inst) part)
			 (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
			 (setq pc (cdr pc))   ; skip over "func"
			 (while mark
			   (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
			   (setq mark (cdr mark))))
		     (setq pc (cdr pc))))

		  ((eq op 'mod)
		   (if (if (Math-zerop
                            (setq part (aref math-apply-rw-regs (nth 1 inst))))
			   (Math-zerop (nth 3 inst))
			 (and (not (Math-zerop (nth 2 inst)))
			      (progn
				(setq part (math-mod part (nth 2 inst)))
				(or (Math-numberp part)
				    (setq part (math-rweval
						(math-simplify part))))
				(Math-equal part (nth 3 inst)))))
		       (setq pc (cdr pc))
		     (math-rwfail)))

		  ((eq op 'apply)
		   (if (and (consp
                             (setq part (aref math-apply-rw-regs (car (cdr inst)))))
			    (not (Math-objvecp part))
			    (not (eq (car part) 'var)))
		       (progn
			 (aset math-apply-rw-regs (nth 2 inst)
			       (math-calcFunc-to-var (car part)))
			 (aset math-apply-rw-regs (nth 3 inst)
			       (cons 'vec (cdr part)))
			 (setq pc (cdr pc)))
		     (math-rwfail)))

		  ((eq op 'cons)
		   (if (and (consp
                             (setq part (aref math-apply-rw-regs (car (cdr inst)))))
			    (eq (car part) 'vec)
			    (cdr part))
		       (progn
			 (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
			 (aset math-apply-rw-regs (nth 3 inst)
                               (cons 'vec (cdr (cdr part))))
			 (setq pc (cdr pc)))
		     (math-rwfail)))

		  ((eq op 'rcons)
		   (if (and (consp
                             (setq part (aref math-apply-rw-regs (car (cdr inst)))))
			    (eq (car part) 'vec)
			    (cdr part))
		       (progn
			 (aset math-apply-rw-regs (nth 2 inst) (calcFunc-rhead part))
			 (aset math-apply-rw-regs (nth 3 inst) (calcFunc-rtail part))
			 (setq pc (cdr pc)))
		     (math-rwfail)))

		  ((eq op 'cond)
		   (if (math-is-true
			(math-rweval
			 (math-simplify
			  (math-rwapply-replace-regs (nth 1 inst)))))
		       (setq pc (cdr pc))
		     (math-rwfail)))

		  ((eq op 'let)
		   (aset math-apply-rw-regs (nth 1 inst)
			 (math-rweval
			  (math-normalize
			   (math-rwapply-replace-regs (nth 2 inst)))))
		   (setq pc (cdr pc)))

		  ((eq op 'copy)
		   (aset math-apply-rw-regs (nth 2 inst)
                         (aref math-apply-rw-regs (nth 1 inst)))
		   (setq pc (cdr pc)))

		  ((eq op 'copy-neg)
		   (aset math-apply-rw-regs (nth 2 inst)
			 (math-rwapply-neg (aref math-apply-rw-regs (nth 1 inst))))
		   (setq pc (cdr pc)))

		  ((eq op 'alt)
		   (setq btrack (cons pc btrack)
			 pc (nth 1 inst)))

		  ((eq op 'end-alt)
		   (while (and btrack (not (eq (car btrack) (nth 1 inst))))
		     (setq btrack (cdr btrack)))
		   (setq btrack (cdr btrack)
			 pc (cdr pc)))

		  ((eq op 'done)
		   (setq result (math-rwapply-replace-regs (nth 1 inst)))
		   (if (or (and (eq (car-safe result) '+)
				(eq (nth 2 result) 0))
			   (and (eq (car-safe result) '*)
				(eq (nth 2 result) 1)))
		       (setq result (nth 1 result)))
		   (setq part (and (nth 2 inst)
				   (math-is-true
				    (math-rweval
				     (math-simplify
				      (math-rwapply-replace-regs
				       (nth 2 inst)))))))
		   (if (or (equal result expr)
			   (equal (setq result (math-normalize result)) expr))
		       (setq result nil)
		     (if part (math-rwapply-remember expr result))
		     (setq rules nil))
		   (setq pc nil))

		  (t (error "%s is not a valid rewrite opcode" op))))))
       (setq rules (cdr rules)))
     result)))