;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; manip-strategies -- Expression manipulation for PVS prover 
;; Author          : Ben Di Vito <b.l.divito@larc.nasa.gov>
;; Created On      : 8 Apr 2001
;; Last Modified By: 
;; Last Modified On: 31 Oct 2001 (v0.9)
;; Last Modified On: 14 Feb 2002 (v1.0)
;; Last Modified On: 27 Jan 2003 (v1.1)
;; Status          : Experimental
;; Version         : 1.1
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This is a U.S. Government work and thus not protected by U.S. copyright.
;; As a courtesy, please retain the header lines and introductory comments
;; in any derivative works.  Problem reports, suggestions and enhancements
;; are encouraged.  Send them to the address above.
;;
;; ----------------------------------------------------------------------------
;;
;; This file implements various PVS strategies (tactics) for manipulating
;; arithmetic expressions and performing other detailed proving.  It
;; includes strategies helpful for proving formulas containing nonlinear
;; arithmetic and similar expressions where PVS has limited automation.
;; Some strategies allow ordinary algebraic manipulation while others
;; are focused on more specialized reasoning for product terms.  Also
;; included are some more general strategies to manipulate sequents, such
;; as higher-order operations that accept parameterized commands and
;; perform substitutions to arrive at concrete command instances.
;;
;; A second feature set implements an extended method of specifying input
;; expressions when invoking prover commands.  Two major types of extensions
;; are included: location references and textual pattern matching.  Location
;; references allow a user to indicate a precise subexpression within a
;; formula by giving a path of indices to follow when descending through the
;; formula's expression tree.  Pattern matching allows strings to be found
;; and extracted using a specialized pattern language that is based on, but
;; much less elaborate than, regular expressions.
;;
;; This version of the package has been tested on PVS version 3.1.
;; It is not backward compatible with PVS versions 2.3 and 2.4; use
;; Manip version 1.0 for 2.3/2.4.
;;
;; =========================== End of preamble ================================


(defvar *manip-strategies-version* "1.1")


;;; ================== Top-level manipulation strategies ===================

;;  (swap lhs operator rhs &opt (infix? t)) ; x op y ==> y op x
;;  (swap! expr-loc)                        ; 
;;  (group term1 operator term2 term3       ; L: x op (y op z) ==> (x op y) op z
;;         &opt (side l) (infix? t))        ; R: (x op y) op z ==> x op (y op z)
;;  (group! expr-loc &opt (side l))         ;
;;  (swap-group term1 operator term2 term3  ; L: x op (y op z) ==> y op (x op z)
;;         &opt (side l) (infix? t))        ; R: (x op y) op z ==> (x op z) op y
;;  (swap-group! expr-loc &opt (side l))    ;
;;  (swap-rel &rest fnums)                  ; Swap sides and reverse relations
;;  (equate lhs rhs &opt (try-just nil))    ; ...lhs... ==> ...rhs...
;;  (has-sign term &opt                     ; Claims term has sign indicated
;;            (sign +) (try-just nil))      ;
;;  (mult-by fnums term &opt (sign +))      ; Multiply both sides by term
;;  (div-by  fnums term &opt (sign +))      ; Divide both sides by term
;;  (split-ineq fnum &opt (replace? nil))   ; Split <=,>= into <,> and = cases
;;  (flip-ineq fnums &opt (hide? t))        ; Negate and move inequalities
;;  (show-parens &opt (fnums *))            ; Show fully parenthesized formulas
;; -----------------------------------------------------------------------------
;;  (move-terms fnum side                   ; Move additive terms to other side
;;              &opt (term-nums *))
;;  (isolate fnum side term-num)            ; Move all but one term
;;  (isolate-replace fnum side term-num     ; Isolate then replace with equation
;;         &opt (targets *))
;;  (cancel &opt (fnums *) (sign nil))      ; Cancel terms from both sides
;;  (cancel-terms &opt (fnums *) (end l)    ; Cancel speculatively & defer proof
;;          (sign nil) (try-just nil))
;;  (op-ident fnum &opt                     ; Apply operator identity to
;;            (side l) (operation *1))      ;   rewrite expression
;;  (op-ident! expr-loc                     ;
;;             &opt (operation *1))
;;  (cross-mult &opt (fnums *))             ; Multiply both sides by denom
;;  (cross-add &opt (fnums *))              ; Add subtrahend to both sides
;;  (factor fnums &opt (side *)             ; Factor common multiplicative terms
;;          (term-nums *) (id? nil))        ;   from additive terms given
;;  (factor! expr-loc &opt                  ;
;;          (term-nums *) (id? nil))
;;  (transform-both fnum transform          ; Apply transform to both
;;     &opt (swap nil) (try-just nil))      ;   sides of formula
;; -----------------------------------------------------------------------------
;;  (permute-mult fnums &opt (side r)       ; Rearrange factors in a product
;;                (term-nums 2) (end l))
;;  (permute-mult! expr-loc &opt            ;
;;                 (term-nums 2) (end l))
;;  (name-mult name fnum side               ; Select factors, assign name to
;;        &opt (term-nums *))               ;   their product, then replace
;;  (name-mult! name expr-loc               ;
;;        &opt (term-nums *))
;;  (recip-mult fnums side)                 ; x / d ==> x * (1/d)
;;  (recip-mult! expr-loc)                  ;
;;  (isolate-mult fnum &opt (side l)        ; Select a factor and divide both
;;                (term-num 1) (sign +))    ;   both sides to isolate factor
;;  (mult-eq rel-fnum eq-fnum               ; Multiply sides of relation by
;;        &opt (sign +))                    ;   sides of equality
;;  (mult-ineq fnum1 fnum2                  ; Multiply sides of inequality by
;;        &opt (signs (+ +)))               ;   sides of another inequality
;;  (mult-cases fnum                        ; Generate case analysis for
;;        &opt (abs? nil) (mult-op *1))     ;   relation on product(s)
;;  (mult-extract name fnum &opt            ; Extract selected terms, name
;;                (side *) (term-nums *))   ;   replace them, then simplify
;;  (mult-extract! name expr-loc            ;
;;                 &opt (term-nums *)) 
;; -----------------------------------------------------------------------------
;;  (invoke command &rest expr-specs)       ; Invoke command by instantiating
;;                                          ;   from expressions and patterns
;;  (for-each command &rest expr-specs)     ; Instantiate and invoke separately
;;                                          ;   for each expression
;;  (for-each-rev command &rest expr-specs) ; Invoke in reverse order
;;  (show-subst command &rest expr-specs)   ; Show but don't invoke the
;;                                          ;   instantiated command
;;  (claim cond &opt (try-just nil)         ; Claims condition holds on terms
;;              &rest expr-specs)
;;  (name-extract name &rest expr-specs)    ; Extract & name expr, then replace
;; -----------------------------------------------------------------------------
;;  (move-to-front &rest fnums)             ; Reorder sequent formulas
;;  (rotate--)                              ; Rotate antecedent list
;;  (rotate++)                              ; Rotate consequent list
;;  (use-with lemma &rest fnums)            ; Use a lemma with formula
;;                                          ;   preferences for instantiation
;;  (apply-lemma lemma &rest expr-specs)    ; Use lemma with expressions
;;  (apply-rewrite lemma &rest expr-specs)  ; Rewrite with expressions
;; -----------------------------------------------------------------------------


;;; ================== Utility macros =================

;; Check for previous definitions before introducing new function
;; and variable names.

