; $Id: pconst.scm 2366 2010-01-14 15:09:27Z schwicht $
; 4. Constants
; ============

; Every constant (more explicitely: object constant) has a type and
; denotes a computable (hence continuous) functional of that type.  A
; constant is communicated to the outside world as a string (in order to
; allow for lower and upper case characters).

; We have the following three kinds of constants: 
; - constructors, kind 'constr
; - constants with user defined rules (also called program(mable)
;   constant, or pconst), kind 'pconst
; - constants whose rules are fixed, kind 'fixed-rules.

; The latter are built into the system: recursion operators for
; arbitrary algebras, equality and existence operators for finitary
; algebras, and existence elimination.  They are typed in parametrized
; form, with the actual type (or formula) given by a type (or type and
; formula) substitution that is also part of the constant.  For
; instance, equality is typed by alpha -> alpha -> boole and a type
; substitution alpha --> rho.  This is done for clarity (and brevity,
; e.g. for large rho in the example above), since one should think of
; the type of a constant in this way.

; For constructors and for constants with fixed rules, by efficiency
; reasons we want to keep the object denoted by the constant (as needed
; for normalization by evaluation) as part of it.  It depends on the
; type of the constant, hence must be updated in a given proof whenever
; the type changes by a type substitution.

; For a program constant the denoted object needs to be updated whenever
; a new rule is added.  These rules are of crucial importance for the
; correctness of a proof, and should not be invisibly buried in the
; denoted object taken as part of the constant (hence of any term
; involving it).  Therefore we keep the rules of a program constant and
; also its denoted objects (depending on type substitutions) at a
; central place, a global variable PROGRAM-CONSTANTS which assigns to
; every name of such a constant the constant itself (with uninstantiated
; type), the rules presently chosen for it and also its denoted objects
; (as association list with type substitutions as keys).  When a new
; rule has been added, the new objects for the program constant are
; computed (by nbe-pconst-and-tsubst-and-rules-to-object), and the new
; list to be associated with the program constant is written in
; PROGRAM-CONSTANTS instead.

; For reasons of efficiency in normalization by evaluation, we keep
; the semantical value of a constant - called object - as part of the
; constant.  Then when normalizing is not necessary to recompute the
; object each time the constant is considered.  The only exception is
; for pconsts, where this object changes when a new rule is added.
; For these we look up the object in PROGRAM-CONSTANTS, and use the
; space kept for objects to record the arity of the pconst (a non
; negative integer).

; Generalities for all kinds of constants

(define (make-const
	 obj-or-arity name kind uninst-type tsubst t-deg token-type .
	 type-info-or-repro-formulas)
  (append (list 'const obj-or-arity name kind uninst-type tsubst
		t-deg token-type)
	  type-info-or-repro-formulas))

; The type substitution tsubst must be restricted to the type variables
; in uninst-type.  type-info-or-repro-formulas are only present for the
; constants with fixed rules.  They are needed for the reproduction case.

; Format of type-info-or-repro-formulas: (1) For a rec-const.  (a)
; Ordinary pconst: (k param-type1 ... arrow-type1 ...).  The number k
; indicates how many of the following types are parameter types.  (b)
; From an ind-aconst (while normalizing).  all-formulas.  (c) From an
; elim-aconst (while normalizing).  imp-formulas.  (2) For a
; cases-const.  Here a single arrow-type or all-formula suffices.  (a)
; Ordinary pconst: (param-type1 ... arrow-type).  (b) From a
; cases-aconst (while normalizing).  all-formula.

(define const-to-object-or-arity cadr)
(define const-to-name caddr)
(define const-to-kind cadddr)
(define (const-to-uninst-type x) (car (cddddr x)))
(define (const-to-tsubst x) (cadr (cddddr x)))
(define (const-to-t-deg x) (caddr (cddddr x)))
(define (const-to-token-type x) (cadddr (cddddr x)))
(define (const-to-type-info-or-repro-formulas x) (cddddr (cddddr x)))

(define (const-to-type const)
  (type-substitute (const-to-uninst-type const) (const-to-tsubst const)))

(define (const-to-tvars const)
  (type-to-free (const-to-uninst-type const)))

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

