; $Id: axiom.scm,v 1.108 2010-01-14 23:05:19 logik Exp $
; 8. Assumption variables and axioms
; ==================================
; To be renamed into avars scheme, with the axioms section transferred
; into the new aconst.scm (was globalas.scm)

; 8-1. Assumption variables
; =========================

; Assumption variables are implemented as lists ('avar formula index name).

; To make sure that assumption variables generated by the system are
; different from all user introduced assumption variables, we maintain a
; global counter MAXAVARINDEX.  Whenever the user introduces an
; assumption variable, e.g. by (make-avar formula 27 ""), then MAXAVARINDEX
; is incremented to at least 27.

(define MAXAVARINDEX -1)
(define INITIAL-MAXAVARINDEX MAXAVARINDEX)

; Constructor, accessors and tests for assumption variables:

(define (make-avar formula index name)
  (set! MAXAVARINDEX (max index MAXAVARINDEX))
  (list 'avar formula index name))

(define avar-to-formula cadr)
(define avar-to-index caddr)
(define avar-to-name cadddr)

(define (avar-form? x) (and (pair? x) (eq? 'avar (car x))))

(define (avar? x)
  (and (avar-form? x)
       (list? x)
       (= 4 (length x))
       (let ((formula (cadr x))
	     (index (caddr x))
	     (name (cadddr x)))
	 (and (formula? formula)
	      (<= -1 index)
	      (<= index MAXAVARINDEX)
	      (string? name)))))

(define (avar=? avar1 avar2)
  (or (eq? avar1 avar2)
      (and (avar-form? avar1) (avar-form? avar2)
	   (= (avar-to-index avar1) (avar-to-index avar2))
	   (string=? (avar-to-name avar1) (avar-to-name avar2)))))

; For display we use

(define (avar-to-string avar)
  (let ((name (avar-to-name avar))
	(index (avar-to-index avar)))
    (string-append
     (if (string=? "" name) DEFAULT-AVAR-NAME name)
     (if (= -1 index) "" (number-to-string index)))))

; For automatic generation of assumption variables (e.g. for bound
; renaming) we provide

(define (formula-to-new-avar formula . optional-name)
  (if (null? optional-name)
      (make-avar formula (+ 1 MAXAVARINDEX) "")
      (let ((string (car optional-name)))
	(if (string? string)
	    (make-avar formula (+ 1 MAXAVARINDEX) string)
	    (myerror "formula-to-new-avar" "string expected"
		     (car optional-name))))))

(define DEFAULT-AVAR-NAME "u")

; For convenience we add mk-avar with options.  Options are index (default
; -1) and name (default DEFAULT-AVAR-NAME)

(define (mk-avar formula . options)
  (let ((index -1)
	(name DEFAULT-AVAR-NAME))
    (if (pair? options)
	(begin (set! index (car options))
	       (set! options (cdr  options))))
    (if (pair? options)
	(begin (set! name (car options))
	       (set! options (cdr  options))))
    (if (pair? options)
	 (myerror "make-avar" "unexpected argument" options))
  (cond ((not (and (integer? index) (<= -1 index)))
	 (myerror "make-avar" "index >= -1 expected" index))
	((not (formula-form? formula))
	 (myerror "make-avar" "formula expected" formula))
	((not (string? name))
	 (myerror "make-avar" "string expected" name))
	(else (make-avar formula index name)))))

(define (normalize-avar avar)
  (make-avar (normalize-formula (avar-to-formula avar))
	     (avar-to-index avar)
	     (avar-to-name avar)))


; 8-2. Assumption constants
; =========================

; An assumption constant appears in a proof, as an axiom, a theorem or
; a global assumption.  Its formula is given as an "uninstantiated
; formula", where only type and predicate variables can occur free;
; these are considered to be bound in the assumption constant.  An
; exception is the Elim aconst, where the argument variables xs^ of
; the inductively defined predicate are formally free in the
; uninstantiated formula; however, they are considered bound as well.
; In the proof the bound type variables are implicitely instantiated
; by types, and the bound predicate variables by cterms (the arity of
; a cterm is the type-instantiated arity of the corresponding pvar).
; Since we do not have type and predicate quantification in formulas,
; the aconst contains these parts left implicit in the proof: tsubst
; and pinst (will become a psubst, once the arities of pvars are
; type-instantiated with tsubst).

; To normalize a proof we will first translate it into a term, then
; normalize the term and finally translate the normal term back into a
; proof.  To make this work, in case of axioms we pass to the term
; appropriate "reproduction data" to be used when after normalization
; the axiom in question is to be reconstructed: all-formulas for
; induction, a number i and an inductively defined predicate constant
; idpc for its ith clause, imp-formulas for elimination, an
; existential formula for existence introduction, and an existential
; formula together with a conclusion for existence elimination.
; During normalization of the term these formulas are passed along.
; When the normal form is reached, we have to translate back into a
; proof.  Then these reproduction data are used to reconstruct the
; axiom in question, via

; all-formulas-to-ind-aconst
; number-and-idpredconst-to-intro-aconst
; imp-formulas-to-elim-aconst
; all-formula-to-cases-aconst
; ex-formula-to-ex-intro-aconst
; ex-formula-and-concl-to-ex-elim-aconst

; The reproduction data can be computed from the name, the
; uninstantiated formula, the tsubst and the pinst of the aconst, by
; aconst-to-computed-repro-formulas.  However, to avoid recomputations
; we carry them along.

(define (make-aconst name kind uninst-formula tpinst . repro-formulas)
  (append (list 'aconst name kind uninst-formula tpinst)
	  repro-formulas))

(define aconst-to-name cadr)
(define aconst-to-kind caddr)
(define aconst-to-uninst-formula cadddr)
(define (aconst-to-tpinst x) (car (cddddr x)))
(define (aconst-to-repro-formulas x) (cdr (cddddr x)))

; To construct the formula associated with an aconst, it is useful to
; separate the instantiated formula from the variables to be
; generalized.  The latter can be obtained as free variables in
; inst-formula.

(define (aconst-to-inst-formula aconst)
  (let* ((uninst-formula (aconst-to-uninst-formula aconst))
	 (tpinst (aconst-to-tpinst aconst))
	 (tsubst (list-transform-positive tpinst
		   (lambda (x) (tvar-form? (car x)))))
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x)))))
	 (rename (make-rename tsubst))
	 (prename (make-prename tsubst))
	 (psubst (map (lambda (x) (list (prename (car x)) (cadr x))) pinst)))
    (formula-substitute-aux
     uninst-formula tsubst empty-subst psubst rename prename)))

(define (aconst-to-formula aconst)
  (let* ((inst-formula (aconst-to-inst-formula aconst))
	 (free (formula-to-free inst-formula)))
    (apply mk-allnc (append free (list inst-formula)))))

(define (aconst-form? x) (and (pair? x) (eq? 'aconst (car x))))

; The reproduction data can be computed from the name, the
; uninstantiated formula, the tsubst and the pinst of the aconst, by
; aconst-to-computed-repro-formulas.  However, to avoid recomputations
; we carry them along.

(define (aconst-to-computed-repro-formulas aconst)
  (let* ((name (aconst-to-name aconst))
	 (uninst-fla (aconst-to-uninst-formula aconst))
	 (tpinst (aconst-to-tpinst aconst))
	 (tsubst (list-transform-positive tpinst
		   (lambda (x) (tvar-form? (car x)))))
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x))))))
    (cond
     ((string=? name "Ind")
      (let ((cterms (map cadr pinst)))
	(map (lambda (cterm)
	       (let* ((vars (cterm-to-vars cterm))
		      (fla (cterm-to-formula cterm))
		      (var (if (= 1 (length vars)) (car vars)
			       (myerror "aconst-to-computed-repro-formulas"
					"unary cterm expected" cterm))))
		 (if (t-deg-zero? (var-to-t-deg var))
		     (make-all var (make-imp (make-stotal
					      (make-term-in-var-form var))
					     fla))
		     (make-all var fla))))
	     cterms)))
     ((string=? name "Cases")
      (let* ((cterms (map cadr pinst))
	     (cterm (if (= 1 (length cterms)) (car cterms)
			(myerror "aconst-to-computed-repro-formulas"
				 "only one cterm expected" cterms)))
	     (vars (cterm-to-vars cterm))
	     (fla (cterm-to-formula cterm))
	     (var (if (= 1 (length vars)) (car vars)
		      (myerror "aconst-to-computed-repro-formulas"
			       "unary cterm expected" cterm))))
	(list (if (t-deg-zero? (var-to-t-deg var))
		  (make-all var (make-imp (make-stotal
					   (make-term-in-var-form var))
					  fla))
		  (make-all var fla)))))
     ((string=? name "Ex-Intro")
      (let* ((cterms (map cadr pinst))
	     (cterm (if (= 1 (length cterms)) (car cterms)
			(myerror "aconst-to-computed-repro-formulas"
				 "only one cterm expected" cterms)))
	     (vars (cterm-to-vars cterm))
	     (fla (cterm-to-formula cterm))
	     (var (if (= 1 (length vars)) (car vars)
		      (myerror "aconst-to-computed-repro-formulas"
			       "unary cterm expected" cterm))))
	(list (make-ex var fla))))
     ((string=? name "Ex-Elim")
      (let* ((cterms (map cadr pinst))
	     (cterm1 (if (= 2 (length cterms)) (car cterms)
			 (myerror "aconst-to-computed-repro-formulas"
				  "two cterms expected" cterms)))
	     (cterm2 (cadr cterms))
	     (vars1 (cterm-to-vars cterm1))
	     (var1 (if (= 1 (length vars1)) (car vars1)
		       (myerror "aconst-to-computed-repro-formulas"
				"unary cterm expected" cterm1)))
	     (fla1 (cterm-to-formula cterm1))
	     (vars2 (cterm-to-vars cterm2))
	     (fla2 (if (null? vars2) (cterm-to-formula cterm2)
		       (myerror "aconst-to-computed-repro-formulas"
				"nullary cterm expected" cterm2))))
	(list (make-ex var1 fla1) fla2)))
     ((string=? name "Exnc-Intro")
      (let* ((cterms (map cadr pinst))
	     (cterm (if (= 1 (length cterms)) (car cterms)
			(myerror "aconst-to-computed-repro-formulas"
				 "only one cterm expected" cterms)))
	     (vars (cterm-to-vars cterm))
	     (fla (cterm-to-formula cterm))
	     (var (if (= 1 (length vars)) (car vars)
		      (myerror "aconst-to-computed-repro-formulas"
			       "unary cterm expected" cterm))))
	(list (make-exnc var fla))))
     ((string=? name "Exnc-Elim")
      (let* ((cterms (map cadr pinst))
	     (cterm1 (if (= 2 (length cterms)) (car cterms)
			 (myerror "aconst-to-computed-repro-formulas"
				  "two cterms expected" cterms)))
	     (cterm2 (cadr cterms))
	     (vars1 (cterm-to-vars cterm1))
	     (var1 (if (= 1 (length vars1)) (car vars1)
		       (myerror "aconst-to-computed-repro-formulas"
				"unary cterm expected" cterm1)))
	     (fla1 (cterm-to-formula cterm1))
	     (vars2 (cterm-to-vars cterm2))
	     (fla2 (if (null? vars2) (cterm-to-formula cterm2)
		       (myerror "aconst-to-computed-repro-formulas"
				"nullary cterm expected" cterm2))))
	(list (make-exnc var1 fla1) fla2)))
     ((member name '("Intro"))
      (intro-aconst-to-computed-repro-data aconst))
     ((string=? name "Elim")
      (elim-aconst-to-computed-repro-formulas aconst))
     ((string=? name "GInd")
      (if (= 1 (length pinst))
	  (let* ((cterm (cadar pinst))
		 (vars (cterm-to-vars cterm))
		 (fla (cterm-to-formula cterm)))
	    (list (apply mk-all (append vars (list fla)))))
	  (myerror "aconst-to-computed-repro-formulas"
		   "a single pvar instantiation expected" pinst)))
     (else '()))))

(define (intro-aconst-to-computed-repro-data aconst)
  (let* ((uninst-clause (aconst-to-uninst-formula aconst))
	 (tpinst (aconst-to-tpinst aconst))
	 (tsubst (list-transform-positive tpinst
		   (lambda (x) (tvar-form? (car x)))))
	 (uninst-idpc (predicate-form-to-predicate
		       (imp-impnc-all-allnc-form-to-final-conclusion
			uninst-clause)))
	 (name (idpredconst-to-name uninst-idpc))
	 (orig-clauses-with-names
	  (idpredconst-name-to-clauses-with-names name))
	 (orig-clauses (map car orig-clauses-with-names))
	 (param-pvars (idpredconst-name-to-param-pvars name))
	 (cterms (map (lambda (pvar)
			(let ((info (assoc pvar tpinst)))
			  (if info (cadr info)
			      (if (member name '("ExDT" "ExLT" "ExRT" "ExUT"))
				  (predicate-to-cterm-with-total-vars pvar)
				  (predicate-to-cterm pvar)))))
		      param-pvars))
	 (param-pvar-cterms
	  (if (member name '("ExDT" "ExLT" "ExRT" "ExUT"))
	      (map predicate-to-cterm-with-total-vars param-pvars)
	      (map predicate-to-cterm param-pvars)))
	 (idpc-names-with-pvars-and-opt-alg-names
	  (idpredconst-name-to-idpc-names-with-pvars-and-opt-alg-names
	   name))
	 (names (map car idpc-names-with-pvars-and-opt-alg-names))
	 (pvars (map cadr idpc-names-with-pvars-and-opt-alg-names))
	 (tvars (idpredconst-name-to-tvars name))
	 (uninst-idpcs (map (lambda (name)
			       (make-idpredconst name tvars param-pvar-cterms))
			     names))
	 (uninst-idpc-cterms (map predicate-to-cterm uninst-idpcs))
	 (psubst-for-pvars (make-substitution-wrt pvar-cterm-equal?
						  pvars uninst-idpc-cterms))
	 (i (do ((n 0 (+ 1 n))
		 (l orig-clauses (cdr l)))
		((or (classical-formula=?
		      (formula-substitute (car l) psubst-for-pvars)
		      uninst-clause)
		     (= n (length orig-clauses)))
		 (if (= n (length orig-clauses))
		     (myerror "intro-aconst-to-computed-repro-data"
			      "clause not found"
			      uninst-clause)
		     n))))
	 (types (map (lambda (type) (type-substitute type tsubst)) tvars))
	 (idpc (make-idpredconst name types cterms)))
    (list i idpc)))

(define (elim-aconst-to-computed-repro-formulas aconst)
  (let* ((name (aconst-to-name aconst))
	 (uninst-formula (aconst-to-uninst-formula aconst))
	 (tpinst (aconst-to-tpinst aconst))
	 (tsubst (list-transform-positive tpinst
		   (lambda (x) (tvar-form? (car x)))))
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x)))))
	 (uninst-idpc-formula (imp-form-to-premise uninst-formula))
	 (uninst-idpc (predicate-form-to-predicate uninst-idpc-formula))
	 (idpc-name (if (idpredconst-form? uninst-idpc)
			(idpredconst-to-name uninst-idpc)
			(myerror "elim-aconst-to-computed-repro-formulas"
				 "idpredconst expected" uninst-idpc)))
	 (uninst-types (idpredconst-to-types uninst-idpc))
	 (uninst-param-cterms (idpredconst-to-cterms uninst-idpc))
	 (idpc-names-with-pvars-and-opt-alg-names
	   (idpredconst-name-to-idpc-names-with-pvars-and-opt-alg-names
	    idpc-name))
	 (pvars (map cadr idpc-names-with-pvars-and-opt-alg-names))
	 (relevant-pvars ;in the given order, as determined by pinst
	  (list-transform-positive (map car pinst)
	    (lambda (pvar) (member pvar pvars))))
	 (pvar-name-alist (map (lambda (x) (list (cadr x) (car x)))
			       idpc-names-with-pvars-and-opt-alg-names))
	 (relevant-idpc-names
	  (map (lambda (pvar)
		 (let ((info (assoc pvar pvar-name-alist)))
		   (if info (cadr info)
		       (myerror "elim-aconst-to-computed-repro-formulas"
				"unexpected pvar" pvar))))
	       relevant-pvars))
	 (relevant-uninst-idpcs
	  (map (lambda (name)
		 (make-idpredconst name uninst-types uninst-param-cterms))
	       relevant-idpc-names))
	 (relevant-cterms
	  (map cadr (list-transform-positive pinst
		      (lambda (x) (member (car x) relevant-pvars)))))

	 (inst-formula (aconst-to-inst-formula aconst))
	 (inst-idpc-formula (imp-form-to-premise inst-formula))
	 (inst-idpc (predicate-form-to-predicate inst-idpc-formula))
	 (inst-types (idpredconst-to-types inst-idpc))
	 (inst-param-cterms (idpredconst-to-cterms inst-idpc))
	 (relevant-inst-idpcs
	  (map (lambda (name)
		 (make-idpredconst name inst-types inst-param-cterms))
	       relevant-idpc-names))
	 (pvars (map idpredconst-name-to-pvar relevant-idpc-names))
	 (cterms (map (lambda (pvar) (cadr (assoc pvar pinst))) pvars))
	 (var-lists (map cterm-to-vars cterms))
	 (relevant-inst-idpc-formulas
	  (map (lambda (idpc vars)
		 (apply make-predicate-formula
			(cons idpc (map make-term-in-var-form vars))))
	       relevant-inst-idpcs var-lists)))
    (map (lambda (idpc-fla concl)
	   (make-imp idpc-fla concl))
	 relevant-inst-idpc-formulas (map cterm-to-formula relevant-cterms))))

(define (uniform-non-recursive-clause? formula . pvars)
  (and
   (null? (formula-to-free formula))
   (letrec
       ((impnc-param-prem-clause?
	 (lambda (fla)
	   (if (impnc-form? fla)
	       (let ((prem (impnc-form-to-premise fla))
		     (conc (impnc-form-to-conclusion fla)))
		 (and (null? (intersection (formula-to-pvars prem) pvars))
		      (impnc-param-prem-clause? conc)))
	       (and (predicate-form? fla)
		    (pair? (member (predicate-form-to-predicate fla)
				   pvars)))))))
     (impnc-param-prem-clause?
      (allnc-form-to-final-kernel formula)))))

(define (check-aconst x)
  (if (not (aconst-form? x))
      (myerror "check-aconst" "aconst expected" x))
  (if (not (list? x))
      (myerror "check-aconst" "list expected" x))
  (if (not (<= 5 (length x)))
      (myerror "check-aconst" "list of length at least 5 expected" x))
  (let* ((name (cadr x))
	 (kind (caddr x))
	 (uninst-formula (cadddr x))
	 (tpinst (car (cddddr x)))
	 (repro-formulas (cdr (cddddr x)))
	 (tsubst (if (and (list? tpinst) (apply and-op (map pair? tpinst)))
		     (list-transform-positive tpinst			    
		       (lambda (x) (tvar-form? (car x))))
		     (myerror "check-aconst"
			      "tpinst as list of pairs expected"
			      tpinst)))
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x)))))
	 (tvars (map car tsubst))
	 (pvars (map car pinst)))
    (if (not (string? name))
	(myerror "check-aconst" "string expected" name))
    (if (not (member kind (list 'axiom 'theorem 'global-assumption)))
	(myerror "check-aconst"
		 "kind axiom, theorem or global-assumption expected"
		 kind))
    (if (not (formula? uninst-formula))
	(myerror "check-aconst" "formula expected" uninst-formula))
    (if (not (tsubst? tsubst))
	(apply myerror (cons "check-aconst" (cons "tsubst expected" tsubst))))
    (if (not (pinst? pinst tsubst))
	(apply myerror (cons "check-aconst" (cons "pinst expected" pinst))))
    (if (not (= (+ (length tsubst) (length pinst)) (length tpinst)))
	(myerror "check-aconst" "tpinst expected" tpinst))
    (if (pair? (set-minus tvars (formula-to-tvars uninst-formula)))
	(myerror "check-aconst" "tsubst has superfluous tvars"
		 (set-minus tvars (formula-to-tvars uninst-formula))))
    (if (pair? (set-minus pvars (formula-to-pvars uninst-formula)))
	(myerror "check-aconst" "psubst has superfluous pvars"
		 (set-minus pvars (formula-to-pvars uninst-formula))))
    (let ((violating-pvars
	   (list-transform-positive (formula-to-pvars uninst-formula)
	     (lambda (pvar)
	       (let ((info (assoc pvar tpinst)))
		 (and
		  info
		  (if DIALECTICA-FLAG
		      (or (and (not (pvar-with-positive-content? pvar))
			       (not (nulltype?
				     (formula-to-etdp-type
				      (cterm-to-formula (cadr info))))))
			  (and (not (pvar-with-negative-content? pvar))
			       (not (nulltype?
				     (formula-to-etdn-type
				      (cterm-to-formula (cadr info)))))))
		      (and (not (pvar-with-positive-content? pvar))
			   (not (nulltype?
				 (formula-to-et-type
				  (cterm-to-formula (cadr info)))))))))))))
      (if (pair? violating-pvars)
	  (apply myerror
		 (append (list "check-aconst"
			       "incorrect substitution for pvars")
			 pvars
			 (list "in aconst" name)))))
    (let ((free (formula-to-free uninst-formula)))
      (if (and (string=? name "Elim")
	       (imp-form? uninst-formula)
	       (pair? (set-minus free (formula-to-free (imp-form-to-premise
							uninst-formula)))))
	  (apply myerror
		 (append (list "check-aconst" name "uninstantiated formula"
			       uninst-formula
			       "has unexpected free variables")
			 (set-minus free (formula-to-free
					  (imp-form-to-premise
					   uninst-formula))))))
      (if (and (not (string=? name "Elim")) (pair? free))
	  (apply myerror
		 (append (list "check-aconst" name "uninstantiated formula"
			       uninst-formula
			       "has unexpected free variables")
			 free))))
    (if (and (eq? kind 'axiom)
	     (not
	      (or
	       (member
		name
		'("Truth-Axiom" "Eq-Refl" "Eq-Symm" "Eq-Trans" "Ext"
		  "Eq-Compat" "Pair-Elim" "Total" "STotal" "TotalInhab"
		  "Constr-Total" "Constr-Total-Args"
		  "Total-Pair" "Total-Proj"
		  "All-AllPartial" "AllPartial-All"
		  "Allnc-AllncPartial" "AllncPartial-Allnc"
		  "Ex-ExPartial" "ExPartial-Ex"
		  "Exnc-ExncPartial" "ExncPartial-Exnc"
		  "Ind" "Cases" "GInd" "Ex-Intro" "Ex-Elim"
		  "Intro" "Elim"
		  "Exnc-Intro" "Exnc-Elim"
		  "AtomToEqDTrue" "EqDTrueToAtom"))
	       (apply
		or-op
		(map
		 (lambda (string)
		   (and (<= (string-length string) (string-length name))
			(string=? (substring name 0 (string-length string))
				  string)))
		 '("Eq-to-=-1-"
		   "Eq-to-=-2-"
		   "=-to-Eq-"
		   "=-to-E-"
		   "=-to-E-"
		   "E-to-Total-"
		   "SE-to-E-"
		   "Total-to-E-"
		   "SE-to-STotal-"
		   "STotal-to-SE-"
		   "Total-to-STotal-"
		   "All-AllPartial-"
		   "Allnc-AllncPartial-"
		   "ExPartial-Ex-"
		   "ExncPartial-Exnc-"))))))
	(myerror "check-aconst" "axiom expected" name))
    (if (and (eq? kind 'theorem)
	     (not (assoc name THEOREMS)))
	(myerror "check-aconst" "theorem expected" name))
    (if (and (eq? kind 'global-assumption)
	     (not (assoc name GLOBAL-ASSUMPTIONS)))
	(myerror "check-aconst" "global-assumption expected" name))
    (if
     (string=? "Intro" name)
     (let ((computed-repro-data (intro-aconst-to-computed-repro-data x)))
       (if (not (= 2 (length repro-formulas)))
	   (myerror "check-aconst" "repro data of length 2 expected"
		    repro-formulas))
       (if (not (= (car repro-formulas) (car computed-repro-data)))
	   (myerror "check-aconst" "equal clause numbers expected"
		    (car repro-formulas) (car computed-repro-data)))
       (if (not (idpredconst-equal?
		 (cadr repro-formulas) (cadr computed-repro-data)))
	   (myerror "check-aconst" "equal idpredconsts expected"
		    (cadr repro-formulas) (cadr computed-repro-data))))
     (let ((computed-repro-flas (aconst-to-computed-repro-formulas x)))
       (if (not (= (length repro-formulas) (length computed-repro-flas)))
	   (myerror "check-aconst" "aconst with name" name "has"
		    (length repro-formulas) "repro-formulas but"
		    (length computed-repro-flas) "computed repro-formulas"))
       (for-each (lambda (rfla crfla)
		   (if (not (classical-formula=? rfla crfla))
		       (myerror "check-aconst"
				"equal formulas expected for aconst"
				name
				"repro formula" rfla
				"computed repro formula"
				crfla)))
		 repro-formulas computed-repro-flas)))
    #t))

(define (idpredconst-equal? idpc1 idpc2)
  (or (equal? idpc1 idpc2)
      (let* ((name1 (idpredconst-to-name idpc1))
	     (types1 (idpredconst-to-types idpc1))
	     (cterms1 (idpredconst-to-cterms idpc1))
	     (name2 (idpredconst-to-name idpc2))
	     (types2 (idpredconst-to-types idpc2))
	     (cterms2 (idpredconst-to-cterms idpc2)))
	(and (string=? name1 name2)
	     (equal? types1 types2)
	     (= (length cterms1) (length cterms2))
	     (apply and-op (map (lambda (x y) (classical-cterm=? x y))
				cterms1 cterms2))))))

(define (avar-full=? avar1 avar2 . ignore-deco-flag)
  (or (eq? avar1 avar2)
      (and (avar-form? avar1) (avar-form? avar2)
	   (= (avar-to-index avar1) (avar-to-index avar2))
	   (string=? (avar-to-name avar1) (avar-to-name avar2))
	   (apply
	    classical-formula=?
	    (append (list (avar-to-formula avar1) (avar-to-formula avar2))
		    ignore-deco-flag)))))

; Complete test psubst? for predicate substitutions and pinst? for
; predicate instantiations w.r.t. a type substitution.

(define (psubst? x)
  (and
   (list? x)
   (apply and-op
	  (map (lambda (item)
		 (and (list? item)
		      (= 2 (length item))
		      (pvar? (car item))
		      (cterm? (cadr item))
		      (equal? (arity-to-types (pvar-to-arity (car item)))
			      (map var-to-type (cterm-to-vars (cadr item))))
		      (not (pvar-cterm-equal? (car item) (cadr item)))))
	       x))
   (= (length (remove-duplicates (map car x)))
      (length x))))

(define (pinst? x tsubst)
  (and
   (list? x)
   (apply and-op
	  (map (lambda (item)
		 (and (list? item)
		      (= 2 (length item))
		      (pvar? (car item))
		      (cterm? (cadr item))
		      (equal? (map (lambda (type)
				     (type-substitute type tsubst))
				   (arity-to-types (pvar-to-arity (car item))))
			      (map var-to-type (cterm-to-vars (cadr item))))
		      (not (pvar-cterm-equal? (car item) (cadr item)))))
	       x))
   (= (length (remove-duplicates (map car x)))
      (length x))))

(define (aconst=? aconst1 aconst2)
  (and (string=? (aconst-to-name aconst1) (aconst-to-name aconst2))
       (eq? (aconst-to-kind aconst1) (aconst-to-kind aconst2))
       (classical-formula=? (aconst-to-formula aconst1)
			    (aconst-to-formula aconst2))))

(define (aconst-without-rules? aconst)
  (let ((name (aconst-to-name aconst))
	(kind (aconst-to-kind aconst)))
    (or
     (eq? 'theorem kind)
     (and (eq? 'global-assumption kind)
          (not (string=? "Efq" name))) ;This is a hack.
     (and
      (eq? 'axiom kind)
      (not (member
            name
            '("Ind" "Cases" "Intro" "GInd" "Elim" "Ex-Intro" "Ex-Elim")))))))
    
(define (aconst-to-string aconst)
  (let* ((name (aconst-to-name aconst))
	 (repro-formulas (aconst-to-repro-formulas aconst)) ;better repro-data
	 (repro-string
	  (if
	   (string=? "Intro" name)
	   (string-append " " (number-to-string (car repro-formulas))
			  " " (idpredconst-to-string (cadr repro-formulas)))
	   (apply string-append
		  (map (lambda (x) (string-append " " (formula-to-string x)))
		       repro-formulas)))))
    (cond
     ((string=? "Ind" name) (string-append "(Ind" repro-string ")"))
     ((string=? "Cases" name) (string-append "(Cases" repro-string ")"))
     ((string=? "Intro" name) (string-append "(Intro" repro-string ")"))
     ((string=? "Elim" name) (string-append "(Elim" repro-string ")"))
     ((string=? "Ex-Intro" name) (string-append "(Ex-Intro" repro-string ")"))
     ((string=? "Ex-Elim" name) (string-append "(Ex-Elim" repro-string ")"))
     (else name))))

; pvar-to-cterm is superseded by the more general predicate-to-cterm.
; It is kept temporarily for backwards compatibitiy.

(define (pvar-to-cterm pvar) (predicate-to-cterm pvar))

(define truth-aconst (make-aconst "Truth-Axiom" 'axiom truth empty-subst))

(define eq-refl-aconst
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var (make-var tvar -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (formula-of-eq-refl-aconst
	  (mk-allnc var (make-eq varterm varterm))))
    (make-aconst "Eq-Refl" 'axiom formula-of-eq-refl-aconst empty-subst)))

(define eq-symm-aconst
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var1 (make-var tvar 1 0 name))
	 (var2 (make-var tvar 2 0 name))
	 (varterm1 (make-term-in-var-form var1))
	 (varterm2 (make-term-in-var-form var2))
	 (formula-of-eq-symm-aconst
	  (mk-allnc var1 var2 (mk-imp (make-eq varterm1 varterm2)
				      (make-eq varterm2 varterm1)))))
    (make-aconst "Eq-Symm" 'axiom formula-of-eq-symm-aconst empty-subst)))

(define eq-trans-aconst
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var1 (make-var tvar 1 0 name))
	 (var2 (make-var tvar 2 0 name))
	 (var3 (make-var tvar 3 0 name))
	 (varterm1 (make-term-in-var-form var1))
	 (varterm2 (make-term-in-var-form var2))
	 (varterm3 (make-term-in-var-form var3))
	 (formula-of-eq-trans-aconst
	  (mk-allnc var1 var2 var3 (mk-imp (make-eq varterm1 varterm2)
					   (make-eq varterm2 varterm3)
					   (make-eq varterm1 varterm3)))))
    (make-aconst "Eq-Trans" 'axiom formula-of-eq-trans-aconst empty-subst)))

(define ext-aconst
  (let* ((tvar1 (make-tvar 1 DEFAULT-TVAR-NAME))
	 (tvar2 (make-tvar 2 DEFAULT-TVAR-NAME))
	 (arrow-type (make-arrow tvar1 tvar2))
	 (fname (default-var-name arrow-type))
	 (fvar1 (make-var arrow-type 1 0 fname))
	 (fvar2 (make-var arrow-type 2 0 fname))
	 (name (default-var-name tvar1))
	 (var (make-var tvar1 -1 0 name))
	 (fterm1 (make-term-in-app-form
		  (make-term-in-var-form fvar1)
		  (make-term-in-var-form var)))
	 (fterm2 (make-term-in-app-form
		  (make-term-in-var-form fvar2)
		  (make-term-in-var-form var)))
	 (prem-eq-fla (make-eq fterm1 fterm2))
	 (concl-eq-fla (make-eq (make-term-in-var-form fvar1)
				(make-term-in-var-form fvar2)))
	 (formula-of-ext-aconst
	  (mk-allnc fvar1 fvar2 (mk-imp (mk-allnc var prem-eq-fla)
					concl-eq-fla))))
    (make-aconst "Ext" 'axiom formula-of-ext-aconst empty-subst)))

(define eq-compat-aconst
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var1 (make-var tvar 1 0 name))
	 (var2 (make-var tvar 2 0 name))
	 (varterm1 (make-term-in-var-form var1))
	 (varterm2 (make-term-in-var-form var2))
	 (pvar (make-pvar (make-arity tvar) -1 h-deg-zero n-deg-zero ""))
	 (eq-fla (make-eq varterm1 varterm2))
	 (fla1 (make-predicate-formula pvar varterm1))
	 (fla2 (make-predicate-formula pvar varterm2))
	 (formula-of-eq-compat-aconst
	  (mk-allnc var1 var2 (mk-imp eq-fla fla1 fla2))))
    (make-aconst "Eq-Compat" 'axiom formula-of-eq-compat-aconst empty-subst)))

(define pair-elim-aconst
  (let* ((tvar1 (make-tvar 1 DEFAULT-TVAR-NAME))
	 (tvar2 (make-tvar 2 DEFAULT-TVAR-NAME))
	 (pairtype (make-star tvar1 tvar2))
	 (pairname (default-var-name pairtype))
	 (pairvar (make-var pairtype -1 0 pairname))
	 (pairvarterm (make-term-in-var-form pairvar))
	 (name1 (default-var-name tvar1))
	 (var1 (make-var tvar1 1 0 name1))
	 (name2 (default-var-name tvar2))
	 (var2 (make-var tvar2 2 0 name2))
	 (varterm1 (make-term-in-var-form var1))
	 (varterm2 (make-term-in-var-form var2))
	 (pairterm
	  (make-term-in-pair-form varterm1 varterm2))
	 (pvar (make-pvar (make-arity pairtype) -1 h-deg-zero n-deg-zero ""))
	 (fla1 (mk-all var1 var2
		       (make-predicate-formula pvar pairterm)))
	 (fla2 (mk-all pairvar
		       (make-predicate-formula pvar pairvarterm)))
	 (formula-of-pair-elim-aconst (mk-imp fla1 fla2)))
    (make-aconst "Pair-Elim" 'axiom formula-of-pair-elim-aconst empty-subst)))

(define (all-pair-formula-to-pair-elim-aconst all-pair-formula)
  (let* ((var (all-form-to-var all-pair-formula))
	 (kernel (all-form-to-kernel all-pair-formula))
	 (pairtype (var-to-type var))
	 (type1 (star-form-to-left-type pairtype))
	 (type2 (star-form-to-right-type pairtype))
	 (types (list type1 type2))
	 (fixed-tvar1 (make-tvar 1 DEFAULT-TVAR-NAME))
	 (fixed-tvar2 (make-tvar 2 DEFAULT-TVAR-NAME))
	 (fixed-pairtype (make-star fixed-tvar1 fixed-tvar2))
	 (fixed-tvars (list fixed-tvar1 fixed-tvar2))	 
	 (tsubst (make-substitution fixed-tvars types))
	 (cterm (make-cterm var kernel))
	 (fixed-pvar
	  (make-pvar (make-arity fixed-pairtype) -1 h-deg-zero n-deg-zero ""))
	 (pinst (list (list fixed-pvar cterm))))
    (make-aconst (aconst-to-name pair-elim-aconst)
		 (aconst-to-kind pair-elim-aconst)
		 (aconst-to-uninst-formula pair-elim-aconst)
		 (append tsubst pinst))))

(define total-aconst
  (let* ((tvar1 (make-tvar 1 DEFAULT-TVAR-NAME))
	 (tvar2 (make-tvar 2 DEFAULT-TVAR-NAME))
	 (arrow-type (make-arrow tvar1 tvar2))
	 (fname (default-var-name arrow-type))
	 (fvar (make-var arrow-type -1 0 fname))
	 (name (default-var-name tvar1))
	 (var (make-var tvar1 -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (fterm (make-term-in-var-form fvar))
	 (fappterm (make-term-in-app-form fterm varterm))
	 (formula-of-total-aconst
	  (mk-all fvar
		  (make-and
		   (mk-imp (make-total fterm)
			   (mk-all var (mk-imp (make-total varterm)
					       (make-total fappterm))))
		   (mk-imp (mk-all var (mk-imp (make-total varterm)
					       (make-total fappterm)))
			   (make-total fterm))))))
    (make-aconst "Total" 'axiom formula-of-total-aconst empty-subst)))

(define stotal-aconst
  (let* ((tvar1 (make-tvar 1 DEFAULT-TVAR-NAME))
	 (tvar2 (make-tvar 2 DEFAULT-TVAR-NAME))
	 (arrow-type (make-arrow tvar1 tvar2))
	 (fname (default-var-name arrow-type))
	 (fvar (make-var arrow-type -1 0 fname))
	 (name (default-var-name tvar1))
	 (var (make-var tvar1 -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (fterm (make-term-in-var-form fvar))
	 (fappterm (make-term-in-app-form fterm varterm))
	 (formula-of-stotal-aconst
	  (mk-all fvar
		  (make-and
		   (mk-imp (make-stotal fterm)
			   (mk-all var (mk-imp (make-stotal varterm)
					       (make-stotal fappterm))))
		   (mk-imp (mk-all var (mk-imp (make-stotal varterm)
					       (make-stotal fappterm)))
			   (make-stotal fterm))))))
    (make-aconst "STotal" 'axiom formula-of-stotal-aconst empty-subst)))

(define totalinhab-aconst
  (let ((formula-of-total-inhab-aconst
	 (make-total
	  (make-term-in-const-form
	   (pconst-name-to-pconst "Inhab")))))
    (make-aconst
     "TotalInhab" 'axiom formula-of-total-inhab-aconst empty-subst)))

(define (constr-name-to-constr-total-aconst name)
  (let* ((constr (constr-name-to-constr name)) ;with empty tsubst
	 (type (const-to-uninst-type constr))
	 (arg-types (arrow-form-to-arg-types type))
	 (vars (map type-to-new-partial-var arg-types))
	 (varterms (map make-term-in-var-form vars))
	 (appterm (apply mk-term-in-app-form
			 (cons (make-term-in-const-form constr)
			       (map make-term-in-var-form vars))))
	 (formula-of-constr-total-aconst
	  (apply
	   mk-all
	   (append
	    vars
	    (list (apply mk-imp
			 (append (map make-total varterms)
				 (list (make-total appterm)))))))))
    (make-aconst "Constr-Total" 'axiom formula-of-constr-total-aconst
		 empty-subst)))

(define (constr-name-and-index-to-constr-total-args-aconst name i)
  (let* ((constr (constr-name-to-constr name)) ;with empty tsubst
	 (type (const-to-uninst-type constr))
	 (arg-types (arrow-form-to-arg-types type))
	 (vars (map type-to-new-partial-var arg-types))
	 (var (if (and (integer? i) (not (negative? i))
		       (< i (length arg-types)))
		  (list-ref vars i)
		  (myerror "constr-name-and-index-to-constr-total-args-aconst"
			   "index" i "out of range for constructor" name)))
	 (appterm (apply mk-term-in-app-form
			 (cons (make-term-in-const-form constr)
			       (map make-term-in-var-form vars))))
	 (formula-of-constr-total-args-aconst
	  (apply mk-all
		 (append vars
			 (list (make-imp
				(make-total appterm)
				(make-total (make-term-in-var-form var))))))))
    (make-aconst "Constr-Total-Args" 'axiom formula-of-constr-total-args-aconst
		 empty-subst)))	 

(define total-pair-aconst
  (let* ((tvar1 (make-tvar 1 DEFAULT-TVAR-NAME))
	 (tvar2 (make-tvar 2 DEFAULT-TVAR-NAME))
	 (name1 (default-var-name tvar1))
	 (var1 (make-var tvar1 -1 0 name1))
	 (varterm1 (make-term-in-var-form var1))
	 (name2 (default-var-name tvar2))
	 (var2 (make-var tvar2 -1 0 name2))
	 (varterm2 (make-term-in-var-form var2))
	 (pairterm (make-term-in-pair-form varterm1 varterm2))
	 (formula-of-total-pair-aconst
	  (mk-all var1 var2
		  (mk-imp (make-total varterm1)
			  (make-total varterm2)
			  (make-total pairterm)))))
    (make-aconst "Total-Pair"
		 'axiom formula-of-total-pair-aconst empty-subst)))

(define total-proj-aconst
  (let* ((tvar1 (make-tvar 1 DEFAULT-TVAR-NAME))
	 (tvar2 (make-tvar 2 DEFAULT-TVAR-NAME))
	 (star-type (make-star tvar1 tvar2))
	 (pairname (default-var-name star-type))
	 (pairvar (make-var star-type -1 0 pairname))
	 (pairvarterm (make-term-in-var-form pairvar))
	 (projterm1 (make-term-in-lcomp-form pairvarterm))
	 (projterm2 (make-term-in-rcomp-form pairvarterm))
	 (formula-of-total-proj-aconst
	  (mk-all pairvar
		  (mk-imp (make-total pairvarterm)
			  (make-and (make-total projterm1)
				    (make-total projterm2))))))
    (make-aconst "Total-Proj"
		 'axiom formula-of-total-proj-aconst empty-subst)))

(define (finalg-to-eq-to-=-1-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var1 (make-var finalg 1 0 name))
	 (var2 (make-var finalg 2 0 name))
	 (varterm1 (make-term-in-var-form var1))
	 (varterm2 (make-term-in-var-form var2))
	 (eq-fla (make-eq varterm1 varterm2))
	 (e-fla1 (make-e varterm1))
	 (=-fla (make-= varterm1 varterm2))
	 (formula-of-eq-to-=-1-aconst 
	  (mk-allnc var1 var2 (mk-imp eq-fla e-fla1 =-fla)))
	 (aconst-name (string-append "Eq-to-=-1-" (type-to-string finalg))))
    (make-aconst aconst-name 'axiom formula-of-eq-to-=-1-aconst empty-subst)))

(define (finalg-to-eq-to-=-2-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var1 (make-var finalg 1 0 name))
	 (var2 (make-var finalg 2 0 name))
	 (varterm1 (make-term-in-var-form var1))
	 (varterm2 (make-term-in-var-form var2))
	 (eq-fla (make-eq varterm1 varterm2))
	 (e-fla2 (make-e varterm2))
	 (=-fla (make-= varterm1 varterm2))
	 (formula-of-eq-to-=-2-aconst 
	  (mk-allnc var1 var2 (mk-imp eq-fla e-fla2 =-fla)))
	 (aconst-name (string-append "Eq-to-=-2-" (type-to-string finalg))))
    (make-aconst aconst-name 'axiom formula-of-eq-to-=-2-aconst empty-subst)))

(define (finalg-to-=-to-eq-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var1 (make-var finalg 1 0 name))
	 (var2 (make-var finalg 2 0 name))
	 (varterm1 (make-term-in-var-form var1))
	 (varterm2 (make-term-in-var-form var2))
	 (=-fla (make-= varterm1 varterm2))
	 (eq-fla (make-eq varterm1 varterm2))
	 (formula-of-=-to-eq-aconst 
	  (mk-allnc var1 var2 (mk-imp =-fla eq-fla)))
	 (aconst-name (string-append "=-to-Eq-" (type-to-string finalg))))
    (make-aconst aconst-name 'axiom formula-of-=-to-eq-aconst empty-subst)))
    
(define (finalg-to-=-to-e-1-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var1 (make-var finalg 1 0 name))
	 (var2 (make-var finalg 2 0 name))
	 (varterm1 (make-term-in-var-form var1))
	 (varterm2 (make-term-in-var-form var2))
	 (=-fla (make-= varterm1 varterm2))
	 (e-fla (make-e varterm1))
	 (formula-of-=-to-e-1-aconst 
	  (mk-allnc var1 var2 (mk-imp =-fla e-fla)))
	 (aconst-name (string-append "=-to-E-" (type-to-string finalg))))
    (make-aconst aconst-name 'axiom formula-of-=-to-e-1-aconst empty-subst)))
    
(define (finalg-to-=-to-e-2-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var1 (make-var finalg 1 0 name))
	 (var2 (make-var finalg 2 0 name))
	 (varterm1 (make-term-in-var-form var1))
	 (varterm2 (make-term-in-var-form var2))
	 (=-fla (make-= varterm1 varterm2))
	 (e-fla (make-e varterm2))
	 (formula-of-=-to-e-2-aconst 
	  (mk-allnc var1 var2 (mk-imp =-fla e-fla)))
	 (aconst-name (string-append "=-to-E-" (type-to-string finalg))))
    (make-aconst aconst-name 'axiom formula-of-=-to-e-2-aconst empty-subst)))
    
; Relations between totality concepts for the different types.  Because
; of inclusions relations are inherited from alg to sfinalg to finalg.

; finalg     | sfinalg    | alg      | rho=>sigma
; -----------------------------------------------
; E      | ^ |            |          |  
; SE     | | | SE     | ^ |          |
; STotal |   | STotal v | | STotal ^ | STotal
; Total  v   | Total      | Total  | | Total


(define (finalg-to-e-to-total-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var (make-var finalg -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (total-fla (make-total varterm))
	 (e-fla (make-e varterm))
	 (formula-of-e-to-total-aconst 
	  (mk-allnc var (mk-imp e-fla total-fla)))
	 (aconst-name (string-append "E-to-Total-" (type-to-string finalg))))
    (make-aconst aconst-name 'axiom formula-of-e-to-total-aconst empty-subst)))

(define (finalg-to-se-to-e-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var (make-var finalg -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (se-fla (make-se varterm))
	 (e-fla (make-e varterm))
	 (formula-of-se-to-e-aconst 
	  (mk-allnc var (mk-imp se-fla e-fla)))
	 (aconst-name (string-append "SE-to-E-" (type-to-string finalg))))
    (make-aconst aconst-name 'axiom formula-of-se-to-e-aconst empty-subst)))

(define (finalg-to-total-to-e-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var (make-var finalg -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (total-fla (make-total varterm))
	 (e-fla (make-e varterm))
	 (formula-of-total-to-e-aconst 
	  (mk-allnc var (mk-imp total-fla e-fla)))
	 (aconst-name (string-append "Total-to-E-" (type-to-string finalg))))
    (make-aconst aconst-name 'axiom formula-of-total-to-e-aconst empty-subst)))

; Notice that finalg-to-total-to-e-aconst might be removed, because
; its formula can be derived from alg-to-total-to-stotal-aconst
; sfinalg-to-stotal-to-se-aconst and finalg-to-se-to-e-aconst .

(define (sfinalg-to-se-to-stotal-aconst sfinalg)
  (let* ((name (default-var-name sfinalg))
	 (var (make-var sfinalg -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (stotal-fla (make-stotal varterm))
	 (se-fla (make-se varterm))
	 (formula-of-se-to-stotal-aconst 
	  (mk-allnc var (mk-imp se-fla stotal-fla)))
	 (aconst-name (string-append "SE-to-STotal-"
                                     (type-to-string sfinalg))))
    (make-aconst
     aconst-name 'axiom formula-of-se-to-stotal-aconst empty-subst)))

(define (sfinalg-to-stotal-to-se-aconst sfinalg)
  (let* ((name (default-var-name sfinalg))
	 (var (make-var sfinalg -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (stotal-fla (make-stotal varterm))
	 (se-fla (make-se varterm))
	 (formula-of-stotal-to-se-aconst 
	  (mk-allnc var (mk-imp stotal-fla se-fla)))
	 (aconst-name (string-append "STotal-to-SE-"
                                     (type-to-string sfinalg))))
    (make-aconst
     aconst-name 'axiom formula-of-stotal-to-se-aconst empty-subst)))

(define (alg-to-total-to-stotal-aconst alg)
  (let* ((name (default-var-name alg))
	 (var (make-var alg -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (total-fla (make-total varterm))
	 (stotal-fla (make-stotal varterm))
	 (formula-of-total-to-stotal-aconst 
	  (mk-allnc var (mk-imp total-fla stotal-fla)))
	 (aconst-name (string-append "Total-to-STotal-" (type-to-string alg))))
    (make-aconst
     aconst-name 'axiom formula-of-total-to-stotal-aconst empty-subst)))

(define all-allpartial-aconst
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var (make-var tvar -1 1 name))
	 (varpartial (make-var tvar -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity tvar) -1 h-deg-zero n-deg-zero ""))
	 (all-fla (mk-all var (make-predicate-formula pvar varterm)))
	 (allpartial-fla
	  (mk-all varpartial
		  (mk-imp (make-total varpartialterm)
			  (make-predicate-formula pvar varpartialterm))))
	 (formula-of-all-allpartial-aconst (mk-imp all-fla allpartial-fla)))
    (make-aconst "All-AllPartial"
		 'axiom formula-of-all-allpartial-aconst empty-subst)))

(define allpartial-all-aconst
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var (make-var tvar -1 1 name))
	 (varpartial (make-var tvar -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity tvar) -1 h-deg-zero n-deg-zero ""))
	 (all-fla (mk-all var (make-predicate-formula pvar varterm)))
	 (allpartial-fla
	  (mk-all varpartial
		  (mk-imp (make-total varpartialterm)
			  (make-predicate-formula pvar varpartialterm))))
	 (formula-of-allpartial-all-aconst (mk-imp allpartial-fla all-fla)))
    (make-aconst "AllPartial-All"
		 'axiom formula-of-allpartial-all-aconst empty-subst)))

(define allnc-allncpartial-aconst
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var (make-var tvar -1 1 name))
	 (varpartial (make-var tvar -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity tvar) -1 h-deg-zero n-deg-zero ""))
	 (allnc-fla (mk-allnc var (make-predicate-formula pvar varterm)))
	 (allncpartial-fla
	  (mk-allnc varpartial
		    (mk-imp (make-total varpartialterm)
			    (make-predicate-formula pvar varpartialterm))))
	 (formula-of-allnc-allncpartial-aconst
	  (mk-imp allnc-fla allncpartial-fla)))
    (make-aconst "Allnc-AllncPartial"
		 'axiom formula-of-allnc-allncpartial-aconst empty-subst)))

(define allncpartial-allnc-aconst
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var (make-var tvar -1 1 name))
	 (varpartial (make-var tvar -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity tvar) -1 h-deg-zero n-deg-zero ""))
	 (allnc-fla (mk-allnc var (make-predicate-formula pvar varterm)))
	 (allncpartial-fla
	  (mk-allnc varpartial
		    (mk-imp (make-total varpartialterm)
			    (make-predicate-formula pvar varpartialterm))))
	 (formula-of-allncpartial-allnc-aconst
	  (mk-imp allncpartial-fla allnc-fla)))
    (make-aconst "AllncPartial-Allnc"
		 'axiom formula-of-allncpartial-allnc-aconst empty-subst)))

(define ex-expartial-aconst
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var (make-var tvar -1 1 name))
	 (varpartial (make-var tvar -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity tvar) -1 h-deg-zero n-deg-zero ""))
	 (ex-fla (mk-ex var (make-predicate-formula pvar varterm)))
	 (expartial-fla
	  (mk-ex varpartial
		 (mk-and (make-total varpartialterm)
			 (make-predicate-formula pvar varpartialterm))))
	 (formula-of-ex-expartial-aconst (mk-imp ex-fla expartial-fla)))
    (make-aconst "Ex-ExPartial"
		 'axiom formula-of-ex-expartial-aconst empty-subst)))

(define expartial-ex-aconst
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var (make-var tvar -1 1 name))
	 (varpartial (make-var tvar -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity tvar) -1 h-deg-zero n-deg-zero ""))
	 (ex-fla (mk-ex var (make-predicate-formula pvar varterm)))
	 (expartial-fla
	  (mk-ex varpartial
		 (mk-and (make-total varpartialterm)
			 (make-predicate-formula pvar varpartialterm))))
	 (formula-of-expartial-ex-aconst (mk-imp expartial-fla ex-fla)))
    (make-aconst "ExPartial-Ex"
		 'axiom formula-of-expartial-ex-aconst empty-subst)))

(define exnc-exncpartial-aconst
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var (make-var tvar -1 1 name))
	 (varpartial (make-var tvar -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity tvar) -1 h-deg-zero n-deg-zero ""))
	 (exnc-fla (mk-exnc var (make-predicate-formula pvar varterm)))
	 (exncpartial-fla
	  (mk-exnc varpartial
		   (mk-and (make-total varpartialterm)
			   (make-predicate-formula pvar varpartialterm))))
	 (formula-of-exnc-exncpartial-aconst
	  (mk-imp exnc-fla exncpartial-fla)))
    (make-aconst "Exnc-ExncPartial"
		 'axiom formula-of-exnc-exncpartial-aconst empty-subst)))

(define exncpartial-exnc-aconst
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var (make-var tvar -1 1 name))
	 (varpartial (make-var tvar -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity tvar) -1 h-deg-zero n-deg-zero ""))
	 (exnc-fla (mk-exnc var (make-predicate-formula pvar varterm)))
	 (exncpartial-fla
	  (mk-exnc varpartial
		   (mk-and (make-total varpartialterm)
			   (make-predicate-formula pvar varpartialterm))))
	 (formula-of-exncpartial-exnc-aconst
	  (mk-imp exncpartial-fla exnc-fla)))
    (make-aconst "ExncPartial-Exnc"
		 'axiom formula-of-exncpartial-exnc-aconst empty-subst)))

(define (finalg-to-all-allpartial-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var (make-var finalg -1 1 name))
	 (varpartial (make-var finalg -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity finalg) -1 h-deg-zero n-deg-zero ""))
	 (all-fla (mk-all var (make-predicate-formula pvar varterm)))
	 (allpartial-fla
	  (mk-all varpartial
		    (mk-imp (make-e varpartialterm)
			    (make-predicate-formula pvar varpartialterm))))
	 (formula-of-all-allpartial-aconst
	  (mk-imp all-fla allpartial-fla))
	 (name (string-append "All-AllPartial-" (type-to-string finalg))))
    (make-aconst name 'axiom formula-of-all-allpartial-aconst empty-subst)))

(define (finalg-to-allnc-allncpartial-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var (make-var finalg -1 1 name))
	 (varpartial (make-var finalg -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity finalg) -1 h-deg-zero n-deg-zero ""))
	 (allnc-fla (mk-allnc var (make-predicate-formula pvar varterm)))
	 (allncpartial-fla
	  (mk-allnc varpartial
		    (mk-imp (make-e varpartialterm)
			    (make-predicate-formula pvar varpartialterm))))
	 (formula-of-allnc-allncpartial-aconst
	  (mk-imp allnc-fla allncpartial-fla))
	 (name (string-append "Allnc-AllncPartial-" (type-to-string finalg))))
    (make-aconst name 'axiom formula-of-allnc-allncpartial-aconst
		 empty-subst)))

(define (finalg-to-expartial-ex-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var (make-var finalg -1 1 name))
	 (varpartial (make-var finalg -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity finalg) -1 h-deg-zero n-deg-zero ""))
	 (ex-fla (mk-ex var (make-predicate-formula pvar varterm)))
	 (expartial-fla
	  (mk-ex varpartial
		 (mk-and (make-e varpartialterm)
			 (make-predicate-formula pvar varpartialterm))))
	 (formula-of-expartial-ex-aconst (mk-imp expartial-fla ex-fla))
	 (name (string-append "ExPartial-Ex-" (type-to-string finalg))))
    (make-aconst name 'axiom formula-of-expartial-ex-aconst empty-subst)))

(define (finalg-to-exncpartial-exnc-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var (make-var finalg -1 1 name))
	 (varpartial (make-var finalg -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity finalg) -1 h-deg-zero n-deg-zero ""))
	 (exnc-fla (mk-exnc var (make-predicate-formula pvar varterm)))
	 (exncpartial-fla
	  (mk-exnc varpartial
		   (mk-and (make-e varpartialterm)
			   (make-predicate-formula pvar varpartialterm))))
	 (formula-of-exncpartial-exnc-aconst (mk-imp exncpartial-fla exnc-fla))
	 (name (string-append "ExncPartial-Exnc-" (type-to-string finalg))))
    (make-aconst name 'axiom formula-of-exncpartial-exnc-aconst empty-subst)))

; Now for induction.  We define a procedure that takes all-formulas
; and returns the corresponding induction axiom.

(define (all-formulas-to-ind-aconst . all-formulas)
  (let* ((uninst-imp-formula-and-tpinst
	  (apply all-formulas-to-uninst-imp-formula-and-tpinst all-formulas))
	 (uninst-imp-formula (car uninst-imp-formula-and-tpinst))
	 (tpinst (cadr uninst-imp-formula-and-tpinst)))
    (apply make-aconst (append (list "Ind" 'axiom uninst-imp-formula tpinst)
			       all-formulas))))

(define (all-formulas-to-uninst-imp-formulas-and-tpinst . all-formulas)
  (if
   (null? all-formulas)
   (list '() empty-subst)
   (let* ((free (apply union (map formula-to-free all-formulas)))
	  (vars (map all-form-to-var all-formulas))
	  (partial-flag (t-deg-zero? (var-to-t-deg (car vars))))
	  (kernels
	   (map
	    (if partial-flag
		(lambda (x)
		  (let ((kernel (all-form-to-kernel x)))
		    (if
		     (and
		      (imp-form? kernel)
		      (let ((prem (imp-form-to-premise kernel)))
			(and (predicate-form? prem)
			     (let ((pred (predicate-form-to-predicate prem)))
			       (and (predconst-form? pred)
				    (string=? "STotal"
					      (predconst-to-name pred)))))))
		     (imp-form-to-conclusion kernel)
		     (myerror "all-formulas-to-uninst-imp-formulas-and-tpinst"
			      "implication with STotal premise expected"
			      kernel))))
		all-form-to-kernel)
	    all-formulas))
	  (types (map var-to-type vars))
	  (alg-names
	   (map (lambda (type)
		  (if (alg-form? type)
		      (alg-form-to-name type)
		      (myerror
		       "all-formulas-to-uninst-imp-formulas-and-tpinst"
		       "alg expected" type)))
		types))
	  (tparam-lists (map alg-form-to-types types))
	  (all-formula (car all-formulas))
	  (type (car types))
	  (alg-name (car alg-names))
	  (orig-tvars (alg-name-to-tvars alg-name))
	  (tvars (map (lambda (x) (new-tvar)) orig-tvars))
	  (tparams (car tparam-lists))
	  (tsubst (make-substitution tvars tparams))
	  (uninst-types (map (lambda (x) (apply make-alg (cons x tvars)))
			     alg-names)) 
	  (uninst-arities (map (lambda (x) (make-arity x)) uninst-types))
	  (cterms (map (lambda (x y) (make-cterm x y)) vars kernels))
	  (pinst (map (lambda (x y) (list (arity-to-new-general-pvar x) y))
		      uninst-arities cterms))
	  (pvars (map car pinst))
	  (uninst-vars (map (lambda (x y) (type-to-new-var x y))
			    uninst-types vars))
	  (uninst-stotal-prems
	   (map (lambda (x y)
		  (if partial-flag
		      (make-stotal (make-term-in-var-form y))
		      #f))
		uninst-arities uninst-vars))
	  (uninst-all-formulas
	   (map (lambda (x y z)
		  (make-all x (if partial-flag
				  (make-imp y (make-predicate-formula
					       z (make-term-in-var-form x)))
				  (make-predicate-formula
				   z (make-term-in-var-form x)))))
		uninst-vars uninst-stotal-prems pvars))
	  (uninst-kernel-formulas
	   (map (lambda (x y)
                  (make-predicate-formula
                   y (make-term-in-var-form x)))
                uninst-vars pvars))
	  (alg-names-with-uninst-all-formulas
	   (map (lambda (x y) (list x y)) alg-names uninst-all-formulas))
	  (simalg-names (alg-name-to-simalg-names alg-name)))
     (if (not (equal? alg-names (remove-duplicates alg-names)))
	 (myerror "all-formulas-to-uninst-imp-formulas-and-tpinst"
		  "distinct algs expected" alg-names))
     (if (pair? (set-minus alg-names simalg-names))
	 (myerror "all-formulas-to-uninst-imp-formulas-and-tpinst"
		  "too many alg names" (set-minus alg-names simalg-names)))
     (if (< 1 (length (remove-duplicates tparam-lists)))
	 (myerror "all-formulas-to-uninst-imp-formulas-and-tpinst"
		  "lists expected" tparam-lists))
     (let* ((relevant-simalg-names (list-transform-positive simalg-names
				     (lambda (x) (member x alg-names))))
	    (orig-typed-constr-names
	     (apply append (map alg-name-to-typed-constr-names
				relevant-simalg-names)))
	    (renaming-tsubst (make-substitution orig-tvars tvars))
	    (typed-constr-names
	     (map (lambda (x)
		    (list (car x) (type-substitute (cadr x) renaming-tsubst)))
		  orig-typed-constr-names))
	    (uninst-step-formulas
	     (map (lambda (x) (typed-constr-name-to-step-formula
			       x alg-names-with-uninst-all-formulas
			       renaming-tsubst))
		  typed-constr-names))
            (uninst-imp-formulas
             (map (lambda (uninst-var uninst-stotal-prem uninst-kernel-formula)
                    (make-all uninst-var
                              (apply mk-imp
                                     (append (if partial-flag
                                                 (list uninst-stotal-prem)
                                                 '())
                                             uninst-step-formulas
                                             (list uninst-kernel-formula)))))
                  uninst-vars uninst-stotal-prems uninst-kernel-formulas)))
       (list uninst-imp-formulas (append tsubst pinst))))))

(define (all-formulas-to-uninst-imp-formula-and-tpinst . all-formulas)
  (let* ((uninst-imp-formulas-and-tpinst
	  (apply all-formulas-to-uninst-imp-formulas-and-tpinst all-formulas))
	 (uninst-imp-formulas (car uninst-imp-formulas-and-tpinst))
	 (pinst (cadr uninst-imp-formulas-and-tpinst)))
    (list (car uninst-imp-formulas) pinst)))

(define (typed-constr-name-to-step-formula
	 typed-constr-name alg-names-with-all-formulas renaming-tsubst)
  (let* ((constr-name (typed-constr-name-to-name typed-constr-name))
	 (type (typed-constr-name-to-type typed-constr-name))
	 (alg-name (alg-form-to-name (arrow-form-to-final-val-type type)))
	 (all-formula (cadr (assoc alg-name alg-names-with-all-formulas)))
	 (var (all-form-to-var all-formula))
	 (partial-flag (t-deg-zero? (var-to-t-deg var)))
	 (kernel
	  (if partial-flag
	      (imp-form-to-conclusion (all-form-to-kernel all-formula))
	      (all-form-to-kernel all-formula)))
	 (argtypes (arrow-form-to-arg-types type))
	 (orig-tvars (alg-name-to-tvars alg-name))
	 (subst-tvars (map (lambda (type)
			     (type-substitute type renaming-tsubst))
			   orig-tvars))
	 (argvars (if (and partial-flag (not (finalg? (var-to-type var))))
		      (map type-to-new-partial-var argtypes)
		      (map type-to-new-var argtypes)))
	 (constr (const-substitute (constr-name-to-constr constr-name)
				   renaming-tsubst #t))
	 (constr-app-term
	  (apply mk-term-in-app-form
		 (cons (make-term-in-const-form constr)
		       (map make-term-in-var-form argvars))))
	 (concl-of-step (formula-subst kernel var constr-app-term))
	 (non-param-argvars
	  (list-transform-positive argvars
	    (lambda (var)
	      (not (member (arrow-form-to-final-val-type (var-to-type var))
			   subst-tvars)))))
	 (stotal-formulas ;as many as there are non-param-argvars
	  (if
	   (and partial-flag (not (finalg? (var-to-type var))))
	   (map (lambda (argvar)
		  (let* ((argtype (var-to-type argvar))
			 (argargtypes (arrow-form-to-arg-types argtype))
			 (argargvars (map type-to-new-var argargtypes))
			 (argvaltype (arrow-form-to-final-val-type argtype))
			 (app-term (apply mk-term-in-app-form
					  (cons (make-term-in-var-form argvar)
						(map make-term-in-var-form
						     argargvars)))))
                    (apply mk-all (append argargvars
					  (list (make-stotal app-term))))))
		non-param-argvars)
	   '()))
	 (pd-formulas
	  (do ((lt argtypes (cdr lt))
	       (lv argvars (cdr lv))
	       (res
		'()
		(let* ((argtype (car lt))
		       (argvar (car lv))
		       (argargtypes (arrow-form-to-arg-types argtype))
		       (argargvars (map type-to-new-var argargtypes))
		       (argvaltype (arrow-form-to-final-val-type argtype))
		       (argvaltype-name (if (alg-form? argvaltype)
					    (alg-form-to-name argvaltype)
					    ""))
		       (info (assoc argvaltype-name
				    alg-names-with-all-formulas)))
		  (if
		   info
		   (let* ((hyp-all-formula (cadr info))
			  (hyp-var (all-form-to-var hyp-all-formula))
			  (hyp-kernel
			   (if (t-deg-zero? (var-to-t-deg hyp-var))
			       (imp-form-to-conclusion
				(all-form-to-kernel hyp-all-formula))
			       (all-form-to-kernel hyp-all-formula)))
			  (app-term
			   (apply mk-term-in-app-form
				  (cons (make-term-in-var-form argvar)
					(map make-term-in-var-form
					     argargvars))))
			  (hyp-formula
			   (formula-subst hyp-kernel hyp-var app-term))
			  (pd-formula
			   (apply mk-all
				  (append argargvars (list hyp-formula)))))
		     (cons pd-formula res))
		   res))))
	      ((null? lt) (reverse res)))))
    (apply mk-all
	   (append argvars
		   (list (apply mk-imp
				(append stotal-formulas pd-formulas
					(list concl-of-step))))))))

; We define a procedure that takes an all-formula and returns the
; corresponding cases axiom.

(define (all-formula-to-cases-aconst all-formula)
  (let* ((uninst-imp-formula-and-tpinst
	  (all-formula-to-uninst-cases-imp-formula-and-tpinst all-formula))
	 (uninst-imp-formula (car uninst-imp-formula-and-tpinst))
	 (tpinst (cadr uninst-imp-formula-and-tpinst)))
    (make-aconst "Cases" 'axiom uninst-imp-formula tpinst all-formula)))

(define (all-formula-to-uninst-cases-imp-formula-and-tpinst all-formula)
  (let* ((free (formula-to-free all-formula))
	 (var (all-form-to-var all-formula))
	 (partial-flag (t-deg-zero? (var-to-t-deg var)))
	 (kernel (if partial-flag
		     (imp-form-to-conclusion
		      (all-form-to-kernel all-formula))
		     (all-form-to-kernel all-formula)))
	 (type (var-to-type var))
	 (alg-name (if (alg-form? type)
		       (alg-form-to-name type)
		       (myerror
			"all-formula-to-uninst-cases-imp-formula-and-tpinst"
			"alg expected" type)))
	 (orig-tvars (alg-name-to-tvars alg-name))
	 (tvars (map (lambda (x) (new-tvar)) orig-tvars))
	 (tparams (alg-form-to-types type))
	 (tsubst (make-substitution tvars tparams))
	 (uninst-type (apply make-alg (cons alg-name tvars)))
	 (uninst-arity (make-arity uninst-type))
	 (cterm (make-cterm var kernel))
	 (pinst (list (list (arity-to-new-general-pvar uninst-arity) cterm)))
	 (pvar (caar pinst))
	 (uninst-var (type-to-new-var uninst-type var))
	 (uninst-stotal-prem
	  (if partial-flag
	      (make-stotal (make-term-in-var-form uninst-var))
	      #f))
	 (uninst-all-formula
	  (make-all uninst-var
		    (if partial-flag
			(make-imp uninst-stotal-prem
				  (make-predicate-formula
				   pvar (make-term-in-var-form uninst-var)))
			(make-predicate-formula
			 pvar (make-term-in-var-form uninst-var)))))
	 (uninst-kernel-formula
          (make-predicate-formula pvar (make-term-in-var-form uninst-var)))
	 (orig-typed-constr-names (alg-name-to-typed-constr-names alg-name))
	 (renaming-tsubst (make-substitution orig-tvars tvars))
	 (typed-constr-names
	  (map (lambda (x)
		 (list (car x) (type-substitute (cadr x) renaming-tsubst)))
	       orig-typed-constr-names))
	 (uninst-step-formulas
	  (map (lambda (x) (typed-constr-name-to-cases-step-formula
			    x uninst-all-formula renaming-tsubst))
	       typed-constr-names))
	 (uninst-imp-formula
	  (make-all uninst-var
                    (apply mk-imp (append
                                   (if partial-flag
                                       (list uninst-stotal-prem)
                                       '())
                                   uninst-step-formulas
                                   (list uninst-kernel-formula))))))
    (list uninst-imp-formula (append tsubst pinst))))

(define (typed-constr-name-to-cases-step-formula
	 typed-constr-name all-formula renaming-tsubst)
  (let* ((constr-name (typed-constr-name-to-name typed-constr-name))
	 (type (typed-constr-name-to-type typed-constr-name))
	 (alg-name (alg-form-to-name (arrow-form-to-final-val-type type)))
	 (var (all-form-to-var all-formula))
	 (partial-flag (t-deg-zero? (var-to-t-deg var)))
	 (kernel
	  (if partial-flag
	      (imp-form-to-conclusion (all-form-to-kernel all-formula))
	      (all-form-to-kernel all-formula)))
	 (argtypes (arrow-form-to-arg-types type))
	 (orig-tvars (alg-name-to-tvars alg-name))
	 (subst-tvars (map (lambda (type)
			     (type-substitute type renaming-tsubst))
			   orig-tvars))
	 (argvars (if (and partial-flag (not (finalg? (var-to-type var))))
		      (map type-to-new-partial-var argtypes)
		      (map type-to-new-var argtypes)))
	 (constr (const-substitute (constr-name-to-constr constr-name)
				   renaming-tsubst #t))
	 (constr-app-term
	  (apply mk-term-in-app-form
		 (cons (make-term-in-const-form constr)
		       (map make-term-in-var-form argvars))))
	 (concl-of-step (formula-subst kernel var constr-app-term))
	 (non-param-argvars
	  (list-transform-positive argvars
	    (lambda (var)
	      (not (member (arrow-form-to-final-val-type (var-to-type var))
			   subst-tvars)))))
	 (stotal-formulas ;as many as there are non-param-argvars
	  (if
	   (and partial-flag (not (finalg? (var-to-type var))))
	   (map (lambda (argvar)
		  (let* ((argtype (var-to-type argvar))
			 (argargtypes (arrow-form-to-arg-types argtype))
			 (argargvars (map type-to-new-var argargtypes))
			 (argvaltype (arrow-form-to-final-val-type argtype))
			 (app-term (apply mk-term-in-app-form
					  (cons (make-term-in-var-form argvar)
						(map make-term-in-var-form
						     argargvars)))))
                    (apply mk-all (append argargvars
					  (list (make-stotal app-term))))))
		non-param-argvars)
	   '())))
    (apply mk-all
	   (append argvars
		   (list (apply mk-imp (append stotal-formulas
					       (list concl-of-step))))))))

(define (formula-var-measure-to-prog-formula formula vars mu)
  (let* ((newvars (map var-to-new-var vars))
         (natlt-term (if (not (assoc "nat" ALGEBRAS))
			 (myerror "First execute (libload \"nat.scm\")")
			 (pt "NatLt")))
         (test-term (mk-term-in-app-form
                     natlt-term
                     (apply
                      mk-term-in-app-form
                      (cons mu (map make-term-in-var-form newvars)))
                     (apply
                      mk-term-in-app-form
                      (cons mu (map make-term-in-var-form vars)))))
         (test-formula (make-atomic-formula test-term))
         (varsubst (make-substitution
                    vars
                    (map make-term-in-var-form newvars)))
         (prem (formula-substitute formula varsubst))
         (all-prem
          (apply mk-all
                 (append newvars (list (make-imp test-formula prem))))))
    (apply mk-all (append vars (list (make-imp all-prem formula))))))

; We in addition need a number n for the number of arguments of the
; measure function.

; GInd: all h,x(all x(all y(hy<hx -> Ry) -> Rx) -> all p(p -> Rx))
; with h a measure function of type alpha1 => ... => alphan => nat.

(define (all-formula-to-uninst-gind-formula-and-tpinst all-formula n)
  (let* ((h (make-fixed-measure-var n))
	 (x (make-fixed-vars 1 n))
	 (y (make-fixed-vars 2 n))
	 (R (make-fixed-pvar n))
	 (Rx (apply make-predicate-formula
		    (cons R (map make-term-in-var-form x))))
	 (Ry (apply make-predicate-formula
		    (cons R (map make-term-in-var-form y))))
	 (hx (apply mk-term-in-app-form
		    (cons (make-term-in-var-form h)
			  (map make-term-in-var-form x))))
	 (hy (apply mk-term-in-app-form
		    (cons (make-term-in-var-form h)
			  (map make-term-in-var-form y))))
	 (hy<hx (make-atomic-formula
		 (mk-term-in-app-form (make-term-in-const-form
				       (pconst-name-to-pconst "NatLt"))
				      hy hx)))
	 (prog-fla ;all x(all y(hy<hx -> Ry) -> Rx)
	  (apply
	   mk-all
	   (append
	    x (list (make-imp
		     (apply mk-all (append y (list (make-imp hy<hx Ry))))
		     Rx)))))
	 (boolevar (make-var (py "boole") -1 1 "")) ;p
	 (booleatom (make-atomic-formula (make-term-in-var-form boolevar)))
	 (concl (make-all boolevar (make-imp booleatom Rx)))
         (uninst-gind-formula
          (apply mk-all (cons h (append x (list (make-imp prog-fla concl))))))
	 (free (formula-to-free all-formula))
         (vars (all-form-to-vars all-formula n))
         (kernel (all-form-to-final-kernel all-formula n))
         (types (map var-to-type vars))
	 (tsubst (make-substitution (map var-to-type x) types))
         (cterm (apply make-cterm (append vars (list kernel))))
         (pinst (list (list R cterm))))
    (if (apply and-op
               (map (lambda (x) (t-deg-one? (var-to-t-deg x))) vars))
        (list uninst-gind-formula (append tsubst pinst))
        (myerror "all-formula-to-uninst-gind-formula-and-tpinst"
                 "total variables expected" vars))))

; all-formula-to-gind-aconst takes an optional argument for the name
; of a theorem proving gind from induction.  If opt-gindthmname is not
; present, gind is viewed as an axiom (and grec will be extracted).
; Otherwise gind is viewed as proved from ind (and rec is extracted):

;                                    NatLtLtSuccTrans hy hx k v:hy<hx w:hx<Sk
;                                    ----------------------------------------
;                           IH  y                            hy<k
;                           -------------------------------------
;                                                   Ry
;                                      ---------------------------
;          Efq:bot->Rx u:hx<0          Prog^h  x  all y(hy<hx->Ry)
;          ------------------          ---------------------------
;                    Rx                           Rx
;             ---------------    ----------------------------------------
; Ind h S(hx) all x(hx<0->Rx)    all k(all x(hx<k->Rx)->all x(hx<Sk->Rx))
; -----------------------------------------------------------------------
;                          all x(hx<S(hx)->Rx)                             x T
;                          ---------------------------------------------------
;                                                     Rx
;                                      ---------------------------------
;                                      all h,x(Prog^h -> all p(p -> Rx))

; In all-formula-to-gind-aconst we also need a number n for the number
; of arguments of the measure function.

(define (all-formula-to-gind-aconst all-formula n . opt-gindthmname)
  (let* ((uninst-gind-formula-and-tpinst
	  (all-formula-to-uninst-gind-formula-and-tpinst all-formula n))
	 (uninst-gind-formula (car uninst-gind-formula-and-tpinst))
	 (tpinst (cadr uninst-gind-formula-and-tpinst)))
    (if
     (null? opt-gindthmname)
					;use gind as axiom
     (let* ((tsubst (list-transform-positive tpinst
		      (lambda (x) (tvar-form? (car x)))))
	    (pinst (list-transform-positive tpinst
		     (lambda (x) (pvar-form? (car x)))))
	    (cterm (cadr (car pinst)))
	    (typeinst-gind-formula
	     (formula-substitute uninst-gind-formula tsubst))
	    (pvar (predicate-form-to-predicate
		   (imp-all-allnc-form-to-final-conclusion
		    typeinst-gind-formula)))
	    (psubst (list (list pvar cterm))))
       (make-aconst "GInd" 'axiom typeinst-gind-formula psubst all-formula))
					;else prove gind from ind
     (let* ((gind-name (string-append "GInd" (number-to-alphabetic-string n)))
	    (info (assoc gind-name THEOREMS)))
       (if (not (and (string? (car opt-gindthmname))
		     (string=? (car opt-gindthmname) gind-name)))
	   (begin (comment "warning: for clarity use the gind-name")
		  (comment gind-name)
		  (comment "rather than")
		  (comment (car opt-gindthmname))))
       (if
	info
	(let ((aconst (theorem-name-to-aconst gind-name)))
	  (make-aconst (aconst-to-name aconst)
		       (aconst-to-kind aconst)
		       (aconst-to-uninst-formula aconst)
		       tpinst
		       all-formula))
	(let* ((h-and-x (all-form-to-vars uninst-gind-formula))
	       (h (car h-and-x))
	       (x (cdr h-and-x))
	       (kernel (all-form-to-final-kernel uninst-gind-formula))
	       (boolevar (all-form-to-var (imp-form-to-conclusion kernel)))
	       (booleatom
		(make-atomic-formula (make-term-in-var-form boolevar)))
	       (prog-fla (imp-form-to-premise kernel))
	       (prog-kernel  (all-form-to-final-kernel prog-fla))
	       (y (all-form-to-vars (imp-form-to-premise prog-kernel)))
	       (Rx (imp-form-to-conclusion prog-kernel))
	       (hx (apply mk-term-in-app-form
			  (cons (make-term-in-var-form h)
				(map make-term-in-var-form x))))
	       (hy (apply mk-term-in-app-form
			  (cons (make-term-in-var-form h)
				(map make-term-in-var-form y))))
	       (k (make-var (py "nat") -1 1 ""))
	       (hx<0 (make-atomic-formula
		      (mk-term-in-app-form (make-term-in-const-form
					    (pconst-name-to-pconst "NatLt"))
					   hx (pt "Zero"))))
	       (hx<k (make-atomic-formula
		      (mk-term-in-app-form (make-term-in-const-form
					    (pconst-name-to-pconst "NatLt"))
					   hx (make-term-in-var-form k))))
	       (hy<hx (make-atomic-formula
		       (mk-term-in-app-form (make-term-in-const-form
					     (pconst-name-to-pconst "NatLt"))
					    hy hx)))
	       (hx<Sk (make-atomic-formula
		       (mk-term-in-app-form (make-term-in-const-form
					     (pconst-name-to-pconst "NatLt"))
					    hx (make-term-in-app-form
						(pt "Succ")
						(make-term-in-var-form k)))))
	       (IH-fla ;all x(hx<k->Rx)
		(apply mk-all (append x (list (make-imp hx<k Rx)))))
	       (ind-fla (make-all k IH-fla))
	       (u (formula-to-new-avar hx<0))
	       (v (formula-to-new-avar hy<hx))
	       (w (formula-to-new-avar hx<Sk))
	       (IH (formula-to-new-avar IH-fla))
	       (prog (formula-to-new-avar prog-fla))
	       (udummy (formula-to-new-avar booleatom))
	       (efq (proof-of-efq-at Rx))
	       (proof
		(apply
		 mk-proof-in-intro-form
		 (append
		  (list h)
		  x
		  (list
		   prog
		   (make-proof-in-all-intro-form
		    boolevar ;p
		    (make-proof-in-imp-intro-form
		     udummy
		     (apply
		      mk-proof-in-elim-form
		      (append
		       (list
			(make-proof-in-aconst-form
			 (all-formulas-to-ind-aconst ind-fla))
			(make-term-in-var-form h)
			(make-term-in-app-form (pt "Succ") hx)
			(apply ;base
			 mk-proof-in-intro-form
			 (append
			  x (list u (mk-proof-in-elim-form
				     efq (make-proof-in-avar-form u)))))
			(apply ;step
			 mk-proof-in-intro-form
			 (append
			  (list k IH)
			  x (list
			     w (apply
				mk-proof-in-elim-form
				(append
				 (list (make-proof-in-avar-form prog))
				 (map make-term-in-var-form x)
				 (list
				  (apply
				   mk-proof-in-intro-form
				   (append
				    y (list
				       v (apply
					  mk-proof-in-elim-form
					  (append
					   (list (make-proof-in-avar-form IH))
					   (map make-term-in-var-form y)
					   (list
					    (mk-proof-in-elim-form
					     (make-proof-in-aconst-form
					      (theorem-name-to-aconst
					       "NatLtLtSuccTrans"))
					     hy hx
					     (make-term-in-var-form k)
					     (make-proof-in-avar-form v)
					     (make-proof-in-avar-form
					      w)))))))))))))))
		       (map make-term-in-var-form x)
		       (list (make-proof-in-aconst-form truth-aconst))))))))))
	       (aconst (begin (set! OLD-COMMENT-FLAG COMMENT-FLAG)
			      (set! COMMENT-FLAG #f)
			      (add-theorem gind-name proof)
			      (set! COMMENT-FLAG OLD-COMMENT-FLAG)
			      (theorem-name-to-aconst gind-name))))
	  (make-aconst (aconst-to-name aconst)
		       (aconst-to-kind aconst)
		       (aconst-to-uninst-formula aconst)
		       tpinst
		       all-formula)))))))

(define (formula-to-efq-aconst formula)
  (let* ((efqaconst (global-assumption-name-to-aconst "Efq"))
         (uninst-efq-formula (aconst-to-uninst-formula efqaconst))
         (pvar (predicate-form-to-predicate
                (imp-form-to-conclusion uninst-efq-formula)))
         (cterm (make-cterm formula))
         (pinst (list (list pvar cterm))))
    (make-aconst "Efq" 'global-assumption uninst-efq-formula pinst)))

; Now the introduction and elimination axioms for the existential quantifier.

; We define a procedure that takes an existential formula and returns the
; corresponding existence introduction axiom:
; ex-intro: all zs,z(A -> ex z A)

(define (ex-formula-to-ex-intro-aconst ex-formula)
  (let* ((var (ex-form-to-var ex-formula))
	 (kernel (ex-form-to-kernel ex-formula))
	 (cterm (make-cterm var kernel))
	 (type (var-to-type var))
	 (tvar (new-tvar))
	 (new-var (type-to-new-var tvar var))
	 (arity (make-arity tvar))
	 (pvar (if (nulltype? (cterm-to-formula cterm))
		   (arity-to-new-pvar arity)
		   (arity-to-new-general-pvar arity)))
	 (predicate-formula
	  (make-predicate-formula pvar (make-term-in-var-form new-var)))
	 (imp-formula (make-imp predicate-formula
				(make-ex new-var predicate-formula)))
	 (uninst-ex-intro-formula (make-all new-var imp-formula))
	 (tsubst (make-substitution (list tvar) (list type)))
	 (pinst (list (list pvar cterm))))
    (make-aconst
     "Ex-Intro" 'axiom uninst-ex-intro-formula (append tsubst pinst)
     ex-formula)))

; We define a procedure that takes an existential formula and a
; conclusion, and returns the corresponding existence elimination axiom:
; ex-elim: allnc zs(ex z A -> all z(A -> B) -> B)

(define (ex-formula-and-concl-to-ex-elim-aconst ex-formula concl)
  (let* ((var (ex-form-to-var ex-formula))
	 (kernel (ex-form-to-kernel ex-formula))
	 (cterm1 (make-cterm var kernel))
	 (cterm2 (make-cterm concl))
	 (type (var-to-type var))
	 (tvar (new-tvar))
	 (new-var (type-to-new-var tvar var))
	 (arity1 (make-arity tvar))
	 (pvar1 (if (nulltype? (cterm-to-formula cterm1))
		    (arity-to-new-pvar arity1)
		    (arity-to-new-general-pvar arity1)))
	 (predicate-formula1
	  (make-predicate-formula pvar1 (make-term-in-var-form new-var)))
	 (arity2 (make-arity))
	 (pvar2 (if (nulltype? (cterm-to-formula cterm2))
		    (arity-to-new-pvar arity2)
		    (arity-to-new-general-pvar arity2)))
	 (predicate-formula2 (make-predicate-formula pvar2))
	 (imp-formula
	  (mk-imp
	   (make-ex new-var predicate-formula1)
	   (make-all new-var (make-imp predicate-formula1 predicate-formula2))
	   predicate-formula2))
	 (tsubst (make-substitution (list tvar) (list type)))
	 (pinst (list (list pvar1 cterm1) (list pvar2 cterm2))))
    (make-aconst "Ex-Elim" 'axiom imp-formula (append tsubst pinst)
		 ex-formula concl)))

; Now the introduction and elimination axioms for the exnc quantifier.

; We define a procedure that takes an exnc formula and returns the
; corresponding existence introduction axiom:
; exnc-intro: allnc zs,z(A -> exnc z A)

(define (exnc-formula-to-exnc-intro-aconst exnc-formula)
  (let* ((var (exnc-form-to-var exnc-formula))
	 (kernel (exnc-form-to-kernel exnc-formula))
	 (cterm (make-cterm var kernel))
	 (type (var-to-type var))
	 (tvar (new-tvar))
	 (new-var (type-to-new-var tvar var))
	 (arity (make-arity tvar))
	 (pvar (if (nulltype? (cterm-to-formula cterm))
		   (arity-to-new-pvar arity)
		   (arity-to-new-general-pvar arity)))
	 (predicate-formula
	  (make-predicate-formula pvar (make-term-in-var-form new-var)))
	 (imp-formula (make-imp predicate-formula
				(make-exnc new-var predicate-formula)))
	 (uninst-exnc-intro-formula (make-allnc new-var imp-formula))
	 (tsubst (make-substitution (list tvar) (list type)))
	 (pinst (list (list pvar cterm))))
    (make-aconst
     "Exnc-Intro" 'axiom uninst-exnc-intro-formula (append tsubst pinst)
     exnc-formula)))

; We define a procedure that takes an exnc formula and a
; conclusion, and returns the corresponding exnc elimination axiom:
; exnc-elim: allnc zs(exnc z A -> allnc z(A -> B) -> B)

(define (exnc-formula-and-concl-to-exnc-elim-aconst exnc-formula concl)
  (let* ((var (exnc-form-to-var exnc-formula))
	 (kernel (exnc-form-to-kernel exnc-formula))
	 (cterm1 (make-cterm var kernel))
	 (cterm2 (make-cterm concl))
	 (type (var-to-type var))
	 (tvar (new-tvar))
	 (new-var (type-to-new-var tvar var))
	 (arity1 (make-arity tvar))
	 (pvar1 (if (nulltype? (cterm-to-formula cterm1))
		    (arity-to-new-pvar arity1)
		    (arity-to-new-general-pvar arity1)))
	 (predicate-formula1
	  (make-predicate-formula pvar1 (make-term-in-var-form new-var)))
	 (arity2 (make-arity))
	 (pvar2 (if (nulltype? (cterm-to-formula cterm2))
		    (arity-to-new-pvar arity2)
		    (arity-to-new-general-pvar arity2)))
	 (predicate-formula2 (make-predicate-formula pvar2))
	 (imp-formula
	  (mk-imp
	   (make-exnc new-var predicate-formula1)
	   (make-allnc new-var
		       (make-imp predicate-formula1 predicate-formula2))
	   predicate-formula2))
	 (tsubst (make-substitution (list tvar) (list type)))
	 (pinst (list (list pvar1 cterm1) (list pvar2 cterm2))))
    (make-aconst "Exnc-Elim" 'axiom imp-formula (append tsubst pinst)
		 exnc-formula concl)))

; Additional axioms with names "Intro" and "Elim"

; We define a procedure that takes an inductively defined predicate
; constant and a list of comprehension terms, and returns the
; corresponding elimination axiom.  For instance, for the inductively
; defined exd z^ A we obtain 
; Elim: allnc z^(exid z^ A -> allnc z^(A -> B) -> B)

; We begin with the strengthened elimination axioms.

(define (number-and-idpredconst-to-intro-aconst i idpc)
  (let* ((name (idpredconst-to-name idpc))
	 (types (idpredconst-to-types idpc))
	 (tsubst (idpredconst-name-and-types-to-tsubst name types))
	 (pinst-for-param-pvars (idpredconst-to-pinst idpc))
	 (param-pvars (idpredconst-name-to-param-pvars name))
	 (param-pvar-cterms
	  (if (member name '("ExDT" "ExLT" "ExRT" "ExUT"))
	      (map predicate-to-cterm-with-total-vars param-pvars)
	      (map predicate-to-cterm param-pvars)))
	 (idpc-names-with-pvars-and-opt-alg-names
	  (idpredconst-name-to-idpc-names-with-pvars-and-opt-alg-names
	   name))
	 (names (map car idpc-names-with-pvars-and-opt-alg-names))
	 (pvars (map cadr idpc-names-with-pvars-and-opt-alg-names))
	 (tvars (idpredconst-name-to-tvars name))
	 (uninst-idpcs (map (lambda (name)
			       (make-idpredconst name tvars param-pvar-cterms))
			     names))
	 (uninst-idpc-cterms (map predicate-to-cterm uninst-idpcs))
	 (psubst-for-pvars (make-substitution-wrt pvar-cterm-equal?
						  pvars uninst-idpc-cterms))
	 (orig-clauses-with-names
	  (idpredconst-name-to-clauses-with-names name))
	 (orig-clauses (map car orig-clauses-with-names))
	 (orig-clause
	  (if (and (integer? i) (< i (length orig-clauses)))
	      (list-ref orig-clauses i)
	      (myerror "number-and-idpredconst-to-intro-aconst" i
		       "should be an index of a clause for" name)))
	 (uninst-clause (formula-substitute orig-clause psubst-for-pvars)))
    (make-aconst "Intro" 'axiom uninst-clause
		 (append tsubst pinst-for-param-pvars) i idpc)))

; Again, now parallel to induction, with repro-formulas.  Reason:
; repro-formulas needed for proof-to-extracted-term-aux , and probably
; also for normalization via terms.

; Now for elimination.  

; imp-formulas is a list of formulas I xs^ -> A(xs^), where all idpcs
; are simultaneously inductively defined.  Then uninst-elim-formula is
; I xs^ -> K1(Is,Ps) ->..-> Kk(Is,Ps) -> P xs^.  This elim-formula is
; "simplified" in the sense that all clauses K(Is,Ps) are for the
; relevant idpcs only, i.e., those mentioned in the imp-formulas.
; Moreover, these clauses are simplified by omitting the recursive
; premises and their I-duplicates (the "strengthening") for
; non-relevant idpcs.

(define (imp-formulas-to-uninst-elim-formulas-etc . imp-formulas)
  (if
   (null? imp-formulas)
   (list '() empty-subst empty-subst empty-subst)
   (let* ((prems (map (lambda (x)
			(if (imp-form? x) (imp-form-to-premise x)
			    (myerror
			     "imp-formulas-to-uninst-elim-formulas-etc"
			     "implication expected" x)))
		      imp-formulas))
	  (concls (map imp-form-to-conclusion imp-formulas))
	  (relevant-idpcs
	   (map (lambda (prem)
		  (if (and
		       (predicate-form? prem)
		       (idpredconst-form? (predicate-form-to-predicate prem)))
		      (predicate-form-to-predicate prem)
                      (myerror
                       "imp-formulas-to-uninst-elim-formulas-etc"
                       "idpredconst formula expected" prem)))
		prems))
	  (relevant-idpc-names (map idpredconst-to-name relevant-idpcs))
	  (idpc (car relevant-idpcs))
	  (name (car relevant-idpc-names))
	  (idpc-names-with-pvars-and-opt-alg-names
	   (idpredconst-name-to-idpc-names-with-pvars-and-opt-alg-names
	    name))
	  (names (map car idpc-names-with-pvars-and-opt-alg-names))
	  (ordered-relevant-idpc-names
	   (list-transform-positive names
	     (lambda (x) (member x relevant-idpc-names))))
	  (relevant-orig-clauses ;with Xj
	   (apply append (map idpredconst-name-to-clauses
			      ordered-relevant-idpc-names)))
	  (relevant-pvars (map idpredconst-name-to-pvar relevant-idpc-names))
	  (pvars (map cadr idpc-names-with-pvars-and-opt-alg-names))
	  (irrelevant-pvars (set-minus pvars relevant-pvars))
	  (simplified-relevant-orig-clauses
	   (map (lambda (clause)
		  (clause-to-simplified-clause clause irrelevant-pvars))
		relevant-orig-clauses))
	  (relevant-rec-prems-list ;only rec-prems with relevant Xj
	   (map (lambda (clause)
		  (let* ((kernel (all-allnc-form-to-final-kernel clause))
			 (clause-prems (imp-impnc-form-to-premises kernel)))
		    (list-transform-positive clause-prems
		      (lambda (x)
			(let ((concl
			       (imp-impnc-all-allnc-form-to-final-conclusion
				x)))
			  (and (predicate-form? concl)
			       (member (predicate-form-to-predicate concl)
				       relevant-pvars)))))))
		relevant-orig-clauses))
	  (tvars (idpredconst-name-to-tvars name))
	  (param-pvars (idpredconst-name-to-param-pvars name))
	  (param-pvar-cterms
	   (if (member name '("ExDT" "ExLT" "ExRT" "ExUT"))
	       (map predicate-to-cterm-with-total-vars param-pvars)
	       (map predicate-to-cterm param-pvars)))
	  (uninst-idpcs (map (lambda (name)
			       (make-idpredconst name tvars param-pvar-cterms))
			     names))
	  (uninst-idpc-cterms (map predicate-to-cterm uninst-idpcs))
	  (psubst-for-pvars (make-substitution-wrt pvar-cterm-equal?
						   pvars uninst-idpc-cterms))
	  (simplified-relevant-clauses ;with Ij
	   (map (lambda (orig-clause)
		  (formula-substitute orig-clause psubst-for-pvars))
		simplified-relevant-orig-clauses))
	  (simplified-relevant-strengthened-clauses ;the K(Is,Xs)'s
	   (map (lambda (clause rec-prems orig-clause)
		  (replace-final-conclusion
		   clause
		   (apply
		    mk-imp
		    (append rec-prems
			    (list (imp-impnc-all-allnc-form-to-final-conclusion
				   orig-clause))))))
		simplified-relevant-clauses
		relevant-rec-prems-list
		relevant-orig-clauses))
	  (relevant-pvars (map idpredconst-name-to-pvar relevant-idpc-names))
	  (new-var-lists (map (lambda (pvar)
				(map type-to-new-partial-var
				     (arity-to-types (pvar-to-arity pvar))))
			      relevant-pvars))
	  (relevant-pvar-formulas
	   (map (lambda (pvar vars)
		  (apply make-predicate-formula
			 (cons pvar (map make-term-in-var-form vars))))
		relevant-pvars new-var-lists))
	  (relevant-uninst-idpcs
	   (map (lambda (name) (make-idpredconst name tvars param-pvar-cterms))
		relevant-idpc-names))
	  (relevant-uninst-idpc-formulas
	   (map (lambda (uninst-idpc vars)
		  (apply make-predicate-formula
			 (cons uninst-idpc (map make-term-in-var-form vars))))
		relevant-uninst-idpcs new-var-lists))
	  (uninst-elim-formulas
	   (map (lambda (uninst-idpc-formula pvar-formula)
		  (apply mk-imp (cons uninst-idpc-formula
                                      (append
				       simplified-relevant-strengthened-clauses
				       (list pvar-formula)))))
		relevant-uninst-idpc-formulas relevant-pvar-formulas))
	  (pinst-for-param-pvars (idpredconst-to-pinst idpc))
	  (arg-lists (map predicate-form-to-args prems))
	  (var-lists
	   (map (lambda (args)
		  (map (lambda (arg)
			 (if (and
			      (term-in-var-form? arg)
			      (t-deg-zero?
			       (var-to-t-deg (term-in-var-form-to-var arg))))
			     (term-in-var-form-to-var arg)
			     (myerror
			      "imp-formulas-to-uninst-elim-formulas-etc"
			      "partial variable expected" arg)))
		       args))
		arg-lists))
	  (var-lists-test
	   (for-each
	    (lambda (vars prem)
	      (if (not (= (length (remove-duplicates vars)) (length vars)))
		  (myerror "imp-formulas-to-uninst-elim-formulas-etc"
			   "distinct variables expected in" prem)))
	    var-lists prems))
	  (concl-cterms (map (lambda (vars concl)
			       (apply make-cterm (append vars (list concl))))
			     var-lists concls))
	  (pinst-for-pvars
	   (make-substitution-wrt pvar-cterm-equal?
				  relevant-pvars concl-cterms))
	  (types (idpredconst-to-types idpc))
	  (tsubst (idpredconst-name-and-types-to-tsubst name types)))
     (list uninst-elim-formulas
	   tsubst pinst-for-param-pvars pinst-for-pvars))))

(define (clause-to-simplified-clause clause irrelevant-pvars)
  (cond
   ((all-form? clause)
    (make-all (all-form-to-var clause)
	      (clause-to-simplified-clause
	       (all-form-to-kernel clause) irrelevant-pvars)))
   ((allnc-form? clause)
    (make-allnc (allnc-form-to-var clause)
		(clause-to-simplified-clause
		 (allnc-form-to-kernel clause) irrelevant-pvars)))
   ((impnc-form? clause)
    (make-impnc (impnc-form-to-premise clause)
		(clause-to-simplified-clause
		 (impnc-form-to-conclusion clause) irrelevant-pvars)))
   ((imp-form? clause)
    (let* ((prem (imp-form-to-premise clause))
	   (final-conc (imp-impnc-all-allnc-form-to-final-conclusion prem)))
      (if (and (predicate-form? final-conc)
	       (member (predicate-form-to-predicate final-conc)
		       irrelevant-pvars))
	  (clause-to-simplified-clause
	   (imp-form-to-conclusion clause) irrelevant-pvars)
	  (make-imp prem (clause-to-simplified-clause
			  (imp-form-to-conclusion clause) irrelevant-pvars)))))
   ((predicate-form? clause) clause)
   (else (myerror "clause-to-simplified-clause"
		  "clause expected" clause))))

(define (replace-final-conclusion clause new-conclusion)
  (cond
   ((all-form? clause)
    (make-all (all-form-to-var clause)
	      (replace-final-conclusion
	       (all-form-to-kernel clause) new-conclusion)))
   ((allnc-form? clause)
    (make-allnc (allnc-form-to-var clause)
		(replace-final-conclusion
		 (allnc-form-to-kernel clause) new-conclusion)))
   ((impnc-form? clause)
    (make-impnc (impnc-form-to-premise clause)
		(replace-final-conclusion
		 (impnc-form-to-conclusion clause) new-conclusion)))
   ((imp-form? clause)
    (make-imp (imp-form-to-premise clause)
	      (replace-final-conclusion
	       (imp-form-to-conclusion clause) new-conclusion)))
   ((predicate-form? clause) new-conclusion)
   (else (myerror "replace-final-conclusion"
		  "clause expected" clause))))

(define (cr-idpc-clause? formula new-pvars param-pvars)
  (and
   (null? (formula-to-free formula))
   (let* ((allnc-kernel (allnc-form-to-final-kernel formula))
	  (all-kernel (all-form-to-final-kernel allnc-kernel))
	  (impnc-prems (impnc-form-to-premises all-kernel))
	  (final-impnc-conc (impnc-form-to-final-conclusion all-kernel))
	  (param-prems-and-final-conc
	   (imp-form-to-param-premises-and-final-conclusion-for-cr-idpc
	    final-impnc-conc new-pvars param-pvars))
	  (param-prems (car param-prems-and-final-conc))
	  (rec-prems-imp-final-conc (cadr param-prems-and-final-conc))
	  (rec-prems (imp-form-to-premises rec-prems-imp-final-conc))
	  (final-conc (imp-form-to-final-conclusion rec-prems-imp-final-conc)))
     (and (predicate-form? final-conc)
	  (member (predicate-form-to-predicate final-conc) new-pvars)
	  (apply and-op (map (lambda (fla)
			       (rec-premise-of-cr-idpc-clause?
				fla new-pvars param-pvars))
			     rec-prems))))))

(define (nc-idpc-clause? formula new-pvars param-pvars)
  (and
   (null? (formula-to-free formula))
   (let* ((allnc-kernel (allnc-form-to-final-kernel formula))
	  (all-kernel (all-form-to-final-kernel allnc-kernel))
	  (impnc-prems (impnc-form-to-premises all-kernel))
	  (final-impnc-conc (impnc-form-to-final-conclusion all-kernel))
	  (param-prems-and-final-conc
	   (imp-form-to-param-premises-and-final-conclusion-for-nc-idpc
	    final-impnc-conc new-pvars param-pvars))
	  (param-prems (car param-prems-and-final-conc))
	  (rec-prems-imp-final-conc (cadr param-prems-and-final-conc))
	  (rec-prems (imp-form-to-premises rec-prems-imp-final-conc))
	  (final-conc (imp-form-to-final-conclusion rec-prems-imp-final-conc)))
     (and (predicate-form? final-conc)
	  (member (predicate-form-to-predicate final-conc) new-pvars)
	  (apply and-op (map (lambda (fla)
			       (rec-premise-of-nc-idpc-clause?
				fla new-pvars))
			     rec-prems))))))

(define (imp-form-to-param-premises-and-final-conclusion-for-cr-idpc
	 formula new-pvars param-pvars) 
  (if (and (imp-form? formula)
	   (param-premise-of-cr-idpc-clause? (imp-form-to-premise formula)
					     new-pvars param-pvars))
      (let* ((rec-result
	      (imp-form-to-param-premises-and-final-conclusion-for-cr-idpc
	       (imp-form-to-conclusion formula) new-pvars param-pvars))
	     (formula-list (car rec-result))
	     (final-conclusion (cadr rec-result)))
	(list (cons (imp-form-to-premise formula) formula-list)
	      final-conclusion))
      (list '() formula)))

(define (imp-form-to-param-premises-and-final-conclusion-for-nc-idpc
	 formula new-pvars param-pvars) 
  (if (and (imp-form? formula)
	   (param-premise-of-nc-idpc-clause? (imp-form-to-premise formula)
					     new-pvars param-pvars))
      (let* ((rec-result
	      (imp-form-to-param-premises-and-final-conclusion-for-nc-idpc
	       (imp-form-to-conclusion formula) new-pvars param-pvars))
	     (formula-list (car rec-result))
	     (final-conclusion (cadr rec-result)))
	(list (cons (imp-form-to-premise formula) formula-list)
	      final-conclusion))
      (list '() formula)))

; For an imp-impnc-all-allnc formula and a list pvars we define when
; the formula is strictly positive in pvars.

(define (strictly-positive? formula pvars)
  (cond
   ((atom-form? formula) #t)
   ((prime-predicate-form? formula)
    (let ((pred (predicate-form-to-predicate formula)))
      (cond
       ((pvar-form? pred) (member pred pvars))
       ((predconst-form? pred) #t)
       ((idpredconst-form? pred)
	(let* ((cterms (idpredconst-to-cterms pred))
	       (formulas (map cterm-to-formula cterms)))
	  (apply and-op (map (lambda (fla) (strictly-positive? fla pvars))
			     formulas))))
       (else (myerror "strictly-positive?" "predicate expected" pred)))))
   ((imp-form? formula)
    (let ((prem (imp-form-to-premise formula))
	  (conc (imp-form-to-conclusion formula)))
      (and (null? (intersection (formula-to-pvars prem) pvars))
	   (strictly-positive? conc pvars))))
   ((impnc-form? formula)
    (let ((prem (impnc-form-to-premise formula))
	  (conc (impnc-form-to-conclusion formula)))
      (and (null? (intersection (formula-to-pvars prem) pvars))
	   (strictly-positive? conc pvars))))
   ((all-form? formula)
    (let ((kernel (all-form-to-kernel formula)))
      (strictly-positive? kernel pvars)))
   ((allnc-form? formula)
    (let ((kernel (allnc-form-to-kernel formula)))
      (strictly-positive? kernel pvars)))
   (else (myerror "strictly-positive?"
		  "imp-impnc-all-allnc formula expected" formula))))

(define (param-premise-of-cr-idpc-clause? formula new-pvars param-pvars)
  (let ((free-pvars (formula-to-pvars formula)))
    (and (null? (intersection free-pvars new-pvars))
	 (null? (set-minus free-pvars param-pvars))
	 (strictly-positive? formula param-pvars))))

(define (param-premise-of-nc-idpc-clause? formula new-pvars param-pvars)
  (let ((free-pvars (formula-to-pvars formula)))
    (and (null? (intersection free-pvars new-pvars))
	 (or (and (null? (intersection free-pvars param-pvars))
		  (non-computational-invariant? formula))
	     (and (prime-predicate-form? formula)
		  (let ((pred (predicate-form-to-predicate formula)))
		    (and (pvar-form? pred)
			 (member pred param-pvars))))))))

; Recursive premises in clauses for computationally relevant idpcs
; have a new-pvar-formula as final conclusion and are strictly
; positive in the new-pvars (for the idpcs), and its premises are
; strictly positive in the param-pvars.

(define (rec-premise-of-cr-idpc-clause? formula new-pvars param-pvars)
  (let ((free-pvars (formula-to-pvars formula)))
    (and (pair? (intersection free-pvars new-pvars))
	 (strictly-positive? formula new-pvars)
	 (apply and-op (map (lambda (fla)
			      (strictly-positive? fla param-pvars))
			    (imp-impnc-all-allnc-form-to-premises formula))))))

; Recursive premises in clauses for non-computational idpcs in
; addition must have premises without pvars which are
; non-computational-invariant premises.

(define (rec-premise-of-nc-idpc-clause? formula new-pvars)
  (let ((free-pvars (formula-to-pvars formula)))
    (and (null? (set-minus free-pvars new-pvars))
	 (pair? (intersection free-pvars new-pvars))
	 (strictly-positive? formula new-pvars)
	 (apply and-op (map non-computational-invariant?
					;order not required
			    (imp-impnc-all-allnc-form-to-premises formula))))))

; For an imp-impnc-all-allnc formula without predicate variables we
; define when it is non-computational-invariant.

(define (non-computational-invariant? formula)
  (cond
   ((atom-form? formula) #t)
   ((prime-predicate-form? formula)
    (let ((pred (predicate-form-to-predicate formula)))
      (cond
       ((pvar-form? pred)
	(myerror "non-computational-invariant?"
		 "formula without predicate variables expected"
		 formula))
       ((predconst-form? pred) #t)
       ((idpredconst-form? pred)
	(let* ((name (idpredconst-to-name pred))
	       (cterms (idpredconst-to-cterms pred))
	       (formulas (map cterm-to-formula cterms)))
	  (and (null? (idpredconst-name-to-opt-alg-name name))
	       (apply and-op (map non-computational-invariant? formulas)))))
       (else
	(myerror "non-computational-invariant?" "predicate expected" pred)))))
   ((imp-form? formula)
    (let ((prem (imp-form-to-premise formula))
	  (conc (imp-form-to-conclusion formula)))
      (and (non-computational-invariant? prem)
	   (non-computational-invariant? conc))))
   ((impnc-form? formula)
    (let ((prem (impnc-form-to-premise formula))
	  (conc (impnc-form-to-conclusion formula)))
      (and (non-computational-invariant? prem)
	   (non-computational-invariant? conc))))
   ((and-form? formula)
    (let ((left (and-form-to-left formula))
	  (right (and-form-to-right formula)))
      (and (non-computational-invariant? left)
	   (non-computational-invariant? right))))
   ((all-form? formula)
    (let ((kernel (all-form-to-kernel formula)))
      (non-computational-invariant? kernel)))
   ((ex-form? formula) #f)
   ((allnc-form? formula)
    (let ((kernel (allnc-form-to-kernel formula)))
      (non-computational-invariant? kernel)))
   ((exnc-form? formula)
    (let ((kernel (exnc-form-to-kernel formula)))
      (non-computational-invariant? kernel)))
   ((or (exca-form? formula) (excl-form? formula))
    (non-computational-invariant? (unfold-formula formula)))
   (else (myerror "non-computational-invariant?"
		  "formula expected" formula))))

(define (imp-formulas-to-uninst-elim-formula-etc . imp-formulas)
  (let* ((uninst-elim-formulas-etc
	  (apply imp-formulas-to-uninst-elim-formulas-etc
		 imp-formulas))
	 (uninst-elim-formulas (car uninst-elim-formulas-etc))
	 (rest (cdr uninst-elim-formulas-etc)))
    (cons (car uninst-elim-formulas) rest)))

; We define a procedure that takes imp-formulas and returns the
; corresponding elimination axiom.

(define (imp-formulas-to-elim-aconst . imp-formulas)
  (let* ((uninst-elim-formula-etc
	  (apply imp-formulas-to-uninst-elim-formula-etc
		 imp-formulas))
	 (uninst-elim-formula (car uninst-elim-formula-etc))
	 (tpinst (apply append (cdr uninst-elim-formula-etc))))
    (apply make-aconst (append (list "Elim" 'axiom uninst-elim-formula tpinst)
			       imp-formulas))))

; Theorems

; A theorem is a special assumption constant.  We maintain an
; association list THEOREMS assigning to every name of a theorem the
; assumption constant and its proof.

; Format of THEOREMS 
; ((name aconst proof <extracted-term>) ...)

(define (theorem-name-to-aconst name)
  (let ((info (assoc name THEOREMS)))
    (if info
	(cadr info)
	(myerror "theorem-name-to-aconst" "theorem name expected" name))))

(define (theorem-name-to-proof name)
  (let ((info (assoc name THEOREMS)))
    (if info
	(caddr info)
	(myerror "theorem-name-to-proof" "theorem name expected" name))))

(define (theorem-aconst-to-inst-proof aconst)
  (let* ((name (aconst-to-name aconst))
	 (kind (aconst-to-kind aconst))
	 (proof-of-thm
	  (if (eq? 'theorem kind)
	      (theorem-name-to-proof name)
	      (myerror "theorem-aconst-to-inst-proof" "kind theorem expected"
		       kind (aconst-to-formula aconst))))
	 (tpinst (aconst-to-tpinst aconst))
	 (tsubst (list-transform-positive tpinst
		   (lambda (x) (tvar-form? (car x)))))
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x)))))
	 (rename (make-rename tsubst))
	 (prename (make-prename tsubst))
	 (psubst (map (lambda (x) (list (prename (car x)) (cadr x))) pinst))
	 (arename (make-arename tsubst psubst rename prename)))
    (proof-substitute-aux
     proof-of-thm tsubst empty-subst psubst empty-subst
     rename prename arename)))

(define (theorem-or-global-assumption-name-to-pconst-name string)
  (string-append "c"
		 (list->string (remove-numerals (string->list string)))))

(define (remove-numerals charlist)
  (if (null? charlist)
      '()
      (append (let ((char (car charlist)))
		(cond ((char=? char #\-) (list #\X #\x))
		      ((char=? char #\() (list #\Y #\y)) 
		      ((char=? char #\)) (list #\y #\Y)) 
		      ((char=? char #\1) (list #\O #\n #\e)) 
		      ((char=? char #\2) (list #\T #\w #\o)) 
		      ((char=? char #\3) (list #\T #\h #\r #\e #\e)) 
		      ((char=? char #\4) (list #\F #\o #\u #\r))
		      ((char=? char #\5) (list #\F #\i #\v #\e))
		      ((char=? char #\6) (list #\S #\i #\x))
		      ((char=? char #\7) (list #\S #\e #\v #\e #\n))
		      ((char=? char #\8) (list #\E #\i #\g #\h #\t))
		      ((char=? char #\9) (list #\N #\i #\n #\e))
		      ((char=? char #\0) (list #\Z #\e #\r #\o))
		      (else (list char))))
	      (remove-numerals (cdr charlist)))))

(define (theorem-or-global-assumption-to-pconst thm-or-ga)
  (let* ((thm-or-ga-name (aconst-to-name thm-or-ga))
	 (pconst-name
	  (theorem-or-global-assumption-name-to-pconst-name thm-or-ga-name))
	 (pconst (pconst-name-to-pconst pconst-name))
	 (tpinst (aconst-to-tpinst thm-or-ga))
	 (tsubst (list-transform-positive tpinst
		   (lambda (x) (tvar-form? (car x)))))
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x)))))
	 (new-tsubst
	  (do ((l pinst (cdr l))
	       (res '() (let* ((pvar (caar l))
			       (cterm (cadar l))
			       (cterm-type (formula-to-et-type
					    (cterm-to-formula cterm))))
			  (if (nulltype? cterm-type)
			      res
			      (cons (list (PVAR-TO-TVAR pvar) cterm-type)
				    res)))))
	      ((null? l) (reverse res)))))
    (const-substitute pconst (compose-t-substitutions tsubst new-tsubst) #f)))

(define (add-theorem string . opt-proof)
  (if (and (null? opt-proof)
	   (null? PPROOF-STATE))
      (myerror
       "add-theorem" "proof argument or proof under construction expected"))
  (let ((proof (if (null? opt-proof)
		   (pproof-state-to-proof)
		   (car opt-proof))))
    (if (not (null? (proof-to-free-avars proof)))
	(apply myerror
	       (cons "unexpected free assumptions"
		     (proof-to-free-avars proof))))
    (if
     (is-used? string '() 'theorem)
     *the-non-printing-object*
     (let ((formula (unfold-formula (proof-to-formula proof)))
	   (nc-viols (nc-violations proof))
	   (h-deg-viols (h-deg-violations proof)))
       (if (pair? nc-viols)
	   (apply myerror (cons "allnc-intro with cvars" nc-viols)))
       (if (pair? h-deg-viols)
	   (apply myerror (cons "h-deg violations at aconsts" h-deg-viols)))
       (let ((aconst (make-aconst string 'theorem formula empty-subst)))
	 (set! THEOREMS (cons (list string aconst proof) THEOREMS))
	 (if (not (member string (list "Id" "If")))
	     (comment "ok, " string " has been added as a new theorem."))
	 (if (not (formula-of-nulltype? formula))
	     (let ((pconst-name
		    (theorem-or-global-assumption-name-to-pconst-name string))
		   (type (formula-to-et-type formula)))
	       (add-program-constant pconst-name type t-deg-zero 'const 0)))
	 (if (final-substring? "Total" string)
	     (let ((name (substring string 0 (- (string-length string)
						(string-length "Total")))))
	       (if (assoc name PROGRAM-CONSTANTS)
		   (change-t-deg-to-one name)))))))))

(define save add-theorem)

(define (nc-violations proof)
  (if (formula-of-nulltype? (proof-to-formula proof))
      '()
      (nc-violations-aux proof)))

; In nc-violations-aux we can assume that the proved formula has
; computational content.

(define (nc-violations-aux proof)
  (case (tag proof)
    ((proof-in-avar-form proof-in-aconst-form) '())
    ((proof-in-imp-intro-form)
     (nc-violations-aux (proof-in-imp-intro-form-to-kernel proof)))
    ((proof-in-imp-elim-form)
     (let* ((op (proof-in-imp-elim-form-to-op proof))
	    (arg (proof-in-imp-elim-form-to-arg proof))
	    (prevop (nc-violations-aux op))
	    (prevarg (nc-violations arg)))
       (union prevop prevarg)))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (prev (nc-violations-aux kernel)))
       (if (member-wrt avar=? avar (proof-to-cvars proof))
	   (adjoin avar prev)
	   prev)))
    ((proof-in-impnc-elim-form)
     (nc-violations-aux (proof-in-impnc-elim-form-to-op proof)))
    ((proof-in-and-intro-form)
     (let* ((left (proof-in-and-intro-form-to-left proof))
	    (right (proof-in-and-intro-form-to-right proof)))
       (if (formula-of-nulltype? (proof-to-formula left))
	   (nc-violations-aux right)
	   (union (nc-violations-aux left)
		  (nc-violations right)))))
    ((proof-in-and-elim-left-form)
     (nc-violations-aux
      (proof-in-and-elim-left-form-to-kernel proof)))
    ((proof-in-and-elim-right-form)
     (nc-violations-aux
      (proof-in-and-elim-right-form-to-kernel proof)))
    ((proof-in-all-intro-form)
     (nc-violations-aux
      (proof-in-all-intro-form-to-kernel proof)))
    ((proof-in-all-elim-form)
     (nc-violations-aux (proof-in-all-elim-form-to-op proof)))
    ((proof-in-allnc-intro-form)
     (let* ((var (proof-in-allnc-intro-form-to-var proof))
	    (kernel (proof-in-allnc-intro-form-to-kernel proof))
	    (prev (nc-violations-aux kernel)))
       (if (member var (proof-to-cvars proof))
	   (adjoin var prev)
	   prev)))
    ((proof-in-allnc-elim-form)
     (nc-violations-aux
      (proof-in-allnc-elim-form-to-op proof)))
    (else (myerror "nc-violations-aux" "proof expected" proof))))

; h-deg-violations (parallel to nc-violation) gives the list of names
; of aconsts where a pvar whose tvar shows up in the eterm is
; substituted by a cterm without computational content.  Reason: this
; situation generally produces an error when proof-to-extracted-term
; is applied.  Exceptions: the aconsts receiving a special treatment
; in proof-to-extracted-term

(define (h-deg-violations proof)
  (if (formula-of-nulltype? (proof-to-formula proof))
      '()
      (h-deg-violations-aux proof)))

; In h-deg-violations-aux we can assume that the proven formula has
; computational content.

(define (h-deg-violations-aux proof)
  (case (tag proof)
    ((proof-in-avar-form) '())
    ((proof-in-aconst-form)
     (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	    (name (aconst-to-name aconst)))
       (if (or (member
		name
		'("Ind" "Cases" "GInd" "Intro" "Elim" "Ex-Intro" "Ex-Elim"
		  "Exnc-Intro" "Exnc-Elim" "Eq-Compat"))

	       (apply
		or-op
		(map
		 (lambda (string)
		   (and (<= (string-length string) (string-length name))
			(string=? (substring name 0 (string-length string))
				  string)))
		 '("All-AllPartial" "ExPartial-Ex"
		   "ExclIntro" "ExclElim" "MinPr"))))
	   '()
	   (let* ((uninst-formula (aconst-to-uninst-formula aconst))
		  (tpinst (aconst-to-tpinst aconst))
		  (pvars (formula-to-pvars uninst-formula))
		  (et-type (formula-to-et-type uninst-formula))
		  (et-tvars (type-to-free et-type))
		  (violating-pvars
		   (list-transform-positive pvars
		     (lambda (pvar)
		       (let ((info (assoc pvar tpinst)))
			 (and info
			      (member (PVAR-TO-TVAR pvar) et-tvars)
			      (nulltype?
			       (formula-to-et-type
				(cterm-to-formula (cadr info))))))))))
	     (if (pair? violating-pvars)
		 (list (aconst-to-name aconst))
		 '())))))
    ((proof-in-imp-intro-form)
     (h-deg-violations-aux (proof-in-imp-intro-form-to-kernel proof)))
    ((proof-in-imp-elim-form)
     (let* ((op (proof-in-imp-elim-form-to-op proof))
	    (arg (proof-in-imp-elim-form-to-arg proof))
	    (prevop (h-deg-violations-aux op))
	    (prevarg (h-deg-violations arg)))
       (union prevop prevarg)))
    ((proof-in-impnc-intro-form)
     (h-deg-violations-aux (proof-in-impnc-intro-form-to-kernel proof)))
    ((proof-in-impnc-elim-form)
     (h-deg-violations-aux (proof-in-impnc-elim-form-to-op proof)))
    ((proof-in-and-intro-form)
     (let* ((left (proof-in-and-intro-form-to-left proof))
	    (right (proof-in-and-intro-form-to-right proof)))
       (if (formula-of-nulltype? (proof-to-formula left))
	   (h-deg-violations-aux right)
	   (union (h-deg-violations-aux left)
		  (h-deg-violations right)))))
    ((proof-in-and-elim-left-form)
     (h-deg-violations-aux
      (proof-in-and-elim-left-form-to-kernel proof)))
    ((proof-in-and-elim-right-form)
     (h-deg-violations-aux
      (proof-in-and-elim-right-form-to-kernel proof)))
    ((proof-in-all-intro-form)
     (h-deg-violations-aux
      (proof-in-all-intro-form-to-kernel proof)))
    ((proof-in-all-elim-form)
     (h-deg-violations-aux (proof-in-all-elim-form-to-op proof)))
    ((proof-in-allnc-intro-form)
     (h-deg-violations-aux
      (proof-in-allnc-intro-form-to-kernel proof)))
    ((proof-in-allnc-elim-form)
     (h-deg-violations-aux
      (proof-in-allnc-elim-form-to-op proof)))
    (else (myerror "h-deg-violations-aux" "proof expected" proof))))

(define (remove-theorem . strings)
  (define (rthm1 thm-name)
    (let ((info (assoc thm-name THEOREMS)))
      (if info
	  (let* ((proof (theorem-name-to-proof thm-name))
		 (formula (unfold-formula (proof-to-formula proof))))
	    (do ((l THEOREMS (cdr l))
		 (res '() (if (string=? thm-name (caar l))
			      res
			      (cons (car l) res))))
		((null? l) (set! THEOREMS (reverse res))))
	    (comment "ok, theorem " thm-name " is removed")
	    (if (not (formula-of-nulltype? formula))
		(remove-program-constant
		 (theorem-or-global-assumption-name-to-pconst-name
		  thm-name))))
	  (myerror "remove-theorem" "theorem expected"
		   thm-name))))
  (for-each rthm1 strings))

(define (display-theorems . x)
  (if
   COMMENT-FLAG
   (let ((reduced-thms (if (null? x)
			   THEOREMS
			   (do ((l THEOREMS (cdr l))
				(res '() (if (member (caar l) x)
					     (cons (car l) res)
					     res)))
			       ((null? l) res)))))
     (for-each (lambda (thm)
		 (display (car thm))
		 (display tab)
		 (display-formula
		  (fold-formula (aconst-to-formula (cadr thm))))
		 (newline))
	       reduced-thms))))


; Global assumptions

; A global assumption is a special assumption constant.  It provides a
; proposition whose proof does not concern us presently.  We maintain an
; association list GLOBAL-ASSUMPTIONS assigning to every name of a
; global assumption the assumption constant.

; Format of GLOBAL-ASSUMPTIONS 
; ((name aconst) ...)

(define (global-assumption-name-to-aconst name)
  (let* ((info (assoc name GLOBAL-ASSUMPTIONS)))
    (if info
	(cadr info)
	(myerror "global-assumption-name-to-aconst"
		 "global assumption name expected" name))))

(define (add-global-assumption string formula . optional-arity)
  (if (pair? (formula-to-free formula))
      (apply myerror
	     (append (list "add-global-assumption" "unexpected free variables")
		     (formula-to-free formula))))
  (let* ((fla (unfold-formula formula))
	 (aconst (make-aconst string 'global-assumption fla empty-subst)))
    (if
     (is-used? string formula 'global-assumption)
     *the-non-printing-object*
     (begin
       (set! GLOBAL-ASSUMPTIONS (cons (list string aconst) GLOBAL-ASSUMPTIONS))
       (if
	(not (member string (list "Efq-Log" "Stab-Log" "Efq" "Stab")))
	(comment "ok, " string " has been added as a new global assumption."))
       (if (not (formula-of-nulltype? fla))
	   (let* ((pconst-name
		   (theorem-or-global-assumption-name-to-pconst-name string))
		  (type (formula-to-et-type fla))
		  (arity (if (pair? optional-arity)
			     (car optional-arity)
			     0)))
	     (add-program-constant pconst-name type 1 'const arity)))))))

(define aga add-global-assumption)

(define (remove-global-assumption . strings)
  (define (rga1 ga-name)
    (let ((info (assoc ga-name GLOBAL-ASSUMPTIONS)))
      (if info
	  (let* ((aconst (global-assumption-name-to-aconst ga-name))
		 (formula (aconst-to-uninst-formula aconst)))
	    (do ((l GLOBAL-ASSUMPTIONS (cdr l))
		 (res '() (if (string=? ga-name (caar l))
			      res
			      (cons (car l) res))))
		((null? l) (set! GLOBAL-ASSUMPTIONS (reverse res))))
	    (comment "ok, global assumption " ga-name " is removed")
	    (if (not (formula-of-nulltype? formula))
		(remove-program-constant
		 (theorem-or-global-assumption-name-to-pconst-name
		  ga-name))))
	  (myerror "remove-global-assumption" "global assumption expected"
		   ga-name))))
  (for-each rga1 strings))

(define rga remove-global-assumption)

(define (display-global-assumptions . x)
  (if
   COMMENT-FLAG
   (let ((reduced-gas (if (null? x)
			  GLOBAL-ASSUMPTIONS
			  (do ((l GLOBAL-ASSUMPTIONS (cdr l))
			       (res '() (if (member (caar l) x)
					    (cons (car l) res)
					    res)))
			      ((null? l) res)))))
     (for-each (lambda (ga)
		 (display (car ga))
		 (display tab)
		 (display-formula (fold-formula (aconst-to-formula (cadr ga))))
		 (newline))
	       reduced-gas))))

(define (new-global-assumption-name string)
  (new-global-assumption-name-aux string 0))

(define (new-global-assumption-name-aux string n)
  (if (assoc (string-append string (number-to-string n))
	     GLOBAL-ASSUMPTIONS)
      (new-global-assumption-name-aux string (+ n 1))
      (string-append string (number-to-string n))))

; (search-about string) searches in THEOREMS and GLOBAL-ASSUMPTIONS
; for all items whose name contains string.

(define (search-about string)
  (let ((thms (list-transform-positive THEOREMS
		(lambda (x) (substring? string (car x)))))
	(gas (list-transform-positive GLOBAL-ASSUMPTIONS
		(lambda (x) (substring? string (car x))))))
    (if (null? thms)
	(comment "No theorems with name containing " string)
	(begin
	  (comment "Theorems with name containing " string)
	  (for-each (lambda (x)
		      (comment (car x))
		      (display-comment
		       (pretty-print-string
			(string-length COMMENT-STRING)
			(- pp-width (string-length COMMENT-STRING))
			(aconst-to-formula (cadr x))))
		      (newline))
		    thms)))
    (if (null? gas)
	(comment "No global assumptions with name containing " string)
	(begin
	  (comment "Global assumptions with name containing " string)
	  (for-each (lambda (x)
		      (comment (car x))
		      (display-comment
		       (pretty-print-string
			(string-length COMMENT-STRING)
			(- pp-width (string-length COMMENT-STRING))
			(aconst-to-formula (cadr x))))
		      (newline))
		    gas)))))

(define (initial-substring? string1 string2)
  (let ((l1 (string-length string1))
	(l2 (string-length string2)))
    (and (<= l1 l2)
	 (string=? string1 (substring string2 0 l1)))))

; (initial-substring? "abc" "abcde")

(define (final-substring? string1 string2)
  (let ((l1 (string-length string1))
	(l2 (string-length string2)))
    (and (<= l1 l2)
	 (string=? string1 (substring string2 (- l2 l1) l2)))))

; (final-substring? "cde" "abcde")

(define (substring? string1 string2)
  (do ((s string2 (substring s 1 (string-length s)))
       (res #f (initial-substring? string1 s)))
      ((or res (zero? (string-length s)))
       res)))

; (substring? "bcd" "abcde")