(defmacro define-exclusively (&rest forms)
  (dolist (form forms) (eval `(define-excl ,form))))

(defmacro define-excl (form)
  (let ((name (cadr form)))
    (cond ((member name global-manip-strat-symbols) form)
	  ((or (boundp name) (fboundp name))
	   (setf failed-global-manip-defn name)
	   (error "The symbol ~A is already defined." name))
	  (t (push name global-manip-strat-symbols)
	     form))))

(defvar global-manip-strat-symbols nil)  ;; symbols defined in this file
(defvar failed-global-manip-defn nil)    ;; name of failed defn on error


(define-exclusively
  (defmacro textify (form) `(format nil "~A" ,form)))


;;; =============== Simple arithmetic strategies ===============

(defstep swap (lhs operator rhs &optional (infix? t))
  (let ((op (string-trim whitespace-chars (textify operator)))
	(lhs-expr (ee-obj-or-string (car (eval-ext-expr lhs))))
	(rhs-expr (ee-obj-or-string (car (eval-ext-expr rhs))))
	(old-expr (commute-expr op lhs-expr rhs-expr infix?))
	(new-expr (commute-expr op rhs-expr lhs-expr infix?))
	(just-step (function-prop-just-step op infix?))
	(eq-step `(equate$ ,old-expr ,new-expr :try-just ,just-step)))
    eq-step)
  "Try commutatively swapping two terms and replacing.  Set INFIX?
to nil for prefix applications.  Commutativity proof for operator will
be tried automatically."
  "~%Swapping terms in a commutative expression and replacing")

(defstep swap! (expr-loc)
  (let ((eq-step
	 (handler-case
	     (let* ((expr   (ee-pvs-obj (car (eval-ext-expr expr-loc))))
		    (op     (textify (operator expr)))
		    (infix? (typep expr 'infix-application)))
	       `(swap$ ,(textify (args1 expr)) ,op
		       ,(textify (args2 expr)) ,infix?))
	   (error (condition)
		  (gen-manip-response 'swap! "Invalid expression.")))))
    eq-step)
  "Try commutatively swapping the two arguments of the function
application found at EXPR-LOC.  Commutativity proof for operator will
be tried automatically."
  "~%Swapping terms in a commutative expression and replacing")

;;; Construct swapped expression from commuted terms and wrap
;;; with parentheses if necessary.

(define-exclusively
  (defun commute-expr (op term1 term2 infix?)
    (if infix?
	(let ((p-term1 (safety-parens term1))
	      (p-term2 (safety-parens term2)))
	  (format nil "~A ~A ~A" p-term1 op p-term2))
        (format nil "~A(~A, ~A)" op term1 term2))))

(define-exclusively
  (defun function-prop-just-step (op infix?)
    (cond (infix? `(assert))
	  ((expr-match-success (match-expr pvs-identifier-pattern op))
	   `(then (expand ,op 1) (smash)))
	  (t nil))))


(defstep group (term1 operator term2 term3 &optional (side l) (infix? t))
  (let ((op (string-trim whitespace-chars (textify operator)))
	(term1-expr (ee-obj-or-string (car (eval-ext-expr term1))))
	(term2-expr (ee-obj-or-string (car (eval-ext-expr term2))))
	(term3-expr (ee-obj-or-string (car (eval-ext-expr term3))))
	(old-side (if (eq side 'l) 'r 'l))
	(old-expr (assoc-expr op term1-expr term2-expr term3-expr 
			      old-side infix?))
	(new-expr (assoc-expr op term1-expr term2-expr term3-expr side infix?))
	(just-step (function-prop-just-step op infix?))
	(eq-step `(equate$ ,old-expr ,new-expr :try-just ,just-step)))
    eq-step)
  "Try associatively regrouping three terms toward SIDE (L or R) and
replacing.  Set INFIX? to nil for prefix applications.  Associativity
proof for operator will be tried automatically."
  "~%Regrouping terms in an associative expression and replacing")

(defstep group! (expr-loc &optional (side l))
  (let ((eq-step
	 (handler-case
	     (let* ((expr  (ee-pvs-obj (car (eval-ext-expr expr-loc))))
		    (op    (textify (operator expr)))
		    (term1 (if (eq side 'l) (args1 expr) (args1 (args1 expr))))
		    (term2 (if (eq side 'l)
			       (args1 (args2 expr))
			       (args2 (args1 expr))))
		    (term3 (if (eq side 'l) (args2 (args2 expr)) (args2 expr)))
		    (infix? (typep expr 'infix-application)))
	       `(group$ ,(textify term1) ,op ,(textify term2)
			,(textify term3) ,side ,infix?))
	   (error (condition)
		  (gen-manip-response 'group! "Invalid expression.")))))
    eq-step)
  "Try associatively regrouping the three subexpressions of the function
applications found at EXPR-LOC toward SIDE (L or R).  Associativity proof
for operator will be tried automatically."
  "~%Regrouping terms in an associative expression and replacing")

;;; Construct grouped expression by associating L or R.

(define-exclusively
  (defun assoc-expr (op term1 term2 term3 side infix?)
    (if infix?
	(let ((p-term1 (safety-parens term1))
	      (p-term2 (safety-parens term2))
	      (p-term3 (safety-parens term3)))
	  (format nil (if (eq side 'l) "(~A ~A ~A) ~A ~A" "~A ~A (~A ~A ~A)")
		  p-term1 op p-term2 op p-term3))
        (if (eq side 'l)
	    (format nil "~A(~A(~A, ~A), ~A)" op op term1 term2 term3)
	    (format nil "~A(~A, ~A(~A, ~A))" op term1 op term2 term3)))))


(defstep swap-group (term1 operator term2 term3 &optional (side l) (infix? t))
  (let ((op (string-trim whitespace-chars (textify operator)))
	(term1-expr (ee-obj-or-string (car (eval-ext-expr term1))))
	(term2-expr (ee-obj-or-string (car (eval-ext-expr term2))))
	(term3-expr (ee-obj-or-string (car (eval-ext-expr term3))))
	(assoc-side (if (eq side 'l) 'r 'l))
	(old-expr (assoc-expr op term1-expr term2-expr term3-expr 
			      assoc-side infix?))
	(new-expr (if (eq side 'l)
		      (assoc-expr op term2-expr term1-expr term3-expr
				  assoc-side infix?)
		      (assoc-expr op term1-expr term3-expr term2-expr
				  assoc-side infix?)))
	(just-step (function-prop-just-step op infix?))
	(eq-step `(equate$ ,old-expr ,new-expr :try-just ,just-step)))
    eq-step)
  "Try associatively regrouping and swapping three terms according to
the scheme indicated by SIDE: 
  L: x op (y op z) ==> y op (x op z)  R: (x op y) op z ==> (x op z) op y
so as to lift and move center term to the left or right.  Set INFIX? to
nil for prefix applications.  Justification proof for operator will be
tried automatically."
  "~%Regrouping and swapping terms in an associative expression and replacing")

(defstep swap-group! (expr-loc &optional (side l))
  (let ((eq-step
	 (handler-case
	     (let* ((expr  (ee-pvs-obj (car (eval-ext-expr expr-loc))))
		    (op    (textify (operator expr)))
		    (term1 (if (eq side 'l) (args1 expr) (args1 (args1 expr))))
		    (term2 (if (eq side 'l)
			       (args1 (args2 expr))
			       (args2 (args1 expr))))
		    (term3 (if (eq side 'l) (args2 (args2 expr)) (args2 expr)))
		    (infix? (typep expr 'infix-application)))
	       `(swap-group$ ,(textify term1) ,op ,(textify term2)
			     ,(textify term3) ,side ,infix?))
	   (error (condition)
		  (gen-manip-response 'swap-group! "Invalid expression.")))))
    eq-step)
  "Try associatively regrouping the three subexpressions of the function
applications found at EXPR-LOC according to the scheme indicated by SIDE: 
  L: x op (y op z) ==> y op (x op z)  R: (x op y) op z ==> (x op z) op y
so as to lift and move center term to the left or right.  Justification
proof for operator will be tried automatically."
  "~%Regrouping and swapping terms in an associative expression and replacing")

;;;;;;;;;;;;;;;;;;;;

(defstep swap-rel (&rest fnums)
  (let ((f-nums (get-relations (extract-fnums-arg fnums)))
	(swap-step
	  (if f-nums
	      `(then@ ,@(mapcar #'(lambda (n) `(swap-rel-one$ ,n)) f-nums))
	      (gen-manip-response 'swap-rel "No suitable formulas."))))
    swap-step)
  "Swap the two sides of relational formulas and reverse the direction
of the relational operators."
  "~%Reversing the order of the relations in formulas ~A")

(defhelper swap-rel-one (fnum)
  (let ((formula (manip-get-formula fnum))
	(operator (id (operator formula)))
	(lhs (textify (args1 formula)))
	(rhs (textify (args2 formula)))
	(new-op (reverse-relation operator))
	(new-expr (format nil "~A ~A ~A" rhs new-op lhs))
	(replace-expr (format nil "~A IFF ~A" formula new-expr))
	(case-step `(case ,replace-expr))
	(main-branch `(replace -1 ,(if (< fnum 0) (- fnum 1) fnum) :hide? t))
	(just-step '(ground))
	(steplist (list main-branch just-step)))
    (spread case-step steplist))
  "Reverse order of a relational formula."
  "~%Reversing the order of the relation in formula ~A")

;;;;;;;;;;;;;;;;;;;;

(defstep equate (lhs rhs &optional (try-just nil))
  (let ((lhs-expr (safety-parens (ee-obj-or-string (car (eval-ext-expr lhs)))))
	(rhs-expr (virt-ee-string (car (eval-ext-expr rhs))))
	(case-eq `(case ,(format nil "~A = ~A" lhs-expr rhs-expr)))
	(steplist (list (try-fail-announce `(replace -1 :hide? t)
					   'equate "Replacement")
			(try-justification 'equate try-just))))
    (spread case-eq steplist))
  "Try equating two expressions and replacing the LHS by the RHS.
Proof of the justification step can be tried or deferred.  Use
TRY-JUST to supply the rule for the justification proof or T for
the default rule (GRIND)."
  "~%Equating two expressions and replacing")

;;;;;;;;;;;;;;;;;;;;

(defstep has-sign (term &optional (sign +) (try-just nil))
  (let ((term-expr (ee-obj-or-string (car (eval-ext-expr term))))
	(relation (case sign
		    ((+) '>) ((-) '<) ((0) '=)
		    ((0+) '>=) ((0-) '<=) ((+-) '/=) (t '>)))
	(case-step `(case ,(format nil "~A ~A 0" term-expr relation)))
	(step-list (list '(skip) (try-justification 'has-sign try-just)))
	(step `(then ,@(gen-value-warning 'has-sign sign 'sign '(+ - 0 0+ 0- +-))
		     (spread ,case-step ,step-list))))
    step)
  "Try claiming that a TERM has the designated SIGN (relationship to 0).
Symbols for SIGN are (+ - 0 0+ 0- +-), which have meanings positive,
negative, zero, nonnegative, nonpositive, and nonzero.  Proof of the
justification step can be tried or deferred.  Use TRY-JUST to supply
a step for the justification proof or T for the default rule (GRIND)."
  "~%Claiming the selected term has the designated sign")

;;;;;;;;;;;;;;;;;;;;

(defstep mult-by (fnums term &optional (sign +))
  (let ((f-nums (get-relations (extract-fnums-arg fnums)))
	(term-expr (virt-ee-string (car (eval-ext-expr term))))
	(mult-step
	  (if f-nums
	      `(then@ ,@(gen-value-warning 'mult-by sign 'sign '(+ - *))
		      ,@(mapcar #'(lambda (n)
				    `(mult/div-by$ * ,term-expr ,n ,sign))
				f-nums))
	      (gen-manip-response 'mult-by "No suitable formulas."))))
    mult-step)
  "Multiply both sides of relational formulas by the factor TERM.
If TERM is known to be positive or negative, use + or - as the SIGN
argument.  Otherwise, use *, which introduces a conditional expression
to handle the two cases."
  "~%Multiplying both sides of selected formulas by given term")

(defstep div-by (fnums term &optional (sign +))
  (let ((f-nums (get-relations (extract-fnums-arg fnums)))
	(term-expr (virt-ee-string (car (eval-ext-expr term))))
	(div-step
	  (if f-nums
	      `(then@ ,@(gen-value-warning 'div-by sign 'sign '(+ - *))
		      ,@(mapcar #'(lambda (n)
				    `(mult/div-by$ / ,term-expr ,n ,sign))
				f-nums))
	      (gen-manip-response 'div-by "No suitable formulas."))))
    div-step)
  "Divide both sides of relational formulas by the factor TERM.
If TERM is known to be positive or negative, use + or - as the SIGN
argument.  Otherwise, use *, which introduces a conditional expression
to handle the two cases."
  "~%Dividing both sides of selected formulas by given term")

(defhelper mult/div-by (op term fnum sign)
  (let ((formula (manip-get-formula fnum))
	(relation (id (operator formula)))
	(mult/div-step (if (and (eq op '*)
				(or (and (< fnum 0)
					 (member relation '(= <= >=)))
				    (and (> fnum 0)
					 (member relation '(< >)))))
			   `(mult-by-real$ ,term ,fnum ,sign ,formula ,relation)
			   `(mult/div-by-nz$ ,op ,term ,fnum
					     ,sign ,formula ,relation))))
    mult/div-step)
  "Multiply/divide both sides of a relation by a term."
  "~%Multiplying/dividing both sides of formula by given term")

;; If multiplying an antecedent relation in {=, <=, >=}, or a consequent
;; relation in {<, >}, we can allow multiplier to be any real.  Use
;; extension lemmas in extra_real_props.

(defhelper mult-by-real (term fnum sign formula relation)
  (let ((lhs-text (textify (args1 formula)))
	(rhs-text (textify (args2 formula)))
	(consequent? (> fnum 0))
	(lemma-rel (if consequent? (negate-inequality relation) relation))
	(both-sides-lemma
	  (format nil "both_sides_times~A~A~A_imp"
		  (cond ((eq relation '=) "")
			((eq sign '-) "_neg")
			((eq sign '+) "_pos")
			(t            "_pos_neg"))
		  (prepend-underscore
		    (cdr (assoc lemma-rel real-props-relation)))
		  "1"))
	(both-sides-lemma-step `(lemma ,both-sides-lemma))
	(inst-step (if (and (eq sign '-) (not (eq relation '=)))
		       `(inst -1 ,term ,rhs-text ,lhs-text)
		       `(inst -1 ,term ,lhs-text ,rhs-text)))
	(target (if (< fnum 0) (- fnum 1) fnum))
	(cancel-steps `((rewrite "div_cancel2" ,fnum)))  ;; useful still?
	(simplify-step `(branch (split -1 1)
				((then (hide ,target)
				       ,@(if consequent? `((flip-ineq$ -1)) '())
				       ,@cancel-steps)
				 (assert))))
	(step-list `(,simplify-step (assert))))
    (branch (then both-sides-lemma-step inst-step) step-list))
  "Multiply both sides of a relation by a term."
  "~%Multiplying both sides of formula by given term")

(defhelper mult/div-by-nz (op term fnum sign formula relation)
  (let ((lhs-text (textify (args1 formula)))
	(rhs-text (textify (args2 formula)))
	(lemma-op (if (eq op '*) "times" "div"))
	(both-sides-lemma
	  (format nil "both_sides_~A~A~A~A" lemma-op
		  (cond ((eq relation '=) "")
			((eq sign '-) "_neg")
			((eq sign '+) "_pos")
			(t            "_pos_neg"))
		  (prepend-underscore
		    (cdr (assoc relation real-props-relation)))
		  "1"))
	(both-sides-lemma-step `(lemma ,both-sides-lemma))
	(inst-step (if (and (eq sign '-) (not (eq relation '=)))
		       `(inst -1 ,term ,rhs-text ,lhs-text)
		       `(inst -1 ,term ,lhs-text ,rhs-text)))
	(target (if (< fnum 0) (- fnum 1) fnum))
	(cancel-steps (if (eq op '*)
			  `((repeat (rewrite "div_cancel2" ,fnum)))
			  `((repeat (rewrite "div_simp" ,fnum))
			    (repeat (rewrite "times_div_cancel1" ,fnum))
			    (repeat (rewrite "times_div_cancel2" ,fnum)))))
	(replace-step `(then@ (replace -1 ,target rl t) ,@cancel-steps))
	(step-list `(,replace-step (assert))))
    (branch (then both-sides-lemma-step inst-step) step-list))
  "Multiply/divide both sides of a relation by a term."
  "~%Multiplying/dividing both sides of formula by given term")

;;;;;;;;;;;;;;;;;;;;

(defstep split-ineq (fnum &optional replace?)
  (let ((fnumber (car (extract-fnums-arg fnum)))
	(formula (manip-get-formula fnumber))
	(suitable (and formula
		       (is-relation formula t)
		       (member (id (operator formula))
			       (if (< fnumber 0) '(<= >=) '(< >)))))
	(split-step (if suitable
		       `(split-ineq-one$ ,fnumber ,formula ,replace?)
		       (gen-manip-response 'split-ineq
					   "Formula not suitable."))))
    split-step)
  "Given that FNUM is a nonstrict antecedent inequality (<= or >=),
split it into two cases, e.g., an equal-to and a less-than case.  Also
works if FNUM is a strict consequent inequality.  Simplification using
(ASSERT) is applied after splitting.  The equality may be optionally
used for replacement by supplying  the direction LR or RL for the
REPLACE? argument."
  "~%Splitting off the equality case from formula ~A")

(defhelper split-ineq-one (fnum formula replace?)
  (let ((rel-op (id (operator formula)))
	(case-step
	  `(case ,(format nil "~A = ~A" (args1 formula) (args2 formula))))
	(eq-step (if replace?
		     `(then (replace -1 :dir ,replace?) (assert))
		     `(assert))))
    (branch case-step (eq-step (assert))))
  "Split an inequality based on equal-to case."
  "~%Splitting off the equality case from formula ~A")

;;;;;;;;;;;;;;;;;;;;

(defstep flip-ineq (fnums &optional (hide? t))
  (let ((f-nums (extract-fnums-arg fnums))
	(f-labels (mapcar #'(lambda (n) (name-gensym "flip_ineq")) f-nums))
	(label-steps (mapcar #'(lambda (l n) `(label ,l ,n)) f-labels f-nums))
	(formula-steps (mapcar #'(lambda (l n) `(flip-ineq-one$ ,l ,n ,hide?))
			       f-labels f-nums))
	(err-step (gen-manip-response 'flip-ineq "No suitable formulas."))
	(flip-step
	  (if f-nums
	      `(try (then ,@label-steps
			  (try (then ,@formula-steps)
			       (unlabel ,f-labels)
			       (fail)))
		    (skip)
		    ,err-step)
	      err-step)))
    flip-step)
  "Negate the inequality formulas and move the resulting formulas by
exchanging between antecedents and consequents.  Conjunctions and
disjunctions of inequalities are also accepted, causing each conjunct
or disjunct in the form of an inequality to be negated and moved.
If HIDE? is set to NIL, the original formulas are left intact."
  "~%Negating and moving the inequalities in formulas ~A")

(defhelper flip-ineq-one (flabel orig-fnum hide?)
  (let ((fnum (car (map-fnums-arg flabel)))
	(formula (manip-get-formula fnum))
	(new-formula (flip-ineq-formula formula))
	(case-step `(case ,new-formula))
	(main-branch (if hide? `(hide ,fnum) `(skip)))
	(just-step '(then (assert) (ground)))
	(steplist (if (< fnum 0)
		      (list just-step main-branch)
		      (list main-branch just-step)))
	(err-step (gen-manip-response 'flip-ineq
		   (format nil "Formula (originally numbered) ~A is unsuitable."
			   orig-fnum))))
    (if new-formula (spread case-step steplist) err-step))
  "Negate and move inequality formulas."
  "~%Negating and moving the inequalities in formula ~A")

(define-exclusively

(defun flip-ineq-formula (formula)
  (cond ((typep formula 'infix-conjunction)
	 (flip-ineq-con/disjunction formula t))
	((typep formula 'infix-disjunction)
	 (flip-ineq-con/disjunction formula nil))
	((is-relation formula t) (flip-ineq-expr formula))
	(t nil)))

;; For conjunctions and disjunctions, flatten the expression
;; and collect con/disjuncts.  Then negate each one individually.

(defun flip-ineq-con/disjunction (formula conj?)
  (make-new-con/disjunction
    (mapcar #'flip-ineq-expr (collect-con/disjunctive-terms formula conj?))
    (not conj?)))

(defun flip-ineq-expr (expr)
  (if (is-relation expr t)
      (let ((lhs (textify (args1 expr)))
	    (rhs (textify (args2 expr)))
	    (new-op (negate-inequality (id (operator expr)))))
	(format nil "~A ~A ~A" lhs new-op rhs))
      (format nil "NOT ~A" (safety-parens expr))))

)  ;;; end (define-exclusively

;;;;;;;;;;;;;;;;;;;;

(defstep show-parens (&optional (fnums *))
  (let ((f-nums (extract-fnums-arg fnums))
	(dummy (loop for fnum in f-nums
		     initially (when f-nums (terpri))
		     do (format t "~%[~A]  ~A" fnum
				(parenthesize-formula
				  (manip-get-formula fnum)))
		     finally (when f-nums (terpri))))
	(step (if f-nums
		  '(skip)
		  (gen-manip-response 'show-parens "No suitable formulas."))))
    step)
  "Show how infix operators and operands are associated by displaying
formulas with full parenthesization.  This strategy overlaps the new
built-in feature of PVS 3.0, M-x pvs-set-proof-parens (also available
from the PVS menu)."
  "~%")

;; Create a fully parenthesized version of a formula by copying all
;; the relevant object instances in the parse tree and turning on
;; the PARENS slot when an EXPRS slot exists at 2 adjacent levels.
;; NOTE: slots set only in newly created instances.

(define-exclusively
  (defun parenthesize-formula (formula &optional (above 0))
    (handler-case
      (let ((f-arg (argument formula))
	    (obj (make-instance (class-of formula))))
	(setf (place obj) (place formula))
	(setf (operator obj) (operator formula))
	(setf (parens obj) (parens formula))
	(setf (argument obj)
	      (handler-case
	        (let ((subexprs (exprs f-arg)))
		  (setf (parens obj) above)
		  (parenthesize-argument
		    (mapcar #'(lambda (e) (parenthesize-formula e 1))
			    subexprs)))
		(error (condition) (parenthesize-formula f-arg))))
	obj)
      (error (condition) formula))))

(define-exclusively
  (defun parenthesize-argument (expr-list)
    (let ((obj (make-instance 'arg-tuple-expr)))
      (setf (exprs obj) expr-list)
      obj)))


;;; =============== Intermediate arithmetic strategies ==============

(defstep move-terms (fnum side &optional (term-nums *))
  (let ((fnumber (car (extract-fnums-arg fnum)))
	(formula (manip-get-formula fnumber))
	(move-step (if (and formula (is-relation formula))
		       `(move-terms-one$ ,(id (operator formula))
					 ,fnumber ,formula ,side ,term-nums)
		       (gen-manip-response 'move-terms
					   "Not a suitable formula."))))
    move-step)
  "Move additive terms numbered TERM-NUMS in relational formula FNUM
from SIDE (L or R) to the other side, adding or substracting as needed."
  "~%Moving additive terms to the other side of formula ~A")

(defhelper move-terms-one (rel fnum formula side term-nums)
  (let ((left  (collect-additive-terms '+ (args1 formula)))
	(right (collect-additive-terms '+ (args2 formula)))
	(from-list (if (eq side 'l) left right))
	(to-list   (if (eq side 'l) right left)) 
	(tnums (map-term-nums-arg term-nums (length from-list)))
	(move-step (if tnums
		       `(move-terms-two$ 
			 ,@(list rel fnum formula side from-list to-list tnums))
		       (gen-manip-response 'move-terms "No suitable terms."))))
    move-step)
  "Move additive terms to the other side of a relation."
  "~%Moving additive terms to the other side of relation")

(defhelper move-terms-two (rel fnum formula side from-list to-list tnums)
  (let ((term-mask (mapcar #'(lambda (n) (member (1+ n) tnums))
			   (consec (length from-list))))
	(in-terms (mapcan #'(lambda (p x) (and p (list x)))
			  term-mask from-list))
	(out-terms (mapcan #'(lambda (p x) (and (not p) (list x)))
			   term-mask from-list))
	(new-from (make-new-addition out-terms t))
	(new-to (make-new-addition
		  (append to-list
			  (mapcar #'(lambda (term)
				      (cons (xor-signs (car term) '-)
					    (cdr term)))
				  in-terms))
		  t))
	(new-left  (if (eq side 'l) new-from new-to))
	(new-right (if (eq side 'l) new-to new-from))
	(old-formula (textify formula))
	(new-formula (format nil "~A ~A ~A" new-left rel new-right))
	(move-step `(case ,(format nil "(~A) = (~A)"
				   old-formula new-formula)))
	(step-list `((replace -1 ,(if (< fnum 0) (- fnum 1) fnum) :hide? t)
		     (smash))))
    (spread move-step step-list))
  "Move additive terms to the other side of a relation."
  "~%Moving additive terms to the other side of relation")

;;;;;;;;;;;;;;;;;;;;

(defstep isolate (fnum side term-num)
  (let ((expr-desc (car (eval-ext-expr `(! ,fnum ,side))))
	(orig-terms (and expr-desc
			 (collect-additive-terms '+ (ee-pvs-obj expr-desc))))
	(move-step (if (map-term-nums-arg term-num (length orig-terms))
		       `(move-terms$ ,fnum ,side (^ ,term-num))
		       (gen-manip-response 'isolate "Term not suitable."))))
    move-step)
  "Move all additive terms except that numbered TERM-NUM in relational
formula FNUM from SIDE (L or R) to the other side."
  "~%Moving all but one additive terms to the other side of formula ~A")

(defstep isolate-replace (fnum side term-num &optional (targets *))
  (let ((fnumber (car (extract-fnums-arg fnum)))
	(formula (manip-get-formula fnumber))
	(move-step (if (and formula (< fnumber 0)
			    (typep formula 'infix-application)
			    (eq (id (operator formula)) '=))
		       `(then (isolate$ ,fnumber ,side ,term-num)
			      ,(if (eq side 'l)
				    `(replace ,fnumber ,targets lr t)
				    `(replace ,fnumber ,targets rl t)))
		       (gen-manip-response 'isolate-replace
					   "Not a suitable formula."))))
    move-step)
  "Isolate the term TERM-NUM on SIDE (L or R) of relational formula FNUM,
then replace and hide it.  Use TARGETS to restrict scope of replacement."
  "~%Isolating and replacing an additive term of formula ~A")


;;;;;;;;;;;;;;;;;;;;

(defstep cancel (&optional (fnums *) sign)
  (let ((candidates (get-relations (extract-fnums-arg fnums)))
	(f-nums (mapcan #'(lambda (n)
			    (and (both-sides-same-op (manip-get-formula n)
						     '(+ - * /))
				 (list n)))
			candidates))
	(cancel-step
	  (if f-nums
	      `(then@ ,@(gen-value-warning 'cancel sign 'sign '(+ - 0+ 0- * nil))
		      ,@(mapcar #'(lambda (n) `(cancel-one$ ,n ,sign)) f-nums))
	      (gen-manip-response 'cancel "No suitable formulas."))))
    cancel-step)
  "Cancel terms from both sides of relational formulas involving
arithmetic expressions.  If SIGN = NIL, common terms are assumed to be
(non)positive or (non)negative as needed for the appropriate rewrite
rules to apply.  Otherwise, an explicit SIGN can be supplied to force
a case split so the rules will apply.  If SIGN is `+' or `-', terms
are claimed to be positive or negative.  If SIGN is `0+' or `0-', terms
are nonnegative or nonpositive.  If SIGN is `*', the terms  are assumed
to be arbitrary reals and a three-way case split is used."
  "~%Canceling terms from both sides of selected formulas")

;; Both-sides cancellation (x op y R x op z).

(defhelper cancel-one (fnum sign)
  (let ((formula (manip-get-formula fnum))
	(relation (id (operator formula)))
	(op (id (operator (args1 formula))))
	(term1-lhs (args1 (args1 formula)))
	(term2-lhs (args2 (args1 formula)))
	(term1-rhs (args1 (args2 formula)))
	(term2-rhs (args2 (args2 formula)))
	(same-1 (equal (textify term1-lhs) (textify term1-rhs)))
	(cancel-term (if same-1 term1-lhs term2-lhs))
	(left-term  (if same-1 term2-lhs term1-lhs))
	(right-term (if same-1 term2-rhs term1-rhs))
	(name? (or (typep cancel-term 'infix-application)
		   (typep left-term 'infix-application)
		   (typep right-term 'infix-application)))
	(cancel-step 
	  (cond ((not sign)
		 `(cancel-any$ ,fnum ,formula ,name? ,cancel-term
			       ,left-term ,op ,relation ,right-term))
		((and (eq op '/) same-1)
		 `(cancel-cases$ ,fnum ,formula ,sign ,name? ,cancel-term
				 ,right-term ,op ,relation ,left-term))
		(t `(cancel-cases$ ,fnum ,formula ,sign ,name? ,cancel-term
				   ,left-term ,op ,relation ,right-term)))))
    cancel-step)
  "Try canceling terms in a relational formula."
  "~%Canceling terms from both sides of formula ~A")

;; The simplest case tries to apply rewrite rules without considering the
;; polarity of the cancellation term.  If expressions are involved, name
;; replace is used to prevent unwanted simplification.

(defhelper cancel-any (fnum formula name? cancel-term
		       left-term op rel right-term)
  (let ((name-rep (if name?
		      `((name ,(name-gensym "x")     ,(textify cancel-term))
			(name ,(name-gensym "y" nil) ,(textify left-term))
			(name ,(name-gensym "z" nil) ,(textify right-term))
			(replace -1) (replace -2) (replace -3))
		      `()))
	(rep-back (if name?
		      `((replace -1 :dir rl :hide? t)
			(replace -1 :dir rl :hide? t)
			(replace -1 :dir rl) (hide -1))
		      `()))
	(adj-fnum (if (and name? (< fnum 0)) (- fnum 3) fnum))
	(cancel-step
	 `(try (then ,@name-rep
		     (try (try-rewrites$ ,adj-fnum
					 ,@(cancellation-lemma-names op rel ""))
			  (then ,@rep-back)
			  (fail)))
	       (skip)
	       ,(gen-manip-response 'cancel "No cancellation rules apply."))))
    cancel-step)
  "Try canceling terms in a relational formula."
  "~%Canceling terms from both sides of formula ~A")

;; Basic cancellation proceeds by introducing the new relation, name
;; replacing expressions if necessary, then simplifying with rewrite
;; rules selected according to the operators involved.  NOTE: propagates
;; failure to caller -- be sure to protect via TRY.

(defhelper cancel-basic (fnum formula name? cancel-term
			 left-term op rel right-term &optional (polarity ""))
  (let ((new-form (format nil "~A ~A ~A" left-term rel right-term))
	(case-step `(case ,(format nil "~A IFF ~A" formula new-form)))
	(name-rep (if name?
		      `((name ,(name-gensym "x")     ,(textify cancel-term))
			(name ,(name-gensym "y" nil) ,(textify left-term))
			(name ,(name-gensym "z" nil) ,(textify right-term))
			(replace -1) (replace -2) (replace -3))
		      `()))
	(just-step
	 `(then ,@name-rep
		(try (try-rewrites$
		       * ,@(cancellation-lemma-names op rel "" polarity))
		     ,(try-justification 'cancel '(assert))
		     (fail))))
	(step-list `((replace -1 :hide? t) ,just-step)))
    (spread case-step step-list))
  "Try canceling terms in a relational formula."
  "~%Canceling terms from both sides of formula ~A")

;; For cancellation terms whose type doesn't satisfy the rewrite rules,
;; set up a suitable case split on the term's polarity.

(defhelper cancel-cases (fnum formula sign name? cancel-term
			 left-term op rel right-term)
  (let ((case-step
	  (if (eq sign '*)
	      `(spread
		 (case ,(format nil "~A >= 0" cancel-term)
		       ,(format nil "~A = 0"  cancel-term))
		 ((then (replace -1 :hide? t) (assert))
		  (cancel-basic$ ,(if (< fnum 0) (- fnum 1) (+ fnum 1))
				 ,formula ,name? ,cancel-term
				 ,left-term ,op ,rel ,right-term "_pos_")
		  (cancel-basic$ ,(if (< fnum 0) fnum (+ fnum 1))
				 ,formula ,name? ,cancel-term
				 ,right-term ,op ,rel ,left-term "_neg_")))
	      (let* ((comp (case sign
			     ((+) '>) ((-) '<) ((0+) '>=) ((0-) '<=) (t '>)))
		     (cancel-args 
		       `(,formula ,name? ,cancel-term
				  ,@(if (member sign '(- 0-))
					(list right-term op rel left-term)
					(list left-term op rel right-term))
				  ,(if (member comp '(> >=)) "_pos_" "_neg_"))))
		`(spread (case ,(format nil "~A ~A 0" cancel-term comp))
			 (,(if (member sign '(+ -))
			       `(cancel-basic$ ,(if (< fnum 0) (- fnum 1) fnum)
					       ,@cancel-args)
			       `(spread (case ,(format nil "~A = 0"
						       cancel-term))
				  ((then (replace -1 :hide? t) (assert))
				   (cancel-basic$
				     ,(if (< fnum 0) (- fnum 1) (+ fnum 1))
				     ,@cancel-args))))
			  (assert))))))
	(msg-step (gen-manip-response 'cancel "No cancellation rules apply.")))
    (try case-step (skip) msg-step))
  "Try canceling terms in a relational formula."
  "~%Canceling terms from both sides of formula ~A")

;;; Generate list of applicable lemma names based on relation and
;;; top-level operator.

(define-exclusively
  (defun cancellation-lemma-names (operator relation suffix
					    &optional (polarity ""))
    (flet ((lemma (polarity-word op-word number)
	     (format nil "both_sides_~A~A~A~A~A"
		     (cdr (assoc operator arith-op-name))
		     polarity-word op-word number suffix)))
      (let ((op (cdr (assoc relation real-props-relation))))
	(cond ((eq relation '=)
	       (list (lemma "" "" 1) (lemma "" "" 2)))
	      ((member operator '(+ -))
	       (list (lemma "_" op 1) (lemma "_" op 2)))
	      ((eq operator '*)
	       (if (equal polarity "")
		   (list (lemma "_pos_" op 1) (lemma "_pos_" op 2)
			 (lemma "_neg_" op 1) (lemma "_neg_" op 2))
		   (list (lemma polarity op 1) (lemma polarity op 2))))
	      (t (list (lemma "_pos_" op 1) (lemma "_pos_" op 2)
		       (lemma "_pos_" op 3)
		       (lemma "_neg_" op 1) (lemma "_neg_" op 2)
		       (lemma "_neg_" op 3)) ))))))

;;;;;;;;;;;;;;;;;;;;

(defstep cancel-terms (&optional (fnums *) (end l) (sign nil) (try-just nil))
  (let ((candidates (get-relations (extract-fnums-arg fnums)))
	(f-nums (mapcan #'(lambda (n)
			    (and (both-sides-same-op (manip-get-formula n)
						     '(+ - * /))
				 (list n)))
			candidates))
	(cancel-step
	  (if f-nums
	      `(then@ ;,@(gen-value-warning 'cancel-terms sign 'sign
			;		   '(+ - 0+ 0- * nil))
		      ,@(mapcar #'(lambda (n)
				    `(cancel-lr-one$ ,n ,end ,sign ,try-just))
				f-nums))
	      (gen-manip-response 'cancel-terms "No suitable formulas."))))
    cancel-step)
  "Cancel left-most or right-most terms, which need not be identical,
from both sides of relational formulas involving arithmetic expressions.
Introduces a case split to prove the terms are equal.  END may be used to
select L or R end of a chain of associative terms for cancellation.  The
`-' operator is considered equivalent to `+' for this purpose.  On the
other hand, only the outer-most application in a chain of `/'-separated
terms is recognized.  SIGN may be used to indicate polarity as in cancel."
  "~%Canceling terms from both sides of selected formulas")

(defhelper cancel-lr-one (fnum end sign try-just)
  (let ((formula (manip-get-formula fnum))
	(lhs (args1 formula))
	(rhs (args2 formula))
	(op (id (operator lhs)))
	(lhs-term (cond ((not (eq op '/))
			 (make-new-product (get-end-terms lhs end 1)))
			((eq end 'l) (args1 lhs))
			(t           (args2 lhs))))
	(rhs-term (cond ((not (eq op '/))
			 (make-new-product (get-end-terms rhs end 1)))
			((eq end 'l) (args1 rhs))
			(t           (args2 rhs))))
	(eq-step `(case ,(format nil "~A = ~A" lhs-term rhs-term)))
	(main-branch
	 `(then@ (replace -1 ,(if (< fnum 0) (- fnum 1) fnum)
			  :hide? t)
		 ,@(case op
		     ((+ -) `((move-terms$ ,fnum l ,(if (eq end 'l) 1 -1))
			      (assert ,fnum)))
		     ((*) (if (eq end 'l)
			      `((invoke$ (permute-mult-terms$ $1j ,fnum 1 r)
					 (! ,fnum l))
				(permute-mult-terms$ ,rhs ,fnum 1 r)
				(cancel$ ,fnum ,sign))
			      `((invoke$ (permute-mult-terms$ $1j ,fnum -1 r)
					 (! ,fnum l))
				(permute-mult-terms$ ,rhs ,fnum -1 r)
				(cancel$ ,fnum ,sign))))
		     ((/) `((cancel$ ,fnum ,sign))) ;; -1 hidden in step above
		     (t nil))))
	(step-list (list main-branch
			 (try-justification 'cancel-terms try-just))))
    (spread eq-step step-list))
  "Try canceling terms in a relational formula."
  "~%Canceling terms from both sides of formula ~A")


;;;;;;;;;;;;;;;;;;;;

(defstep op-ident (fnum &optional (side l) (operation *1))
  (let ((fnumber (car (extract-fnums-arg fnum)))
	(formula (manip-get-formula fnumber))
	(step (if formula
		  `(then ,@(gen-value-warning 'op-ident operation 'operation
					      '(z+ +z -z 1* *1 /1))
			 (op-ident-one$ ,fnumber ,formula ,side ,operation))
		  (gen-manip-response 'op-ident "Formula not suitable."))))
    step)
  "Apply the operator identity given by OPERATION to rewrite the
expression found on SIDE (L or R) of relational formula FNUM.
Performs the following operations using these designated symbols:
   z+      +z      -z      1*      *1      /1
   0 + x   x + 0   x - 0   1 * x   x * 1   x / 1"
  "~%Applying identity operation to rewrite selected expression")

(defhelper op-ident-one (fnumber formula side operation)
  (let ((relation (id (operator formula)))
	(old-expr   (if (eq side 'l) (args1 formula) (args2 formula)))
	(other-expr (if (eq side 'l) (args2 formula) (args1 formula)))
	(new-expr (op-ident-expr old-expr operation))
	(case-expr 
	  (if (eq side 'l)
	      (format nil "(~A) IFF (~A ~A ~A)"
		      formula new-expr relation other-expr)
	      (format nil "(~A) IFF (~A ~A ~A)"
		      formula other-expr relation new-expr)))
	(rewrite-step
	  `(branch (case ,case-expr)
		   ((replace -1 ,(if (< fnumber 0) (- fnumber 1) fnumber)
			     :hide? t)
		    (then (assert) (assert))))))
    rewrite-step)
  "Apply operator identity to rewrite expression."
  "~%Applying identity operation to rewrite selected expression")

(defstep op-ident! (expr-loc &optional (operation *1))
  (let ((descriptors (eval-ext-expr expr-loc))
	(rewrite-step
	  (if descriptors
	      `(then@ ,@(gen-value-warning 'op-ident! operation 'operation
					   '(z+ +z -z 1* *1 /1))
		      ,@(mapcar #'(lambda (d) `(op-ident!-one$ ,d ,operation))
				descriptors))
	      (gen-manip-response 'op-ident! "No suitable expressions."))))
    rewrite-step)
  "Apply the operator identity given by OPERATION to rewrite the
expression found at EXPR-LOC.  Currently performs the following
operations using these designated symbols:
   z+      +z      -z      1*      *1      /1
   0 + x   x + 0   x - 0   1 * x   x * 1   x / 1"
  "~%Applying identity operation to rewrite selected expression")

(defhelper op-ident!-one (expr-descriptor operation)
  (let ((old-expr (ee-pvs-obj expr-descriptor))
	(fnumber (ee-fnum expr-descriptor))
	(new-expr (op-ident-expr old-expr operation))
	(rewrite-step
	  `(branch (case ,(format nil "~A = ~A" old-expr new-expr))
		   ((replace -1 ,(if (< fnumber 0) (- fnumber 1) fnumber)
			     :hide? t)
		    (assert 1)))))
    rewrite-step)
  "Apply operator identity to rewrite expression."
  "~%Applying identity operation to rewrite selected expression")

(define-exclusively
  (defun op-ident-expr (expr operation)
    (case operation
      ((z+) (format nil "0 + ~A" expr))
      ((+z) (format nil "~A + 0" expr))
      ((-z) (format nil "~A - 0" expr))
      ((1*) (format nil "1 * ~A" (safety-parens expr)))
      ((*1) (format nil "~A * 1" (safety-parens expr)))
      ((/1) (format nil "~A / 1" (safety-parens expr)))
      (t    (format nil "~A * 1" (safety-parens expr))))))  ;; *1 default


;;;;;;;;;;;;;;;;;;;;

(defstep cross-mult (&optional (fnums *))
  (let ((f-nums (get-relations (extract-fnums-arg fnums)))
	(rewrite-step1 `(repeat (rewrite "times_div1" ,f-nums)))
	(rewrite-step2 `(repeat (rewrite "times_div2" ,f-nums)))
	(mult-step
	  `(then@ ,@(mapcar #'(lambda (n) `(cross-mult-one$ ,n)) f-nums)))
	(cross-step (if f-nums
			`(then ,rewrite-step1 ,rewrite-step2 ,mult-step)
		        (gen-manip-response 'cross-mult
					    "No suitable formulas."))))
    cross-step)
  "Apply cross multiplication to relational expressions.  Multiply
both sides of a formula by the respective divisors of each side and
then simplify.  Checks for negative real divisors and invokes suitable
lemmas as needed.  Applies cross multiplication recursively until all
outermost division operators are gone."
  "~%Multiplying both sides of selected formulas by LHS/RHS divisor(s)")

(defhelper cross-mult-one (fnum &optional (depth-limit 10))
  (let ((formula (manip-get-formula fnum))
	(recur-step `(then@ (rewrite "times_div1" ,fnum)
			    (rewrite "times_div2" ,fnum)
			    (cross-mult-one$ ,fnum ,(- depth-limit 1))))
	(mult-step
	  (cond ((= depth-limit 0)
		 (gen-manip-response 'cross-mult "Depth limit exceeded."))
		((is-term-operator (args1 formula) '/)  ;; LHS
		 `(spread (cross-mult-lr$ ,fnum ,formula l)
			  (,recur-step (skip))))
		((is-term-operator (args2 formula) '/)  ;; RHS
		 `(spread (cross-mult-lr$ ,fnum ,formula r)
			  (,recur-step (skip))))
		(t '(skip)))))
    mult-step)
  "Multiply both sides of a relation by LHS/RHS divisor(s)."
  "~%Multiplying both sides of ~A by LHS/RHS divisor(s)")

(defhelper cross-mult-lr (fnum formula side)
  (let ((relation (id (operator formula)))
	(left-side (eq side 'l))
	(side-obj (if left-side (args1 formula) (args2 formula)))
	(divisor-obj (args2 side-obj))
	(lemma-step
 	  (if (eq relation '=)
	      `(rewrite ,(if left-side "div_cancel3" "div_cancel4") ,fnum)
	      (let ((suffix (format nil "_~A~A"
				    (cdr (assoc relation real-props-relation))
				    (if left-side "1" "2")))
		    (divisor-type (textify (type divisor-obj))))
		(if (member divisor-type '("posreal" "negreal") :test #'equal)
		    (let ((sign
			   (if (equal divisor-type "negreal") "_neg" "_pos")))
		      `(rewrite ,(format nil "div_mult~A~A" sign suffix) ,fnum))
		    (let* ((lemmas
			    (mapcar #'(lambda (sign)
					(format nil "div_mult~A~A" sign suffix))
				    '("_pos" "_neg" "_pos_neg")))
			   (other-side
			    (if left-side (args2 formula) (args1 formula)))
			   (terms (list divisor-obj other-side 
					(args1 side-obj))))
		      (apply #'rewrite-until-justified lemmas fnum terms)))))))
    lemma-step)
  "Multiply both sides of a relation by LHS/RHS divisor(s)."
  "~%Multiplying both sides of ~A by LHS/RHS divisor")

;;;;;;;;;;;;;;;;;;;;

(defstep cross-add (&optional (fnums *))
  (let ((f-nums (get-relations (extract-fnums-arg fnums)))
	(add-step (if f-nums
		      `(then@ ,@(mapcar #'(lambda (n) `(cross-add-one$ ,n))
					f-nums))
		      (gen-manip-response 'cross-add "No suitable formulas."))))
    add-step)
  "Apply cross addition to relational formulas.  Add to both sides of
a formula the respective subtrahend of each side and then simplify.
Applies cross addition recursively until all outermost subtraction
operators are gone."
  "~%Adding LHS/RHS subtrahend(s) to both sides of selected formulas")

(defhelper cross-add-one (fnum &optional (depth-limit 10))
  (let ((formula (manip-get-formula fnum))
	(add-step
	  (cond ((= depth-limit 0)
		 (gen-manip-response 'cross-add "Depth limit exceeded."))
		((is-term-operator (args1 formula) '-)      ;; LHS
		 `(then (cross-add-lr$ ,fnum l)
			(cross-add-one$ ,fnum ,(- depth-limit 1))))
		((is-term-operator (args2 formula) '-)  ;; RHS
		 `(then (cross-add-lr$ ,fnum r)
			(cross-add-one$ ,fnum ,(- depth-limit 1))))
		(t '(skip)))))
    add-step)
  "Add LHS/RHS subtrahend(s) to both sides of a relation."
  "~%Adding LHS/RHS subtrahend(s) to both sides of formula ~A")

(defhelper cross-add-lr (fnum side)
  (let ((formula (manip-get-formula fnum))
	(relation (operator formula))
	(lhs-obj (args1 formula))
	(rhs-obj (args2 formula))
	(is-left (eq side 'l))
	(side-obj  (if is-left lhs-obj rhs-obj))
	(other-obj (if is-left rhs-obj lhs-obj))
	(new-expr (if is-left
		      (format nil "~A ~A ~A + ~A" (args1 side-obj) relation
			      (args2 side-obj) other-obj)
		      (format nil "~A + ~A ~A ~A" (args2 side-obj) other-obj
			      relation (args1 side-obj))))
	(replace-expr (format nil "~A IFF ~A" formula new-expr))
	(case-step `(case ,replace-expr))
	(main-branch '(then (replace -1) (hide -1)))
	(just-step '(assert))
	(steplist (list main-branch just-step)))
    (spread case-step steplist))
  "Add LHS/RHS subtrahend(s) to both sides of a relation."
  "~%Adding LHS/RHS subtrahend(s) to both sides of ~A")

;;;;;;;;;;;;;;;;;;;;

(defstep factor (fnums &optional (side *) (term-nums *) id?)
  (let ((extract-step `(factor!$ (! ,fnums ,side) ,term-nums ,id?)))
    extract-step)
  "Extract common multiplicative factors from the additive terms given
by TERM-NUMS for the expression found on SIDE (L or R) of each relational
formula in FNUMS, then rearrange.  ID? = T indicates the factor made of
summed terms should be embedded in a call to the identity function to
prevent later distribution."
  "~%Extracting common factors from additive terms of selected expressions")

(defstep factor! (expr-loc &optional (term-nums *) (id? nil))
  (let ((descriptors (eval-ext-expr expr-loc))
	(extract-step
	   (if descriptors
	       `(try (then@ ,@(mapcar #'(lambda (d)
					  `(factor-one$ ,d ,term-nums ,id?))
				      descriptors))
		     (skip)
		     ,(gen-manip-response 'factor! "No suitable expressions."))
	       (gen-manip-response 'factor!
				   "No suitable formulas or expressions."))))
    extract-step)
  "Extract common multiplicative factors from the additive terms given
by TERM-NUMS for the expressions found at EXPR-LOC, then rearrange.
ID? = T indicates the factor made of summed terms should be embedded
in a call to the identity function to prevent later distribution."
  "~%Extracting common factors from additive terms of selected expressions")

(defhelper factor-one (expr-descriptor term-nums id?)
  (let ((expr-obj (ee-pvs-obj expr-descriptor))
	(fnumber (ee-fnum expr-descriptor))
	(full-terms (collect-additive-terms '+ expr-obj))
	(tnums (map-term-nums-arg term-nums (length full-terms)))
	(extract-step
	 (cond ((null tnums)
		(gen-manip-response 'factor! "No suitable terms."))
	       ((and (typep expr-obj 'infix-application)
		     (member (id (operator expr-obj)) '(+ -)))
		`(factor-terms$ ,expr-obj ,fnumber ,full-terms ,tnums ,id?))
	       (t '(skip)))))
    extract-step)
  "Extract common factors from additive terms."
  "~%Extracting common factors from additive terms of selected expression")

(defhelper factor-terms (old-expr fnum full-terms tnums id?)
  (let ((term-mask (mapcar #'(lambda (n) (member (1+ n) tnums))
			   (consec (length full-terms))))
	(in-terms (mapcan #'(lambda (p x) (and p (list x)))
			  term-mask full-terms))
	(out-terms (mapcan #'(lambda (p x) (and (not p) (list x)))
			   term-mask full-terms))
	(in-objs (mapcar #'collect-multiplicative-terms
			 (mapcar #'cadr in-terms)))  ;; signs removed
	(in-terms-str
	 (mapcar #'(lambda (a) (mapcar #'(lambda (m) (safety-parens m)) a))
		 (extract-gcds in-objs)))
	(common (find-common-factors in-terms-str))
	(common-expr (make-new-product common nil))
	(uncommon (strip-common-factors in-terms-str common))
	(uncommon-expr
	 (make-new-addition
	  (mapcar #'(lambda (orig new)
		      (list (car orig) (make-new-product new nil)))
		  in-terms uncommon)
	  t))
	(ident (if id? "id" ""))
	(new-expr (format nil "~A * ~A(~A)~A" common-expr ident uncommon-expr
			  (if out-terms (make-new-addition out-terms nil) "")))
	(extract-step `(case ,(format nil "~A = ~A" old-expr new-expr)))
	(adj-fnum (if (< fnum 0) (- fnum 1) fnum))
	(step-list (cond ((not common)  `((skip)))
			 (id? `((replace -1 ,adj-fnum :hide? t)
				(then (expand "id") (assert))))
			 (t   `((replace -1 ,adj-fnum :hide? t) (assert))))))
    (spread extract-step step-list))
  "Extract common factors from additive terms."
  "~%Extracting common factors from additive terms of selected expression")


;;;;;;;;;;;;;;;;;;;;

(defstep transform-both (fnum transform &optional (swap nil) (try-just nil))
  (let ((fnumber (car (extract-fnums-arg fnum)))
	(formula (manip-get-formula fnumber))
	(step (cond ((not formula)
		     (gen-manip-response 'transform-both
					 "Formula not suitable."))
		    ((stringp transform)
		     `(transform-both-one$ ,fnumber ,formula ,transform
					   ,swap ,try-just))
		    (t (gen-manip-response 'transform-both
					   "TRANSFORM must be a string.")))))
    step)
  "Apply TRANSFORM to both sides of relational formula FNUM, where a
transform has the form `...%1...', and `%1' represents the left- and
righthand side expressions in the relation.  The transform can be
regarded as a template expression with `%1' as an implicit template
variable.  Example: (transform-both 3 \"2 * %1 + 1\") multiplies both
sides of formula 3 by 2 then adds 1.  The flag SWAP is used to indicate
when the terms should be swapped (e.g., when multiplying by a negative
number).  Proof of the justification step can be tried by supplying
a proof step for TRY-JUST."
  "~%Applying transform to both sides of formula ~A and simplifying")

(defhelper transform-both-one (fnumber formula transform swap try-just)
  (let ((operator (textify (operator formula)))
	(lhs (textify (car (exprs (argument formula)))))
	(rhs (textify (cadr (exprs (argument formula)))))
	(trans-lhs (percent-subst transform (list lhs)))
	(trans-rhs (percent-subst transform (list rhs)))
	(trans-relation
	  (if swap
	      (format nil "~A ~A ~A" trans-rhs operator trans-lhs)
	      (format nil "~A ~A ~A" trans-lhs operator trans-rhs)))
	(case-step
	  `(case ,(format nil (if (> fnumber 0) "NOT ~A" "~A") trans-relation)))
	(steplist (list '(skip) (try-justification 'transform-both try-just))))
    (spread case-step steplist))
  "Apply TRANSFORM to both sides of relational formula FNUM."
  "~%Applying transform to both sides of formula ~A and simplifying")


;;; ============== Strategies for manipulating products ==============

(defstep permute-mult (fnums &optional (side r) (term-nums 2) (end l))
  (let ((extract-step `(permute-mult!$ (! ,fnums ,side) ,term-nums ,end)))
    extract-step)
  "Reorder multiplicative terms from the factors given by TERM-NUMS 
for the expression found on SIDE (L or R) of relational formulas FNUMS.
Those factors cited in TERM-NUMS will be moved to the END in the order
listed.  The remaining factors will be placed at the other END in their
original order."
  "~%Permuting factors in selected expressions")

(defstep permute-mult! (expr-loc &optional (term-nums 2) (end l))
  (let ((descriptors (eval-ext-expr expr-loc))
	(extract-step
	  (if descriptors
	      `(then@ ,@(mapcar #'(lambda (d)
				    `(permute-mult-one$ ,d ,term-nums ,end))
				descriptors))
	      (gen-manip-response 'permute-mult!
				  "No suitable formulas or expressions."))))
    extract-step)
  "Reorder multiplicative terms from the factors given by TERM-NUMS 
for the expressions found at EXPR-LOC.  Those factors cited in TERM-NUMS
will be moved to the END in the order listed.  The remaining factors
will be placed at the other END in their original order."
  "~%Permuting factors in selected expressions")

(defhelper permute-mult-one (expr-descriptor term-nums end)
  (let ((expr-obj (ee-pvs-obj expr-descriptor))
	(fnumber (ee-fnum expr-descriptor))
	(extract-step
	 (if (is-term-operator expr-obj '*)
	     (let* ((orig-terms (collect-multiplicative-terms expr-obj))
		    (tnums (map-term-nums-arg term-nums (length orig-terms))))
	       (if tnums
		   `(permute-mult-terms$ ,expr-obj ,fnumber ,term-nums ,end)
		   (gen-manip-response 'permute-mult! "No suitable terms.")))
	     (gen-manip-response 'permute-mult! "Not a suitable expression."))))
    extract-step)
  "Reorder multiplicative terms."
  "~%Permuting factors in selected expression")

;;; Internal strategy allows permutation in either direction.
;;; END argument indicates movement to L or R.  Term number generation
;;; is redundant for some callers, but there are multiple invokers.

(defhelper permute-mult-terms (old-expr fnum term-nums end)
  (let ((orig-terms (collect-multiplicative-terms old-expr))
	(tnums (map-term-nums-arg term-nums (length orig-terms)))
	(term-mask (mapcar #'(lambda (n) (member (1+ n) tnums))
			   (consec (length orig-terms))))
	(other-terms (mapcan #'(lambda (p x) (and (not p) (list x)))
			     term-mask orig-terms))
	(selected (mapcan #'(lambda (n) (let ((e (nth (- n 1) orig-terms)))
					  (and e (list e))))
			  tnums))
	(new-terms (if (eq end 'l)
		       (append selected other-terms)
		       (append other-terms selected)))
	(new-expr (make-new-product new-terms))
	(extract-step `(case ,(format nil "~A = ~A" old-expr new-expr)))
	(step-list `((replace -1 ,(if (< fnum 0) (- fnum 1) fnum) :hide? t)
		     (assert))))
    (branch extract-step step-list))
  "Reorder multiplicative terms."
  "~%Permuting factors in selected expression")

;;; Internal strategy to permute right.

(defhelper permute-mult-right (expr-loc &optional (term-nums 1))
  (let ((expr-descriptor (car (eval-ext-expr expr-loc)))
	(expr-obj (ee-pvs-obj expr-descriptor))
	(fnumber (ee-fnum expr-descriptor))
	(extract-step `(permute-mult-terms$ ,expr-obj ,fnumber ,term-nums r)))
    extract-step)
  "Reorder multiplicative terms."
  "~%Permuting factors in selected expression")

;;;;;;;;;;;;;;;;;;;;

(defstep name-mult (name fnum side &optional (term-nums *))
  (let ((name-step `(name-mult!$ ,name (! ,fnum ,side) ,term-nums)))
    name-step)
  "Select a list of factors (indicated by TERM-NUMS) from the expression
found on SIDE (L or R) of relational formula FNUM.  Assign a NAME to the
product of the selected factors and replace the product by NAME."
  "~%Permuting factors and replacing selected terms by ~A in expression")

(defstep name-mult! (name expr-loc &optional (term-nums *))
  (let ((expr-desc (car (eval-ext-expr expr-loc)))
	(step (cond ((not expr-desc)
		     (gen-manip-response 'name-mult!
					 "Formula or expression not suitable."))
		    ((or (stringp name) (symbolp name))
		     `(name-mult-one$ ,name ,expr-desc ,expr-loc ,term-nums))
		    (t (gen-manip-response 'name-mult!
			"NAME must be a string or a symbol.")))))
    step)
  "Select a list of factors (indicated by TERM-NUMS) from the expression
found at EXPR-LOC.  Assign a NAME to the product of the selected factors
and replace the product by NAME.  Can only handle first expression that
results from EXPR-LOC."
  "~%Permuting factors and replacing selected terms by ~A in expression")

(defhelper name-mult-one (name expr-desc expr-loc term-nums)
  (let ((full-expr (ee-pvs-obj expr-desc))
	(orig-terms (collect-multiplicative-terms full-expr))
	(tnums (map-term-nums-arg term-nums (length orig-terms)))
	(permute-step `(permute-mult!$ ,expr-loc ,tnums))
	(continue-step `(name-mult-rest$ ,name ,expr-loc ,tnums))
	(step (if tnums
		  `(then@ ,permute-step ,continue-step)
		  (gen-manip-response 'name-mult! "No suitable terms."))))
    step)
  "Select a list of factors and assign a NAME to their product."
  "~%Permuting factors and replacing selected terms by ~A in expression")

;;; expr-loc is the same, but the expression it locates is different
;;; after permutation.

(defhelper name-mult-rest (name expr-loc term-nums)
  (let ((full-expr (ee-pvs-obj (car (eval-ext-expr expr-loc))))
	(terms (get-end-terms full-expr 'l (length term-nums)))
	(new-expr (make-new-product terms))
	;; might want to replace in just fnum:
	(name-step `(name-replace ,name ,new-expr nil)))  ;; don't hide
    name-step)
  "Permute factors, name selection, and replace."
  "~%Permuting factors and replacing selected terms by ~A in expression")

;;;;;;;;;;;;;;;;;;;;

(defstep recip-mult (fnums side)
  (let ((rewrite-step `(recip-mult!$ (! ,fnums ,side))))
    rewrite-step)
  "Convert the top-level division operation for the expression found on
SIDE (L or R) of relational formulas FNUMS to a multiplication by the
reciprocal of the divisor."
  "~%Converting division in selected terms to multiplication by reciprocal")

(defstep recip-mult! (expr-loc)
  (let ((descriptors (eval-ext-expr expr-loc))
	(rewrite-step
	  (if descriptors
	      `(then@ ,@(mapcar #'(lambda (d) `(recip-mult-one$ ,d))
				descriptors))
	      (gen-manip-response 'recip-mult!
				  "No suitable formulas or expressions."))))
    rewrite-step)
  "Convert the top-level division operation for the expressions found at
EXPR-LOC to a multiplication by the reciprocal of the divisor."
  "~%Converting division in selected terms to multiplication by reciprocal")

(defhelper recip-mult-one (expr-descriptor)
  (let ((expr (ee-pvs-obj expr-descriptor))
	(fnumber (ee-fnum expr-descriptor))
	(case-step
	  (cond ((not (is-term-operator expr '/))
		 (gen-manip-response 'recip-mult! "Not a suitable expression."))
		(t `(case ,(format nil "~A = ~A * (1/~A)" expr
				   (safety-parens (args1 expr))
				   (safety-parens (args2 expr)))))))
	(adj-fnum (if (< fnumber 0) (- fnumber 1) fnumber))
	(step-list `((replace -1 ,adj-fnum :hide? t) (assert))))
    (branch case-step step-list))
  "Convert division operation to multiplication by reciprocal."
  "~%Converting division in selected term to multiplication by reciprocal")

;;;;;;;;;;;;;;;;;;;;

(defstep isolate-mult (fnum &optional (side l) (term-num 1) (sign +))
  (let ((swap-steps (if (eq side 'l) '() `((swap-rel$ ,fnum))))
	(permute-step `(permute-mult-right$ (! ,fnum l) ,term-num))
	(rest-step `(isolate-mult-rest$ ,fnum ,side ,sign))
	(expr-desc (car (eval-ext-expr `(! ,fnum ,side))))
	(orig-terms (and expr-desc
			 (collect-multiplicative-terms (ee-pvs-obj expr-desc))))
	(full-step
	 (cond ((not (extract-fnums-arg fnum))
		(gen-manip-response 'isolate-mult "Formula not suitable."))
	       ((map-term-nums-arg term-num (length orig-terms))
		`(try (then@ ,@(gen-value-warning 'isolate-mult
						  sign 'sign '(+ - *))
			     ,@swap-steps ,permute-step ,rest-step)
		      (skip) (skip)))
	       (t (gen-manip-response 'isolate-mult "Term not suitable.")))))
    full-step)
  "Select factor TERM-NUM from one SIDE of formula FNUM and divide
both sides as needed to leave the selected term isolated.  SIGN
indicates the sign of the product of the unselected factors.  A case
split to generate the appropriate condition on the divisor is
automatically introduced."
  "~%Dividing by factors to isolate a term in formula ~A")

;;; Assume relation has been swapped first so always operating on left.

(defhelper isolate-mult-rest (fnum side sign)
  (let ((fnumber (car (get-relations (extract-fnums-arg fnum))))
	(step (handler-case
		  (let* ((formula (manip-get-formula fnumber))
			 (relation (id (operator formula)))
			 (condition (cond ((or (eq relation '=) (eq sign '*))
					   "/=")
					  ((eq sign '-) "<")
					  (t            ">")))
			 (divisor (textify (args1 (args1 formula))))
			 (case-step `(case ,(format nil "~A ~A 0"
						    divisor condition)))
			 (adj-fnum (if (< fnumber 0) (- fnumber 1) fnumber))
			 (div-by-step `(div-by$ ,adj-fnum ,divisor ,sign))
			 (group-step `(rewrite "times_div2" ,adj-fnum :dir rl))
			 (cancel-steps `((rewrite "div_simp" ,adj-fnum)
					 (rewrite "identity_mult" ,adj-fnum)))
			 (unswap-steps
			  (if (eq side 'l) '() `((swap-rel$ ,adj-fnum))))
			 (step-list `((then@ ,div-by-step ,group-step
					     ,@cancel-steps ,@unswap-steps)
				      (assert))))
		    `(branch ,case-step ,step-list))
		(error (condition)
		       `(then ,(gen-manip-response 'isolate-mult
				"Formula or term not suitable.")
			      (fail))))))
    step)
  "Divide by factors to isolate term."
  "~%Dividing by factors to isolate a term in formula ~A")

;;;;;;;;;;;;;;;;;;;;

(defstep mult-eq (rel-fnum eq-fnum &optional (sign +))
  (let ((rel-fnumber (car (extract-fnums-arg rel-fnum)))
	(eq-fnumber  (car (extract-fnums-arg eq-fnum)))
	(rel-formula (manip-get-formula rel-fnumber))
	(eq-formula  (manip-get-formula eq-fnumber))
	(suitable (and rel-fnumber eq-fnumber
		       (< eq-fnumber 0)
		       (is-relation rel-formula)
		       (typep eq-formula 'infix-application)
		       (eq (id (operator eq-formula)) '=)))
	(mult-step (if suitable
		       `(then ,@(gen-value-warning 'mult-eq sign 'sign
						   '(+ - 0+ 0-))
			      (mult-eq-one$ ,rel-fnumber ,rel-formula
					    ,eq-fnumber ,eq-formula ,sign))
		       (gen-manip-response 'mult-eq
					   "Formula(s) not suitable."))))
    mult-step)
  "Given two formulas, one a relation `a R b', and the other an antecedent
equality `x = y', introduce a new formula relating the products,
a * x R b * y.  If R is an inequality, the SIGN argument can be set to
one of the symbols in {+, -, 0+, 0-} to indicate the polarity of x and y.
A SIGN of `*' is not supported (yet).  The relational formula may appear
on either side of the sequent, but the equality must be an antecedent."
  "~%Multiplying terms from formula ~A by those in ~A to derive a new relation")

(defhelper mult-eq-one (rel-fnum rel-formula eq-fnum eq-formula sign)
  (let ((rel-op (id (operator rel-formula)))
	(normal-order (or (member sign '(+ 0+)) (eq rel-op '=)))
	(rel-term-1 (safety-parens (args1 rel-formula)))
	(rel-term-2 (safety-parens (args2 rel-formula)))
	(eq-term-1  (safety-parens (args1 eq-formula)))
	(eq-term-2  (safety-parens (args2 eq-formula)))
	(left-terms  (if normal-order
			 (format nil "~A * ~A" rel-term-1 eq-term-1)
			 (format nil "~A * ~A" rel-term-2 eq-term-2)))
	(right-terms (if normal-order
			 (format nil "~A * ~A" rel-term-2 eq-term-2)
			 (format nil "~A * ~A" rel-term-1 eq-term-1)))
	(case-step
	  `(case ,(format nil "~A ~A ~A" left-terms rel-op right-terms)))
	(just-step (if (< rel-fnum 0)
		       `(then (replace ,eq-fnum) (cancel$ 1 ,sign) (assert))
		       `(then (replace ,(- eq-fnum 1))
			      (cancel$ -1 ,sign)
			      (assert))))
	(step-list
	  (if (< rel-fnum 0) `((skip) ,just-step) `(,just-step (skip)))))
    (spread case-step step-list))
  "Multiply terms in relational formula by equality to form new relation."
  "~%Multiplying terms from formula ~A by those in ~A to derive a new relation")

;;;;;;;;;;;;;;;;;;;;

(defstep mult-ineq (fnum1 fnum2 &optional (signs (+ +)))
  (let ((fnumber1 (car (extract-fnums-arg fnum1)))
	(fnumber2 (car (extract-fnums-arg fnum2)))
	(formula1 (manip-get-formula fnumber1))
	(formula2 (manip-get-formula fnumber2))
	(suitable (and fnumber1 fnumber2
		       (is-relation formula1 t) (is-relation formula2 t)))
	(mult-step (if suitable
		       `(then ,@(gen-value-warning 'mult-ineq signs 'signs
						   '((+ +) (+ -) (- +) (- -)))
			      (mult-ineq-one$ ,fnumber1 ,formula1
					      ,fnumber2 ,formula2 ,signs))
		       (gen-manip-response 'mult-ineq
					   "Formula(s) not suitable."))))
    mult-step)
  "Given two antecedent inequalities, a R1 b and x R2 y, form an
inequality on their products, a * x R3 b * y.  If R2 is not in the same
direction as R1, the strategy uses y rev(R2) x instead.  R3 is strict if
either R1 or R2 is.  SIGNS indicates the polarity of the pairs (a,b) and
(x,y).  Only inequalities on terms of matching signs can be usefully
multiplied.  Example: SIGNS = (+ -) indicates a,b are positive terms
while x,y are negative.  If either formula appears as a consequent,
its relation is negated before carrying out the multiplication."
  "~%Multiplying terms from formulas ~A and ~A to derive a new inequality")

(defhelper mult-ineq-one (fnum1 formula1 fnum2 formula2 signs)
  (let ((orig-op1 (id (operator formula1)))
	(orig-op2 (id (operator formula2)))
	(rel-op1 (if (> fnum1 0) (negate-inequality orig-op1) orig-op1))
	(rel-op2 (if (> fnum2 0) (negate-inequality orig-op2) orig-op2))
	(pos1 (not (eq (car signs) '-)))
	(pos2 (not (eq (cadr signs) '-)))
	(lt-1 (member rel-op1 '(< <=)))
	(lt-2 (member rel-op2 '(< <=)))
	(lt-same (eq (not lt-1) (not lt-2)))

	(term1-left  (safety-parens
		       (if pos2 (args1 formula1) (args2 formula1))))
	(term1-right (safety-parens
		       (if pos2 (args2 formula1) (args1 formula1))))
	(rel2-left   (if lt-same (args1 formula2) (args2 formula2)))
	(rel2-right  (if lt-same (args2 formula2) (args1 formula2)))
	(term2-left  (safety-parens (if pos1 rel2-left  rel2-right)))
	(term2-right (safety-parens (if pos1 rel2-right rel2-left)))

	(mult-strict (or (member rel-op1 '(< >)) (member rel-op2 '(< >))))
	(mult-rel-op (if lt-1 (if mult-strict '< '<=) (if mult-strict '> '>=)))
	(case-step `(case ,(format nil "~A * ~A ~A ~A * ~A"
				   term1-left term2-left mult-rel-op
				   term1-right term2-right)))
	(rel-name (cdr (assoc mult-rel-op real-props-relation)))
	(rewrite-step
	  `(rewrite ,(format nil "~A_times_~A_any1" rel-name rel-name) 1))
	(just-step `(try (then (expand "abs") (assert) (fail))
			 (skip)
			 (assert))))
    (spread case-step ((skip) (then rewrite-step just-step))))
  "Multiply terms in relational formulas to form new relation."
  "~%Multiplying terms from formulas to derive a new inequality")


;;;;;;;;;;;;;;;;;;;;

(defstep mult-cases (fnum &optional (abs? nil) (mult-op *1))
  (let ((fnumber (car (extract-fnums-arg fnum)))
	(next-step (if fnumber
		       `(then ,@(gen-value-warning 'mult-cases mult-op 'mult-op
						   '(1* *1))
			      (mult-cases-next$ ,fnumber ,abs? ,mult-op))
		       (gen-manip-response 'mult-cases 
					   "Formula not suitable."))))
    next-step)
  "Generate case analyses for relational formulas containing products.
If FNUM has the form `x * y R 0' (or 0 R x * y), rewrite FNUM to two
cases relating x and y to 0, as appropriate.  Some flattening and
simplification will be attempted after rewriting.

IF FNUM is a consequent inequality of the form a * b R c * d, generate
sufficient conditions to establish the inequality by considering relations
between a and c, and between b and d.  Likewise, for an antecedent inequality
of this form, generate necessary conditions for FNUM.  There is likely to
be some branching of the sequent.  The lemmas used contain instances of the
abs function, which are normally expanded.  To suppress this expansion,
set ABS? to T.

IF FNUM is an inequality of the form 'a * b R c' or 'a R c * d', first
transform FNUM into the form a * b R c * d by multiplying c or a by 1.
MULT-OP may be set to *1 (1*) to multiply on the right (left).  Then
proceed as in the previous case."
  "~%Analyzing cases for the relation in formula ~A")

(defstep mult-cases-next (fnumber abs? mult-op)
  (let ((formula (manip-get-formula fnumber))
	(expr1 (args1 formula))
	(expr2 (args2 formula))
	(is-mult1 (is-term-operator expr1 '*))
	(is-mult2 (is-term-operator expr2 '*))
	(is-zero1 (equal (textify expr1) "0"))
	(is-zero2 (equal (textify expr2) "0"))
	(split-step
	  (cond ((and (is-relation formula nil)
		      (or (and is-mult1 is-zero2) (and is-mult2 is-zero1)))
		 `(mult-cases-zero$ ,fnumber ,formula ,is-mult1))
		((and (is-relation formula t) (or is-mult1 is-mult2))
		 `(mult-cases-nonzero$ ,fnumber ,abs?
				       ,is-mult1 ,is-mult2 ,mult-op))
		(t (gen-manip-response 'mult-cases "Formula not suitable.")))))
    split-step)
  "Generate case analyses for relational formulas containing products."
  "~%Analyzing cases for the relation in formula ~A")

(defhelper mult-cases-zero (fnum formula left-mult)
  (let ((rel-op (id (operator formula)))
	(prefix (if (member rel-op '(< <=))
		    (if left-mult "neg" "pos")
		    (if left-mult "pos" "neg")))
	(lemma-name (if (eq rel-op '=)
			(if left-mult "zero_times3" "zero_times4")
		        (format nil "~A_times_~A" prefix
				(cdr (assoc rel-op real-props-relation)))))
	(rewrite-step `(rewrite ,lemma-name ,fnum))
	(simp-step (if (< fnum 0) `((split ,fnum)) `()))
	(split-step `(then ,rewrite-step ,@simp-step (flatten) (assert))))
    split-step)
  "Analyze cases for a relation on products."
  "~%Analyzing cases for the relation in formula ~A")

(defhelper mult-cases-nonzero (fnum abs? left-mult right-mult mult-op)
  (let ((prep-step
	  (if (and left-mult right-mult)
	      nil
	      `(op-ident$ ,fnum ,(if left-mult 'r 'l) ,mult-op)))
	(split-step
	  `(,(if (> fnum 0) 'mult-cases-cons$ 'mult-cases-ante$)
	    ,fnum ,abs?))
	(nonzero-step (if prep-step `(then ,prep-step ,split-step) split-step)))
    nonzero-step)
  "Analyze cases for a relation on products."
  "~%Analyzing cases for the relation in formula ~A")

(defhelper mult-cases-cons (fnum abs?)
  (let ((formula (manip-get-formula fnum))
	(rel-op (id (operator formula)))
	(rel-name (cdr (assoc rel-op real-props-relation)))
	(lemma (format nil "~A_times_~A_any1" rel-name rel-name))
	(rewrite-step `(rewrite ,lemma ,fnum))
	(all-steps `(then ,rewrite-step 
			  ,@(unless abs? `((expand "abs" ,fnum)))
			  (flatten))))
    all-steps)
  "Analyze cases for a relation on products."
  "~%Analyzing cases for the relation in formula ~A")

(defhelper mult-cases-ante (fnum abs?)
  (let ((formula (manip-get-formula fnum))
	(rel-op (id (operator formula)))
	(rel-name (cdr (assoc rel-op real-props-relation)))
	(lemma-step
	  `(lemma ,(format nil "~A_times_~A_any2" rel-name rel-name)))
	(inst-step `(invoke$ (inst -1 $*s) (! ,(- fnum 1) * *)))
	(all-steps `(then ,lemma-step ,inst-step
			  ,@(unless abs? `((expand "abs" -1)))
			  (assert) (flatten))))
    all-steps)
  "Analyze cases for a relation on products."
  "~%Analyzing cases for the relation in formula ~A")

;;;;;;;;;;;;;;;;;;;;

(defstep mult-extract (name fnum &optional (side *) (term-nums *))
  (let ((extract-step `(mult-extract!$ ,name (! ,fnum ,side) ,term-nums)))
    extract-step)
  "Extract additive terms TERM-NUMS from the expression found on SIDE of
relational formula FNUM.  Each term is treated as a product of factors,
some of which contain divisions.  Each selected product term is assigned
a name derived from NAME and is extracted using name-replace to form a new
antecedent equality.  Then all the divisors are cross multiplied and any
common factors are identified and canceled."
  "~%Naming (using ~A), extracting and canceling terms from expression")

(defstep mult-extract! (name expr-loc &optional (term-nums *))
  (let ((extract-step
	 (handler-case
	     (let* ((expr-descriptor (car (eval-ext-expr expr-loc)))
		    (expr (ee-pvs-obj expr-descriptor))
		    (fnumber (ee-fnum expr-descriptor))
		    (full-terms (collect-additive-terms '+ expr))
		    (term-numbers (map-term-nums-arg term-nums
						     (length full-terms))))
	       (cond ((not (or (stringp name) (symbolp name)))
		      (gen-manip-response 'mult-extract!
					  "NAME must be a string or a symbol."))
		     ((null term-numbers)
		      (gen-manip-response 'mult-extract! "Term not suitable."))
		     ((< (length full-terms) 2)
		      `(mult-extract-one$ ,name ,full-terms 1))
		     (t (flet ((make-step (n)
				 `(mult-extract-one$
				   ,(format nil "~A_~A" name n) ,full-terms ,n)))
			  `(then ,@(mapcar #'make-step term-numbers))))))
	   (error (condition)
		  (gen-manip-response 'mult-extract!
				      "Formula or expression not suitable.")))))
    extract-step)
  "Extract additive terms TERM-NUMS from the expression found at EXPR-LOC.
Each term is treated as a product of factors, some of which contain
divisions.  Each selected product term is assigned a name derived from
NAME and extracted using name-replace to form a new antecedent equality.
Then all the divisors are cross multiplied and any common factors are
identified and canceled.  Can only handle first expression from EXPR-LOC."
  "~%Naming (using ~A), extracting and canceling terms from expression")

(defhelper mult-extract-one (name full-terms term-num)
  (let ((old-mult (cadr (nth (- term-num 1) full-terms)))
	(name-step `(name-replace ,name ,(textify old-mult) nil))
	(factors (collect-multiplicative-terms old-mult))
	(factor-nums (mapcar #'1+ (consec (length factors))))
	(nondiv-terms
	  (mapcan #'(lambda (x n) (and (not (is-term-operator x '/)) (list n)))
		  factors factor-nums))
	(permute-step (if (null nondiv-terms)
			  '(skip)
			  `(permute-mult!$ (! -1 l) ,nondiv-terms)))
	(div-step `(repeat (then (rewrite "times_div1" -1)
				 (rewrite "div_cancel3" -1))))
	(continue-step `(mult-extract-two$)))
    (then@ name-step permute-step div-step continue-step))
  "Extract additive terms formed by factors containing divisions."
  "~%Naming (using ~A), extracting and canceling terms from expression")

(defhelper mult-extract-two ()
  (let ((formula (manip-get-formula -1))
	(left-terms  (collect-multiplicative-terms (args1 formula)))
	(right-terms (collect-multiplicative-terms (args2 formula)))
	(left-str  (mapcar #'(lambda (m) (textify m)) left-terms))
	(right-str (mapcar #'(lambda (m) (textify m)) right-terms))
	(common-factors (find-common-factors (list left-str right-str)))
	(common (if (equal common-factors '("1")) nil common-factors))
	(left-posns
	  (mapcar #'(lambda (f) (position f left-str :test #'equal)) common))
	(right-posns
	  (mapcar #'(lambda (f) (position f right-str :test #'equal)) common))
	;; could skip either permute if no change in order:
	(permute-left  `(permute-mult-right$ (! -1 l)
					     ,(mapcar #'1+ left-posns)))
	(permute-right `(permute-mult-right$ (! -1 r)
					     ,(mapcar #'1+ right-posns)))
	(cancel-step `(repeat (rewrite "both_sides_times1" -1)))
	(extract-step
	  (if (null common)
	      '(skip)
	      `(then@ ,permute-left ,permute-right ,cancel-step))))
    extract-step)
  "Extract additive terms formed by factors containing divisions."
  "~%Naming, extracting and canceling terms from expression")


;;; ================= General purpose strategies ==================

(defstep invoke (command &rest expr-specs)
  (let ((descriptors (mapappend #'eval-ext-expr expr-specs))
	(new-cmd (build-instan-cmd command descriptors))
	(new-step (gen-manip-response 'invoke (format nil "~S" new-cmd) nil)))
    (then new-step new-cmd))
  "Invoke a rule or strategy by instantiating COMMAND with substitutions
extracted from the extended expression specifications EXPR-SPECS.
Example: suppose formula 1 is f(x+y) = f(a*(z+1)).  Then
   (invoke (case \"%1 = %2\") (? 1 \"f(%1) = f(%2)\"))
would match and create the bindings %1=`x+y' and %2=`a*(z+1)', which
results in the prover command (case \"x+y = a*(z+1)\") being invoked."
  "~%Invoking instantiated command after substitutions")

(defstep for-each (command &rest expr-specs)
  (let ((descriptors (mapappend #'eval-ext-expr expr-specs))
	(for-each-cmd `(for-each-one$ ,command ,descriptors)))
    for-each-cmd)
  "Repeatedly invoke a rule or strategy by instantiating COMMAND with
substitutions extracted from the extended expression specifications
EXPR-SPECS.  For each expression specified, instantiate and invoke
COMMAND with a different binding for parameters %1, $1, etc."
  "~%Invoking instantiated command for each substitution")

(defstep for-each-rev (command &rest expr-specs)
  (let ((descriptors (reverse (mapappend #'eval-ext-expr expr-specs)))
	(for-each-cmd `(for-each-one$ ,command ,descriptors)))
    for-each-cmd)
  "Repeatedly invoke a rule or strategy by instantiating COMMAND with
substitutions extracted from the extended expression specifications
EXPR-SPECS.  For each expression specified, instantiate and invoke
COMMAND with a different binding for parameters %1, $1, etc.  Performs
the invocations in reverse order."
  "~%Invoking instantiated command for each substitution")

(defhelper for-each-one (command descriptors)
  (let ((cmd-list
	  (mapcan #'(lambda (expr)
		      (let ((cmd (build-instan-cmd command (list expr))))
			(list (gen-manip-response 'for-each
						  (format nil "~S" cmd) nil)
			      cmd)))
		  descriptors))
	(invocations `(then@ ,@cmd-list)))
;;	(invocations `(then@ (skip) ,@cmd-list))) ;; extra skip to suppress msg
    invocations)
  "Repeatedly invokes instantiated rule or strategy after substitutions."
  "~%Invoking instantiated command for each substitution")

(defstep show-subst (command &rest expr-specs)
  (let ((descriptors (mapappend #'eval-ext-expr expr-specs))
	(new-cmd (build-instan-cmd command descriptors))
	(new-step (gen-manip-response 'show-subst (format nil "~S" new-cmd))))
    new-step)
  "Tests command formation with substitutions extracted from extended
expression specifications.  Emits messages to show what substitutions
occur, but doesn't invoke any commands.  Use the idiom
    (show-subst ($*) <ext expr 1> ... <ext expr n>)
to see the evaluation of extended expressions against the current sequent."
  "~%")

;;;;;;;;;;;;;;;;;;;;

(defstep claim (cond &optional (try-just nil) &rest expr-specs)
  (let ((terms (mapappend #'eval-ext-expr expr-specs))
	(case-step (build-instan-cmd `(case ,cond) terms))
	(steplist (list '(skip) (try-justification 'claim try-just))))
    (spread case-step steplist))
  "Generalized case step that uses a parameterized condition applied
to multiple terms (two-way split only).  COND can be regarded as a
template expression with %1, %2, ..., serving as implicit template
variables to represent terms to be substituted in the parameterized
condition expression.  The justification step can be tried by setting
TRY-JUST to a proof step.  Example: (claim \"%1 < %2\" t \"x\" \"y+z\")
case splits on `x < y+z' and tries to prove the relation using grind."
  "~%Claiming the parameterized condition holds on the terms supplied")

(defstep name-extract (name &rest expr-specs)
  (let ((exprs (mapcar #'virt-ee-string (eval-ext-expr expr-specs)))
	(extract-step
	 (cond ((not (or (stringp name) (symbolp name)))
		(gen-manip-response 'name-extract
				    "NAME must be a string or a symbol."))
	       ((< (length exprs) 2)
		`(name-replace ,name ,(car exprs) nil))
	       (t (let ((expr-names
			 (mapcar #'(lambda (n) (format nil "~A_~A" name (1+ n)))
				 (consec (length exprs)))))
		    `(then ,@(mapcar #'(lambda (n e) `(name-replace ,n ,e nil))
				     expr-names exprs)))))))
    extract-step)
  "Extract expressions using the extended expression specifications
supplied in EXPR-SPECS.  Assign NAME (or NAME_1, NAME_2,...) to the
expressions and replace them throughout the sequent, leaving the
antecedent equalities visible."
  "~%Assigning designated expressions to ~A and replacing")

;;;;;;;;;;;;;;;;;;;;

(defstep move-to-front (&rest fnums)
  (let ((f-nums (extract-fnums-arg fnums))
	(len (length f-nums))
	(move-step (case len
		     ((0) (gen-manip-response 'move-to-front
			                      "No formulas selected."))
		     ((1) (let* ((fn (car f-nums))
				 (fn+1 (if (< fn 0) (- fn 1) (+ fn 1))))
			    `(then (copy ,fn) (delete ,fn+1))))
		     (t (let ((merged-fnum (if (some #'plusp f-nums) 1 -1)))
			  `(then (merge-fnums ,f-nums)
				 (flatten-disjunct ,merged-fnum
						   ,(- len 1))))))))
    move-step)
  "Rearranges the order of antecedent and consequent formulas.  Takes
the FNUMS given and moves the corresponding formulas to the front of
the antecedent and consequent lists as appropriate."
  "~%Moving selected formulas up in the sequent")

(defstep rotate-- ()
  (let ((fnums (gather-fnums (s-forms (current-goal *ps*))
			     '- nil true-predicate))
	(move-step `(move-to-front$ ,@(cdr fnums))))
    move-step)
  "Moves the first antecedent formula to the end of the list of antecedents."
  "~%Moving the first antecedent to the end")

(defstep rotate++ ()
  (let ((fnums (gather-fnums (s-forms (current-goal *ps*))
			     '+ nil true-predicate))
	(move-step `(move-to-front$ ,@(cdr fnums))))
    move-step)
  "Moves the first consequent formula to the end of the list of consequents."
  "~%Moving the first consequent to the end")


;;;;;;;;;;;;;;;;;;;;

(defstep use-with (lemma &rest fnums)
  (let ((f-nums (extract-fnums-arg fnums))
	(terms (mapcar #'make-preferred-use-term f-nums))
	(pref (format nil "id(~A~{ AND ~A~})" (car terms) (cdr terms)))
	(case-step `(case ,pref))
	(main-branch `(try (use ,lemma) (hide -2) (fail)))
	(just-branch `(then (expand "id" 1) (ground)))
	(use-step (if terms
		      `(spread ,case-step (,main-branch ,just-branch))
		      `(then ,(gen-manip-response 'use-with
			       "No formulas or preferred terms selected.")
			     (try (use ,lemma) (skip) (fail)))))
	(step (if (stringp lemma)
		  `(try ,use-step (skip) (skip))
		  (gen-manip-response 'use-with "LEMMA must be a string."))))
    step)
  "USE a lemma with formula preferences for instantiation.  A temporary
copy of the terms in FNUMS is constructed and placed at the front of
the sequent (formula -1).  Then a USE command for LEMMA is invoked
so that the search for instantiable terms begins with the temporary
formula.  The effect is to match terms from the user's preferred
formulas (in the order given) before looking elsewhere in the sequent."
  "~%Using ~A with formula preferences for instantiation")

(define-exclusively
  (defun make-preferred-use-term (fnum)
    (let ((formula (manip-get-formula fnum)))
      (if (> fnum 0)
	  (format nil "NOT (~A)" formula)
	  formula))))

;;;;;;;;;;;;;;;;;;;;

(defstep apply-lemma (lemma &rest expr-specs)
  (let ((exprs (mapcar #'virt-ee-string (eval-ext-expr expr-specs)))
	(lemma-step `(lemma ,lemma))
	(inst-step  `(inst -1 ,@exprs))
	(step (if (stringp lemma)
		  `(then ,lemma-step ,inst-step)
		  (gen-manip-response 'apply-lemma "LEMMA must be a string."))))
    step)
  "Try applying a lemma (via USE) with explicit instantiations using an
implicit variable list.  In PVS, lemma variables appear in alphabetical
order when introduced by the LEMMA rule.  That order needs to be observed
when entering EXPR-SPECS."
  "~%Invoking lemma ~A on given expressions")

(defstep apply-rewrite (lemma &rest expr-specs)
  (let ((exprs (mapcar #'virt-ee-string (eval-ext-expr expr-specs)))
	(lemma-step `(lemma ,lemma))
	(inst-step  `(inst -1 ,@exprs))
	(replace-step (try-fail-announce '(replace -1 :hide? t)
					 'apply-rewrite "Replacement"))
	(step (if (stringp lemma)
		  `(then ,lemma-step ,inst-step ,replace-step)
		  (gen-manip-response 'apply-rewrite
				      "LEMMA must be a string."))))
    step)
  "Try applying a (purely equational) rewrite rule with explicit
instantiations using an implicit variable list.  In PVS, lemma variables
appear in alphabetical order when introduced by the LEMMA rule.  That
order needs to be observed when entering EXPR-SPECS."
  "~%Rewriting with lemma ~A on given expressions")


;;; =============== Misc. utility strategies ===============

(defstep else* (&rest steps)
  (if (null steps)
      (skip)
      (let ((try-step `(try ,(car steps) (skip) (else*$ ,@(cdr steps)))))
	try-step))
  "Try STEPS in sequence until the first one succeeds."
  "~%Trying steps in sequence")

(defstep try-rewrites (fnums &rest lemmas)
  (if (null lemmas)
      (skip)
      (let ((try-step `(try (rewrite ,(car lemmas) ,(extract-fnums-arg fnums))
			    (skip)
			    (try-rewrites$ ,fnums ,@(cdr lemmas)))))
	try-step))
  "Try rewriting LEMMAS in sequence within FNUMS until first one succeeds."
  "~%Trying lemma rewrites in sequence")

;;; Following strategy provides an alternative to REWRITE for use when
;;; exact instantiations are desired or when certain automatic
;;; instantiations are problematic.  Note that it can propagate (FAIL).
;;; Be sure to protect by using it within a TRY rule.

(defhelper explicit-rewrite (lemma-name fnum &rest terms)
  (let ((adj-fnum (if (< fnum 0) (- fnum 1) fnum))
	(term-strings (if (every #'stringp terms)
			  terms
			  (mapcar #'(lambda (term) (textify term)) terms)))
	(inst-step `(inst -1 ,@term-strings)))
    (then@ (lemma lemma-name)
	   inst-step
	   (if (typep (manip-get-formula -1) 'forall-expr)
	       (fail)
	       (replace -1 adj-fnum :hide? t))))
  "Alternative form of REWRITE using explicit terms, propagating failure if INST fails."
  "~%Rewriting with lemma ~A in formula ~A")


;;; =============== Extended expression evaluation ===============

;;; The following functions implement a unified method of accessing
;;; PVS expressions using both textual pattern matching and indexed
;;; term referencing.

(define-exclusively  ;;; detect package name clashes in following definitions

(defconstant loc-ref-symb        '!  )
(defconstant pat-match-symb      '?  )
(defconstant deep-wild-all       '** )
(defconstant deep-wild-term      '-* )   ;; '<* ?
(defconstant deep-wild-nonterm   '*- )   ;; '*< ?
(defconstant goto-index-symb     '-> )
(defconstant goto-all-symb       '->* )
(defconstant all-but-symb        '^  )   ;; '*- ?
(defconstant all-but-ante        '-^ )   ;; '-- ?
(defconstant all-but-cons        '+^ )   ;; '+- ?
(defconstant rich-pat-char       #\@ )
(defconstant subst-symb-char     #\$ )

(defconstant ext-expr-symbols (list loc-ref-symb pat-match-symb))
(defconstant deep-wild-symbols
  (list deep-wild-all deep-wild-term deep-wild-nonterm))
(defconstant goto-index-symbols (list goto-index-symb goto-all-symb))
(defconstant all-but-symbols (list all-but-symb all-but-ante all-but-cons))
(defconstant all-but-dict
  (list (cons all-but-symb '*) (cons all-but-ante '-) (cons all-but-cons '+)))

)  ;;; end (define-exclusively

;;; The structure for extended expression descriptors saves the
;;; expression's string representation, its formula number, and its
;;; PVS CLOS object.  Only the string is guaranteed to exist.  There
;;; is a kind of lazy evaluation implemented, however, wherein the
;;; string is not initially stored if the PVS object exists.  It
;;; will be generated (but not stored) on first access.  Use the
;;; function virt-ee-string rather than the slot accessor ee-string.

(defstruct (ee-descriptor (:conc-name ee-))
  (string nil) (fnum nil) (pvs-obj nil))

(define-exclusively  ;;; detect package name clashes in following definitions

(defun virt-ee-string (descriptor)
  (if (ee-descriptor-p descriptor)
      (or (ee-string descriptor) (textify (ee-pvs-obj descriptor)))
      ""))

(defun ee-obj-or-string (descriptor)
  (if (ee-descriptor-p descriptor)
      (or (ee-pvs-obj descriptor) (ee-string descriptor))
      ""))

;;; Compute expression(s) specified by argument.  Return a list of
;;; expression descriptors, each of which is a structure of the form:
;;; #S(<expr string> <fnum> <CLOS object>).  Some descriptors have
;;; only a string component, allowing the others to be nil.

(defun eval-ext-expr (expr)
  (cond ((stringp expr) (list (make-ee-descriptor :string expr)))
	((numberp expr) (fnum->descriptor-list expr))
	((symbolp expr) (mapcan #'fnum->descriptor-list (map-fnums-arg expr)))
	((ee-descriptor-p expr) (list expr))
	((consp expr)
	 (cond ((eq (car expr) pat-match-symb)
		(let ((subexpr (eval-ext-expr (cadr expr))))
		  (mapcan #'(lambda (e) (match-one-expr e (cddr expr)))
			  subexpr)))
	       ((eq (car expr) loc-ref-symb)
		(let ((subexpr (eval-ext-expr (cadr expr))))
		  (mapappend #'(lambda (e) (ref-one-expr e (cddr expr)))
			     subexpr)))
	       ((every #'ee-descriptor-p expr) expr)
	       ((member (car expr) all-but-symbols)
		(mapcan #'fnum->descriptor-list (map-fnums-arg expr)))
	       (t (mapappend #'eval-ext-expr expr))))
	(t nil)))

;;; Convert a formula number to a list of expression descriptors by
;;; constructing the string form of the formula.  Returns either a list
;;; of length 1 for a valid number or nil.

(defun fnum->descriptor-list (fnum)
  (let ((obj (manip-get-formula fnum)))
    (if obj
	(list (make-ee-descriptor ;; :string (textify obj)
	                          :fnum fnum :pvs-obj obj))
        nil)))

;;; Apply pattern matching and construct a list of expression descriptors
;;; for all captured strings resulting from the match.

(defun match-one-expr (expr patterns)
  (let* ((regexp-pat (percent-to-regexp-pattern patterns)) ;; compile pattern?
	 (fnum     (if (ee-descriptor-p expr) (ee-fnum expr) nil))
	 (match (match-expr regexp-pat expr)))
    (if (ee-descriptor-p match)
	(progn (setf (ee-fnum match) fnum) (list match))
        (and (car match)
	     (mapcar #'(lambda (m) (make-ee-descriptor :string m :fnum fnum))
		     (or (cddr match) '("")) )))))


;;; --------------- Locations references ----------------

;;; Recursively descend the expression tree to arrive at the subexpression(s)
;;; specified by the list of indexes.  Returns a list of descriptors.
;;; If no object found in input descriptor, return nil.

(defun ref-one-expr (descriptor indexes)
  (let ((top-obj (ee-pvs-obj descriptor))
	(fnum    (ee-fnum descriptor)))
    (labels
      ((make-descriptor (obj)
	 (make-ee-descriptor ;; :string (textify obj)
			     :fnum fnum :pvs-obj obj))
       (ref-next-level (obj indices)
         (cond
	  ((null obj) nil)
	  ((null indices) (list (make-descriptor obj)))
	  (t (let ((index (car indices))
		   (rest  (cdr indices))
		   (children (next-lower-objects obj)))
	       (cond
		((eq index '*)
		 (mapappend #'(lambda (child) (ref-next-level child rest))
			    children))
		((or (stringp index)
		     (and (consp index) (every #'stringp index)))
		 (if (match-function-symbol obj index)
		     (ref-next-level obj rest)
		     nil))
		((and (consp index) (member (car index) goto-index-symbols))
		 (cond ((null (cdr index)) (ref-next-level obj rest))
		       ((match-function-symbol obj (cadr index))
			(ref-next-level
			  obj (cons (cons (car index) (cddr index)) rest)))
		       ((eq (car index) goto-index-symb)
			(loop for child in children
			      when (ref-next-level child indices)
			      return it))
		       (t (mapappend       ;; goto all
			   #'(lambda (child) (ref-next-level child indices))
			   children))))
		((member index deep-wild-symbols)
		 (let ((lower (mapappend #'(lambda (child)
					     (ref-next-level child indices))
					 children))
		       (contin (ref-next-level obj rest)))
		   (cond
		     ((eq index deep-wild-term) (if children lower contin))
		     ((eq index deep-wild-nonterm)
		      (and children (append contin lower)))
		     ((eq index deep-wild-all) (append contin lower)))))
		((and (consp index) (eq (car index) all-but-symb))
		 (let ((excl (mapcar #'(lambda (n) (symbolic-index n children))
				     (cdr index))))
		   (mapappend #'(lambda (child) (ref-next-level child rest))
			      (mapcar #'(lambda (n) (nth n children))
				      (bag-difference (consec (length children))
						      excl)))))
		((and (consp index)
		      (every #'(lambda (x) (or (numberp x) (symbolp x)))
			     index))
		 (mapappend #'(lambda (child) (ref-next-level child rest))
			    (mapcar #'(lambda (n) (symbolic-nth n children))
				    index)))
		((eql index 0) 
		 (and (typep obj 'application)
		      (ref-next-level (operator obj) rest)))
		(t (ref-next-level (symbolic-nth index children) rest))))))))
      (ref-next-level top-obj indexes))))

;;; Try to match the function/operator symbol of an expression against
;;; a string or list of patterns.  For a string use simple equality.
;;; For a list do pattern matching.

(defun match-function-symbol (obj patterns)
  (handler-case
    (let ((op (textify (operator obj))))
      (if (consp patterns)
	  (match-one-expr op patterns)
	  (equal op patterns)))
    (error (condition) nil)))

;;; Translate symbolic, negative and 1-based indexes into proper numeric
;;; indexes, then apply nth to select an object.

(defun symbolic-nth (index objects)
  (let ((num-index (symbolic-index index objects)))
    (and num-index (nth num-index objects))))

(defun symbolic-index (index objects)
  (cond ((eq index 'l) 0)
	((eq index 'r) 1)
	((numberp index)
	 (let ((shifted-index
		(if (minusp index) (+ index (length objects)) (- index 1))))
	   (and (>= shifted-index 0) shifted-index)))
	(t nil)))

;;; Descend to next lower objects in expression tree.  For certain
;;; associative and commutative operators, observe some tree
;;; "flattening" and allow index to select nth term from those
;;; at the same "level".  Returns a list of objects.

(defun next-lower-objects (obj)
  (and obj
       (handler-case
	 (cond ((and (typep obj 'infix-application)
		     (member (id (operator obj)) '(+ -)))
		(mapcar #'cadr (collect-additive-terms '+ obj)))
	       ((and (typep obj 'infix-application)
		     (eq (id (operator obj)) '*))
		(collect-multiplicative-terms obj))
	       (t (let ((arg (argument obj)))
		    (cond ((typep arg 'arg-tuple-expr) (exprs arg))
			  ((listp arg) arg)
			  (t (list arg))))))
	 (error (condition) nil))))


;;; ------------------ Pattern matching ------------------

;; Map a pattern involving %-variables (capturing text fields) into a
;; regular expression suitable for matching and collecting substrings.
;; Return a list of regular expression pattern strings.

(defun percent-to-regexp-pattern (pattern)
  (let ((pattern-list (if (listp pattern) pattern (list pattern))))
    (mapcar #'(lambda (pat)
		(replace-substrings "\\b*" " "  ;; arbitrary whitespace on " "
				    (map-percent-fields pat)))
	    pattern-list)))

;; Escape regular expression meta-characters by prefixing them with "\\".

(defun escape-regexp-metachars (pattern)
  (map-string #'(lambda (c)
		  (if (member c metachars-regexp) (list #\\ c) (list c)))
	      pattern))

;; Regular expression metachars:
(defvar metachars-regexp (map 'list #'(lambda (c) c) "][.*+$\\^"))

;; Map text field designators from pattern language into regular expression
;; syntax.  A pattern may be "simple", having only one field type (arbitrary
;; text) and one matching type (partial), or "rich", having multiple field
;; types and matching types.  A rich pattern begins with the character `@'
;; followed by the match type.  Simple patterns have neither.
;; Each rich field is 3 characters long having the format:
;; `% <digit> <field type>'.  If the digit is 0, it's a noncapturing field.
;; If it's the first occurrence of digit d, create a capturing field for it.
;; Otherwise, it's a reference to a previously captured field that it must
;; match.  Digits used must be consecutive (e.g., can't have "%1* %3*").
;; Simple fields are 2 characters long, `% <digit>'.

(defun map-percent-fields (pattern)
  (do* ((next-index 1) (posn t) (fragments '()) (edge 0)
	(len (length pattern))
	(is-rich (and (> len 0) (eq (char pattern 0) #\@))))
      ((not posn)
       (apply #'concatenate
	      'string
	      (reverse (cons (escape-regexp-metachars (subseq pattern edge))
			     fragments))))
    (setf posn (position #\% pattern :start edge))
    (when posn
      (push (escape-regexp-metachars (subseq pattern edge posn)) fragments)
      (let ((index-char (if (< posn (- len 1)) (char pattern (1+ posn)) #\_)))
	(push (cond ((eq index-char #\0)
		     (if is-rich
			 (multiple-value-bind (desig-len field-pattern)
			     (match-field-pattern pattern (+ posn 2) nil)
			   (setf edge (min len (+ posn desig-len)))
			   field-pattern)
		         (progn (setf edge (min len (+ posn 2)))
				".*")))
		    ((digit-char-p index-char)
		     (let ((index (parse-integer (string index-char))))
		       (cond ((< index next-index)
			      (setf edge (+ posn 2))
			      (format nil "\\~A" index))
			     (is-rich
			      (multiple-value-bind (desig-len field-pattern)
				  (match-field-pattern pattern (+ posn 2) t)
				(incf next-index)
				(setf edge (min len (+ posn desig-len)))
				field-pattern))
			     (t (incf next-index)
				(setf edge (min len (+ posn 2)))
				"\\(.*\\)"))))
		    (t (setf edge (1+ posn)) "%"))
	      fragments)))))

;; Build sub-patterns for rich pattern string fields.
;; Field type characters include:
;;   * -- zero or more arbitrary characters
;;   + -- one or more arbitrary characters
;;   & -- one or more arbitrary characters, where first & last are
;;        non-whitespace characters; (doesn't handle length 1 case yet)
;;   i -- PVS identifier (allows ! for prover variables)
;;   # -- numeric field (digits only)
;;   s -- special symbols (not implemented yet)
;;   none of the above -- same as *
;; If a capturing field is requested, wrap it in parentheses.

(defun match-field-pattern (pattern posn capture)
  (let* ((field-type (if (< posn (length pattern)) (char pattern posn) nil))
	 (field-desig-len 3)
	 (field-pattern (case field-type
			  ((#\*) ".*")
			  ((#\+) ".+")
			  ((#\&) "\\B.*\\B")
			  ((#\#) "[0-9]+")
			  ((#\i) "[a-zA-Z][a-zA-Z0-9?_!]*")
;;;;		              ((#\s) "")  ;; special symbols -- add later
			  (t (setf field-desig-len 2) ".*"))))
    (values field-desig-len
	    (if capture
		(format nil "\\(~A\\)" field-pattern)
	        field-pattern))))

;; Match patterns in pattern list against a string or ee-descriptor.
;; Patterns are tried in order.  Search stops on first successful match.
;; Result is either a list form as returned by excl:match-regexp or an
;; ee-descriptor value.

(defun match-expr (patterns str-or-expr)
  (let ((expr (if (stringp str-or-expr)
		  (make-ee-descriptor :string str-or-expr)
		str-or-expr)))
    (loop for pat in patterns
          when (let ((match (if (> (length pat) 0)
				(match-expr-pattern pat expr)
			        (list t nil ""))))
		 (and (expr-match-success match) match))
	  return it)))

(defun expr-match-success (match)
  (or (ee-descriptor-p match) (car match)))

;; Match a pattern against a string using the second character of the
;; pattern to select the match type (for rich patterns) or using a partial
;; match (for simple patterns).  Types include:
;;   f       -- full string match
;;   p       -- partial string match (first substring to match pattern)
;;   s       -- partial match returning original string (obj) if successful
;;   t       -- top-down expression matching
;;   b       -- bottom-up expression matching
;;   <digit> -- top-down expr matching, skipping top-most <digit> levels
;;   none of the above -- partial string match
;; Pattern must be already converted to regexp format.
;; Returns either an ee-descriptor or a list value as returned by
;; excl:match-regexp.

(defun match-expr-pattern (pattern descriptor)
  (let* ((is-rich (eq (char pattern 0) rich-pat-char))
	 (match-type (if is-rich (char pattern 1) #\p))
	 (regexp-pat (if is-rich (subseq pattern 2) pattern)))
    (if (member match-type '(#\f #\p #\s))
	(let ((expr-text (virt-ee-string descriptor)))
	  (case match-type
	    ((#\f) 
	     (multiple-value-list
	      (excl:match-regexp (format nil "^~A$" regexp-pat) expr-text)))
	    ((#\p) 
	     (multiple-value-list (excl:match-regexp regexp-pat expr-text)))
	    ((#\s) 
	     (let ((match (multiple-value-list
			   (excl:match-regexp regexp-pat expr-text))))
	       (if (car match)
		   (make-ee-descriptor ;; :string expr-text
		                       :pvs-obj (ee-pvs-obj descriptor))
		   match)))))
        (let ((expr-obj (ee-pvs-obj descriptor)))
	  (cond ((eq match-type #\t)
		 (top-down-expr-match regexp-pat expr-obj 0))
		((digit-char-p match-type) 
		 (top-down-expr-match regexp-pat expr-obj
				      (parse-integer (string match-type))))
		((eq match-type #\b)
		 (bottom-up-expr-match regexp-pat expr-obj))
            ;; none of the above -- do partial match, keep first pattern char
		(t (multiple-value-list
		    (excl:match-regexp (subseq pattern 1)
				       (virt-ee-string descriptor)))))))))

;; Apply pattern to match subexpressions of an expression in top-down
;; fashion (pre-order traversal).  Skip top-most n layers while matching.
;; Currently handles basic function applications (infix and prefix).
;; Yet to be added is support for various syntactic forms of PVS.

(defun top-down-expr-match (pattern expr-obj skip)
  (labels ((expr-match (expr depth)
	     (let ((node-match
		    (and (>= depth skip)
			 (multiple-value-list
			  (excl:match-regexp pattern (textify expr))))))
	       (if (car node-match)
		   node-match
		   (let ((expr-arg (handler-case (argument expr)
						 (error (condition) nil))))
		     (and expr-arg
			  (handler-case 
			    (do ((subexprs (exprs expr-arg) (cdr subexprs))
				 (match nil))
				((or (car match) (null subexprs)) match)
			      (setf match
				    (expr-match (car subexprs) (1+ depth))))
			    (error (condition)
				   (expr-match expr-arg (1+ depth))))))))))
    (expr-match expr-obj 0)))

;; Apply pattern to match subexpressions of an expression in bottom-up
;; fashion (post-order traversal).

(defun bottom-up-expr-match (pattern expr-obj)
  (labels ((expr-match (expr)
	     (let ((subtree-match
		    (let ((expr-arg (handler-case (argument expr)
						  (error (condition) nil))))
		      (and expr-arg
			   (handler-case 
			     (do ((subexprs (exprs expr-arg) (cdr subexprs))
				  (match nil))
				 ((or (car match) (null subexprs)) match)
			       (setf match (expr-match (car subexprs))))
			     (error (condition) (expr-match expr-arg)))))))
	       (if (car subtree-match)
		   subtree-match
		   (multiple-value-list
		    (excl:match-regexp pattern (textify expr)))))))
    (expr-match expr-obj)))


;;; --------------- Parameterized command substitution ----------------

;; Build instantiated command by substituting for special expression
;; symbols.  Includes:
;;    $1, $2, ...   -- nth expression descriptor
;;    $*            -- list of all expression descriptors
;;    $1s, $2s, ... -- nth expression text string
;;    $*s           -- list of all text strings
;;    $1n, $2n, ... -- number of nth originating formula
;;    $*n           -- list of originating formula numbers
;;    $1j, $2j, ... -- nth expression CLOS object
;;    $*j           -- list of all expression CLOS objects
;;    $+, $+s, $+n, $+j -- no-duplicates versions of $*, $*s, $*n, $*j

;; Also substitute for %-variables and implement embedded extended
;; expression shortcuts.

(defun build-instan-cmd (cmd descriptors)
  (labels ((build-cmd (expr)
	     (cond ((stringp expr)
		    (let ((str-values (mapcar #'virt-ee-string descriptors)))
		      (percent-subst-ext (percent-subst-all
					  (percent-subst expr str-values)
					  str-values)
					 str-values)))
		   ((symbolp expr)
		    (multiple-value-prog1 (cmd-symbol-subst expr descriptors)))
		   ((and (consp expr) (member (car expr) ext-expr-symbols))
		    (values-list (mapcar #'ee-fnum (eval-ext-expr expr))))
		   ((consp expr)
		    (mapcan #'(lambda (e)
				(multiple-value-list (build-cmd e)))
			    expr))
		   (t expr))))
    (handler-case (build-cmd cmd) (error nil))))

;; Embedded extended expressions are allowed in strings using the form
;; "%! ...%".  Extract these, convert to (! ...) form, evaluate them,
;; and substitute them in the target (pattern) string.  Regular %-vars
;; (%1, %2, etc.) may also be included, which get substituted first.

(defconstant embedded-ext-expr-pattern
  (excl:compile-regexp ".*%\\(.*\\)%.*"))

(defun percent-subst-ext (pattern values)
  (loop with target = pattern with index = t
        do (setf index (multiple-value-list
			(excl:match-regexp embedded-ext-expr-pattern target
					   :return :index :shortest t)))
	unless (car index) return target
	do (let* ((ext (caddr (multiple-value-list
			       (excl:match-regexp embedded-ext-expr-pattern
						  target :shortest t))))
		  (ext-expr (eval-ext-expr
			     (read-from-string (format nil "(~A)" ext))))
		  (ext-str (if (consp ext-expr)
			       (virt-ee-string (car ext-expr))
			       ""))
		  (start (- (caaddr index) 1))
		  (finish (1+ (cdaddr index))))
	     (setf target (replace-substring ext-str target start finish)))))
					     

(defun cmd-symbol-subst (symb descriptors)
  (let ((name (symbol-name symb)))
    (if (eql (char name 0) subst-symb-char)
	(let* ((num (char name 1))
	       (index (if (digit-char-p num)
			  (- (read-from-string (subseq name 1 2)) 1)
			  num))
	       (d-func (if (= (length name) 2) 
			   #'identity
;;;;; use downcased chars for new Allegro 6.2 case-sensitive Lisp
			   (case (char-downcase (char name 2))
			     ((#\s) #'virt-ee-string)
			     ((#\n) #'ee-fnum)
			     ((#\j) #'ee-pvs-obj)))))
	  (cond ((numberp index)
		 (funcall d-func (nth index descriptors)))
		((eql index #\+)
		 (values-list (remove-duplicates (mapcar d-func descriptors)
						 :test #'equalp :from-end t)))
;; note: equalp causes case of strings to be ignored
		(t (values-list (mapcar d-func descriptors)))))
      symb)))


;;; ==================== Support functions =====================

;;; ------------------ Proof step generators ------------------

(defun try-fail-announce (step name description)
  (let ((failure (format nil "~A unsuccessful." description)))
    `(try ,step (skip) ,(gen-manip-response name failure))))

(defun try-justification (name try-just)
  (let* ((just-rule (if (eq try-just t) '(grind) try-just))
	 (message
	  (if just-rule
	      (format nil "Justification proof using ~A is unfinished;
undoing proof attempt." just-rule)
	      (format nil "Justification proof is untried."))))
    (if just-rule
	`(try (then ,just-rule (fail))  ;; fail if not completely proved
	      (skip)
	      ,(gen-manip-response name message))
        (gen-manip-response name message))))

;;; Generates steps to try rewriting with lemmas in sequence using given
;;; terms for explicit substitution.

(defun rewrite-until-justified (lemma-names fnum &rest terms)
  (if (= (length lemma-names) 1)
      `(explicit-rewrite$ ,(car lemma-names) ,fnum ,@terms)
      `(try (then (explicit-rewrite$ ,(car lemma-names) ,fnum ,@terms)
		  (if (eql (get-goalnum *ps*) 1)
		      (skip)
		      (then (assert) (fail))))  ;; backtrack if not proved
	    (skip)
	    ,(apply #'rewrite-until-justified (cdr lemma-names) fnum terms))))

;; Generate an error/status message step using skip-msg.  Forces printing by
;; default.  A Manip user, however, which might be another strategy package,
;; can override this setting and suppress the message.

(defun gen-manip-response (name msg &optional (force-printing? t))
  (if *suppress-manip-messages*
      '(skip)
      `(skip-msg ,(format nil "[Manip.~A]  ~A" name msg) ,force-printing?)))

(defvar *suppress-manip-messages* nil)  ;;; consider alternative mechanism

(defun gen-value-warning (name val symb legit &optional (force-printing? t))
  (if (or *suppress-manip-messages* (member val legit :test #'equal))
      '()
      (let ((msg (format nil "[Manip.~A]  Value ~A for ~A should be one of ~A."
			 name val (string-upcase (symbol-name symb)) legit)))
	`((skip-msg ,msg ,force-printing?)))))   ;; returns nil or list of one


;;; ------------------ Term/expression utilities ------------------

(defun is-term-operator (term-obj op)
  (and (typep term-obj 'infix-application) (eq (id (operator term-obj)) op)))

(defun is-relation (expr &optional inequality?)
  (and (typep expr 'infix-application)
       (member (id (operator expr)) 
	       (if inequality? '(< <= > >=) '(= < <= > >=)))))

(defun both-sides-same-op (formula operators)
  (let ((lhs (args1 formula)) (rhs (args2 formula)))
    (and (typep lhs 'infix-application)
	 (member (id (operator lhs)) operators)
	 (typep rhs 'infix-application)
	 (eq (id (operator lhs)) (id (operator rhs))))))

;; Next two functions should always be called with a validated operator symbol.

(defun reverse-relation (operator)
  (case operator ((<) '>) ((<=) '>=) ((>) '<) ((>=) '<=) ((=) '=)))

(defun negate-inequality (operator)
  (case operator ((<) '>=) ((<=) '>) ((>) '<=) ((>=) '<)))

;; Get list of term numbers, converting * as needed.  Also accommodate
;; form (^ n1 ... nk) for all numbers but n1,...,nk.

(defun map-term-nums-arg (tnums num-terms)
  (labels ((map-num (num)
             (cond ((eq num '*)
		    (mapcar #'1+ (consec num-terms)))
		   ((stringp num)
		    (map-num (read-from-string num)))
		   (t (and (integerp num)  (not (zerop num))
			   (<= (- num-terms) num num-terms)
			   (list (if (< num 0) (+ num num-terms 1) num)))))))
    (cond ;;((eq tnums '*) (mapcar #'1+ (consec num-terms)))
	  ((and (consp tnums) (eq (car tnums) all-but-symb))
	   (let ((all-nums (mapcar #'1+ (consec num-terms))))
	     (bag-difference all-nums (mapcan #'map-num (cdr tnums)))))
	  ((listp tnums) (mapcan #'map-num tnums))
	  (t (map-num tnums)))))

;; Add parens if necessary to protect expression from combining
;; with adjacent infix operators.

(defun safety-parens (expr)
  (if (or (and (stringp expr)
	       (not (expr-match-success
		      (match-expr non-infix-expr-patterns expr))))
	  (and (typep expr 'infix-application) (zerop (parens expr))))
      (format nil "(~A)" expr)
      (textify expr)))

;;;;;;;;;;;;;;;;;;;;

;; Extract the NUM left-most or right-most terms (indicated by END = L or R),
;; returning a list of objects in their original order.

(defun get-end-terms (full-expr end num)
  (if (typep full-expr 'infix-application)
      (let ((top-op (case (id (operator full-expr))
		      ((+ -) '(+ -))
		      ((*) '(*))      ;;; ((* /) '(* /))
		      (t     nil))))
	(labels ((find-terms (expr n)
		   (cond ((zerop n) nil)
			 ((not (typep expr 'infix-application)) (list expr))
			 ((not (member (id (operator expr)) top-op))
			  (list expr))
			 ((eq end 'l) 
			  (let ((terms (find-terms (args1 expr) n)))
			    (append terms
				    (find-terms (args2 expr)
						(- n (length terms))))))
			 (t (let ((terms (find-terms (args2 expr) n)))
			      (append (find-terms (args1 expr)
						  (- n (length terms)))
				      terms))))))
	  (find-terms full-expr num)))
      (list full-expr)))


;;; ------------------ Arithmetic term synthesis ------------------

;; Generate additive terms having form ((+/- term-obj) ... (+/- term-obj)).

(defun collect-additive-terms (sign expr)
  (if (typep expr 'infix-application)
      (let ((op (id (operator expr))))
	(if (member op '(+ -))
	    (append (collect-additive-terms sign (args1 expr))
		    (collect-additive-terms (xor-signs sign op) (args2 expr)))
	    (list (list sign expr))))
      (list (list sign expr))))

(defun xor-signs (s1 s2)
  (cond ((eq s1 '+) s2) ((eq s2 '+) '-) (t '+)))

;; Fuse terms t1, ..., tn into the sum [-] t1 +/- t2 +/- ... +/- tn.

(defun make-new-addition (terms suppress-leading-plus)
  (let ((str-terms
	 (mapcar #'(lambda (x) (format nil (if (symbolp x) " ~A " "~A") x))
		 (apply #'append terms))))
    (apply #'concatenate 'string 
	   (cond ((and suppress-leading-plus (eq (caar terms) '+))
		  (cdr str-terms))
		 (terms str-terms)
		 (t '("0"))))))

;;;;;;;;;;;;;;;;;;;;

;; Compute list of common factors from list of list of factors.
;; If none found, use "1" as common factor.

(defun find-common-factors (candidates)
  (do ((common (car candidates)) (rest (cdr candidates)))
      ((null rest) (or common '("1")))
    ;; Use reverse to keep original order:
    (setf common (bag-intersection common (car rest)))
    (setf rest (cdr rest))))

;; Factor out common divisors from integer coefficients.  If all
;; multiplicative terms contain integer factors, find their gcd.
;; If gcd > 1, divide each term by the common divisor.  The reduced
;; numbers are returned as Lisp numbers rather than the PVS objects
;; from which they were derived.

(defun extract-gcds (terms)
  (let ((num-list (find-num-factors terms t))
	(nonnum-list (find-num-factors terms nil)))
    (if (member nil num-list)
	terms
        (let* ((nums (mapcar #'(lambda (factors) (reduce #'* factors))
			     num-list))
	       (common-abs (apply #'gcd nums))
	       (common (if (every #'minusp nums) (- common-abs) common-abs)))
	  (if (= common 1)
	      terms
	      (let ((reduced (mapcar #'(lambda (n) (/ n common)) nums)))
		(mapcar #'(lambda (num nonnums)
			    (cons common
				  (if (= num 1) nonnums (cons num nonnums))))
			reduced nonnum-list)))))))

;; Find and extract numeric factors or the complement of same.  Assumes
;; negative numbers are in the form of a unary minus expression.  Numbers
;; are converted from PVS objects to Lisp integers.

(defun find-num-factors (terms numeric?)
  (flet ((numbered-factors (term)
	   (mapcar #'(lambda (factor)
		       (cond ((typep factor 'number-expr)
			      (number factor))
			     ((and (typep factor 'unary-application)
				   (eq (id (operator factor)) '-)
				   (typep (argument factor) 'number-expr))
			      (- (number (argument factor))))
			     (t factor)))
		   term)))
    (mapcar #'(lambda (term)
		(mapcan #'(lambda (factor)
			    (and (eq numeric? (integerp factor))
				 (list factor)))
		        (numbered-factors term)))
	    terms)))

(defun strip-common-factors (terms common)
  (mapcar #'(lambda (e) (or (bag-difference e common) '("1"))) terms))

;; Generate multiplicative terms having form (term-obj ... term-obj).

(defun collect-multiplicative-terms (expr)
  (if (typep expr 'infix-application)
      (let ((op (id (operator expr))))
	(if (eq op '*)
	    (append (collect-multiplicative-terms (args1 expr))
		    (collect-multiplicative-terms (args2 expr)))
	    (list expr)))
      (list expr)))

;; Fuse terms t1, ..., tn into product t1 * t2 * ... * tn.

(defun make-new-product (terms &optional (parens? t))
  (case (length terms)
    ((0) "1")
    ((1) (textify (car terms)))
    (t (apply #'concatenate 'string
	      (append (mapcar (if parens?
				  #'(lambda (f) (format nil "~A * "
							(safety-parens f)))
				  #'(lambda (f) (format nil "~A * " f)))
			      (butlast terms))
		      (list (if parens?
				(safety-parens (car (last terms)))
			        (textify (car (last terms))))) )))))

;; Generate con/disjunctive terms having form (term-obj ... term-obj).

(defun collect-con/disjunctive-terms (bool-expr conj?)
  (let ((class (if conj? 'infix-conjunction 'infix-disjunction)))
    (labels ((collect-terms (expr)
	       (if (typep expr class)
		   (append (collect-terms (args1 expr))
			   (collect-terms (args2 expr)))
		   (list expr))))
      (collect-terms bool-expr))))

;; Fuse terms t1, ..., tn into con/disjunction t1 op t2 op ... op tn.

(defun make-new-con/disjunction (terms conj? &optional (parens? t))
  (case (length terms)
    ((0) (if conj? "TRUE" "FALSE"))
    ((1) (textify (car terms)))
    (t (apply #'concatenate 'string
	      (let ((op (if conj? "AND" "OR")))
		(append (mapcar (if parens?
				    #'(lambda (b) (format nil "~A ~A "
							  (safety-parens b) op))
				    #'(lambda (b) (format nil "~A ~A " b op)))
				(butlast terms))
			(list (if parens?
				  (safety-parens (car (last terms)))
			          (textify (car (last terms))))) ))))))


;;; ---------------- Formula utility functions ----------------

;;; Get formula from current goal (unnegated if antecedent formula).
;;; Assumes symbolic and other forms have already been converted to
;;; numbers using map-fnums-arg.

(defun manip-get-formula (fnum)
  (if (numberp fnum)
      (let ((index (- (abs fnum) 1))
	    (goal (current-goal *ps*)))
	(handler-case
	    (if (> fnum 0)
		(formula (nth index (p-sforms goal)))
	        (argument (formula (nth index (n-sforms goal)))))
	  (error (condition) nil)))
      nil))

;;; Collect fnums for equality hypotheses

(defun get-equalities ()
  (gather-fnums (s-forms (current-goal *ps*)) '- nil
		#'(lambda (sf) (and (negation? (formula sf))
				    (equation? (args1 (formula sf)))))))

;;; Collect fnums for relation formulas in current sequent (except /=)

(defun get-relations (fnums)
  (gather-fnums (s-forms (current-goal *ps*)) fnums nil
		#'(lambda (sf)
		    (let* ((any (formula sf))
			   (form (if (negation? any) (argument any) any)))
		      (and (typep form 'infix-application)
			   (member (id (operator form)) '(= < <= > >=)))))))

(defconstant true-predicate #'(lambda (sf) t))

;;; Get list of formula numbers, converting *,-,+ as needed.  Also
;;; converts formula labels (symbols).  Also accommodate form
;;; (^ n1 ... nk) for all numbers but n1,...,nk.  (+^ ...) and (-^ ...)
;;; do the same for antecedents, consequents.

(defun map-fnums-arg (fnums)
  (cond ((numberp fnums) (list fnums))
	((or (stringp fnums) (symbolp fnums))
	 (gather-fnums (s-forms (current-goal *ps*))
		       fnums nil true-predicate))
	((and (consp fnums) (member (car fnums) all-but-symbols))
	 (let ((all-nums (map-fnums-arg
			  (cdr (assoc (car fnums) all-but-dict)))))
	   (bag-difference all-nums (mapappend #'map-fnums-arg (cdr fnums)))))
	((consp fnums) 
	 (remove-duplicates (mapappend #'map-fnums-arg fnums) :from-end t))
	(t nil)))

;;; Get list of formula numbers, converting *,-,+ as needed.  Also
;;; extracts fnum component from extended expression descriptors.

(defun extract-fnums-arg (fnums)
  (let ((nums (mapcar #'ee-fnum (eval-ext-expr fnums))
		     :from-end t))
    (remove-duplicates (mapcan #'(lambda (n) (and n (list n))) nums))))


;;; ------------------ Lemma name utilities ------------------

(defvar arith-op-name
  '((+ . "plus") (- . "minus") (* . "times") (/ . "div")))

(defvar real-props-relation
  '((= . "") (< . "lt") (<= . "le") (> . "gt") (>= . "ge")))

(defun prepend-underscore (str)
  (if (equal str "") "" (format nil "_~A" str)))


;;; ---------------- String utility functions ----------------

;;; Perform textual substitution of template variables %1, ..., %n
;;; using list of values provided.  Number of values must equal n.

(defun percent-subst (pattern str-values)
  (let ((result (copy-seq pattern)) (n 1))
    (dolist (v str-values)
      (let* ((p (percent-to-tilde n result))
	     (vals (make-list (car p) :initial-element v)))
	(setf result (apply #'format nil (cadr p) vals)))
      (incf n))
    result))

(defun percent-to-tilde (index str)
  (let* ((match-str (format nil "%~A" index)))
    (do ((done nil) (result str) (n 0 (1+ n)))
	(done (list (- n 1) result))
      (let ((posn (search match-str result)))
	(if posn
	    (setf result (replace result "~A" :start1 posn))
	    (setf done t))))))

;; Same as above except replaces "%*" by all values, and "%," by all
;; values with comma-space delimiters.

(defun percent-subst-all (pattern str-values)
  (let ((p (percent-to-tilde "*" pattern)))
    (if (zerop (car p))
	(progn (setf p (percent-to-tilde "," pattern))
	       (if (zerop (car p))
		   pattern
		   (let ((delim-values
			  (append (mapcar #'(lambda (s) (format nil "~A, " s))
					  (butlast str-values 1))
				  (last str-values))))
		     (format nil (cadr p)
			     (apply #'concatenate 'string delim-values)))))
        (format nil (cadr p) (apply #'concatenate 'string str-values)))))

;; Map a string into another of arbitrary length.  Argument func must take
;; a char and return a list of chars.

(defun map-string (func str)
  (coerce (loop for i from 0 below (length str)
	        append (funcall func (char str i)))
	  'string))

(defun replace-substring (new-str full-str start finish)
  (let ((s1 (subseq full-str 0 start))
	(s2 (subseq full-str finish)))
    (concatenate 'string s1 new-str s2)))

(defun replace-substrings (new-str match-str full-str &optional (count 10000))
  (do ((len (length match-str)) (rest full-str) (result '())
       (loc t) (num 0 (1+ num)))
      ((or (not loc) (>= num count))
       (apply #'concatenate 'string (reverse (cons rest result))))
    (setf loc (search match-str rest))
    (when loc
      (push (subseq rest 0 loc) result)
      (push new-str result)
      (setf rest (subseq rest (+ loc len))))))

(defvar whitespace-chars '(#\Space #\Tab #\Newline))


;;; ---------------- Misc. utility functions ----------------

(defun consec (n)  ;; Consecutive integers 0, ..., n-1.
  (loop for i from 0 below n collect i))

(defun bag-intersection (a b)
  (cond ((null a) nil)
	((member (car a) b :test #'equal)
	 (cons (car a)
	       (bag-intersection (cdr a)
				 (remove (car a) b :test #'equal :count 1))))
	(t (bag-intersection (cdr a) b))))

(defun bag-difference (a b)
  (cond ((null a) nil)
	((member (car a) b :test #'equal)
	 (bag-difference (cdr a) (remove (car a) b :test #'equal :count 1)))
	(t (cons (car a) (bag-difference (cdr a) b)))))

)  ;;; end (define-exclusively

(let ((count 0))
  (define-excl
    (defun name-gensym (str &optional (inc? t))
      (format nil "~A~A__" str (if inc? (incf count) count)))))


;;; ------------ Constants (depend on prior definitions) ------------

;; PVS expression strings not requiring surrounding parentheses are
;; filtered out using the following patterns.  Currently includes
;; numbers, identifiers and expressions with outermost parentheses.
;; Will add prefix function applications later when pattern language
;; is powerful enough to express it.

(define-exclusively
  (defconstant non-infix-expr-patterns
    (percent-to-regexp-pattern '("@f%1#" "@f%1i" "@f(%0*)")))
                                 ;;; "@f%1i(%0*)"))))  ;;; prefix funs

  (defconstant pvs-identifier-pattern
    (percent-to-regexp-pattern '("@f%1i")))
)

;;; ============= Utility functions called from Emacs Lisp =============

;;; ------------- Proof maintenance utilities --------------

;; Retrieve the rulebase-signatures file, which is needed by the
;; expand-strategy-steps function.

(unless (boundp '*pvs-rulebase-signatures*)
  (load "rulebase-signatures"))

(define-exclusively  ;;; detect package name clashes in following definitions

(defvar *pvs-rulebase-names* (mapcar #'car *pvs-rulebase-signatures*))

;; Interactive function to "expand" the strategy steps of a proof file.
;; Each proof rule is checked against a list of base rules found in
;; the core PVS distribution.  Any strategy name not found there is
;; appended with a `$' character so that its next proof will expand into
;; steps found only in the core rule base.  A backup file of the
;; original proofs is saved in a ".sprf" version of the proof file.

(defun expand-strategy-steps (prf-file sprf-file)
  (let ((current-proofs nil) (prev-strat-proofs nil))
    (with-open-file (prf prf-file :direction :input)
      (setf current-proofs 
	    (do ((p (read prf nil) (read prf nil)) (result '()))
		((not p) (reverse result))
	      (push p result))))
    (if (probe-file sprf-file)
	(with-open-file (prf sprf-file :direction :input)
	  (setf prev-strat-proofs
		(do ((p (read prf nil) (read prf nil)) (result '()))
		    ((not p) (reverse result))
		  (push p result))))
        (setf prev-strat-proofs nil))
    (with-open-file (prf sprf-file :direction :output :if-exists :supersede)
      (loop for theory in current-proofs
	    do (prin1 (save-new-strat-proofs theory
					     (cdr (assoc (car theory)
							 prev-strat-proofs)))
		      prf)
	    do (terpri prf))
      (terpri prf))
    (with-open-file (prf prf-file :direction :output :if-exists :supersede)
      (loop for theory in current-proofs
	    do (prin1 (expand-strat-proofs theory) prf)
	    do (terpri prf))
      (terpri prf)))
  nil)   ;; make sure Emacs gets nothing to complain about

;; Previously saved proofs in a .sprf file are retained and not overwritten;
;; otherwise, expanded forms of these proofs would wipe out the originals.
;; Only new proof instances will be appended (e.g., f-2 if only f-1 exists).

(defun save-new-strat-proofs (new-thy-prf prev-thy-proofs)
  (let* ((prev-fmla-names (mapcar #'car prev-thy-proofs))
	 (new-fmla-names  (mapcar #'car (cdr new-thy-prf)))
	 (old-fmla-proofs (loop for f in prev-thy-proofs
			        unless (member (car f) new-fmla-names)
				collect f))
	 (merged-proofs
	   (loop for f in (cdr new-thy-prf)
	     collect (if (member (car f) prev-fmla-names)
			 (append (list (car f) (cadr f))
				 (let* ((prfs (cddr (assoc (car f)
							   prev-thy-proofs)))
					(prev-names (mapcar #'car prfs)))
				   (loop for p in (cddr f)
				     collect (if (member (car p) prev-names)
						 (assoc (car p) prfs)
					         p))))
		         f))))
    (cons (car new-thy-prf) (append merged-proofs old-fmla-proofs))))

;; When the multiple proofs feature was added in PVS 3.0, the format of
;; proof files changed.  Each theory portion now takes the form:
;;   (theory-name
;;     (formula-name 0
;;       (name-n nil <number/nil> <number/nil> <proof-step-tree>
;;               unfinished nil <number/nil> <number/nil> t shostak)
;;       . . .
;;       (name-1 ...))  ;; first proof instance
;;     formula-2 ... formula-k)

(defun expand-strat-proofs (proofs)
  (labels ((subst-proof (proof)
	     (cond ((consp proof)
		    (if (symbolp (car proof))
			(let ((symb (symbol-name (car proof))))
			  (if (or (member (car proof) *pvs-rulebase-names*)
				  (eql (elt symb (- (length symb) 1)) #\$))
			      proof
			      (cons (intern (format nil "~A$" symb))
				    (cdr proof))))
		        (mapcar #'subst-proof proof)))
		   (t proof))))
    (cons (car proofs)
	  (loop for f in (cdr proofs)
	        collect (append (list (car f) (cadr f))
				(loop for p in (cddr f)
				  collect (replace-steps-in-prf
					    (subst-proof 
					      (extract-steps-from-prf p))
					      p)))))))
					

;; For proof files as of PVS 3.0:
(defun extract-steps-from-prf (proof) (nth 4 proof))
(defun replace-steps-in-prf (steps proof)
  (append (butlast proof 7) (list steps) (nthcdr 5 proof)))


;; Function to restore the strategy-steps version of a proof file as
;; saved in the ".sprf" file.  The backup file is simply renamed to
;; become the new ".prf" file.

(defun restore-strategy-steps (prf-file sprf-file)
  (rename-file sprf-file prf-file)
  nil)  ;; multiple values from rename-file cause problems with Emacs
  

;;; ------ Utility functions to support the TAB prover-helps features ------

;;; Construct the Lisp function signature for a rule or strategy
;;; known in the current state.  Downcase the symbols for easy
;;; reading by Emacs Lisp.

(defun rule-or-strategy-signature (name)
  (let* ((entry (or (gethash name *steps*)
		    (gethash name *rules*)))
	 (sig (cond (entry (formals entry))
		    (t (let ((val (gethash name *rulebase*)))
			 (and val
			      (let ((opt-args (optional-args val)))
				(append (required-args val)
					(if (or (null opt-args)
						(eq (car opt-args) '&rest))
					    '()
					    '(&optional))
					opt-args))))))))
    (write-to-string sig :case :downcase)))

)  ;;; end (define-exclusively


;;;;;;;;;;; NEW CODE ;;;;;;;;;;;


;;;;;;;;;;;
;; END
;;;;;;;;;;;