(define (const? x)
  (and (const-form? x)
       (list? x)
       (<= 7 (length x))
       (let ((obj-or-arity (cadr x))
	     (name (caddr x))
	     (kind (cadddr x))
	     (uninst-type (car (cddddr x)))
	     (tsubst (cadr (cddddr x)))
	     (t-deg (caddr (cddddr x)))
	     (token-type (cadddr (cddddr x))))
	 (and (string? name)
	      (t-deg? t-deg)
	      (memq token-type
		    '(const constscheme
			    postfix-op prefix-op add-op mul-op rel-op pair-op))
	      (case kind
		((constr)
		 (and (type? uninst-type)
		      (constr-name? name)))
		((pconst)
		 (and (type? uninst-type)
		      (pconst-name? name)))
		((fixed-rules)
		 (fixed-rules-name? name))
		(else #f))))))

(define (constr-name? string) (assoc string CONSTRUCTORS))
(define (pconst-name? string) (assoc string PROGRAM-CONSTANTS))
(define (fixed-rules-name? string)
  (and (member string '("Rec" "Cases" "GRec" "GRecGuard" "Efq"
			"Ex-Elim" "=" "E" "SE"))))

(define (const=? const1 const2)
  (and (string=? (const-to-name const1) (const-to-name const2))
       (equal? (const-to-type const1)
	       (const-to-type const2))))

; (define (const=? const1 const2)
;   (and (string=? (const-to-name const1) (const-to-name const2))
;        (equal? (const-to-uninst-type const1)
; 	       (const-to-uninst-type const2))))

; Constructors

; A constructor is a special constant with no rules.  We maintain an
; association list CONSTRUCTORS assigning to every name of a constructor
; an association list associating with every type substitution
; (restricted to the type parameters) the corresponding instance of the
; constructor.

; Format of CONSTRUCTORS 
; ((name ((tsubst1 constr1) ... (tsubst_n constr_n))) ...)  
; where tsubst_n is the empty type substitution and constr_n the
; uninstantiated constructor with this name.

(define CONSTRUCTORS '())
(define INITIAL-CONSTRUCTORS CONSTRUCTORS)

(define (constr-name-to-inst-constructors name)
  (let ((info (assoc name CONSTRUCTORS)))
    (if info
	(cadr info)
	(myerror "constr-name-to-inst-constructors" "constructor name expected"
		 name))))

(define (constr-name-and-tsubst-to-constr name tsubst)
  (let ((info (assoc name CONSTRUCTORS)))
    (if info
	(let ((info1 (assoc-wrt substitution-equal? tsubst (cadr info))))
	  (if info1
	      (cadr info1)
	      (myerror "constr-name-and-tsubst-to-constr" "unknown tsubst"
		       tsubst "for constructor" name)))
	(myerror "constr-name-and-tsubst-to-constr" "constructor name expected"
		 name))))

(define (constr-name-to-constr name . rest)
  (cond
   ((string? name)
    (let ((tsubst (if (null? rest) empty-subst (car rest))))
      (constr-name-and-tsubst-to-constr name tsubst)))
   ((and (pair? name) (string=? "Ex-Intro" (car name)))
    (let ((ex-formula
	   (if (pair? (cdr name))
	       (cadr name)
	       (myerror "constr-name-to-constr" "name expected" name))))
      (ex-formula-to-ex-intro-const ex-formula)))
   ((and (pair? name) (string=? "Intro" (car name)))
    (let ((i (if (pair? (cdr name))
		 (cadr name)
		 (myerror "constr-name-to-constr" "name expected" name)))
	  (idpc (if (pair? (cddr name))
			   (caddr name)
			   (myerror "constr-name-to-constr" "name expected"
				    name))))
      (number-and-idpredconst-to-intro-const i idpc)))
   (else (myerror "constr-name-to-constr" "name expected" name))))

(define (display-constructors . x)
  (if
   COMMENT-FLAG
   (let ((reduced-algs (if (null? x)
			   ALGEBRAS
			   (do ((l ALGEBRAS (cdr l))
				(res '() (if (member (caar l) x)
					     (cons (car l) res)
					     res)))
			       ((null? l) res)))))
     (for-each
      (lambda (alg)
	(let* ((alg-name (car alg))
	       (typed-constr-names
		(alg-name-to-typed-constr-names alg-name)))
	  (display alg-name) (newline)
	  (for-each (lambda (tcn)
		      (let ((name (typed-constr-name-to-name tcn))
			    (type (typed-constr-name-to-type tcn))
			    (optional-token-type
			     (typed-constr-name-to-optional-token-type tcn)))
			(display tab)
			(display name) (display ":")
			(display tab)
			(display (type-to-string type))
			(if (pair? optional-token-type)
			    (begin
			      (display tab)
			      (display (car optional-token-type))))
			(newline)))
		    typed-constr-names)))
      reduced-algs))))

(define (ex-formula-to-ex-intro-const ex-formula)
  (let* ((free (formula-to-free ex-formula))
	 (free-types (map var-to-type free))
	 (f (length free))
         (var (ex-form-to-var ex-formula))
         (kernel (ex-form-to-kernel ex-formula))
	 (type (var-to-type var))
	 (kernel-type (nbe-formula-to-type kernel))
	 (arity (+ f 2))
	 (exintroop-type
	  (apply mk-arrow
		 (append free-types
			 (list type kernel-type (make-tconst "existential")))))
	 (obj (nbe-make-object
	       exintroop-type
	       (nbe-curry
		(lambda objs
		  (nbe-make-object
		     (make-tconst "existential")
		     (nbe-make-constr-value
		      (list "Ex-Intro" ex-formula) objs)))
		exintroop-type
		arity))))
    (make-const obj "Ex-Intro" 'constr
		exintroop-type empty-subst 1 'const ex-formula)))

(define (number-and-idpredconst-to-intro-const i idpc)
  (let* ((aconst (number-and-idpredconst-to-intro-aconst i idpc))
	 (formula (aconst-to-formula aconst))
	 (introop-type (nbe-formula-to-type formula))
	 (arity (length (arrow-form-to-arg-types introop-type)))
	 (nbe-alg-type (arrow-form-to-final-val-type introop-type))
	 (constr-value-name (list "Intro" i idpc))
	 (obj (nbe-make-object
	       introop-type
	       (if (zero? arity)
		   (nbe-make-constr-value constr-value-name '())
		   (nbe-curry (lambda objs
				(nbe-make-object 
				 nbe-alg-type (nbe-make-constr-value
					       constr-value-name objs)))
		    introop-type
		    arity)))))
    (make-const obj "Intro" 'constr
		introop-type empty-subst 1 'const i idpc)))

; Constants with user defined rules, i.e. program constants

; Format of PROGRAM-CONSTANTS
; ((name pconst comprules rewrules 
;        ((tsubst1 obj1) ... (tsubst_n obj_n)) opt-external-code)
;  ...)
; where pconst comprules rewrules are for the uninstantiated type.
; The last obligatory entry is an association list assigning to every
; type substitution (restricted to the type parameters) the
; corresponding object.  The optional final entry is code of an
; external function mapping a type substitution and an object list to
; either an object to be returned immediately, or else to #f, in which
; case the rules are tried next.

(define PROGRAM-CONSTANTS '())
(define INITIAL-PROGRAM-CONSTANTS PROGRAM-CONSTANTS)

(define (pconst-name-to-pconst name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (if info
	(cadr info)
	(myerror "pconst-name-to-pconst" "pconst name expected" name))))

(define (pconst-name-to-comprules name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (if info
	(caddr info)
	(myerror "pconst-name-to-comprules" "pconst name expected" name))))

(define (pconst-name-to-rewrules name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (if info
	(cadddr info)
	(myerror "pconst-name-to-rewrules" "pconst name expected" name))))

(define (pconst-name-to-inst-objs name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (if info
	(car (cddddr info))
	(myerror "pconst-name-to-inst-objs" "pconst name expected" name))))

(define (pconst-name-and-tsubst-to-object name tsubst)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (if info
	(let ((info1
	       (assoc-wrt substitution-equal? tsubst (car (cddddr info)))))
	  (if info1
	      (cadr info1)
	      (let ((pconst (pconst-name-to-pconst name)))
		(const-substitute pconst tsubst #f) ;updates PROGRAM-CONSTANTS
		(pconst-name-and-tsubst-to-object name tsubst))))
	(myerror "pconst-name-and-tsubst-to-object" "pconst name expected"
		 name))))

(define (pconst-name-to-object name)
  (pconst-name-and-tsubst-to-object name empty-subst))

(define (pconst-name-to-external-code name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (if info
	(let ((info1 (cdr (cddddr info))))
	  (if (pair? info1)
	      (car info1)
	      #f))
	(myerror "pconst-name-to-external-code" "pconst name expected" name))))

(define (display-program-constant string)
  (if (not (string? string))
      (myerror "display-program-constant" "string expected" string))
  (let ((info (assoc string PROGRAM-CONSTANTS)))
    (if
     (not info)
     (myerror "display-program-constant" "program constant expected" string))
    (if
     COMMENT-FLAG
     (begin
       (display (car info)) (newline)
       (let ((comprules (caddr info))
	     (rewrules (cadddr info))
	     (external-code (cdr (cddddr info))))
	 (if (pair? comprules)
	     (begin
	       (display "  comprules") (newline)
	       (do ((lc comprules (cdr lc)))
		   ((null? lc))
		 (begin (display tab)
			(dt (rule-to-lhs (car lc)))
			(display tab)
			(dt (term-to-eta-nf (rule-to-rhs (car lc))))
			(newline)))))
	 (if (pair? rewrules)
	     (begin
	       (display "  rewrules") (newline)
	       (do ((lr rewrules (cdr lr)))
		   ((null? lr))
		 (begin (display tab)
			(dt (rule-to-lhs (car lr)))
			(display tab)
			(dt (term-to-eta-nf (rule-to-rhs (car lr))))
			(newline)))))
	 (if (pair? external-code)
	     (begin (display "  external code") (newline)
		    (display tab)
		    (display (car external-code))
		    (newline))))))))

(define (display-program-constants . x)
  (if (pair? x)
      (begin (newline)
	     (display-program-constant (car x))
	     (apply display-program-constants (cdr x)))))

; In the following rest consists of an initial segment of: t-deg
; (default 0), token type (default const) and arity (default maximal
; number of argument types).

(define (add-program-constant name uninst-type . rest)
  (define (add-program-constant-aux name uninst-type t-deg token-type arity)
    (if
     (is-used? name (list uninst-type t-deg token-type arity)
	       'program-constant)
     *the-non-printing-object*
     (cond
      ((not (string? name))
       (myerror "add-program-constant" "string expected" name))
      ((not (type? uninst-type))
       (myerror "add-program-constant" "type expected" uninst-type))
      ((not (t-deg? t-deg))
       (myerror "add-program-constant" "t-degree expected" t-deg))
      ((not (and (integer? arity)
		 (not (negative? arity))
		 (<= arity (length (arrow-form-to-arg-types uninst-type)))))
       (myerror "add-program-constant" "arity expected" arity))
      ((not (memq token-type
		  '(const postfix-op prefix-op binding-op add-op mul-op
			  rel-op and-op or-op imp-op pair-op)))
       (myerror "add-program-constant" "token type expected" token-type))
      (else
       (let* ((pconst (make-const arity name 'pconst uninst-type empty-subst
				  t-deg token-type))
	      (obj
	       (if (zero? arity)
		   (nbe-reflect
		    (nbe-make-termfam
		     uninst-type
		     (lambda (k) (make-term-in-const-form pconst))))
		   (nbe-make-object
		    uninst-type
		    (nbe-curry
		     (lambda objs ;arity many
		       (let* ((obj1 (nbe-reflect
				     (nbe-make-termfam
				      uninst-type
				      (lambda (k)
				       (make-term-in-const-form pconst)))))
			      (val (nbe-object-to-value obj1)))
			 (apply (nbe-uncurry val arity) objs)))
		     uninst-type
		     arity)))))
	 (set! PROGRAM-CONSTANTS
	       (cons (list name pconst '() '() (list (list empty-subst obj)))
		     PROGRAM-CONSTANTS))
	 (if (null? (type-to-free uninst-type))
	     (add-token name
			token-type
			(const-to-token-value pconst))
	     (add-token name
			'constscheme
			pconst))
	 (if (not (member name
			  (list "cEfqXxLog" "cStabXxLog" "cEfq" "cStab" "cId"
				"cIf" "Inhab"
				"AndConst" "ImpConst" "OrConst" "NegConst")))
	     (begin
	       (comment
		"ok, program constant " name ": "
		(type-to-string uninst-type))
	       (if (not (eq? 'const token-type))
		   (comment "of token type " token-type " and"))
	       (comment "of t-degree " t-deg " and arity " arity
			" added")
	       (if (and (t-deg-one? t-deg)
			(not (assoc (string-append name "Total") THEOREMS)))
		   (comment "warning: theorem "
			    (string-append name "Total")
			    " stating totality missing")))))))))
  (let ((l (length (arrow-form-to-arg-types uninst-type))))
    (if 
     (null? rest)
     (add-program-constant-aux name uninst-type 0 'const l)
     (let ((t-deg (car rest)))
       (if (null? (cdr rest))
	   (add-program-constant-aux name uninst-type t-deg 'const l)
	   (let ((token-type (cadr rest)))
	     (if
	      (null? (cddr rest))
	      (add-program-constant-aux name uninst-type t-deg token-type l)
	      (add-program-constant-aux name uninst-type t-deg token-type
					(caddr rest)))))))))

(define (change-t-deg-to-one name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (if
     (not info)
     (myerror "change-t-deg-to-one" "name of program constant expected" name))
    (let* ((pconst (pconst-name-to-pconst name))
	   (comprules (pconst-name-to-comprules name))
	   (rewrules (pconst-name-to-rewrules name))
	   (code (pconst-name-to-external-code name)) ;may be #f
	   (pconsts-exept-name
	    (do ((l PROGRAM-CONSTANTS (cdr l))
		 (res '() (if (string=? (caar l) name)
			      res
			      (cons (car l) res))))
		((null? l) (reverse res))))
	   (arity (const-to-object-or-arity pconst))
	   (uninst-type (const-to-uninst-type pconst))
	   (token-type (const-to-token-type pconst))
	   (new-pconst (make-const arity name 'pconst uninst-type empty-subst
				   t-deg-one token-type))
	   (obj
	    (if (zero? arity)
		(nbe-reflect
		 (nbe-make-termfam
		  uninst-type
		  (lambda (k) (make-term-in-const-form new-pconst))))
		(nbe-make-object
		 uninst-type
		 (nbe-curry
		  (lambda objs ;arity many
		    (let* ((obj1 (nbe-reflect
				  (nbe-make-termfam
				   uninst-type
				   (lambda (k)
				     (make-term-in-const-form new-pconst)))))
			   (val (nbe-object-to-value obj1)))
		      (apply (nbe-uncurry val arity) objs)))
		  uninst-type
		  arity))))
	   (inst-objs (list (list empty-subst obj))))
      (set! PROGRAM-CONSTANTS
	    (cons (if code
		      (list name new-pconst '() '() inst-objs code)
		      (list name new-pconst '() '() inst-objs))
		  pconsts-exept-name))
      (remove-token name)
      (if (null? (type-to-free uninst-type))
	  (add-token name
		     (const-to-token-type pconst)
		     (const-to-token-value new-pconst))
	  (add-token name
		     'constscheme
		     new-pconst))
      (do ;add again the previous comprules, now using the new-pconst
	  ((lc comprules (cdr lc)))
	  ((null? lc))
	(add-computation-rule (pt (term-to-string (rule-to-lhs (car lc))))
			      (pt (term-to-string (rule-to-rhs (car lc))))))
      (do ;add again the previous rewrules, now using the new-pconst
	  ((lr rewrules (cdr lr)))
	  ((null? lr))
	(add-rewrite-rule (pt (term-to-string (rule-to-lhs (car lr))))
			  (pt (term-to-string (rule-to-rhs (car lr)))))))))

(define apc add-program-constant)

(define (remove-program-constant . strings)
  (define (rpc1 pconst-name)
    (let ((info (assoc pconst-name PROGRAM-CONSTANTS)))
      (if info
	  (begin (do ((l PROGRAM-CONSTANTS (cdr l))
		      (res '() (if (string=? pconst-name (caar l))
				   res
				   (cons (car l) res))))
		     ((null? l) (set! PROGRAM-CONSTANTS (reverse res))))
		 (remove-token pconst-name)
		 (comment
		  "ok, program constant " pconst-name " removed"))
	  (myerror "remove-program-constant" "program constant expected"
		   pconst-name))))
  (for-each rpc1 strings))

(define rpc remove-program-constant)

; Computation rules and rewrite rules are association lists associating
; a rhs to a lhs.

(define rule-to-lhs car)
(define rule-to-rhs cadr)
(define (lhs-and-rhs-to-rule lhs rhs) (list lhs rhs))

(define (add-computation-rule x y)
  (let ((lhs (if (string? x) (pt x) x))
	(rhs (if (string? y) (pt y) y)))
    (if (not (term-form? lhs))
	(myerror "add-computation-rule" "term expected" x))
    (if (not (term-form? rhs))
	(myerror "add-computation-rule" "term expected" y))
    (if (not (equal? (term-to-type lhs) (term-to-type rhs)))
	(myerror "add-computation-rule" "equal types expected"
		 (term-to-type lhs) (term-to-type rhs)))
    (let* ((op (term-in-app-form-to-final-op lhs))
	   (args (term-in-app-form-to-args lhs))
	   (lhsfree (term-to-free lhs)))
      (if (not (and (term-in-const-form? op)
		    (eq? 'pconst
			 (const-to-kind (term-in-const-form-to-const op)))))
	  (myerror "add-computation-rule" "program constant expected" op))
      (if (and (pair? (const-to-tsubst (term-in-const-form-to-const op)))
	       (positive? (const-to-object-or-arity
			   (term-in-const-form-to-const op))))
	  (myerror "add-computation-rule" "expected type variables are"
		   (term-in-const-form-to-string
		    (make-term-in-const-form
		     (pconst-name-to-pconst
		      (const-to-name (term-in-const-form-to-const op)))))))
      (if (not (= (length args) (const-to-object-or-arity
				 (term-in-const-form-to-const op))))
	  (myerror "add-computation-rule" "number of args should be"
		   (const-to-object-or-arity
		    (term-in-const-form-to-const op))))
      (do ((l args (cdr l))
	   (free '() (union (term-to-free (car l)) free)))
	  ((null? l) #f)
	(if (not (nbe-constructor-pattern? (car l)))
	    (myerror "add-computation-rule" "constructor pattern expected"
		     (car l))
	    (if (not (null? (intersection free (term-to-free (car l)))))
		(myerror "add-computation-rule"
			 "left linear lhs expected" lhs))))
      (if (not (null? (set-minus (term-to-free rhs) lhsfree)))
	  (apply myerror
		 (append (list "add-computation-rule" "new free vars in rhs")
			 (set-minus (term-to-free rhs) lhsfree))))
      (let* ((pconst (term-in-const-form-to-const op))
	     (name (const-to-name pconst))
	     (comprules (pconst-name-to-comprules name))
	     (rewrules (pconst-name-to-rewrules name))
	     (arity (const-to-object-or-arity pconst))
	     (renamed-lhs-and-rhs
	      (if (zero? arity)
		  (let* ((lhs-tvars (const-to-tvars pconst))
			 (new-tvars (map (lambda (x) (new-tvar)) lhs-tvars))
			 (new-tsubst
			  (map (lambda (x y) (list x y)) lhs-tvars new-tvars)))
		    (list (term-substitute lhs new-tsubst)
			  (term-substitute rhs new-tsubst)))
		  (let* ((newvars (map (lambda (x) (make-term-in-var-form
						    (var-to-new-var x)))
				       lhsfree))
			 (subst (map (lambda (x y) (list x y))
				     lhsfree newvars)))
		    (list (term-substitute lhs subst)
			  (term-substitute rhs subst)))))
	     (renamed-lhs (car renamed-lhs-and-rhs))
	     (renamed-rhs (cadr renamed-lhs-and-rhs)))
	(for-each ;of comprules
	 (lambda (cr)
	   (let ((old-lhs (car cr))
		 (old-rhs (cadr cr)))
	     (if
	      (if (zero? arity)
		  (let ((tunif (type-unify (term-to-type old-lhs)
					   (term-to-type renamed-lhs))))
		    (and tunif
			 (not (term=? (term-substitute old-rhs tunif)
				      (term-substitute renamed-rhs tunif)))))
		  (let ((unif (unify old-lhs renamed-lhs)))
		    (and unif
			 (not (term=? (term-substitute old-rhs unif)
				      (term-substitute renamed-rhs unif))))))
	      (myerror
	       "add-computation-rule" lhs "->" rhs
	       "is in conflict with already existing computation rule"
	       old-lhs "->" old-rhs))))
	 comprules)
	(let*
	    ((new-comprules
	      (append
	       comprules
	       (list
		(list
		 lhs
		 (term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs
		  rhs)))))
	     (tsubst-obj-alist (pconst-name-to-inst-objs name))
	     (external-code (pconst-name-to-external-code name))
	     (new-tsubst-obj-alist
	      (if
	       (zero? arity)
	       (let* ((internal-tsubst (const-to-tsubst pconst))
		      (reduced-tsubst-obj-alist
		       (list-transform-positive
			   tsubst-obj-alist
			 (lambda (p)
			   (not (tsubst-match internal-tsubst (car p)))))))
		 (cons (list internal-tsubst
			     (nbe-term-to-object
			      rhs (nbe-make-bindings '() '())))
		       reduced-tsubst-obj-alist))
					;map nbe-... through tsubst-obj-alist
	       (map (lambda (x)
		      (list
		       (car x)
		       (if
			external-code
			(nbe-pconst-and-tsubst-and-rules-to-object
			 pconst (car x) new-comprules rewrules external-code)
			(nbe-pconst-and-tsubst-and-rules-to-object
			 pconst (car x) new-comprules rewrules))))
		    tsubst-obj-alist)))
	     (uninst-pconst (pconst-name-to-pconst name))
	     (pconsts-exept-name
	      (do ((l PROGRAM-CONSTANTS (cdr l))
		   (res '() (if (string=? (caar l) name)
				res
				(cons (car l) res))))
		  ((null? l) (reverse res)))))
	  (set! PROGRAM-CONSTANTS
		(cons (if external-code
			  (list name uninst-pconst new-comprules rewrules
				new-tsubst-obj-alist external-code)
			  (list name uninst-pconst new-comprules rewrules
				new-tsubst-obj-alist))
		      pconsts-exept-name))
	  (if (not (member name (list "Inhab" "AndConst" "ImpConst"
				      "OrConst" "NegConst")))
	      (comment
	       "ok, computation rule " (term-to-string lhs) " -> "
	       (term-to-string rhs) " added")))))))

(define (constr-type-to-constr-param-types constr-type)
  (let* ((alg-name (alg-form-to-name
		    (arrow-form-to-final-val-type constr-type)))
	 (simalg-names (alg-name-to-simalg-names alg-name))
	 (argtypes (arrow-form-to-arg-types constr-type)))
    (list-transform-positive argtypes
      (lambda (argtype)
	(let ((valtype (arrow-form-to-final-val-type argtype)))
	  (not (and (alg-form? valtype)
		    (member (alg-form-to-name valtype) simalg-names))))))))

(define (add-computation-rules . x)
  (if (odd? (length x))
      (myerror "add-computation-rules" "even number of arguments expected"))
  (if (null? x)
      (myerror "add-computation-rules" "arguments expected"))
  (letrec ((acr (lambda (ts)
                  (if (< 3 (length ts))
                      (begin
                        (add-computation-rule (car ts) (cadr ts))
                        (acr (cddr ts)))
                      (add-computation-rule (car ts) (cadr ts))))))
    (acr x)))

(define acrs add-computation-rules)

(define (add-rewrite-rule x y . opt-proof)
  (let ((lhs (if (string? x) (pt x) x))
	(rhs (if (string? y) (pt y) y))
	(proof (if (null? opt-proof)
		   (pproof-state-to-proof)
		   (let ((p (car opt-proof)))
		     (if (string? p)
			 (theorem-name-to-proof p)
			 p)))))
    (if (not (term-in-app-form? lhs))
	(myerror "add-rewrite-rule" "term in app form expected" lhs))
    (if (not (equal? (term-to-type lhs) (term-to-type rhs)))
	(myerror "add-rewrite-rule" "equal types expected"
		 (term-to-type lhs)
		 (term-to-type rhs)))
    (let ((op (term-in-app-form-to-final-op lhs))
	  (args (term-in-app-form-to-args lhs)))
      (if (and (term-in-const-form? op)
	       (eq? 'constr (const-to-kind (term-in-const-form-to-const op))))
	  (myerror "add-rewrite-rule" "non-constructor expected" op))
      (if (not (and (term-in-const-form? op)
		    (eq? 'pconst
			 (const-to-kind (term-in-const-form-to-const op)))))
	  (myerror "add-rewrite-rule" "program constant expected" op))
      (if (pair? (const-to-tsubst (term-in-const-form-to-const op)))
	  (myerror
	   "add-rewrite-rule"
	   "arguments in lhs need to fit the *unsubstituted* type of op"
	   (const-to-type
	    (pconst-name-to-pconst
	     (const-to-name (term-in-const-form-to-const op))))))
      (if (not (= (length args) (const-to-object-or-arity
				 (term-in-const-form-to-const op))))
	  (myerror
	   "add-rewrite-rule" "number of args should be"
	   (const-to-object-or-arity (term-in-const-form-to-const op))))
      (if (not (null? (set-minus (term-to-free rhs) (term-to-free lhs))))
	  (apply myerror
		 (append (list "add-rewrite-rule" "new free vars in rhs")
			 (set-minus (term-to-free rhs) (term-to-free lhs)))))
      (let ((rewrite-fla
	     (if (and (term-in-const-form? rhs)
		      (string=? "True" (const-to-name
					(term-in-const-form-to-const rhs))))
		 (make-atomic-formula lhs)
		 (if (finalg? (term-to-type lhs))
		     (make-= lhs rhs)
		     (make-eq lhs rhs)))))
	(if (or (not (proof-form? proof))
		(pair? (proof-to-free-avars proof))
		(not (formula=? (cadr (all-form-to-vars-and-final-kernel
				       (proof-to-formula proof)))
				rewrite-fla)))
	    (add-global-assumption
	     (new-global-assumption-name "RewriteGA")
	     (apply mk-all (append (formula-to-free rewrite-fla)
				   (list rewrite-fla))))))
      (let* ((pconst (term-in-const-form-to-const op))
	     (name (const-to-name pconst))
	     (comprules (pconst-name-to-comprules name))
	     (rewrules (pconst-name-to-rewrules name))
	     (new-rewrules
	      (append
	       rewrules
	       (list
		(list
		 lhs
		 (term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs
		  rhs)))))
	     (tsubst-obj-alist (pconst-name-to-inst-objs name))
	     (external-code (pconst-name-to-external-code name))
	     (pconsts-exept-name
	      (do ((l PROGRAM-CONSTANTS (cdr l))
		   (res '() (if (string=? (caar l) name)
				res
				(cons (car l) res))))
		  ((null? l) (reverse res))))
	     (new-alist-for-name
	      (map (lambda (x)
		     (list
		      (car x)
		      (if external-code
			  (nbe-pconst-and-tsubst-and-rules-to-object
			   pconst (car x) comprules new-rewrules external-code)
			  (nbe-pconst-and-tsubst-and-rules-to-object
			   pconst (car x) comprules new-rewrules))))
		   tsubst-obj-alist))
	     (uninst-pconst (pconst-name-to-pconst name)))
	(set! PROGRAM-CONSTANTS
	      (cons (if external-code
			(list name uninst-pconst comprules new-rewrules
			      new-alist-for-name external-code)
			(list name uninst-pconst comprules new-rewrules
			      new-alist-for-name))
		    pconsts-exept-name))
	(if (not (member name
			 (list "AndConst" "ImpConst" "OrConst" "NegConst")))
	    (comment "ok, rewrite rule " (term-to-string lhs) " -> "
		     (term-to-string rhs) " added"))))))

(define arw add-rewrite-rule)

(define (add-rewrite-rules . x)
  (if (odd? (length x))
      (myerror "add-rewrite-rules" "even number of arguments expected"))
  (if (null? x)
      (myerror "add-rewrite-rules" "arguments expected"))
  (letrec ((arr (lambda (ts)
                  (if (< 3 (length ts))
                      (begin
                        (add-rewrite-rule (car ts) (cadr ts))
                        (arr (cddr ts)))
                      (add-rewrite-rule (car ts) (cadr ts))))))
    (arr x)))

(define arws add-rewrite-rules)

(define (add-external-code name code)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (if (not info)
	(myerror "add-external-code" "name of program constant expected" name))
    (let* ((comprules (pconst-name-to-comprules name))
	   (rewrules (pconst-name-to-rewrules name))
	   (tsubst-obj-alist (pconst-name-to-inst-objs name))
	   (pconsts-exept-name
	    (do ((l PROGRAM-CONSTANTS (cdr l))
		 (res '() (if (string=? (caar l) name)
			      res
			      (cons (car l) res))))
		((null? l) (reverse res))))
	   (pconst (pconst-name-to-pconst name))
	   (new-alist-for-name
	    (map (lambda (x)
		   (list (car x) (nbe-pconst-and-tsubst-and-rules-to-object
				  pconst (car x) comprules rewrules code)))
		 tsubst-obj-alist)))
      (set! PROGRAM-CONSTANTS
	    (cons (list name pconst comprules rewrules new-alist-for-name code)
		  pconsts-exept-name))
      (comment "ok, external code added for program constant " name))))

(define (remove-computation-rules-for lhs)
  (if (not (term-form? lhs))
      (myerror "remove-computation-rules-for" "term expected" lhs))
  (let* ((op (term-in-app-form-to-final-op lhs))
	 (args (term-in-app-form-to-args lhs)))
    (if (not (and (term-in-const-form? op)
		  (eq? 'pconst
		       (const-to-kind (term-in-const-form-to-const op)))))
	(myerror "remove-computation-rules-for"
		 "program constant expected" op))
    (if (not (= (length args) (const-to-object-or-arity
			       (term-in-const-form-to-const op))))
	(myerror "remove-computation-rules-for" "number of args should be"
		 (const-to-object-or-arity (term-in-const-form-to-const op))))
    (let* ((pconst (term-in-const-form-to-const op))
	   (name (const-to-name pconst))
	   (comprules (pconst-name-to-comprules name))
	   (rewrules (pconst-name-to-rewrules name))
	   (new-comprules
	    (list-transform-positive comprules
	      (lambda (comprule) (not (match lhs (car comprule))))))
	   (tsubst-obj-alist (pconst-name-to-inst-objs name))
	   (external-code (pconst-name-to-external-code name))
	   (pconsts-exept-name
	    (do ((l PROGRAM-CONSTANTS (cdr l))
		 (res '() (if (string=? (caar l) name)
			      res
			      (cons (car l) res))))
		((null? l) (reverse res))))
	   (new-alist-for-name
	    (map (lambda (x)
		   (list
		    (car x)
		    (if external-code
			(nbe-pconst-and-tsubst-and-rules-to-object
			 pconst (car x) new-comprules rewrules external-code)
			(nbe-pconst-and-tsubst-and-rules-to-object
			 pconst (car x) new-comprules rewrules))))
		 tsubst-obj-alist))
	   (uninst-pconst (pconst-name-to-pconst name)))
      (set! PROGRAM-CONSTANTS
	    (cons (list name uninst-pconst new-comprules rewrules
			new-alist-for-name)
		  pconsts-exept-name))
      (comment "ok, computation rules of the form " (term-to-string lhs)
	       " removed"))))

(define (remove-rewrite-rules-for lhs)
  (let* ((op (term-in-app-form-to-final-op lhs))
	 (args (term-in-app-form-to-args lhs)))
    (if (not (and (term-in-const-form? op)
		  (eq? 'pconst
		       (const-to-kind (term-in-const-form-to-const op)))))
	(myerror "remove-rewrite-rules-for" "program constant expected" op))
    (if (not (= (length args) (const-to-object-or-arity
			       (term-in-const-form-to-const op))))
	(myerror "remove-rewrite-rules-for" "number of args should be"
		 (const-to-object-or-arity (term-in-const-form-to-const op))))
    (let* ((pconst (term-in-const-form-to-const op))
	   (name (const-to-name pconst))
	   (comprules (pconst-name-to-comprules name))
	   (rewrules (pconst-name-to-rewrules name))
	   (new-rewrules
	    (list-transform-positive rewrules
	      (lambda (rewrule) (not (match lhs (car rewrule))))))
	   (tsubst-obj-alist (pconst-name-to-inst-objs name))
	   (external-code (pconst-name-to-external-code name))
	   (pconsts-exept-name
	    (do ((l PROGRAM-CONSTANTS (cdr l))
		 (res '() (if (string=? (caar l) name)
			      res
			      (cons (car l) res))))
		((null? l) (reverse res))))
	   (new-alist-for-name
	    (map (lambda (x)
		   (list
		    (car x)
		    (if external-code
			(nbe-pconst-and-tsubst-and-rules-to-object
			 pconst (car x) comprules new-rewrules external-code)
			(nbe-pconst-and-tsubst-and-rules-to-object
			 pconst (car x) comprules new-rewrules))))
		 tsubst-obj-alist))
	   (uninst-pconst (pconst-name-to-pconst name)))
      (set! PROGRAM-CONSTANTS
	    (cons (list name uninst-pconst comprules new-rewrules
			new-alist-for-name)
		  pconsts-exept-name))
      (comment "ok, rewrite rules with lhs of the form "
	       (term-to-string lhs)
	       " removed"))))

(define (remove-external-code name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (if (not info)
	(myerror "remove-external-code"
		 "name of program constant expected" name))
    (let* ((comprules (pconst-name-to-comprules name))
	   (rewrules (pconst-name-to-rewrules name))
	   (tsubst-obj-alist (pconst-name-to-inst-objs name))
	   (pconsts-exept-name
	    (do ((l PROGRAM-CONSTANTS (cdr l))
		 (res '() (if (string=? (caar l) name)
			      res
			      (cons (car l) res))))
		((null? l) (reverse res))))
	   (pconst (pconst-name-to-pconst name))
	   (new-alist-for-name
	    (map (lambda (x)
		   (list (car x) (nbe-pconst-and-tsubst-and-rules-to-object
				  pconst (car x) comprules rewrules)))
		 tsubst-obj-alist)))
      (set! PROGRAM-CONSTANTS
	    (cons (list name pconst comprules rewrules new-alist-for-name)
		  pconsts-exept-name))
      (comment "ok, external code removed for program constant " name))))

; nbe-pconst-and-tsubst-and-rules-to-object instantiates the rules
; with (given) tsubst (not the one from pconst) and then computes the
; object.  It is assumed that tsubst is restricted to the tvars in the
; type of pconst.

(define (nbe-pconst-and-tsubst-and-rules-to-object
	 pconst tsubst comprules rewrules . rest)
  (let* ((tsubst-obj-alist (pconst-name-to-inst-objs (const-to-name pconst)))
	 (info (assoc-wrt substitution-equal? tsubst tsubst-obj-alist))
	 (arity (const-to-object-or-arity pconst))
	 (uninst-type (const-to-uninst-type pconst))
	 (inst-type (type-substitute uninst-type tsubst))
	 (inst-pconst
	  (make-const arity (const-to-name pconst) 'pconst
		      uninst-type tsubst (const-to-t-deg pconst)
		      (const-to-token-type pconst)
		      (const-to-type-info-or-repro-formulas pconst)))
	 (rename (make-rename tsubst))
	 (inst-comprules
	  (map (lambda (cr)
		 (let ((lhs (rule-to-lhs cr))
		       (rhs (rule-to-rhs cr)))
		   (lhs-and-rhs-to-rule
		    (term-substitute-aux lhs tsubst '() rename)
		    (term-substitute-aux rhs tsubst '() rename))))
	       comprules))
	 (inst-rewrules
	  (map (lambda (cr)
		 (let ((lhs (rule-to-lhs cr))
		       (rhs (rule-to-rhs cr)))
		   (lhs-and-rhs-to-rule
		    (term-substitute-aux lhs tsubst '() rename)
		    (term-substitute-aux rhs tsubst '() rename))))
	       rewrules))
	 (external-proc (if (pair? rest)
			    (ev (car rest))
			    (lambda (tsubst objs) #f))))
    (if
     (zero? arity)
     (let* ((repro-obj
	     (nbe-reflect (nbe-make-termfam
			   inst-type
			   (lambda (k)
			     (make-term-in-const-form inst-pconst)))))
	    (pattern (const-to-type pconst))
	    (subst-pconst (const-substitute pconst tsubst #t))
	    (instance (const-to-type subst-pconst))
	    (match-test (type-match pattern instance)))
       (if
	match-test ;else reproduce
	(or ;return externally provided object, if it exists, else try rules
	 (external-proc tsubst '())
	 (let comp-aux ((l inst-comprules)) ;search first matching rule
	   (if
	    (null? l) ;reproduce
	    repro-obj
	    (let* ((inst-rule (car l))
		   (lhs (rule-to-lhs inst-rule))
		   (rhs (rule-to-rhs inst-rule))
		   (empty-bindings (nbe-make-bindings '() '())))
	      (if (equal? instance (const-to-type
				    (term-in-const-form-to-const lhs)))
		  (nbe-term-to-object rhs empty-bindings)
		  (comp-aux (cdr l)))))))
	repro-obj))
     (nbe-make-object
      inst-type
      (nbe-curry
       (lambda objs ;arity many
	 (or ;return externally provided object, if it exists, else try rules
	  (external-proc tsubst objs)
	  (let comp-aux ((l1 inst-comprules)) ;search first matching comprule
	    (if
	     (null? l1) ;search for first matching rewrite rule
	     (let* ((reified-objs (map nbe-reify objs))
		    (extracted-terms
		     (map term-to-eta-nf (map nbe-extract reified-objs))))
	       (let rew-aux ((l2 inst-rewrules))
		 (if
		  (null? l2) ;reproduce
		  (let* ((obj (nbe-reflect (nbe-make-termfam
					    inst-type
					    (lambda (k)
					      (make-term-in-const-form
					       inst-pconst)))))
			 (val (nbe-object-to-value obj)))
		    (apply (nbe-uncurry val arity) objs))
		  (let* ((rewrule (car l2))
			 (lhs (rule-to-lhs rewrule))
			 (args (term-in-app-form-to-args lhs))
			 (subst (match-list args extracted-terms)))
		    (if
		     subst
		     (let* ((rhs (rule-to-rhs rewrule))
			    (vars (map car subst))
			    (terms (map cadr subst))
			    (objs (map (lambda (x)
					 (nbe-term-to-object x empty-subst))
				       terms))
			    (bindings (nbe-make-bindings vars objs)))
		       (nbe-term-to-object rhs bindings))
		     (rew-aux (cdr l2)))))))
	     (let* ((comprule (car l1))
		    (lhs (rule-to-lhs comprule))
		    (constr-patterns (term-in-app-form-to-args lhs)))
	       (if (apply and-op (map nbe-inst? constr-patterns objs))
		   (let* ((rhs (rule-to-rhs comprule))
			  (genargs
			   (apply append
				  (map nbe-genargs constr-patterns objs)))
			  (free (term-to-free lhs))
			  (bindings (nbe-make-bindings free genargs)))
		     (nbe-term-to-object rhs bindings))
		   (comp-aux (cdr l1))))))))
       inst-type
       arity)))))

; Constants with fixed rules

; 2004-12-31 =-at and e-at moved to boole.scm.  Reason: They need
; AndConst, which requires the algebra boole.

(define (rec-const-to-param-types const)
  (let ((type-info-or-repro-formulas
	 (const-to-type-info-or-repro-formulas const)))
    (if (formula-form? (car type-info-or-repro-formulas))
	(let* ((repro-formulas type-info-or-repro-formulas)
	       (id? (imp-form? (car repro-formulas)))
	       (free-lists
		(if id? 
		    (map (lambda (x) ;x imp-formula I xs^ -> A
			   (set-minus (formula-to-free x)
				      (map term-in-var-form-to-var
					   (predicate-form-to-args
					    (imp-form-to-premise x)))))
			 repro-formulas)	       
		    (map formula-to-free repro-formulas)))
	       (free (apply union free-lists)))
	  (map var-to-type free))
	(let* ((type-info type-info-or-repro-formulas)
	       (fst (car type-info)))
	  (if (integer? fst)
	      (list-head (cdr type-info) fst)
	      '())))))

; From the uninstantiated type of a recursion constant we can read off
; the uninstantiated form of its arrow type iota_j -> tau_j, and also
; the remaining uninstantiated arrow types, in some order.

(define (rec-const-to-uninst-arrow-types const)
  (let* ((uninst-type (const-to-uninst-type const))
	 (arg-types (arrow-form-to-arg-types uninst-type))
	 (val-type (arrow-form-to-final-val-type uninst-type))
	 (param-types (rec-const-to-param-types const))
	 (f (length param-types))
	 (alg-type-and-step-types (list-tail arg-types f))
	 (step-types (cdr alg-type-and-step-types))
	 (alg-type (car alg-type-and-step-types))
	 (alg-name (alg-form-to-name alg-type))
	 (simalg-names (alg-name-to-simalg-names alg-name))
	 (step-arg-types (map arrow-form-to-arg-types step-types))
	 (step-alg-arg-types ;((ss_1->iota_1 .. ss_n->iota_n) ..)
	  (map (lambda (l)
		 (list-transform-positive l
		   (lambda (y)
		     (let ((val-type (arrow-form-to-final-val-type y)))
		       (and (alg-form? y)
			    (member (alg-form-to-name y)
				    simalg-names))))))
	       step-arg-types))
	 (step-alg-arg-lengths (map length step-alg-arg-types))
	 (step-prev-arg-types ;((ss_1->alpha_1 .. ss_n->alpha_n) ..)
	  (map (lambda (l n) (list-tail l (- (length l) n)))
	       step-arg-types step-alg-arg-lengths))
	 (uninst-arrow-types-list
	  (map (lambda (l1 l2)
		 (map (lambda (x1 x2)
			(make-arrow (arrow-form-to-final-val-type x1)
				    (arrow-form-to-final-val-type x2)))
		      l1 l2))
	       step-alg-arg-types step-prev-arg-types)))
    (apply union (cons (list (make-arrow alg-type val-type))
		       uninst-arrow-types-list))))

; We define a procedure that takes arrow-types and returns the types of
; the recursion constants, split into uninstantiated types and a type
; substitution.

; arrow-types is a list of types alg -> rho, where all algs are
; simultaneously defined.  Then uninst-rec-type is alg ->
; delta1(algs,alphas) ->..-> deltak(algs,alphas) -> alphaj.  This
; rec-type is "simplified" in the sense that all step types
; delta(algs,alphas) are for the relevant algs only, i.e., those
; mentioned in the arrow-types.  Moreover, these step types are
; simplified by omitting the recursive arg types and their
; alg-duplicates (the "strengthening") for non-relevant algs.

(define (arrow-types-to-uninst-paramless-recop-types-and-tsubst . arrow-types)
  (if
   (null? arrow-types)
   (list '() empty-subst)
   (let* ((arg-types (map arrow-form-to-arg-type arrow-types))
	  (val-types (map arrow-form-to-val-type arrow-types))
	  (alg-names
	   (map (lambda (type)
		  (if
		   (alg-form? type)
		   (alg-form-to-name type)
		   (myerror
		    "arrow-types-to-uninst-paramless-recop-types-and-tsubst"
		    "alg expected" type)))
		arg-types))
	  (alg-name (car alg-names))
	  (alg-tvars (alg-name-to-tvars alg-name))
	  (tparam-lists (map alg-form-to-types arg-types))
	  (tparams (car tparam-lists))
	  (tsubst1 (map (lambda (x y) (list x y)) alg-tvars tparams))
	  (tsubst2 (map (lambda (y) (list (new-tvar) y)) val-types))
	  (val-tvars (map car tsubst2)) ;new tvars for val-types
	  (paramless-algs
	   (map (lambda (x) (apply make-alg (cons x alg-tvars)))
                alg-names))
	  (paramless-uninst-arrow-types (map (lambda (x y) (make-arrow x y))
				   paramless-algs val-tvars))
	  (paramless-uninst-arrow-type (car paramless-uninst-arrow-types))
	  (alg-names-with-val-types
	   (map (lambda (x y) (list x (arrow-form-to-val-type y)))
		alg-names paramless-uninst-arrow-types))
	  (simalg-names (alg-name-to-simalg-names alg-name)))
     (if (not (equal? alg-names (remove-duplicates alg-names)))
	 (myerror "arrow-types-to-uninst-paramless-recop-types-and-tsubst"
		  "distinct algs expected" alg-names))
     (if (pair? (set-minus alg-names simalg-names))
	 (myerror "arrow-types-to-uninst-paramless-recop-types-and-tsubst"
		  "too many alg names" (set-minus alg-names simalg-names)))
     (if (< 1 (length (remove-duplicates tparam-lists)))
	 (myerror "arrow-types-to-uninst-paramless-recop-types-and-tsubst"
		  "equal paramlists expected" tparam-lists))
     (let* ((rel-simalg-names (list-transform-positive simalg-names
				(lambda (x) (member x alg-names))))
	    (typed-constr-names
	     (apply append (map alg-name-to-typed-constr-names
				rel-simalg-names)))
	    (constr-types (map typed-constr-name-to-type typed-constr-names))
	    (step-types (map (lambda (x) (constructor-type-to-step-type
					  x alg-names-with-val-types))
			     constr-types)))
       (list (map (lambda (x y)
		    (apply mk-arrow (cons x (append step-types (list y)))))
		  paramless-algs val-tvars)
	     (append tsubst1 tsubst2))))))

; constructor-type-to-step-type works for constructor types with or
; without substitution for its type parameters.  It is assumed that
; the algebra to which constr-type belongs has a value type associated
; in alg-names-with-val-types.

(define (constructor-type-to-step-type constr-type alg-names-with-val-types)
  (let* ((alg-name (alg-form-to-name
		    (arrow-form-to-final-val-type constr-type)))
	 (valtype (let ((info (assoc alg-name alg-names-with-val-types)))
		    (if info (cadr info)
			(myerror "constructor-type-to-step-type"
				 "val-type missing for alg-name" alg-name))))
	 (argtypes (arrow-form-to-arg-types constr-type))
	 (irrel-alg-names (set-minus (alg-name-to-simalg-names alg-name)
				     (map car alg-names-with-val-types)))
	 (shortened-argtypes
	  (list-transform-positive argtypes
	    (lambda (argtype)
	      (let ((argvaltype (arrow-form-to-final-val-type argtype)))
		(not (and (alg-form? argvaltype)
			  (member (alg-form-to-name argvaltype)
				  irrel-alg-names)))))))
	 (pd-types
	  (do ((l argtypes (cdr l))
	       (res
		'()
		(let* ((argtype (car l))
		       (argargtypes (arrow-form-to-arg-types argtype))
		       (argvaltype (arrow-form-to-final-val-type argtype))
		       (argval-is-alg? (alg-form? argvaltype))
		       (info (if argval-is-alg?
				 (assoc (alg-form-to-name argvaltype)
					alg-names-with-val-types))))
		  (if
		   (and argval-is-alg? info)
		   (let* ((hyp-valtype (cadr info))
			  (pd-type
			   (apply mk-arrow
				  (append argargtypes (list hyp-valtype)))))
		     (cons pd-type res))
		   res))))
	      ((null? l) (reverse res)))))
    (apply mk-arrow (append shortened-argtypes pd-types (list valtype)))))

(define (arrow-types-to-rec-consts . arrow-types)
  (apply type-info-to-rec-consts arrow-types))

(define (type-info-to-rec-const fst . rest)
  (car (apply type-info-to-rec-consts (cons fst rest))))

(define (type-info-to-rec-consts fst . rest)
  (let* ((param-types (if (number? fst) (list-head rest fst) '()))
	 (arrow-types (if (number? fst) (list-tail rest fst) (cons fst rest)))
	 (uninst-paramless-recop-types-and-tsubst
	  (apply arrow-types-to-uninst-paramless-recop-types-and-tsubst
		 arrow-types))
	 (uninst-paramless-recop-types
	  (car uninst-paramless-recop-types-and-tsubst))
	 (tsubst (cadr uninst-paramless-recop-types-and-tsubst))
	 (uninst-recop-types
	  (map (lambda (x) (apply mk-arrow (append param-types (list x))))
	       uninst-paramless-recop-types))
	 (alg-names-with-uninst-recop-types
	  (map (lambda (x y)
		 (list (alg-form-to-name (arrow-form-to-arg-type x)) y))
	       arrow-types uninst-recop-types))
	 (alg-names (map car alg-names-with-uninst-recop-types))
	 (simalg-names (if (pair? alg-names)
			   (alg-name-to-simalg-names (car alg-names))
			   '()))
	 (relevant-simalg-names (list-transform-positive simalg-names
				  (lambda (x) (member x alg-names))))
	 (typed-constr-names ;the relevant ones only
	  (apply append (map alg-name-to-typed-constr-names
			     relevant-simalg-names)))
	 (constr-names (map typed-constr-name-to-name typed-constr-names))
	 (f (length param-types))
	 (type-info (if (zero? f)
			arrow-types
			(cons f (append param-types arrow-types)))))
    (map (lambda (x)
	   (let* ((uninst-recop-type
		   (cadr (assoc x alg-names-with-uninst-recop-types)))
		  (inst-recop-type (type-substitute uninst-recop-type tsubst)))
	     (apply alg-name-etc-to-rec-const
		    (append (list x uninst-recop-type tsubst inst-recop-type
				  f constr-names
				  alg-names-with-uninst-recop-types)
			    type-info))))
	 alg-names)))

; alg-name-etc-to-rec-const computes the required object, via rec-at.
; Both are defined general enough to be usable for
; all-formulas-to-rec-const as well, hence need to accommodate the f
; free variables in the induction formulas.  We have to consider the
; free variables in the scheme formulas, and let the type of the
; rec-const depend on them.  This is necessary to have the
; all-conversion be adequately represented in term normalization.

; The arguments for rec-at are all those needed in the construction of
; the object (for nbe), i.e. alg-name, tsubst, f, constr-names,
; alg-names-with-uninst-recop-types and arrow-types-or-all-formulas.  In
; the reproduction case the required term is formed using
; alg-name-etc-to-rec-const, which takes the same arguments.  In this
; setup these arguments need only be computed once, not repeatedly in
; the loop where alg-name-etc-to-rec-const and rec-at call themselves.

; type-info-or-all-formulas are carried along, to allow construction of
; the original recursion constant or induction scheme, in the
; reproduction case of normalization.  To have in the term (or proof)
; something close to what was given to the parser (or in the interactive
; proof), we take type-info-or-all-formulas.

(define (alg-name-etc-to-rec-const
	 alg-name uninst-recop-type tsubst inst-recop-type
	 f constr-names alg-names-with-uninst-recop-types .
	 type-info-or-all-formulas)
  (apply
   make-const
   (append
    (list (apply rec-at (append (list alg-name uninst-recop-type tsubst
				      inst-recop-type f constr-names
				      alg-names-with-uninst-recop-types)
				type-info-or-all-formulas))
	  "Rec" 'fixed-rules uninst-recop-type tsubst 1 'const)
    type-info-or-all-formulas)))

; While normalizing, the unfolding mechanism of the rec-operator
; may be blocked by setting UNFOLDING-FLAG to #f.

(define UNFOLDING-FLAG #t)
(define INITIAL-UNFOLDING-FLAG UNFOLDING-FLAG)

(define (rec-at alg-name uninst-recop-type tsubst inst-recop-type
		f constr-names alg-names-with-uninst-recop-types .
		type-info-or-all-formulas)
  (let* ((f-plus-s ;number f of free variables plus number s of step types
	  (- (length (arrow-form-to-arg-types uninst-recop-type)) 1))
	 (s (- f-plus-s f))
	 (arity (+ f-plus-s 1))
	 (nbe-for-idps? (and (pair? type-info-or-all-formulas)
			     (imp-form? (car type-info-or-all-formulas)))))
    (nbe-make-object
     inst-recop-type
     (nbe-curry
      (lambda objs
	(let* ((rec-obj (list-ref objs f))
	       (rec-val (nbe-object-to-value rec-obj)))
	  (cond
					;((nbe-fam-value? rec-val) ;reproduce
	   ((or (nbe-fam-value? rec-val) (not UNFOLDING-FLAG))
	    (nbe-reflect
	     (nbe-make-termfam
	      (arrow-form-to-final-val-type inst-recop-type (length objs))
	      (lambda (k)
		(apply mk-term-in-app-form
		       (cons (make-term-in-const-form ;rec-const
			      (apply
			       alg-name-etc-to-rec-const
			       (append
				(list alg-name uninst-recop-type tsubst
				      inst-recop-type f constr-names
				      alg-names-with-uninst-recop-types)
				type-info-or-all-formulas)))
			     (map (lambda (x) (nbe-fam-apply (nbe-reify x) k))
				  objs)))))))
	   ((and (nbe-constr-value? rec-val) (not nbe-for-idps?))
	    (let*
		((name (nbe-constr-value-to-name rec-val))
		 (name-string (if (string? name) name
				  (myerror "rec-at" "string expected" name)))
		 (args (nbe-constr-value-to-args rec-val))
		 (free-objs (list-head objs f))
		 (step-objs (list-head (list-tail objs (+ f 1)) s))
		 (step-obj (do ((cs constr-names (cdr cs))
				(objs step-objs (cdr objs))
				(res #f (if (string=? (car cs) name-string)
					    (car objs)
					    res)))
			       ((null? cs) res)))
		 (pd-objs
		  (do ((l args (cdr l))
		       (res
			'()
			(let* ((arg (car l))
			       (argtype (nbe-object-to-type arg))
			       (argvaltype
				(arrow-form-to-final-val-type argtype)))
			  (if ;pd-objs for recursive args only
			   (and (alg-form? argvaltype)
				(assoc (alg-form-to-name argvaltype)
				       alg-names-with-uninst-recop-types))
			   (let*
			       ((pd-alg-name (alg-form-to-name argvaltype))
				(info (assoc
				       pd-alg-name
				       alg-names-with-uninst-recop-types))
				(pd-uninst-recop-type (cadr info))
				(pd-inst-recop-type
				 (type-substitute pd-uninst-recop-type tsubst))
				(pd-obj
				 (apply
                                  nbe-object-rec-compose
                                  (cons
                                   (apply
				    nbe-object-app
				    (cons
				     (apply
				      rec-at
				      (append
				       (list
					pd-alg-name pd-uninst-recop-type
					tsubst pd-inst-recop-type f
					constr-names
					alg-names-with-uninst-recop-types)
				       type-info-or-all-formulas))
				     free-objs))
                                   (cons step-objs (list arg))))))
			     (cons pd-obj res))
			   res))))
		      ((null? l) (reverse res)))))
	      (apply nbe-object-app (cons step-obj (append args pd-objs)))))
	   ((and (nbe-constr-value? rec-val) nbe-for-idps?)
	    (let*
		((name (nbe-constr-value-to-name rec-val))
		 (i (if (and (pair? name) (string=? "Intro" (car name))
			     (pair? (cdr name)))
			(cadr name)
			(myerror "rec-at" "name expected" name)))
		 (idpc (if (pair? (cddr name))
			   (caddr name)
			   (myerror "rec-at" "name expected" name)))
		 (idpc-name (idpredconst-to-name idpc))
		 (number-string (number-to-alphabetic-string i))
		 (name-string (string-append number-string idpc-name))
		 (args (nbe-constr-value-to-args rec-val))
		 (idpc-params (idpredconst-to-free idpc))
		 (args-wo-idpc-params (list-tail args (length idpc-params)))
		 (free-objs (list-head objs f))
		 (step-objs (list-head (list-tail objs (+ f 1)) s))
		 (step-obj (do ((cs constr-names (cdr cs))
				(objs step-objs (cdr objs))
				(res #f (if (string=? (car cs) name-string)
					    (car objs)
					    res)))
			       ((null? cs) res)))
		 (aconst (number-and-idpredconst-to-intro-aconst i idpc))
		 (inst-formula (aconst-to-inst-formula aconst))
		 (vars (allnc-form-to-vars inst-formula)) ;vec{x}_i
		 (kernel (allnc-form-to-final-kernel inst-formula))
		 (prems (imp-form-to-premises kernel))
		 (concl-terms ;vec{t}_{j_i}
		  (predicate-form-to-args
		   (imp-form-to-final-conclusion kernel)))
		 (pd-objs
		  (do ((l args-wo-idpc-params (cdr l))
		       (l1 (append vars prems) (cdr l1))
		       (res
			'()
			(let* ((arg (car l))
			       (argtype (nbe-object-to-type arg))
			       (argvaltype
				(arrow-form-to-final-val-type argtype)))
			  (if ;pd-objs for recursive args only
			   (and (alg-form? argvaltype)
				(assoc (alg-form-to-name argvaltype)
				       alg-names-with-uninst-recop-types))
			   (let*
			       ((pd-alg-name (alg-form-to-name argvaltype))
				(info (assoc
				       pd-alg-name
				       alg-names-with-uninst-recop-types))
				(pd-uninst-recop-type (cadr info))
				(pd-inst-recop-type
				 (type-substitute pd-uninst-recop-type tsubst))
				(pd-prem (car l1))
				(pd-terms ;vec{s}_{i nu}
				 (predicate-form-to-args
				  (imp-form-to-final-conclusion
				   (all-form-to-final-kernel pd-prem))))
				(termobjs ;[[vec{r}_i]]
				 (list-head args-wo-idpc-params (length vars)))
				(alist-varterms-termobjs
				 (map (lambda (x y)
					(list (make-term-in-var-form x) y))
				      vars termobjs))
				(subst-pd-term-objs
				 (map
				  (lambda (s)
				    (let ((info
					   (assoc s alist-varterms-termobjs)))
				      (if
				       info (cadr info)
				       (let ((terms ;vec{r}_i
					      (map nbe-reify termobjs)))
					 (nbe-reflect
					  (nbe-make-termfam
					   (term-to-type s)
					   (lambda (k)
					     (term-substitute
					      s (map (lambda (x y) (list x y))
						     vars terms)))))))))
				  pd-terms))
				(pd-free-objs ;vec{p}vec{q}subst-pd-term-objs
				 (append (list-head free-objs
						    (- (length free-objs)
						       (length concl-terms)))
					 subst-pd-term-objs))
				(pd-f (length pd-free-objs))
				(pd-obj
				 (apply
                                  nbe-object-rec-compose
				  (cons
                                   (apply
				    nbe-object-app
				    (cons
				     (apply
				      rec-at
				      (append
				       (list
					pd-alg-name pd-uninst-recop-type
					tsubst pd-inst-recop-type pd-f
					constr-names
					alg-names-with-uninst-recop-types)
				       type-info-or-all-formulas))
				     pd-free-objs))
				   (cons step-objs (list arg))))))
			     (cons pd-obj res))
			   res))))
		      ((null? l) (reverse res)))))
	      (apply nbe-object-app
		     (cons step-obj (append args-wo-idpc-params pd-objs)))))
	   (else (myerror "rec-at" "value expected" rec-val)))))
      inst-recop-type
      arity))))

; We assume that recobj has no free parameters (needed to calculate
; the correct type)

(define (nbe-object-rec-compose recobj stepobjs obj)
  (let* ((k (length stepobjs))
         (rectype (nbe-object-to-type recobj))
         (objtype (nbe-object-to-type obj))
         (valtype (arrow-form-to-final-val-type rectype (+ k 1)))
         (argtypes (arrow-form-to-arg-types objtype))
         (l (length argtypes))
         (type (apply mk-arrow (append argtypes (list valtype)))))
    (if (zero? l)
        (apply nbe-object-app (cons recobj (cons obj stepobjs)))
        (nbe-make-object
         type
         (nbe-curry
          (lambda arg-objs
            (apply
             nbe-object-app
             (cons recobj
                   (cons (apply
                          (nbe-uncurry (nbe-object-to-value obj) l) arg-objs)
                         stepobjs))))
          type
          l)))))

; Similarly to arrow-types-to-rec-const we now define
; all-formulas-to-rec-const, again using alg-name-etc-to-rec-const.
; all-formulas-to-rec-const will be used in proof.scm to achieve
; normalization of proofs via translating them in terms, to translate an
; ind-aconst.

(define (all-formulas-to-rec-const . 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))
	 (tpinst (cadr uninst-imp-formulas-and-tpinst))
	 (tsubst (list-transform-positive tpinst
		   (lambda (x) (tvar-form? (car x)))))
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x)))))
	 (pvars (map car pinst))
	 (cterms (map cadr pinst))
	 (new-tvars (map PVAR-TO-TVAR pvars))
	 (nbe-types (map (lambda (x)
			   (nbe-formula-to-type (cterm-to-formula x)))
			 cterms))
	 (new-tsubst (make-substitution new-tvars nbe-types))
	 (free (formula-to-free (apply mk-and all-formulas)))
	 (free-types (map var-to-type free))
	 (uninst-recop-types
	  (map (lambda (x) ;uninst-imp-formula
		 (apply mk-arrow (append free-types
					 (list (nbe-formula-to-type x)))))
	       uninst-imp-formulas))
	 (vars (map all-form-to-var 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-rec-const" "alg expected" type)))
	       types))
	 (alg-names-with-uninst-recop-types
	  (map (lambda (x y) (list x y)) alg-names uninst-recop-types))
	 (simalg-names (alg-name-to-simalg-names (car alg-names)))
	 (sorted-alg-names (list-transform-positive simalg-names
			     (lambda (x) (member x alg-names))))
	 (typed-constr-names
	  (apply append
		 (map alg-name-to-typed-constr-names sorted-alg-names)))
	 (constr-names (map typed-constr-name-to-name typed-constr-names))
	 (alg-name (car alg-names))
	 (uninst-recop-type
	  (cadr (assoc alg-name alg-names-with-uninst-recop-types)))
	 (inst-recop-type (type-substitute uninst-recop-type
					   (append tsubst new-tsubst))))
    (apply alg-name-etc-to-rec-const
	   (append (list alg-name uninst-recop-type (append tsubst new-tsubst)
			 inst-recop-type (length free) constr-names
			 alg-names-with-uninst-recop-types)
		   all-formulas))))

; Cases is similar to recursion/induction, but somewhat simpler: there
; are no recursive calls, and only one arrow-type or all-formula is
; involved.

; We begin by defining arrow-type-to-cases-const, which uses
;    arrow-type-to-uninst-casesop-type-and-tsubst
;    alg-name-etc-to-cases-const 
;    cases-at
; The simplification compared to recursion/induction lies in the fact that
; alg-name-etc-to-cases-const calls cases-at, but not conversely.

(define (cases-const-to-param-types const)
  (let ((type-info-or-repro-formulas
	 (const-to-type-info-or-repro-formulas const)))
    (if (formula-form? (car type-info-or-repro-formulas))
	(let* ((all-formula (car type-info-or-repro-formulas))
	       (free (formula-to-free all-formula)))
	  (map var-to-type free))
	(if (pair? (cdr type-info-or-repro-formulas))
	    (list-head type-info-or-repro-formulas
		       (- (length type-info-or-repro-formulas) 1))
	    '()))))

(define (arrow-type-to-uninst-paramless-casesop-type-and-tsubst arrow-type)
  (let* ((arg-type (arrow-form-to-arg-type arrow-type))
	 (val-type (arrow-form-to-val-type arrow-type))
	 (alg-name
	  (if (alg-form? arg-type)
	      (alg-form-to-name arg-type)
	      (myerror
	       "arrow-type-to-uninst-paramless-casesop-type-and-tsubst"
	       "alg expected" arg-type)))
	 (alg-tvars (alg-name-to-tvars alg-name))
	 (tparams (alg-form-to-types arg-type))
	 (tsubst1 (map make-substitution alg-tvars tparams))
	 (tsubst2 (list (list (new-tvar) val-type)))
	 (new-val-tvar ;new tvar, to be substituted by val-type
	  (caar tsubst2))
         (uninst-arg-type (apply make-alg (cons alg-name alg-tvars)))
	 (typed-constr-names ;only those for the present alg-name
	  (alg-name-to-typed-constr-names alg-name))
	 (constr-types (map typed-constr-name-to-type typed-constr-names))
	 (uninst-step-types
	  (map (lambda (x)
		 (apply mk-arrow (append (arrow-form-to-arg-types x)
					 (list new-val-tvar))))
	       constr-types)))
    (list
     (apply mk-arrow (cons uninst-arg-type
			   (append uninst-step-types (list new-val-tvar))))
     (append tsubst1 tsubst2))))

(define (constructor-type-to-cases-step-type type alg-names-with-arrow-types)
  (let* ((alg-name (alg-form-to-name (arrow-form-to-final-val-type type)))
	 (arrow-type (cadr (assoc alg-name alg-names-with-arrow-types)))
	 (valtype (arrow-form-to-val-type arrow-type))
	 (argtypes (arrow-form-to-arg-types type)))
    (apply mk-arrow (append argtypes (list valtype)))))

(define (arrow-type-to-cases-const arrow-type)
  (param-types-and-arrow-type-to-cases-const '() arrow-type))

; For a cases constant type-info is a list of parameter types followed
; by an arrow-type.

(define (param-types-and-arrow-type-to-cases-const param-types arrow-type)
  (let* ((uninst-paramless-casesop-type-and-tsubst
	  (arrow-type-to-uninst-paramless-casesop-type-and-tsubst arrow-type))
	 (uninst-paramless-casesop-type
	  (car uninst-paramless-casesop-type-and-tsubst))
	 (tsubst (cadr uninst-paramless-casesop-type-and-tsubst))
	 (uninst-casesop-type
	  (apply mk-arrow (append param-types
				  (list uninst-paramless-casesop-type))))
	 (alg-name (alg-form-to-name (arrow-form-to-arg-type arrow-type)))
	 (f (length param-types))
	 (typed-constr-names ;only those for the present alg-name
	  (alg-name-to-typed-constr-names alg-name))
	 (constr-names (map typed-constr-name-to-name typed-constr-names))
	 (type-info (append param-types (list arrow-type))))
    (apply alg-name-etc-to-cases-const
	   (append (list alg-name tsubst f constr-names uninst-casesop-type)
		   type-info))))

; alg-name-etc-to-cases-const computes the required object, via
; cases-at.  Both are defined general enough to be usable for
; all-formula-to-cases-const as well, hence need to accommodate the f
; free variables in all-formula.  We have to consider the free variables
; in all-formula, and let the type of the cases-const depend on them.
; This is necessary to have the all-conversion be adequately represented
; in term normalization.

; The arguments for cases-at are all those needed in the construction of
; the object (for nbe), i.e. alg-name, tsubst, f, constr-names,
; uninst-casesop-type and type-info-or-all-formula.  In the reproduction
; case the required term is formed using alg-name-etc-to-cases-const,
; which takes the same arguments.

; type-info-or-all-formula are carried along, to allow construction of
; the original cases constant or scheme, in the reproduction case of
; normalization.  To have in the term (or proof) somewhat close to what
; was given to the parser (or in the interactive proof), we take
; type-info-or-all-formula.

(define (alg-name-etc-to-cases-const
	 alg-name tsubst f constr-names uninst-casesop-type .
	 type-info-or-all-formula)
  (apply
   make-const
   (append (list (apply cases-at (append (list alg-name tsubst f constr-names
					       uninst-casesop-type)
					 type-info-or-all-formula))
		 "Cases" 'fixed-rules uninst-casesop-type tsubst 1 'const)
	   type-info-or-all-formula)))

(define (cases-at alg-name tsubst f constr-names uninst-casesop-type .
		  type-info-or-all-formula)
  (let* ((f-plus-s ;number f of free variables plus number s of step types
	  (- (length (arrow-form-to-arg-types uninst-casesop-type)) 1))
	 (s (- f-plus-s f))
	 (arity (+ f-plus-s 1))
	 (inst-casesop-type (type-substitute uninst-casesop-type tsubst)))
    (nbe-make-object
     inst-casesop-type
     (nbe-curry
      (lambda objs
	(let* ((free-objs (list-head objs f))
	       (step-objs (list-head (list-tail objs (+ f 1)) s))
	       (cases-obj (list-ref objs f))
	       (cases-val (nbe-object-to-value cases-obj)))
	  (cond
	   ((nbe-fam-value? cases-val) ;reproduce
	    (let* ((obj (nbe-reflect
			 (nbe-make-termfam
			  inst-casesop-type
			  (lambda (k)
			    (make-term-in-const-form
			     (apply alg-name-etc-to-cases-const
				    (append
				     (list alg-name tsubst f constr-names
					   uninst-casesop-type)
				     type-info-or-all-formula)))))))
		   (val (nbe-object-to-value obj)))
	      (apply (nbe-uncurry val arity) objs)))
	   ((nbe-constr-value? cases-val)
	    (let* ((name (nbe-constr-value-to-name cases-val))
		   (args (nbe-constr-value-to-args cases-val))
		   (step-obj (do ((cs constr-names (cdr cs))
				  (objs step-objs (cdr objs))
				  (res #f (if (string=? (car cs) name)
					      (car objs)
					      res)))
				 ((null? cs) res))))
	      (apply nbe-object-app (cons step-obj args))))
	   (else (myerror "cases-at" "value expected" cases-val)))))
      inst-casesop-type
      arity))))

; Similarly to arrow-type-to-cases-const we now define
; all-formula-to-cases-const, again using
; alg-name-etc-to-cases-const.  all-formula-to-cases-const
; will be used in proof.scm to achieve normalization of proofs via
; translating them in terms, to translate a cases-aconst.

(define (all-formula-to-cases-const 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))
	 (tsubst (list-transform-positive tpinst
		   (lambda (x) (tvar-form? (car x)))))
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x)))))
	 (pvars (map car pinst))
	 (cterms (map cadr pinst))
	 (new-tvars (map PVAR-TO-TVAR pvars))
	 (nbe-types (map (lambda (x)
			   (nbe-formula-to-type (cterm-to-formula x)))
			 cterms))
	 (new-tsubst (make-substitution new-tvars nbe-types))
	 (free (formula-to-free all-formula))
	 (free-types (map var-to-type free))
	 (uninst-casesop-type
	  (apply mk-arrow
		 (append free-types
			 (list (nbe-formula-to-type uninst-imp-formula)))))
	 (var (all-form-to-var all-formula))
	 (type (var-to-type var))
	 (alg-name (if (alg-form? type)
		       (alg-form-to-name type)
		       (myerror
			"all-formula-to-cases-const" "alg expected" type)))
	 (typed-constr-names (alg-name-to-typed-constr-names alg-name))
	 (constr-names (map typed-constr-name-to-name typed-constr-names)))
    (alg-name-etc-to-cases-const
     alg-name (append tsubst new-tsubst) (length free) constr-names
     uninst-casesop-type all-formula)))

(define (imp-formulas-to-rec-const . 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))
	 (tsubst (cadr uninst-elim-formulas-etc))
	 (pinst-for-param-pvars (caddr uninst-elim-formulas-etc))
	 (pinst-for-pvars (cadddr uninst-elim-formulas-etc))
	 (prems (map (lambda (x)
			(if (imp-form? x) (imp-form-to-premise x)
			    (myerror "imp-formulas-to-rec-const"
				     "imp form expected" x)))
		     imp-formulas))
	 (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-rec-const"
			       "idpredconst expected" prem)))
		prems))
	 (idpc-names (map idpredconst-to-name idpcs))
	 (param-pvar-cterms (map cadr pinst-for-param-pvars))
	 (param-pvar-formulas (map cterm-to-formula param-pvar-cterms))
	 (param-pvar-types (map nbe-formula-to-type param-pvar-formulas))
	 (param-pvar-tsubst
	  (map (lambda (x param-pvar-type) ;x pair from pinst-for-param-pvars
		 (let* ((param-pvar (car x))
			(tvar (PVAR-TO-TVAR param-pvar)))
		   (list tvar param-pvar-type)))
	       pinst-for-param-pvars param-pvar-types))
	 (tpinst (apply append (cdr uninst-elim-formulas-etc)))
	 (elim-aconst
	  (apply make-aconst
		 (append (list "Elim" 'axiom (car uninst-elim-formulas) tpinst)
			 imp-formulas)))
	 (kernel-of-inst-formula
	  (allnc-form-to-final-kernel (aconst-to-inst-formula elim-aconst)))
	 (free (formula-to-free kernel-of-inst-formula))
	 (free-types (map var-to-type free))
	 (uninst-recop-types
	  (map (lambda (x) ;x uninst-elim-formula
		 (apply mk-arrow (append free-types
					 (list (nbe-formula-to-type x)))))
	       uninst-elim-formulas))
	 (alg-names (map idpredconst-name-to-nbe-alg-name idpc-names))
	 (pvar-cterm-types
	  (map (lambda (cterm)
		 (nbe-formula-to-type (cterm-to-formula cterm)))
	       (map cadr pinst-for-pvars)))
	 (pvar-tsubst
	  (map (lambda (x y) ;x pair form pinst-for-pvars, y pvar-cterm-type
		 (let* ((pvar (car x))
			(tvar (PVAR-TO-TVAR pvar)))
		   (list tvar y)))
	       pinst-for-pvars pvar-cterm-types))
	 (alg-names-with-uninst-recop-types
	  (map (lambda (x y) (list x y)) alg-names uninst-recop-types))
	 (simalg-names (alg-name-to-simalg-names (car alg-names)))
	 (sorted-alg-names (list-transform-positive simalg-names
			     (lambda (x) (member x alg-names))))
	 (typed-constr-names
	  (apply append
		 (map alg-name-to-typed-constr-names sorted-alg-names)))
	 (constr-names (map typed-constr-name-to-name typed-constr-names))
	 (alg-name (car alg-names))
	 (uninst-recop-type
	  (cadr (assoc alg-name alg-names-with-uninst-recop-types)))
	 (inst-recop-type
	  (type-substitute uninst-recop-type
			   (append tsubst param-pvar-tsubst pvar-tsubst))))
    (apply alg-name-etc-to-rec-const
	   (append (list alg-name uninst-recop-type
			 (append tsubst param-pvar-tsubst pvar-tsubst)
			 inst-recop-type (length free) constr-names
			 alg-names-with-uninst-recop-types)
		   imp-formulas))))

; General recursion and induction (work of Simon Huber)

; (GRecGuard rhos tau) :
; (rhos=>nat)=>rhos=>(rhos=>(rhos=>tau)=>tau)=>boole=>tau
; GRecGuard mu xs G True -> G xs([ys]GRecGuard mu ys G(mu ys<mu xs))
; GRecGuard mu xs G False -> Inhab
; For convenience we add GRec with GRec mu xs G -> GRecGuard mu xs G True

; (GRecGuard m alphas rhos tau) :
; alphas=>(rhos=>nat)=>rhos=>(rhos=>(rhos=>atomic=>tau)=>tau)=>
; boole=>atomic=>tau
; GRecGuard ts mu xs G True u ->
; G xs ([ys,atomic]GRecGuard ts mu ys G (mu ys<mu xs) atomic)
; GRecGuard ts mu xs G False u -> Efq u
; Note that this variant is only used to normalize proofs.  Here we need
; that Efq is a constant.

; Induction
; GInd : allnc zs all mu,xs(Prog_mu{xs|A(xs)} ->
;          all boole(atom(boole) -> A(xs))), where
; Prog_mu{xs|A(xs)} = all xs(all ys(mu ys<mu xs -> A(ys)) -> A(xs))
; We get the ordinary general induction GInd' by:
; GInd' ts mu xs M = GInd ts mu xs M True Truth-Axiom

(define (grecguard-const-to-param-types const)
  (let ((repro-formulas (const-to-type-info-or-repro-formulas const)))
    (if (and (pair? repro-formulas)
             (formula-form? (car repro-formulas)))
        (let* ((all-formula (car repro-formulas))
               (free (formula-to-free all-formula)))
          (map var-to-type free))
        '())))

; grecguard-const-for-gind? returns true if the step type of the
; constant is (rhos=>(rhos=>atomic=>tau)=>tau), i.e., if the constant
; comes from a GInd aconst.

(define (grecguard-const-for-gind? const)
  (let* ((type (const-to-type const))
         (f (length (grecguard-const-to-param-types const)))
         (type-wo-params (arrow-form-to-final-val-type type f))
         (measure-type (arrow-form-to-arg-type type-wo-params))
         (arg-types (arrow-form-to-arg-types measure-type))
         (m (length arg-types))
         (step-type (arrow-form-to-arg-type
                     (arrow-form-to-final-val-type type-wo-params (+ m 1))))
         (aux-type (arrow-form-to-arg-type
                    (arrow-form-to-final-val-type step-type m))))
    (= (length (arrow-form-to-arg-types step-type))
       (length (arrow-form-to-arg-types aux-type)))))

(define (type-etc-to-efq-const f uninst-type inst-type tsubst . repro-formula)
  (apply
   make-const
   (append (list (apply efq-at (append (list f uninst-type inst-type tsubst)
                                       repro-formula))
                 "Efq" 'fixed-rules uninst-type tsubst t-deg-one 'const)
           repro-formula)))

; formula-to-efq-const will be used in proof.scm to achieve
; normalization of proofs via translating them in terms, to translate
; an efq-aconst.  In addition we need the number m of quantifiers used
; for the axioms.

(define (formula-to-efq-const formula)
  (let* ((efqaconst (global-assumption-name-to-aconst "Efq"))
         (efq-uninst-formula (aconst-to-uninst-formula efqaconst))
         (pvar (predicate-form-to-predicate
                (imp-form-to-conclusion efq-uninst-formula)))
         (tvar (PVAR-TO-TVAR pvar))
         (nbe-type (nbe-formula-to-type formula))
         (tsubst (make-subst tvar nbe-type))
         (free (formula-to-free formula))
         (param-types (map var-to-type free))
         (f (length free))
         (uninst-type (apply mk-arrow
                             (append param-types
                                     (list (make-tconst "atomic") tvar))))
         (inst-type (type-substitute uninst-type tsubst)))
    (type-etc-to-efq-const f uninst-type inst-type tsubst formula)))

(define (efq-at f uninst-type inst-type tsubst . repro-formula)
  (nbe-make-object
   inst-type
   (nbe-curry
    (lambda objs
      (nbe-reflect ;reproduce
       (nbe-make-termfam
        (arrow-form-to-final-val-type inst-type (+ f 1))
        (lambda (k)
          (apply mk-term-in-app-form
                 (cons
                  (make-term-in-const-form
                   (type-etc-to-efq-const f uninst-type inst-type
                                          tsubst (car repro-formula)))
                  (map (lambda (x) (nbe-fam-apply (nbe-reify x) k)) objs)))))))
    inst-type (+ f 1))))

(define (type-info-to-grec-type type-info)
  (if
   (< (length type-info) 2)
   (myerror "type-info-to-grec-type"
	    "more types expected"
	    type-info)
   (let* ((m (- (length type-info) 1))
	  (arg-types (list-head type-info m))
	  (val-type (list-ref type-info m))
	  (measure-type
	   (apply mk-arrow (append arg-types (list (py "nat")))))
	  (step-type
	   (apply mk-arrow
		  (append
		   arg-types
		   (list (apply mk-arrow (append arg-types (list val-type)))
			 val-type)))))
     (apply mk-arrow
	    (cons measure-type
		  (append arg-types (list step-type val-type)))))))

(define (type-info-to-grecguard-type type-info)
  (if (< (length type-info) 2)
      (myerror "type-info-to-grecguard-type"
               "more types expected"
               type-info)
      (let* ((gind-type? (number? (car type-info)))
             (numparams-and-types
              (if gind-type?
                  type-info
                  (cons 0 type-info)))
             (numparams (car numparams-and-types))
             (types (cdr numparams-and-types))
             (param-types (list-head types numparams)) ;alphas
             (revmtypes (reverse (list-tail types numparams)))
             (arg-types (reverse (cdr revmtypes))) ;rhos
             (val-type (car revmtypes)) ;tau
             (measure-type
              (apply mk-arrow (append arg-types (list (py "nat")))))
             (step-type
              (apply mk-arrow
                     (append arg-types
                             (list
                              (apply
                               mk-arrow
                               (append
                                arg-types
                                (if gind-type?
                                    (list (make-tconst "atomic"))
                                    '())
                                (list val-type)))
                              val-type)))))
        (apply mk-arrow
               (append param-types
                       (cons measure-type
                             (append
                              arg-types
                              (list step-type (py "boole"))
                              (if gind-type?
                                  (list (make-tconst "atomic"))
                                  '())
                              (list val-type))))))))

; In type-info-etc-to-grec-const type-info is (rhos tau).  The case (f
; alphas rhos tau) (f = |alphas|) is not allowed here.

(define (type-info-etc-to-grec-const type-info tsubst)
  (let* ((m (- (length type-info) 1))
         (uninst-grecop-type (type-info-to-grec-type type-info))
         (inst-grecop-type (type-substitute uninst-grecop-type tsubst)))
    (make-const
     (grec-at  m inst-grecop-type type-info tsubst)
     "GRec" 'fixed-rules uninst-grecop-type tsubst t-deg-one 'const)))

(define (type-info-to-grec-const type-info)
  (type-info-etc-to-grec-const type-info empty-subst))

; In type-info-etc-to-grecguard-const type-info is either (rhos tau)
; or (f alphas rhos tau) (f = |alphas|).

(define (type-info-etc-to-grecguard-const type-info tsubst . all-formula)
  (let* ((f (if (number? (car type-info))
                (car type-info)
                0))
         (m (if (number? (car type-info))
                (- (length type-info) f 2)
                (- (length type-info) 1)))
         (uninst-grecguardop-type (type-info-to-grecguard-type type-info))
         (inst-grecguardop-type
          (type-substitute uninst-grecguardop-type tsubst)))
    (apply
     make-const
     (append
      (list (apply grecguard-at
                   (append (list f m inst-grecguardop-type type-info tsubst)
                           all-formula))
            "GRecGuard" 'fixed-rules
            uninst-grecguardop-type tsubst t-deg-one 'const)
      all-formula))))

(define (type-info-to-grecguard-const type-info)
  (type-info-etc-to-grecguard-const type-info empty-subst))

; While normalizing, the unfolding mechanism of the grecguard-operator
; may be blocked by setting GRECGUARD-UNFOLDING-FLAG to #f.

(define GRECGUARD-UNFOLDING-FLAG #t)
(define INITIAL-GRECGUARD-UNFOLDING-FLAG GRECGUARD-UNFOLDING-FLAG)

; grecguard-at computes the object for nbe.  Here f is the number of
; "free" parameter objs and m is the number of arguments for the
; measure function.

(define (grecguard-at f m inst-grecguardop-type type-info tsubst . all-formula)
  (let* ((gind-type? (if (number? (car type-info))
                         #t
                         #f))
         (arity (if gind-type? (+ f m 4) (+ m 3))))
    (nbe-make-object
     inst-grecguardop-type
     (nbe-curry
      (lambda objs
        (let* ((test-obj (list-ref objs (+ f m 2))) ;b
               (test-val (nbe-object-to-value test-obj))
               (param-objs (list-head objs f))
               (measure-obj (list-ref objs f)) ;mu
               (step-obj (list-ref objs (+ f m 1))) ;G
               (arg-objs (list-head (list-tail objs (+ f 1)) m)) ;xs
               (arg-types (map nbe-object-to-type arg-objs))
               (val-type ;tau
                (arrow-form-to-final-val-type inst-grecguardop-type arity)))
          (cond
           ((or (nbe-fam-value? test-val)
		(not GRECGUARD-UNFOLDING-FLAG)) ;reproduce
            (let ((grecguard-term
                   (make-term-in-const-form
                    (apply type-info-etc-to-grecguard-const
			   (append (list type-info tsubst) all-formula)))))
              (nbe-reflect
               (nbe-make-termfam
                val-type
                (lambda (k)
                  (apply
                   mk-term-in-app-form
                   (cons grecguard-term
                         (map (lambda (x)
                                (nbe-fam-apply
                                 (nbe-reify x) k))
                              objs))))))))
           ((nbe-constr-value? test-val)
            (let ((name (nbe-constr-value-to-name test-val)))
              (cond
               ((string=? name "True")
                (let* ((pd-type (apply mk-arrow
                                       (append
                                        arg-types
                                        (if gind-type?
                                            (list (make-tconst "atomic"))
                                            '())
                                        (list val-type))))
                       (pd-obj ;([ys] GRecGuard mu ys G (mu ys < mu xs))
					;or ([ys,atomic] ...)
                        (nbe-make-object
                         pd-type
                         (nbe-curry
                          (lambda objs2
                            (let* ((ys (list-head objs2 m))
                                   (muys (apply nbe-object-app
                                                (cons measure-obj ys)))
                                   (muxs (apply nbe-object-app
                                                (cons measure-obj arg-objs)))
                                   (test-obj ;mu ys < mu xs
                                    (nbe-object-app natlt-obj muys muxs))
                                   (grecguard-const
                                    (apply
                                     type-info-etc-to-grecguard-const
                                     (append (list type-info tsubst)
                                             all-formula)))
                                   (grecguard-obj (const-to-object-or-arity
						   grecguard-const)))
                              (apply
                               nbe-object-app
                               (cons grecguard-obj
                                     (append param-objs (cons measure-obj ys)
                                             (list step-obj test-obj)
                                             (if gind-type?
                                                 (list (list-ref objs2 m))
                                                 '()))))))
                          pd-type
                          (if gind-type? (+ m 1) m)))))
                  (apply nbe-object-app
                         (cons step-obj (append arg-objs (list pd-obj))))))
               ((string=? name "False")
                (if gind-type?
                    (let* ((vars (all-form-to-vars (car all-formula) m))
                           (kernel
                            (all-form-to-final-kernel (car all-formula) m))
                           (free (formula-to-free (car all-formula)))
                           (arg-terms (map (lambda (obj)
                                             (nbe-extract (nbe-reify obj)))
                                           arg-objs))
                           (subst (make-substitution vars arg-terms))
                           (inst-formula (formula-substitute kernel subst))
                           (subst-all-formula
                            (apply mk-all (append free (list inst-formula))))
                           (new-free (formula-to-free subst-all-formula))
                           (new-free-objs
                            (map (lambda (x)
                                   (nbe-reflect
                                    (nbe-term-to-termfam
                                     (make-term-in-var-form x))))
                                 new-free))
                           (new-all-formula
                            (apply mk-all (append
                                           new-free
                                           (list subst-all-formula)))) ;closed
                           (efqconst (formula-to-efq-const new-all-formula))
                           (efqobj (const-to-object-or-arity efqconst))
                           (falsum-obj (list-ref objs (+ f m 3))))
                      (apply
                       nbe-object-app
                       (append (list efqobj falsum-obj)
                               new-free-objs param-objs)))
                    (let ((canon-term ;eps
                           (type-to-canonical-inhabitant val-type)))
                      (nbe-term-to-object canon-term '()))))
               (else (myerror "grecguard-at" "True or False expected"
			      test-name)))))
           (else (myerror "grecguard-at" "value expected" test-val)))))
      inst-grecguardop-type
      arity))))

; We define GRec in terms of GRecGuard

(define (grec-at m inst-grecop-type type-info tsubst)
  (nbe-make-object
   inst-grecop-type
   (nbe-curry
    (lambda objs
      (let* ((trueobj (nbe-term-to-object (pt "True") '()))
             (grecguard-const
              (type-info-etc-to-grecguard-const type-info tsubst))
             (grecguard-obj (const-to-object-or-arity grecguard-const)))
        (apply
         nbe-object-app (cons grecguard-obj (append objs (list trueobj))))))
    inst-grecop-type
    (+ m 2))))

; all-formula-to-grecguard-const will be used in proof.scm to achieve
; normalization of proofs via translating them in terms, to translate
; a gind-aconst.  In addition we need the number m of quantifiers used
; for the axioms.

(define (all-formula-to-grecguard-const all-formula m)
  (let* ((uninst-gind-formula-and-tpinst
          (all-formula-to-uninst-gind-formula-and-tpinst all-formula m))
	 (tpinst (cadr uninst-gind-formula-and-tpinst))
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x)))))
	 (pvar (caar pinst)) ;there is only one pvar (gind is not simult.)
	 (cterm (cadar pinst))
	 (new-tvar (PVAR-TO-TVAR pvar))
	 (nbe-type (nbe-formula-to-type (cterm-to-formula cterm)))
	 (new-tsubst (make-subst new-tvar nbe-type))
	 (free (formula-to-free all-formula))
	 (param-types (map var-to-type free)) ;alphas
	 (f (length free))
	 (vars (all-form-to-vars all-formula m))
	 (types (map var-to-type vars)) ;rhos
	 (type-info (cons f (append param-types types (list nbe-type)))))
    (type-info-etc-to-grecguard-const type-info new-tsubst all-formula)))

; ex-elim: allnc zs(ex z A -> all z(A -> B) -> B)

(define (ex-formula-and-concl-to-ex-elim-const ex-formula concl)
  (let* ((free (union (formula-to-free ex-formula) (formula-to-free concl)))
	 (free-types (map var-to-type free))
	 (f (length free))
         (var (ex-form-to-var ex-formula))
	 (inst-type (var-to-type var))
         (kernel (ex-form-to-kernel ex-formula))
	 (side-formula (mk-all var (mk-imp kernel concl)))
	 (side-type (nbe-formula-to-type side-formula))
	 (concl-type (nbe-formula-to-type concl))
	 (arity (+ f 2))
	 (exelimop-type
	  (apply mk-arrow (append free-types (list (make-tconst "existential")
						   side-type concl-type)))))
    (ex-formula-and-concl-to-ex-elim-const-aux
     ex-formula concl f arity exelimop-type)))

(define (ex-formula-and-concl-to-ex-elim-const-aux
	 ex-formula concl f arity exelimop-type)
  (make-const (ex-formula-and-concl-to-ex-elim-const-obj
	       ex-formula concl f arity exelimop-type)
	      "Ex-Elim" 'fixed-rules exelimop-type empty-subst
	      1 'const ex-formula concl))

(define (ex-formula-and-concl-to-ex-elim-const-obj
	 ex-formula concl f arity exelimop-type)
  (nbe-make-object
   exelimop-type
   (nbe-curry
    (lambda objs
      (let* ((ex-obj (list-ref objs f))
	     (ex-value (nbe-object-to-value ex-obj)))
	(cond
	 ((nbe-fam-value? ex-value) ;then reproduce
	  (let* ((refl-term-obj
		  (nbe-reflect
		   (nbe-make-termfam
		    exelimop-type
		    (lambda (k)
		      (make-term-in-const-form
		       (ex-formula-and-concl-to-ex-elim-const-aux
			ex-formula concl f arity exelimop-type))))))
		 (val (nbe-object-to-value refl-term-obj)))
	    (apply (nbe-uncurry val arity) objs)))
	 ((nbe-constr-value? ex-value)
	  (let* ((args (nbe-constr-value-to-args ex-value))
		 (f1 (- (length args) 2))
		 (inst-obj (list-ref args f1))
		 (kernel-obj (list-ref args (+ f1 1)))
		 (side-obj (list-ref objs (+ f 1))))
	    (nbe-object-app side-obj inst-obj kernel-obj)))
	 (else
	  (myerror
	   "ex-formula-and-concl-to-ex-elim-const-obj" "ex-value expected"
	   ex-value)))))
    exelimop-type
    arity)))

(define (nbe-curry f type n)
  (if (= 1 n)
      f
      (lambda (obj)
	(let ((valtype (arrow-form-to-val-type type)))
	  (nbe-make-object
	   valtype
	   (nbe-curry (lambda objs
			(apply f (cons obj objs))) valtype (- n 1)))))))

(define (nbe-uncurry g n)
  (if (= 1 n)
      g
      (lambda objs
	(apply (nbe-uncurry (nbe-object-to-value (g (car objs))) (- n 1))
	       (cdr objs)))))

; Type substitution in constants:

(define (const-substitute const tsubst update-of-program-constants-done?)
  (if
   (null? tsubst)
   const
   (let* ((obj-or-arity (const-to-object-or-arity const))
	  (name (const-to-name const))
	  (uninst-type (const-to-uninst-type const))
	  (orig-tsubst (const-to-tsubst const))
	  (t-deg (const-to-t-deg const))
	  (token-type (const-to-token-type const))
	  (type-info-or-repro-formulas
	   (const-to-type-info-or-repro-formulas const))
	  (composed-tsubst (compose-t-substitutions orig-tsubst tsubst))
	  (tvars (const-to-tvars const))
	  (restricted-tsubst
	   (restrict-substitution-to-args composed-tsubst tvars)))
     (case (const-to-kind const)
       ((constr)
	(if
	 (or (string=? "Ex-Intro" (const-to-name const))
	     (string=? "Intro" (const-to-name const)))		      
	 const
         ;else form new-constr with restricted-subst.  If not yet done,
         ;update CONSTRUCTORS, via computing for all simalgs and all of
         ;their constructors the new object, type etc.  Return new-constr
	 (let* ((val-type (arrow-form-to-final-val-type uninst-type))
		(alg-name (alg-form-to-name val-type))
		(alg-names (alg-name-to-simalg-names alg-name))
		(alg-names-with-typed-constr-names
		 (map (lambda (x)
			(cons x (alg-name-to-typed-constr-names x)))
		      alg-names))
		(assoc-list (constr-name-to-inst-constructors name))
		(info (assoc-wrt substitution-equal?
				 restricted-tsubst assoc-list)))
	   (if
	    info
	    (cadr info) ;else update CONSTRUCTORS, return new-constr
	    (begin
	      (for-each ;of alg-names-with-typed-constr-names
	       (lambda (item)
		 (let ((typed-constr-names (cdr item)))
		   (for-each ;of typed-constr-names, update CONSTRUCTORS
		    (lambda (y)
		      (let* ((constr-name (typed-constr-name-to-name y))
			     (type (typed-constr-name-to-type y))
			     (optional-token-type1
			      (typed-constr-name-to-optional-token-type y))
			     (token-type1 (if (pair? optional-token-type1)
					      (car optional-token-type1)
					      'const))
			     (argtypes (arrow-form-to-arg-types type))
			     (arity (length argtypes))
			     (new-type
			      (type-substitute type restricted-tsubst))
			     (new-valtype
			      (arrow-form-to-final-val-type new-type))
			     (del-constr 
			      (eval-once (lambda ()
					   (constr-name-and-tsubst-to-constr
					    constr-name restricted-tsubst))))
			     (obj (nbe-make-object
				   new-type
				   (if (zero? arity)
				       (nbe-make-constr-value
					constr-name '() del-constr)
				       (nbe-curry
					(lambda objs ;as many as argtypes
					  (nbe-make-object
					   new-valtype
					   (nbe-make-constr-value
					    constr-name objs del-constr)))
					new-type
					arity))))
			     (constr
			      (make-const obj constr-name 'constr type
					  restricted-tsubst t-deg-one
					  token-type1))
			     (constrs-exept-name
			      (do ((l CONSTRUCTORS (cdr l))
				   (res '() (if (string=? (caar l) constr-name)
						res
						(cons (car l) res))))
				  ((null? l) (reverse res))))
			     (prev-alist-for-name
			      (let ((info (assoc constr-name CONSTRUCTORS)))
				(if info
				    (cadr info)
				    (myerror "const-substitute"
					     "constr expected"
					     constr-name))))
			     (new-alist-for-name
			      (cons (list restricted-tsubst constr)
				    prev-alist-for-name)))
			(set! CONSTRUCTORS
			      (cons (list constr-name new-alist-for-name)
				    constrs-exept-name))))
		    typed-constr-names)))
	       alg-names-with-typed-constr-names)
	      (constr-name-and-tsubst-to-constr name restricted-tsubst))))))
       ((pconst)
        ;form new-pconst with restricted-tsubst.  If not yet done, update
        ;PROGRAM-CONSTANTS with new object for restricted-tsubst,
        ;return new-pconst.
	(let* ((new-pconst (make-const obj-or-arity
				       name
				       'pconst
				       uninst-type
				       restricted-tsubst
				       t-deg
				       token-type))
	       (tsubst-obj-alist (pconst-name-to-inst-objs name))
	       (info (assoc-wrt substitution-equal?
				restricted-tsubst tsubst-obj-alist)))
	  (if
	   (or update-of-program-constants-done? info)
	   new-pconst ;else update PROGRAM-CONSTANTS, then return new-pconst
	   (let* ((uninst-const (pconst-name-to-pconst name))
		  (comprules (pconst-name-to-comprules name))
		  (rewrules (pconst-name-to-rewrules name))
		  (external-code (pconst-name-to-external-code name))
		  (obj (if external-code
			   (nbe-pconst-and-tsubst-and-rules-to-object
			    const restricted-tsubst comprules rewrules
			    external-code)
			   (nbe-pconst-and-tsubst-and-rules-to-object
			    const restricted-tsubst comprules rewrules)))
		  (pconsts-exept-name
		   (do ((l PROGRAM-CONSTANTS (cdr l))
			(res '() (if (string=? (caar l) name)
				     res
				     (cons (car l) res))))
		       ((null? l) (reverse res))))
		  (prev-alist-for-name (pconst-name-to-inst-objs name))
		  (new-alist-for-name (cons (list restricted-tsubst obj)
					    prev-alist-for-name)))
	     (set! PROGRAM-CONSTANTS
		   (cons (list name uninst-const comprules rewrules
			       new-alist-for-name)
			 pconsts-exept-name))
	     new-pconst))))
       ((fixed-rules)
	(cond
	 ((string=? "Rec" name)
	  (let* ((param-types (rec-const-to-param-types const))
		 (f (length param-types))
		 (arg-types (arrow-form-to-arg-types uninst-type))
		 (alg-type-and-step-types (list-tail arg-types f))
                 (step-types (cdr alg-type-and-step-types))
		 (alg-type (car alg-type-and-step-types))
		 (alg-name (alg-form-to-name alg-type))
		 (uninst-arrow-types (rec-const-to-uninst-arrow-types const))
		 (alg-types (map arrow-form-to-arg-type uninst-arrow-types))
		 (alg-names (map alg-form-to-name alg-types))
		 (uninst-recop-types
		  (map (lambda (x)
			 (apply mk-arrow
				(append param-types
					(list (arrow-form-to-arg-type x))
					step-types
                                        (list (arrow-form-to-val-type x)))))
		       uninst-arrow-types))
		 (alg-names-with-uninst-recop-types
		  (map (lambda (x y) (list x y)) alg-names uninst-recop-types))
		 (simalg-names (alg-name-to-simalg-names alg-name))
		 (sorted-alg-names (list-transform-positive simalg-names
				     (lambda (x) (member x alg-names))))
		 (typed-constr-names
		  (apply append (map alg-name-to-typed-constr-names
				     sorted-alg-names)))
		 (constr-names (map car typed-constr-names))
		 (uninst-recop-type
		  (cadr (assoc alg-name alg-names-with-uninst-recop-types)))
		 (inst-recop-type (type-substitute uninst-recop-type
						   restricted-tsubst)))
	    (apply alg-name-etc-to-rec-const
		   (append (list alg-name uninst-recop-type restricted-tsubst
				 inst-recop-type f constr-names
				 alg-names-with-uninst-recop-types)
			   type-info-or-repro-formulas))))
	 ((string=? "Cases" name)
	  (let* ((param-types (cases-const-to-param-types const))
		 (f (length param-types))
		 (arg-types (arrow-form-to-arg-types uninst-type))
		 (val-type (arrow-form-to-final-val-type uninst-type))
		 (alg-type-and-step-types (list-tail arg-types f))
		 (step-types (cdr alg-type-and-step-types))
		 (alg-type (car alg-type-and-step-types))
		 (alg-name (alg-form-to-name alg-type))
		 (uninst-casesop-type
		  (apply mk-arrow (append param-types
					  (list alg-type)
					  step-types
					  (list val-type))))
		 (typed-constr-names (alg-name-to-typed-constr-names alg-name))
		 (constr-names (map car typed-constr-names)))
	    (apply
	     make-const
	     (append
	      (list (apply 
		     cases-at (append (list alg-name restricted-tsubst f
					    constr-names uninst-casesop-type)
				      type-info-or-repro-formulas))
		    "Cases" 'fixed-rules uninst-type restricted-tsubst
		    1 'const)
	      type-info-or-repro-formulas))))
	 ((string=? "SE" name)
	  (let* ((inst-type (type-substitute uninst-type restricted-tsubst))
		 (sfinalg (arrow-form-to-arg-type inst-type)))
	    (make-const (se-at sfinalg)
			"SE" 'fixed-rules
			(make-arrow sfinalg (make-alg "boole")) empty-subst
			1 'prefix-op)))
	 ((string=? "=" name) const)
	 ((string=? "E" name) const)
	 ((string=? "Ex-Elim" name) const)
	 (else (myerror "const-substitute" "fixed rule name expected" name))))
       (else (myerror "const-substitute" "unknown kind"
		      (const-to-kind const)))))))

