; $Id: term.scm 2350 2009-11-13 11:44:02Z schwicht $
; 6. Terms
; ========

; 6-1. Constructors and accessors
; ===============================

; Terms are built from (typed) variables and constants by abstraction,
; application, pairing, formation of left and right components
; (i.e. projections) and the if-construct.  Terms always have the form
; (tag type ...) where ... is a list with further information.

(define tag car)
(define term-to-type cadr)

; Constructors, accessors and test for terms in variable form:
; (term-in-var-form type string var)

(define (make-term-in-var-form var)
  (if (var-form? var)
      (list 'term-in-var-form
	    (var-to-type var)
	    var)
      (myerror "make-term-in-var-form" "variable expected" var)))

(define term-in-var-form-to-var caddr)

(define (term-in-var-form-to-string term)
  (var-to-string (term-in-var-form-to-var term)))

(define (term-in-var-form? term)
  (eq? 'term-in-var-form (tag term)))

; Constructor, accessor and test for terms in constant form:
; (term-in-const-form type const)

(define (make-term-in-const-form const)
  (if (const-form? const)
      (list 'term-in-const-form
	    (const-to-type const)
	    const)
      (myerror "make-term-in-const-form" "constant expected" const)))

(define term-in-const-form-to-const caddr)
(define (term-in-const-form? term) (eq? 'term-in-const-form (tag term)))

; Constructors, accessors and test for abstractions:

(define (make-term-in-abst-form var term)
  (list 'term-in-abst-form
	(make-arrow (var-to-type var) (term-to-type term))
	var
	term))

(define term-in-abst-form-to-var caddr)
(define term-in-abst-form-to-kernel cadddr)

(define (term-in-abst-form? term)
  (eq? 'term-in-abst-form (tag term)))

; (mk-term-in-abst-form var1 ... term) is formed from term by first 
; abstracting var1, then var2 and so on. 

(define (mk-term-in-abst-form x . rest)
  (if (null? rest)
      x
      (if (var-form? x)
	  (let ((prev (apply mk-term-in-abst-form rest)))
	    (make-term-in-abst-form x prev))
	  (myerror "mk-term-in-abst-form" "variable expected" x))))

(define (term-in-abst-form-to-kernel-and-vars term)
  (if (term-in-abst-form? term)
      (let* ((prev (term-in-abst-form-to-kernel-and-vars
		    (term-in-abst-form-to-kernel term)))
             (prev-kernel (car prev))
             (prev-vars (cdr prev)))
        (cons prev-kernel (cons (term-in-abst-form-to-var term) prev-vars)))
      (list term)))

; term-in-abst-form-to-vars computes the first (car x) abstracted vars

(define (term-in-abst-form-to-vars term . x)
  (cond ((null? x)
	 (if (term-in-abst-form? term)
	     (cons (term-in-abst-form-to-var term)
		   (term-in-abst-form-to-vars
		    (term-in-abst-form-to-kernel term)))
	     '()))
	((and (integer? (car x)) (not (negative? (car x))))
	 (let ((n (car x)))
	   (do ((r term (term-in-abst-form-to-kernel r))
		(i 0 (+ 1 i))
		(res '() (cons (term-in-abst-form-to-var r) res)))
	       ((or (= n i) (not (term-in-abst-form? r)))
		(if (= n i)
		    (reverse res)
		    (myerror "term-in-abst-form-to-vars"
			     n "abstracted vars expected in"
			     term))))))
	(else (myerror "term-in-abst-form-to-vars" "number expected"
		       (car x)))))

; term-in-abst-form-to-final-kernel computes the final kernel (kernel
; after removing the first (car x) variables) 

(define (term-in-abst-form-to-final-kernel term . x)
  (cond ((null? x)
	 (if (term-in-abst-form? term)
	     (term-in-abst-form-to-final-kernel
	      (term-in-abst-form-to-kernel term))
	     term))
	((and (integer? (car x)) (not (negative? (car x))))
	 (let ((n (car x)))
	   (do ((r term (term-in-abst-form-to-kernel r))
		(i 0 (+ 1 i))
		(res term (term-in-abst-form-to-kernel res)))
	       ((or (= n i) (not (term-in-abst-form? r)))
		(if (= n i)
		    res
		    (myerror "term-in-abst-form-to-final-kernel"
			     n " abstracted vars expected in"
			     term))))))
	(else (myerror "term-in-abst-form-to-final-kernel" "number expected"
		       (car x)))))

; Constructors, accessors and test for applications:

; Changed 04-01-10, to enable overloading and coercion when working with
; rationals.

(define (make-term-in-app-form term1 term2)
  (let ((type1 (term-to-type term1))
	(type2 (term-to-type term2)))
    (if
     (arrow-form? type1)
     (let ((arg-type (arrow-form-to-arg-type type1))
	   (val-type (arrow-form-to-val-type type1)))
       (if
	(type-leq? type2 arg-type)
	(list 'term-in-app-form val-type term1
	      ((types-to-coercion type2 arg-type) term2))
	(myerror
	    "make-term-in-app-form" "unexpected terms.  Operator:"
	    term1 "with argument type" arg-type
	    "Argument:" term2 "of type" type2)))
     (myerror "make-term-in-app-form" "arrow form expected" type1))))

; (define (make-term-in-app-form term1 term2)
;   (let ((type1 (term-to-type term1))
; 	(type2 (term-to-type term2)))
;     (if (arrow-form? type1)
; 	(let ((arg-type (arrow-form-to-arg-type type1)))
; 	  (list 'term-in-app-form  (arrow-form-to-val-type type1) term1
; 		(if (equal? type2 arg-type)
; 		    term2
; 		    ((increasing-types-to-coercion type2 arg-type)
; 		     term2))))
; 	(myerror "make-term-in-app-form" "arrow form expected"
; 		 (type-to-string type1)))))

; (define (make-term-in-app-form term1 term2)
;   (let ((type1 (term-to-type term1)))
;     (if (arrow-form? type1)
; 	(if (equal? (arrow-form-to-arg-type type1) (term-to-type term2))
; 	    (list 'term-in-app-form 
; 		  (arrow-form-to-val-type type1)
; 		  term1
; 		  term2)
; 	    (myerror "make-term-in-app-form" "types do not fit"
; 		     (type-to-string type1)
; 		     (type-to-string (term-to-type term2))))
; 	(myerror "make-term-in-app-form" "arrow form expected"
; 		 (type-to-string type1)))))

(define term-in-app-form-to-op caddr)
(define term-in-app-form-to-arg cadddr)

(define (term-in-app-form? term) (eq? 'term-in-app-form (tag term)))

(define (mk-term-in-app-form term . terms)
  (if (null? terms)
      term
      (let ((type (term-to-type term)))
	(case (tag type)
	  ((tvar tconst alg)
	   (myerror "mk-term-in-app-form" "applicable type expected" type))
	  ((arrow)
	   (apply mk-term-in-app-form
		  (cons (make-term-in-app-form term (car terms))
			(cdr terms))))
	  ((star)
	   (cond ((eq? 'left (car terms))
		  (apply mk-term-in-app-form
			 (cons (make-term-in-lcomp-form term) (cdr terms))))
		 ((eq? 'right (car terms))
		  (apply mk-term-in-app-form
			 (cons (make-term-in-rcomp-form term) (cdr terms))))
		 (else (myerror "mk-term-in-app-form" "left or right expected"
				(car terms)))))
	  (else (myerror "mk-term-in-app-form" "type expected" type))))))

(define (term-in-app-form-to-final-op term)
  (do ((x term (term-in-app-form-to-op x)))
      ((not (term-in-app-form? x)) x)))

(define (term-in-app-form-to-args term)
  (do ((x term (term-in-app-form-to-op x))
       (res '() (cons (term-in-app-form-to-arg x) res)))
      ((not (term-in-app-form? x)) res)))

; the same again for ``symbolic applications'' (just for printing)

(define (term-in-symbolic-app-form-to-final-op term)
  (do ((x term (term-in-symbolic-app-form-to-op x)))
      ((not (and (term-in-symbolic-app-form? x)
		 (not (is-numeric-term? x)))) x)))

(define (term-in-symbolic-app-form-to-args term)
  (do ((x term (term-in-symbolic-app-form-to-op x))
       (res '() (cons (term-in-symbolic-app-form-to-arg x) res)))
      ((not (and (term-in-symbolic-app-form? x)
		 (not (is-numeric-term? x)))) res)))

; Finally tell the system that terms in app-form can and should be written as
; application:

(add-new-application (lambda (type) (arrow-form? type))
		     make-term-in-app-form) 

(add-new-application-syntax
 term-in-app-form?
 term-in-app-form-to-arg
 term-in-app-form-to-op)

; Vector notation for recursion:

(add-new-application
 (lambda (type) (and (alg-form? type)
		     (= 1 (length (alg-name-to-simalg-names
				   (alg-form-to-name type))))))
 (lambda (arg first-step-term)
   (let* ((first-step-type (term-to-type first-step-term))
	  (alg-name (alg-form-to-name (term-to-type arg)))
	  (typed-constr-names (alg-name-to-typed-constr-names alg-name))
	  (first-typed-constr-name
	   (typed-constr-name-to-name typed-constr-names))
	  (first-constr-type
	   (typed-constr-name-to-type first-typed-constr-name))
	  (argtypes (arrow-form-to-arg-types first-constr-type))
	  (argvaltypes (map arrow-form-to-final-val-type argtypes))
	  (number-of-rec-argtypes
	   (do ((l argvaltypes (cdr l))
		(res 0 (if (and (alg-form? (car l))
				(string=? (alg-form-to-name (car l)) alg-name))
			   (+ 1 res)
			   res)))
	       ((null? l) res)))
	  (val-type (arrow-form-to-final-val-type
		     first-step-type
		     (+ (length argtypes) number-of-rec-argtypes)))
	  (arrow-type (make-arrow (term-to-type arg) val-type))
	  (rec-const (type-info-to-rec-const arrow-type))
	  (recop-type (const-to-type rec-const))
	  (step-types (cdr (arrow-form-to-arg-types
                            recop-type
                            (+ 1 (length typed-constr-names)))))
	  (vars (map type-to-new-var (cdr step-types)))
	  (var-terms (map make-term-in-var-form vars)))
     (apply mk-term-in-abst-form
	    (append
	     vars (list (apply mk-term-in-app-form
			       (cons (make-term-in-const-form rec-const)
				     (cons arg (cons first-step-term
						     var-terms ))))))))))

; ; Allow vector-notation for if-then-else:
; No.  We have vector notation for recursion, which evaluates all
; its arguments and hence is different from the special form if.
; There is also no need for vector notation here, for we have the
; special notation [if test arg_1 ... arg_n].

; (add-new-application
;  (lambda (type) (equal? type (make-alg "boole")))
;  (lambda (test alt1)
;    (let* ((type (term-to-type alt1))
; 	  (var (type-to-new-var type)))
;      (make-term-in-abst-form 
;       var
;       (make-term-in-if-form 
;        test alt1 (make-term-in-var-form var))))))

; For permutative conversion with if-terms we use an application notation:
; [if n r [m]s] is written as n(r,[n]s).  (r,[n]s) is called gen-arg.

(define (term-in-if-form-to-final-test term)
  (if (term-in-if-form? term)
      (term-in-if-form-to-final-test
       (term-in-if-form-to-test term))
      term))

(define (term-in-if-form-to-gen-args term)
  (if (term-in-if-form? term)
      (let ((test (term-in-if-form-to-test term))
	    (alts (term-in-if-form-to-alts term)))
	(append (term-in-if-form-to-gen-args test)
		(list alts)))
      '()))

(define (mk-term-in-if-form term . gen-args)
  (if (null? gen-args)
      term
      (if (alg-form? (term-to-type term))
	  (let ((alts (car gen-args)))
	    (apply mk-term-in-if-form
		   (cons (make-term-in-if-form term alts) (cdr gen-args))))
	  (myerror "mk-term-in-if-form: alg type expected" type))))

(define (gen-args-to-free gen-args)
  (if (null? gen-args)
      '()
      (let* ((gen-arg (car gen-args))
	     (free (if (term-form? gen-arg)
		       (term-to-free gen-arg)
		       (apply union (map term-to-free gen-arg)))))
	(union free (gen-args-to-free (cdr gen-args))))))

; Constructors, accessors and test for pairs:

(define (make-term-in-pair-form term1 term2)
  (list 'term-in-pair-form
	(make-star (term-to-type term1) (term-to-type term2))
	term1
	term2))

(define term-in-pair-form-to-left caddr)
(define term-in-pair-form-to-right cadddr)

(define (term-in-pair-form? term)
  (eq? 'term-in-pair-form (tag term)))

(define (mk-term-in-pair-form term . rest)
  (if (null? rest)
      term
      (make-term-in-pair-form
       term
       (apply mk-term-in-pair-form rest))))

; Constructors, accessors and test for the left and right component:

(define (make-term-in-lcomp-form term)
  (let ((type (term-to-type term)))
    (if (star-form? type)
	(list 'term-in-lcomp-form
	      (star-form-to-left-type type)
	      term)
	(myerror "make-term-in-lcomp-form" "star form expected" type))))

(define term-in-lcomp-form-to-kernel caddr)

(define (term-in-lcomp-form? term)
  (eq? 'term-in-lcomp-form (tag term)))

(define (make-term-in-rcomp-form term)
  (let ((type (term-to-type term)))
    (if (star-form? type)
	(list 'term-in-rcomp-form
	      (star-form-to-right-type type)
	      term)
	(myerror "make-term-in-rcomp-form" "star form expected" type))))

(define term-in-rcomp-form-to-kernel caddr)

(define (term-in-rcomp-form? term)
  (eq? 'term-in-rcomp-form (tag term)))

; Constructors, accessors and test for if-constructs:

(define (make-term-in-if-form test alts . rest) ;rest empty or all-formula
  (let* ((alg (term-to-type test))
	 (name (alg-form-to-name alg))
	 (typed-constr-names (alg-name-to-typed-constr-names name))
	 (constr-types (map typed-constr-name-to-type typed-constr-names))
	 (lengths-of-arg-types
	  (map (lambda (x) (length (arrow-form-to-arg-types x)))
	       constr-types))
	 (types (map (lambda (alt l)
		       (arrow-form-to-final-val-type (term-to-type alt) l))
		     alts lengths-of-arg-types))
	 (lub (apply types-lub types))
	 (coerce-ops (map types-to-coercion
			  types (make-list (length types) lub)))
	 (lifted-alts (map (lambda (op alt) (op alt)) coerce-ops alts)))
    (append (list 'term-in-if-form lub test lifted-alts)
	    rest)))

(define term-in-if-form-to-test caddr)
(define term-in-if-form-to-alts cadddr)
(define term-in-if-form-to-rest cddddr)

(define (term-in-if-form-to-all-formula x)
  (let ((rest (cddddr x)))
    (if (null? rest)
	(myerror "term-in-if-form-to-all-formula" "no all formula present")
	(car rest))))

(define (term-in-if-form? term)
  (eq? 'term-in-if-form (tag term)))

(define (term-form? x)
  (and (pair? x)
       (memq (tag x) '(term-in-var-form
		       term-in-const-form
		       term-in-abst-form
		       term-in-app-form
		       term-in-pair-form
		       term-in-lcomp-form
		       term-in-rcomp-form
		       term-in-if-form))))			     

; To define alpha-equality for terms we use (following Robert Staerk)
; an auxiliary function (corr x y alist alistrev).  Here
; alist = ((u1 v1) ... (un vn)), alistrev = ((v1 u1) ... (vn un)).

; (corr x y alist alistrev) iff one of the following holds.
; 1. There is a first entry (x v) of the form (x _) in alist
;    and a first entry (y u) of the form (y _) in alistrev,
;    and we have v=y and u=x.
; 2. There is no entry of the form (x _) in alist
;    and no entry of the form (y _) in alistrev,
;    and we have x=y.

(define (corr x y alist alistrev)
  (let ((info-x (assoc x alist))
        (info-y (assoc y alistrev)))
    (if (and info-x info-y)
        (equal? info-x (reverse info-y))
        (and (not info-x) (not info-y) (equal? x y)))))

(define (term=? term1 term2)
  (term=-aux? term1 term2 '() '()))

(define (terms=? terms1 terms2)
  (terms=-aux? terms1 terms2 '() '()))

(define (term=-aux? term1 term2 alist alistrev)
  (or (and (term-in-var-form? term1) (term-in-var-form? term2)
           (corr (term-in-var-form-to-var term1)
		 (term-in-var-form-to-var term2)
		 alist alistrev))
      (and (term-in-const-form? term1) (term-in-const-form? term2)
	   (const=? (term-in-const-form-to-const term1)
		    (term-in-const-form-to-const term2)))
      (and (term-in-abst-form? term1) (term-in-abst-form? term2)
           (let ((var1 (term-in-abst-form-to-var term1))
		 (var2 (term-in-abst-form-to-var term2))
		 (kernel1 (term-in-abst-form-to-kernel term1))
		 (kernel2 (term-in-abst-form-to-kernel term2)))
	     (and (equal? (var-to-type var1) (var-to-type var2))
		  (term=-aux? kernel1 kernel2
			      (cons (list var1 var2) alist)
			      (cons (list var2 var1) alistrev)))))
      (and (term-in-app-form? term1) (term-in-app-form? term2)
           (let ((op1 (term-in-app-form-to-op term1))
                 (op2 (term-in-app-form-to-op term2))
                 (arg1 (term-in-app-form-to-arg term1))
                 (arg2 (term-in-app-form-to-arg term2)))
             (and (term=-aux? op1 op2 alist alistrev)
                  (term=-aux? arg1 arg2 alist alistrev))))
      (and (term-in-pair-form? term1) (term-in-pair-form? term2)
           (let ((left1 (term-in-pair-form-to-left term1))
                 (left2 (term-in-pair-form-to-left term2))
                 (right1 (term-in-pair-form-to-right term1))
                 (right2 (term-in-pair-form-to-right term2)))
             (and (term=-aux? left1 left2 alist alistrev)
                  (term=-aux? right1 right2 alist alistrev))))
      (and (term-in-lcomp-form? term1) (term-in-lcomp-form? term2)
           (let ((kernel1 (term-in-lcomp-form-to-kernel term1))
                 (kernel2 (term-in-lcomp-form-to-kernel term2)))
	     (term=-aux? kernel1 kernel2 alist alistrev)))
      (and (term-in-rcomp-form? term1) (term-in-rcomp-form? term2)
           (let ((kernel1 (term-in-rcomp-form-to-kernel term1))
                 (kernel2 (term-in-rcomp-form-to-kernel term2)))
	     (term=-aux? kernel1 kernel2 alist alistrev)))
      (and (term-in-if-form? term1) (term-in-if-form? term2)
           (let ((test1 (term-in-if-form-to-test term1))
                 (test2 (term-in-if-form-to-test term2))
                 (alts1 (term-in-if-form-to-alts term1))
                 (alts2 (term-in-if-form-to-alts term2)))
             (and (term=-aux? test1 test2 alist alistrev)
                  (terms=-aux?
		   alts1 alts2 alist alistrev))))))

(define (terms=-aux? terms1 terms2 alist alistrev)
  (or (and (null? terms1) (null? terms2))
      (and (term=-aux? (car terms1) (car terms2) alist alistrev)
           (terms=-aux? (cdr terms1) (cdr terms2) alist alistrev))))

(define (term-to-free term)
  (case (tag term)
    ((term-in-var-form) (list (term-in-var-form-to-var term)))
    ((term-in-const-form) '())
    ((term-in-abst-form)
     (let* ((var (term-in-abst-form-to-var term))
	    (kernel (term-in-abst-form-to-kernel term))
	    (free (term-to-free kernel)))
       (remove var free)))       
    ((term-in-app-form)
     (let ((free1 (term-to-free (term-in-app-form-to-op term)))
	   (free2 (term-to-free (term-in-app-form-to-arg term))))
       (union free1 free2)))
    ((term-in-pair-form)
     (union (term-to-free (term-in-pair-form-to-left term))
	    (term-to-free (term-in-pair-form-to-right term))))
    ((term-in-lcomp-form)
     (term-to-free (term-in-lcomp-form-to-kernel term)))
    ((term-in-rcomp-form)
     (term-to-free (term-in-rcomp-form-to-kernel term)))
    ((term-in-if-form)
     (apply union (map term-to-free
		       (cons (term-in-if-form-to-test term)
			     (term-in-if-form-to-alts term)))))
    (else (myerror "term-to-free" "term expected" term))))

(define (term-to-bound term)
  (case (tag term)
    ((term-in-var-form term-in-const-form) '())
    ((term-in-abst-form)
     (let* ((var (term-in-abst-form-to-var term))
	    (kernel (term-in-abst-form-to-kernel term))
	    (bound (term-to-bound kernel)))
       (adjoin var bound)))       
    ((term-in-app-form)
     (let ((bound1 (term-to-bound (term-in-app-form-to-op term)))
	   (bound2 (term-to-bound (term-in-app-form-to-arg term))))
       (union bound1 bound2)))
    ((term-in-pair-form)
     (union (term-to-bound (term-in-pair-form-to-left term))
	    (term-to-bound (term-in-pair-form-to-right term))))
    ((term-in-lcomp-form)
     (term-to-bound (term-in-lcomp-form-to-kernel term)))
    ((term-in-rcomp-form)
     (term-to-bound (term-in-rcomp-form-to-kernel term)))
    ((term-in-if-form)
     (apply union (map term-to-bound
		       (cons (term-in-if-form-to-test term)
			     (term-in-if-form-to-alts term)))))
    (else (myerror "term-to-bound" "term expected" term))))

(define (term-to-tvars term)
  (case (tag term)
    ((term-in-var-form)
     (type-to-free (var-to-type (term-in-var-form-to-var term))))
    ((term-in-const-form)
     (type-to-free (const-to-type (term-in-const-form-to-const term))))
    ((term-in-abst-form)
     (let* ((var (term-in-abst-form-to-var term))
	    (kernel (term-in-abst-form-to-kernel term))
	    (tvars1 (type-to-free (var-to-type var)))
	    (tvars2 (term-to-tvars kernel)))
       (union tvars1 tvars2)))
    ((term-in-app-form)
     (let ((tvars1 (term-to-tvars (term-in-app-form-to-op term)))
	   (tvars2 (term-to-tvars (term-in-app-form-to-arg term))))
       (union tvars1 tvars2)))
    ((term-in-pair-form)
     (union (term-to-tvars (term-in-pair-form-to-left term))
	    (term-to-tvars (term-in-pair-form-to-right term))))
    ((term-in-lcomp-form)
     (term-to-tvars (term-in-lcomp-form-to-kernel term)))
    ((term-in-rcomp-form)
     (term-to-tvars (term-in-rcomp-form-to-kernel term)))
    ((term-in-if-form)
     (apply union (map term-to-tvars
		       (cons (term-in-if-form-to-test term)
			     (term-in-if-form-to-alts term)))))
    (else (myerror "term-to-tvars" "term expected" term))))

; Finally we need an operation assigning to every term its degree of
; totality, which can be t-deg-zero (i.e., 0) or else t-deg-one (i.e.,
; 1).

(define (term-to-t-deg-aux term bound-vars)
  (case (tag term)
    ((term-in-var-form)
     (let ((var (term-in-var-form-to-var term)))
       (if (member var bound-vars) t-deg-one (var-to-t-deg var))))
    ((term-in-const-form) (const-to-t-deg
			   (term-in-const-form-to-const term)))
    ((term-in-abst-form)
     (let ((var (term-in-abst-form-to-var term))
	   (kernel (term-in-abst-form-to-kernel term)))
       (term-to-t-deg-aux kernel (cons var bound-vars))))
    ((term-in-app-form)
     (let* ((op (term-in-app-form-to-op term))
	    (arg (term-in-app-form-to-arg term))
	    (t-deg-op (term-to-t-deg-aux op bound-vars))
	    (t-deg-arg (term-to-t-deg-aux arg bound-vars)))
       (if (and (t-deg-one? t-deg-op) (t-deg-one? t-deg-arg))
	   t-deg-one
	   t-deg-zero)))
    ((term-in-pair-form)
     (let* ((left (term-in-pair-form-to-left term))
	    (right (term-in-pair-form-to-right term))
	    (t-deg-left (term-to-t-deg-aux left bound-vars))
	    (t-deg-right (term-to-t-deg-aux right bound-vars)))
       (if (and (t-deg-one? t-deg-left) (t-deg-one? t-deg-right))
	   t-deg-one
	   t-deg-zero)))
    ((term-in-lcomp-form)
     (term-to-t-deg-aux (term-in-lcomp-form-to-kernel term) bound-vars))
    ((term-in-rcomp-form)
     (term-to-t-deg-aux (term-in-rcomp-form-to-kernel term) bound-vars))
    ((term-in-if-form)
     (let* ((test (term-in-if-form-to-test term))
	    (alts (term-in-if-form-to-alts term))
	    (t-deg-test (term-to-t-deg-aux test bound-vars))
	    (t-deg-alts (map (lambda (x) (term-to-t-deg-aux x bound-vars))
			     alts)))
       (if (apply and-op (cons (t-deg-one? t-deg-test)
			       (map t-deg-one? t-deg-alts)))
	   t-deg-one
	   t-deg-zero)))
    (else (myerror "term-to-t-deg-aux" "term expected" term))))

(define (term-to-t-deg term)
  (term-to-t-deg-aux term '()))

(define (synt-total? term)
  (t-deg-one? (term-to-t-deg term)))

; Initially we don't know what numerals look like
(define is-numeric-term? (lambda (term) #f))

(define numeric-term-to-number 
  (lambda (term) (myerror "numeric-term-no-number"
			  "This function has to be supplied by the user")))
		  
(define DISPLAY-FUNCTIONS '())
(define INITIAL-DISPLAY-FUNCTIONS DISPLAY-FUNCTIONS)

(define (add-display type proc)
  (set! DISPLAY-FUNCTIONS
	(cons (list type proc) DISPLAY-FUNCTIONS)))

(define (add-display-end type proc)
  (set! DISPLAY-FUNCTIONS
	(append DISPLAY-FUNCTIONS (list (list type proc)))))

(define (term-to-token-tree term)
  (if
   (is-numeric-term? term)
   (make-token-tree 'number (numeric-term-to-number term))
   (let ((type (term-to-type term)))
     (do ((l DISPLAY-FUNCTIONS (cdr l))
	  (res #f (let* ((item (car l))
			 (pattern (car item)))
		    (if (type-match pattern type)
			((cadr item) term)
			#f))))
	 ((or res (null? l))
	  (cond
	   (res res)
	   ((term-in-symbolic-app-form? term)
	    (let ((op (term-in-symbolic-app-form-to-op term))
		  (arg (term-in-symbolic-app-form-to-arg term)))
	      (if
	       (term-in-symbolic-app-form? op)
	       (let ((opop (term-in-symbolic-app-form-to-op op))
		     (oparg (term-in-symbolic-app-form-to-arg op)))
		 (if
		  (and
		   (term-in-const-form? opop)
		   (string=? "cId" (const-to-name
				    (term-in-const-form-to-const opop)))
		   (term-in-abst-form? oparg))
		  (let ((var (term-in-abst-form-to-var oparg))
			(kernel (term-in-abst-form-to-kernel oparg)))
		    (make-token-tree 'if-op "let"
				     (term-to-token-tree
				      (make-term-in-var-form var))
				     (term-to-token-tree arg)
				     (term-to-token-tree kernel)))
		  (make-token-tree 'appterm ""
				   (term-to-token-tree op)
				   (term-to-token-tree arg))))
	       (make-token-tree 'appterm ""
				(term-to-token-tree op)
				(term-to-token-tree arg)))))
	   (else (default-term-to-token-tree term))))))))

(define (default-term-to-token-tree term)
  (case (tag term)
    ((term-in-var-form)
     (make-token-tree 'var (term-in-var-form-to-string term)))
    ((term-in-const-form)
     (make-token-tree 'const (term-in-const-form-to-string term))) ;unfold?
    ((term-in-abst-form)
     (make-token-tree
      'binding-op (var-to-string (term-in-abst-form-to-var term))
      (term-to-token-tree (term-in-abst-form-to-kernel term))))
    ((term-in-app-form)
     (make-token-tree
      'appterm ""
      (term-to-token-tree (term-in-app-form-to-op term))
      (term-to-token-tree (term-in-app-form-to-arg term))))
    ((term-in-pair-form)
     (make-token-tree
      'pair-op "@"
      (term-to-token-tree (term-in-pair-form-to-left term))
      (term-to-token-tree (term-in-pair-form-to-right term))))
    ((term-in-lcomp-form)
     (make-token-tree
      'prefix-op "left"
      (term-to-token-tree (term-in-lcomp-form-to-kernel term))))
    ((term-in-rcomp-form)
     (make-token-tree
      'prefix-op "right"
      (term-to-token-tree (term-in-rcomp-form-to-kernel term))))
    ((term-in-if-form)
     (apply make-token-tree
	    (append (list 'if-op "if"
			  (term-to-token-tree (term-in-if-form-to-test term)))
		    (map term-to-token-tree
			 (term-in-if-form-to-alts term)))))
    (else (myerror "default-term-to-token-tree" "term expected" term))))

(define (type-info-to-rec-string fst . rest)
  (let* ((param-types (if (number? fst) (list-head rest fst) '()))
	 (arrow-types (if (number? fst) (list-tail rest fst) (cons fst rest)))
	 (f (length param-types))
	 (type-strings (map type-to-string (append param-types arrow-types)))
	 (strings (if (zero? f) type-strings
		      (cons (number-to-string f) type-strings)))
	 (strings-with-sep (map (lambda (x) (string-append " " x)) strings)))
    (apply string-append
	   (append (list "(" "Rec") strings-with-sep (list ")")))))

(define (term-in-const-form-to-string term)
  (let* ((const (term-in-const-form-to-const term))
	 (name (const-to-name const))
	 (tvars (const-to-tvars const))
	 (tsubst (const-to-tsubst const)))
    (cond
     ((string=? "Rec" name)
      (apply type-info-to-rec-string
	     (const-to-type-info-or-repro-formulas const)))
     ((string=? "Cases" name)
      (let* ((param-types (cases-const-to-param-types const))
             (f (length param-types))
             (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))
             (alg-type (list-ref arg-types f))
             (uninst-arrow-type (make-arrow alg-type val-type))
             (subst-arrow-type (type-substitute uninst-arrow-type tsubst))
             (type-strings (map type-to-string
                                (append param-types (list subst-arrow-type))))
             (strings-with-sep
              (map (lambda (x) (string-append " " x)) type-strings)))
        (apply string-append (append (list "(" name)
                                     strings-with-sep
                                     (list ")")))))
     ((string=? "GRecGuard" name)
      (let* ((param-types (grecguard-const-to-param-types const))
             (f (length param-types))
             (type (const-to-type 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))
             (gind-type? (grecguard-const-for-gind? const))
             (val-type (arrow-form-to-final-val-type
                        type (+ f m (if gind-type? 4 3))))
             (type-strings
              (map type-to-string
                   (append param-types arg-types (list val-type))))
             (strings (if (or (< 0 f) gind-type?)
                          (cons (number-to-string f) type-strings)
                          type-strings))
             (strings-with-sep
              (map (lambda (x) (string-append " " x)) strings)))
        (apply string-append (append (list "(" name)
                                     strings-with-sep
                                     (list ")")))))
     ((string=? "GRec" name)
      (let* ((type (const-to-type const))
             (measure-type
              (arrow-form-to-arg-type type))
             (arg-types (arrow-form-to-arg-types measure-type))
             (m (length arg-types))
             (val-type (arrow-form-to-final-val-type type (+ m 2)))
             (strings
              (map type-to-string
                   (append arg-types (list val-type))))
             (strings-with-sep
              (map (lambda (x) (string-append " " x)) strings)))
        (apply string-append (append (list "(" name)
                                     strings-with-sep
                                     (list ")")))))
     ((string=? "SE" name) name)
     (else
      (if
       (null? tvars)
       name
       (let* ((types (map (lambda (x) (type-substitute x tsubst)) tvars))
	      (strings (map type-to-string types))
	      (strings1 (if (< 1 (length strings))
			    (map (lambda (x)
				   (if (memq #\space (string->list x))
				       (string-append "(" x ")")
				       x))
				 strings)
			    strings))
	      (strings-with-sep
	       (map (lambda (string) (string-append " " string)) 
		    strings1)))
	 (apply string-append (append (list "(" name)
				      strings-with-sep
				      (list ")")))))))))

; term-to-expr aims at producing a readable scheme expression that can
; be evaluated.  It transforms an application of a program constant c
; to args, where c has a corresponding built-in Scheme operator
; written in uncurried form with (length args) many arguments, into
; the corresponding Scheme expression.  Example: ((NatLe r1) r2) is
; transformed into (<= e1 e2).  If however c is applied to fewer
; arguments, then the default translation of c is used.  Example:
; (NatLe r1) is transformed into (|NatLe| e1).  To run this expression
; one needs to define the default translation of c on the Scheme
; level, in curried form.  Example: (define |NatLe| (lambda (x)
; (lambda (y) (<= x y)))).  For the usual built-in operators this can
; be done globally.  For constants occurring in a special example it
; must be done locally.  Example: in the gcd example we have the Step
; function.  The general term-to-expr produces (by default) |Step|,
; and then in gcd.scm |Step| needs to be defined on the Scheme level.
; By default |Step| is treated as a curried function.  However, with
; an optional argument '("Step" 4) in term-to-expr one can enforce
; that |Step| is treated as a function with four arguments.

; Equality with name "=" requires a special treatment: if there are
; exactly two arguments, it is transformed into an =-expression if the
; type of = refers to a number type (nat, pos, int or rat), and to an
; equal?-expression otherwise.  If it is applied to fewer arguments,
; then one needs FinAlg= as a special default name, since the internal
; name = cannot be used.

; In term-to-expr, terms in numeric form wrt either pos or nat are
; both displayed as the corresponding number.  Therefore both
; is-numeric-term-wrt-pos? and is-numeric-term-wrt-nat? have been
; moved here, and similarly numeric-term-wrt-pos-to-number and
; numeric-term-wrt-nat-to-number.

(define (term-to-expr term . opt-name-arity-alist)
  (let* ((names (map car opt-name-arity-alist))
	 (arities (map cadr opt-name-arity-alist)))
    (cond
     ((term-in-var-form? term)
      (string->symbol (term-in-var-form-to-string term)))
     ((is-numeric-term-wrt-pos? term)
      (numeric-term-wrt-pos-to-number term))
     ((is-numeric-term-wrt-nat? term)
      (numeric-term-wrt-nat-to-number term))
     ((is-int-numeric-term? term)
      (int-numeric-term-to-number term))
     ((is-rat-numeric-term? term)
      (rat-numeric-term-to-number term))
     ((term-in-const-form? (term-in-app-form-to-final-op term))
      (let* ((op (term-in-app-form-to-final-op term))
	     (args (term-in-app-form-to-args term))
	     (const (term-in-const-form-to-const op))
	     (name (const-to-name const))
	     (l (length args))
	     (prevs (map (lambda (term)
			   (apply term-to-expr
				  (cons term opt-name-arity-alist)))
			 args))
	     (info (assoc name opt-name-arity-alist))
	     (arity (if info (cadr info))))
	(cond
	 ((and info (<= arity l)) ;opt-name-arity-alist overrides everything
	  (non-null-list-to-app-expr
	   (cons (if (zero? arity) (string->symbol name)
		     (cons (string->symbol name) (list-head prevs arity)))
		 (list-tail prevs arity))))
	 ((string=? name "=")
	  (let* ((finalg (arrow-form-to-arg-type (const-to-type const)))
		 (finalg-name (alg-form-to-name finalg)))
	    (if (= l 2)
		(if (member finalg-name '("nat" "pos" "int" "rat"))
		    (cons '= prevs)
		    (cons 'equal? prevs))
		(let ((symbol
		       (string->symbol (string-append finalg-name "="))))
		  (non-null-list-to-app-expr (cons symbol prevs))))))
	 ((member name (list "RatPlus" "IntPlus" "PosPlus" "NatPlus"))
	  (if (= l 2)
	      (cons '+ prevs)
	      (non-null-list-to-app-expr (cons (string->symbol name) prevs))))
	 ((member name (list "RatMinus" "IntMinus" "PosMinus" "NatMinus"))
	  (if (= l 2)
	      (cons '- prevs)
	      (non-null-list-to-app-expr (cons (string->symbol name) prevs))))
	 ((member name (list "RatTimes" "IntTimes" "PosTimes" "NatTimes"))
	  (if (= l 2)
	      (cons '* prevs)
	      (non-null-list-to-app-expr (cons (string->symbol name) prevs))))
	 ((string=? name "RatDiv")
	  (if (= l 2)
	      (cons '/ prevs)
	      (non-null-list-to-app-expr (cons (string->symbol name) prevs))))
	 ((member name (list "RatLe" "IntLe" "PosLe" "NatLe"))
	  (if (= l 2)
	      (cons '<= prevs)
	      (non-null-list-to-app-expr (cons (string->symbol name) prevs))))
	 ((member name (list "RatLt" "IntLt" "PosLt" "NatLt"))
	  (if (= l 2)
	      (cons '< prevs)
	      (non-null-list-to-app-expr (cons (string->symbol name) prevs))))
	 ((member name (list "S" "Succ" "IntS"))
	  (if (= l 1) (list '+ (car prevs) 1) (string->symbol name)))
	 ((string=? name "SZero")
	  (if (= l 1) (list '* (car prevs) 2) (string->symbol name)))
	 ((string=? name "SOne")
	  (if (= l 1)
	      (list '+ (list '* (car prevs) 2) 1)
	      (string->symbol name)))
	 ((string=? name "cId")
	  (cond ((and (term-in-abst-form? (car args)) (= l 2))
		 (let ((var (term-in-abst-form-to-var (car args)))
		       (kernel (term-in-abst-form-to-kernel (car args))))
		   (list 'let
			 (list (list (string->symbol (var-to-string var))
				     (cadr prevs)))
			 (apply term-to-expr
				(cons kernel opt-name-arity-alist)))))
		((= l 1) (car prevs))
		(else (string->symbol name))))
	 ((string=? name "IntNeg")
	  (if (= l 1) (list '- (car prevs)) (string->symbol name)))
	 ((string=? name "NegConst")
	  (if (= l 1) (list 'not (car prevs)) (string->symbol name)))
	 ((string=? name "IntPos")
	  (if (= l 1) (car prevs) (string->symbol name)))
	 ((string=? name "Quot")
	  (if (= l 2)
	      (cons 'quotient-safe prevs)
	      (non-null-list-to-app-expr (cons (string->symbol name) prevs))))
	 ((string=? name "Rem")
	  (if (= l 2)
	      (cons 'modulo-safe prevs)
	      (non-null-list-to-app-expr (cons (string->symbol name) prevs))))
	 ((member name (list "Zero" "IntZero")) 0)
	 ((string=? name "False") #f)
	 ((string=? name "True") #t)
	 ((string=? name "One") 1)
	 ((string=? name "Nil") (list 'quote '()))
	 ((string=? name "Cons")
	  (if (= l 2)
	      (cons 'cons prevs)
	      (non-null-list-to-app-expr (cons 'cons-curried prevs))))
	 ((string=? name "Rec")
	  (let* ((uninst-arrow-types (rec-const-to-uninst-arrow-types const))
		 (alg (if (= 1 (length uninst-arrow-types))
			  (arrow-form-to-arg-type (car uninst-arrow-types))
			  (myerror "term-to-expr" "unknown recursion" term)))
		 (type-name (alg-form-to-name alg))
		 (param-types (rec-const-to-param-types const))
		 (p (length param-types))
		 (rec-symbol
		  (if (zero? p)
		      (string->symbol (string-append type-name "rec"))
		      (string->symbol (string-append type-name "recparam")))))
	    (non-null-list-to-app-expr (cons rec-symbol (list-tail prevs p)))))
	 ((string=? name "GRecGuard")
	  (let* ((type (const-to-type const))
		 (param-types (grecguard-const-to-param-types const))
		 (f (length param-types))
		 (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))
		 (grecguard-symbol
		  (string->symbol
		   (apply string-append
			  (append (map type-to-string arg-types)
				  (list "grecguard"))))))
	    (non-null-list-to-app-expr (cons grecguard-symbol prevs))))
	 (else
	  (non-null-list-to-app-expr (cons (string->symbol name) prevs))))))
     ((term-in-app-form? term)
      (let ((op (term-in-app-form-to-op term))
	    (arg (term-in-app-form-to-arg term)))
	(list (apply term-to-expr (cons op opt-name-arity-alist))
	      (apply term-to-expr (cons arg opt-name-arity-alist)))))
     ((term-in-abst-form? term)
      (list 'lambda
	    (list (string->symbol
		   (var-to-string (term-in-abst-form-to-var term))))
	    (apply term-to-expr
		   (cons (term-in-abst-form-to-kernel term)
			 opt-name-arity-alist))))
     ((term-in-pair-form? term)
      (let ((left (term-in-pair-form-to-left term))
	    (right (term-in-pair-form-to-right term)))
	(list 'cons
	      (apply term-to-expr (cons left opt-name-arity-alist))
	      (apply term-to-expr (cons right opt-name-arity-alist)))))
     ((term-in-lcomp-form? term)
      (list 'car (apply term-to-expr
			(cons (term-in-lcomp-form-to-kernel term)
			      opt-name-arity-alist))))
     ((term-in-rcomp-form? term)
      (list 'cdr (apply term-to-expr
			(cons (term-in-rcomp-form-to-kernel term)
			      opt-name-arity-alist))))
     ((term-in-if-form? term)
      (let* ((test (term-in-if-form-to-test term))
	     (alts (term-in-if-form-to-alts term))
	     (type (term-to-type test))
	     (test-expr (apply term-to-expr (cons test opt-name-arity-alist)))
	     (alt-exprs (map (lambda (term)
			       (apply term-to-expr
				      (cons term opt-name-arity-alist)))
			     alts)))
	(cond
	 ((and (alg-form? type) (string=? (alg-form-to-name type) "boole"))
	  (append (list 'if test-expr) alt-exprs))
	 ((and (alg-form? type) (string=? (alg-form-to-name type) "pos"))
	  (list 'cond
		(list (list '= '1 test-expr) (car alt-exprs))
		(list (list 'even? test-expr)
		      (remove-vacuous-beta-redex
		       (list (cadr alt-exprs)
			     (list 'quotient test-expr 2))))
		(list (list 'odd? test-expr)
		      (remove-vacuous-beta-redex
		       (list (caddr alt-exprs)
			     (list 'quotient test-expr 2))))))
	 ((and (alg-form? type) (string=? (alg-form-to-name type) "int"))
	  (list 'cond
		(list (list 'positive? test-expr)
		      (remove-vacuous-beta-redex
		       (list (car alt-exprs) test-expr)))
		(list (list 'zero? test-expr)
		      (remove-vacuous-beta-redex
		       (cadr alt-exprs)))
		(list (list 'negative? test-expr)
		      (remove-vacuous-beta-redex
		       (list (caddr alt-exprs) (list '- test-expr))))))
	 ((and (alg-form? type) (string=? (alg-form-to-name type) "nat"))
	  (list 'cond
		(list (list 'zero? test-expr)
		      (remove-vacuous-beta-redex
		       (car alt-exprs)))
		(list (list 'positive? test-expr)
		      (remove-vacuous-beta-redex
		       (list (cadr alt-exprs) (list '- test-expr 1))))))
	 ((and (alg-form? type) (string=? (alg-form-to-name type) "list"))
	  (let* ((car-of-test-expr (if (pair? test-expr)
				       (car test-expr)
				       (list 'car test-expr)))
		 (cdr-of-test-expr (if (pair? test-expr)
				       (cdr test-expr)
				       (list 'cdr test-expr))))
	    (list 'if (list 'null? test-expr) (car alt-exprs)
		  (remove-vacuous-beta-redex
		   (list (remove-vacuous-beta-redex
			  (list (cadr alt-exprs) car-of-test-expr))
			 cdr-of-test-expr)))))
	 (else (myerror "term-to-expr" "unknown if" term)))))
     (else (myerror "term-to-expr" "unknown tag" (tag term))))))

(define (modulo-safe x y)
  (if (= y 0)
      0
      (modulo x y)))

(define (quotient-safe x y)
  (if (= y 0)
      0
      (quotient x y)))

(define (is-numeric-term-wrt-pos? term)
  (or
   (and (term-in-const-form? term)
	(string=? "IntZero"
		  (const-to-name (term-in-const-form-to-const term))))
   (and (term-in-const-form? term)
	(string=? "One" (const-to-name (term-in-const-form-to-const term))))
   (and (term-in-app-form? term)
	(let ((op (term-in-app-form-to-op term))
	      (arg (term-in-app-form-to-arg term)))
	  (and (term-in-const-form? op)
	       (let ((name (const-to-name (term-in-const-form-to-const op))))
		 (or (and (string=? "SZero" name)
			  (is-numeric-term-wrt-pos? arg))
		     (and (string=? "SOne" name)
			  (is-numeric-term-wrt-pos? arg)))))))))

(define (numeric-term-wrt-pos-to-number term)
  (cond
   ((and (term-in-const-form? term)
	 (string=? "IntZero" (const-to-name
			      (term-in-const-form-to-const term))))
    0)
   ((and (term-in-const-form? term)
	 (string=? "One" (const-to-name
			  (term-in-const-form-to-const term))))
    1)
   ((term-in-app-form? term)
    (let ((op (term-in-app-form-to-op term))
	  (arg (term-in-app-form-to-arg term)))
      (if
       (term-in-const-form? op)
       (let ((name (const-to-name (term-in-const-form-to-const op))))
	 (cond
	  ((string=? "SZero" name)
	   (* 2 (numeric-term-wrt-pos-to-number arg)))
	  ((string=? "SOne" name)
	   (+ 1 (* 2 (numeric-term-wrt-pos-to-number arg))))
	  (else (myerror "numeric-term-wrt-pos-to-number" "unexpected term"
			 term))))
       (myerror "numeric-term-wrt-pos-to-number" "unexpected term" term))))
   (else (myerror "numeric-term-wrt-pos-to-number" "unexpected term" term))))

(define (is-numeric-term-wrt-nat? term)
  (or
   (and (term-in-const-form? term)
	(string=? "Zero" (const-to-name (term-in-const-form-to-const term))))
   (and (term-in-app-form? term)
	(let ((op (term-in-app-form-to-op term)))
	  (and (term-in-const-form? op)
	       (string=? "Succ" (const-to-name
				 (term-in-const-form-to-const op)))
	       (is-numeric-term-wrt-nat? (term-in-app-form-to-arg term)))))))

(define (numeric-term-wrt-nat-to-number term)
  (if (equal? term (pt "Zero"))
      0
      (+ 1 (numeric-term-wrt-nat-to-number (term-in-app-form-to-arg term)))))

(define (is-int-numeric-term? term)
  (or
   (and
    (term-in-const-form? term)
    (string=? "IntZero" (const-to-name
			 (term-in-const-form-to-const term))))
   (and
    (term-in-app-form? term)
    (let ((op (term-in-app-form-to-op term))
	  (arg (term-in-app-form-to-arg term)))
      (and (term-in-const-form? op)
	   (let ((name (const-to-name (term-in-const-form-to-const op))))
	     (or (and (string=? name "IntPos")
		      (is-numeric-term-wrt-pos? arg))
		 (and (string=? name "IntNeg")
		      (is-numeric-term-wrt-pos? arg)))))))))

(define (int-numeric-term-to-number term)
  (cond
   ((and (term-in-const-form? term)
	 (string=? "IntZero" (const-to-name
			      (term-in-const-form-to-const term))))
    0)
   ((term-in-app-form? term)
    (let ((op (term-in-app-form-to-op term))
	  (arg (term-in-app-form-to-arg term)))
      (if (term-in-const-form? op)
	  (let ((name (const-to-name (term-in-const-form-to-const op))))
	    (cond
	     ((string=? name "IntPos") (numeric-term-to-number arg))
	     ((string=? name "IntNeg") (- (numeric-term-to-number arg)))
	     (else (myerror "int-numeric-term-to-number"
			    "int numeric term expected"
			    term))))
	  (myerror "int-numeric-term-to-number" "int numeric term expected"
		   term))))
   (else (myerror "int-numeric-term-to-number" "int numeric term expected"
		  term))))

(define (is-rat-numeric-term? term)
  (and (term-in-app-form? term)
       (let ((op (term-in-app-form-to-final-op term))
	     (args (term-in-app-form-to-args term)))
	 (and (term-in-const-form? op)
	      (string=? "RatConstr"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args))
	      (let ((arg1 (car args))
		    (arg2 (cadr args)))
		(and (is-int-numeric-term? arg1)
		     (is-pos-numeric-term? arg2)))))))

(define (rat-numeric-term-to-number term)
  (let* ((args (term-in-app-form-to-args term))
	 (k (numeric-term-to-number (cadr args)))
	 (i (int-numeric-term-to-number (car args))))
    (/ i k)))

(define (remove-vacuous-beta-redex expr)
  (if (and (pair? expr)
	   (pair? (car expr))
	   (eq? 'lambda (caar expr))
	   (pair? (cadr (car expr)))
	   (not (member (car (cadr (car expr)))
			(expr-to-free (caddr (car expr))))))
      (caddr (car expr))
      expr))

(define (expr-to-free expr)
  (cond
   ((number? expr) '())
   ((boolean? expr) '())
   ((symbol? expr) (if (memq expr '(+ - * / <= <)) '() (list expr)))
   ((pair? expr)
    (case (car expr)
      ((lambda) (let ((var (caadr expr))
		      (kernel (caddr expr)))
		  (remove-wrt eq? var (expr-to-free kernel))))
      ((cons) (union (expr-to-free (cadr expr)) (expr-to-free (caddr expr))))
      ((car cdr) (expr-to-free (cadr expr)))
      ((if) (union (expr-to-free (cadr expr)) (expr-to-free (caddr expr))
		   (expr-to-free (cadddr expr))))
      ((let) (let* ((alist (cadr expr))
		    (kernel (caddr expr))
		    (bound-vars (map car alist))
		    (assigned-exprs (map cadr alist)))
	       (apply union (cons (set-minus (expr-to-free kernel) bound-vars)
				  (map expr-to-free assigned-exprs)))))
      ((cond) (let* ((conds (map car (cdr expr)))
		     (clauses (map cadr (cdr expr))))
		(apply union (map expr-to-free (append conds clauses)))))
      ((quote) '())
      (else (apply union (map expr-to-free expr)))))
   (else (myerror "expr-to-free" "unknown expr" expr))))

; Here we assume that the keywords are among lambda cons car cdr if
; let cond

(define |cId| (lambda (x) x))

(define |AndConst| (lambda (p) (lambda (q) (and p q))))
(define |ImpConst| (lambda (p) (lambda (q) (or (not p) q))))
(define |OrConst| (lambda (p) (lambda (q) (or p q))))
(define |NegConst| (lambda (p) (not p)))

(define |NatPlus| (lambda (x) (lambda (y) (+ x y))))
(define |PosPlus| (lambda (x) (lambda (y) (+ x y))))
(define |IntPlus| (lambda (x) (lambda (y) (+ x y))))
(define |RatPlus| (lambda (x) (lambda (y) (+ x y))))

(define |NatMinus| (lambda (x) (lambda (y) (- x y))))
(define |PosMinus| (lambda (x) (lambda (y) (- x y))))
(define |IntMinus| (lambda (x) (lambda (y) (- x y))))
(define |RatMinus| (lambda (x) (lambda (y) (- x y))))

(define |NatTimes| (lambda (x) (lambda (y) (* x y))))
(define |PosTimes| (lambda (x) (lambda (y) (* x y))))
(define |IntTimes| (lambda (x) (lambda (y) (* x y))))
(define |RatTimes| (lambda (x) (lambda (y) (* x y))))

(define |RatDiv| (lambda (x) (lambda (y) (/ x y))))

(define |NatLe| (lambda (x) (lambda (y) (<= x y))))
(define |PosLe| (lambda (x) (lambda (y) (<= x y))))
(define |IntLe| (lambda (x) (lambda (y) (<= x y))))
(define |RatLe| (lambda (x) (lambda (y) (<= x y))))

(define |NatLt| (lambda (x) (lambda (y) (< x y))))
(define |PosLt| (lambda (x) (lambda (y) (< x y))))
(define |IntLt| (lambda (x) (lambda (y) (< x y))))
(define |RatLt| (lambda (x) (lambda (y) (< x y))))

(define |S| (lambda (x) (+ x 1)))
(define |Succ| (lambda (x) (+ x 1)))
(define |IntS| (lambda (x) (+ x 1)))

(define |SZero| (lambda (x) (* x 2)))
(define |SOne| (lambda (x) (+ (* x 2) 1)))

(define |IntNeg| (lambda (x) (- x)))
(define |IntPos| (lambda (x) x))

(define |IntToNat| (lambda (x) (if (negative? x) (- x) x)))

(define |PosPred| (lambda (x) (if (= 1 x) 1 (- x 1))))

(define |cDC|
  (lambda (init)
    (lambda (step)
      (lambda (n)
	(if (= 1 n)
	    init
	    ((step n) (((|cDC| init) step) (- n 1))))))))

(define (posrec n)
  (lambda (init)
    (lambda (step0) 
      (lambda (step1)
	(if (= 1 n)
	    init
	    (if (even? n)
		((step0 (/ n 2))
		 ((((posrec (/ n 2)) init) step0) step1))
		((step1 (/ (- n 1) 2))
		 ((((posrec (/ (- n 1) 2)) init) step0) step1))))))))

(define (posrecparam p) (curry posrec (+ p 1)))

(define (natrec n) 
  (lambda (init)
    (lambda (step)
      (if (= 0 n)
	  init
	  ((step (- n 1)) (((natrec (- n 1)) init) step))))))

(define (natrecparam p) (curry natrec (+ p 1)))

(define (natgrecguard h)
  (lambda (x)
    (lambda (G)
      (lambda (p)
	(if (equal? #t p)
	    ((G x) (lambda (y)
		     ((((natgrecguard h) y) G) (< (h y) (h x)))))
	    0)))))

(define (natnatgrecguard h)
  (lambda (x1)
    (lambda (x2)
      (lambda (G)
	(lambda (p)
	  (if (equal? #t p)
	      (((G x1) x2)
	       (lambda (y1)
		 (lambda (y2)
		   (((((natnatgrecguard h) y1) y2) G)
		    (< ((h y1) y2) ((h x1) x2))))))
	      0))))))

(define |ListLength| (lambda (l) (length l)))

(define (listrec l) 
  (lambda (init)
    (lambda (step)
      (if (null? l)
	  init
	  (let ((h (car l))
		(t (cdr l)))
	    (((step h) t) (((listrec t) init) step)))))))

(define (display-term term) (display (term-to-string term)))
(define dt display-term)

(define (composed? term)
  (and
   (not (is-numeric-term? term))
   (or
    (term-in-abst-form? term)
    (term-in-pair-form? term)
    (term-in-lcomp-form? term)
    (term-in-rcomp-form? term)
    (and
     (term-in-app-form? term)
     (let ((op (term-in-app-form-to-final-op term))
	   (args (term-in-app-form-to-args term)))
       (not (and (term-in-const-form? op)
		 (string=? "RealConstr"
			   (const-to-name (term-in-const-form-to-const op)))
		 (= 2 (length args))
		 (term-in-abst-form? (car args))
		 (not (member (term-in-abst-form-to-var (car args))
			      (term-to-free
			       (term-in-abst-form-to-kernel (car args)))))
		 (not (composed?
		       (term-in-abst-form-to-kernel (car args)))))))))))

(define (term-list-to-string term-list)
  (if (null? term-list)
      "()"
      (do ((l (cdr term-list) (cdr l))
	   (res (term-to-string (car term-list))
		(string-append res ", " (term-to-string (car l)))))
	  ((null? l) (string-append "(" res ")")))))
	    

; 6-2. Normalization by evaluation
; ================================

; An object consists of a semantical value and a type.  

(define (nbe-make-object type value) (list 'obj type value))
(define nbe-object-to-type cadr)
(define nbe-object-to-value caddr)
(define (nbe-object? x) (and (list? x) (not (null? x)) (eq? 'obj (car x))))

; To work with objects, we need

(define (nbe-object-apply function-obj arg-obj)
  ((nbe-object-to-value function-obj) arg-obj))

(define (nbe-object-app function-obj . arg-objs)
  (if (null? arg-objs)
      function-obj
      (apply nbe-object-app
	     (cons (nbe-object-apply function-obj (car arg-objs))
		   (cdr arg-objs)))))

(define (nbe-object-compose obj1 obj2)
  (let* ((type1 (nbe-object-to-type obj1))
	 (type2 (nbe-object-to-type obj2))
	 (valtype1 (arrow-form-to-val-type type1))
	 (argtypes2 (arrow-form-to-arg-types type2))
	 (l (length argtypes2))
	 (type (apply mk-arrow (append argtypes2 (list valtype1)))))
    (if (zero? l)
	(nbe-object-app obj1 obj2)
	(nbe-make-object
	 type
	 (nbe-curry
	  (lambda arg-objs
	    (nbe-object-app
	     obj1
	     (apply (nbe-uncurry (nbe-object-to-value obj2) l) arg-objs)))
	  type
	  l)))))

(define (nbe-object-car pair-object)
  (car (nbe-object-to-value pair-object)))

(define (nbe-object-cdr pair-object)
  (cdr (nbe-object-to-value pair-object)))

; For ground type values we need constructors, accessors and tests:

; To make constructors `self-evaluating', a constructor value has the form
; ('constr-value name objs delayed-constr), where delayed-constr is a
; procedure of zero arguments which evaluates to this very same constructor.
; This is necessary to avoid having a cycle (for nullary constructors, and
; only for those).

(define (nbe-make-constr-value name objs . delayed-constr)
  ;delayed-constr is either present - in which case it is reproduced - 
  ;or not present - in which case it is computed (only once, thanks to 
  ;eval-once), via (constr-name-to-constr name).
  (let ((new-delayed-constr (if (null? delayed-constr)
				(eval-once
				 (lambda () (constr-name-to-constr name)))
				(car delayed-constr))))
    (list 'constr-value name objs new-delayed-constr)))

(define nbe-constr-value-to-name cadr)
(define nbe-constr-value-to-args caddr)
(define (nbe-constr-value-to-constr x) ((cadddr x)))

(define (nbe-constr-value? value)
  (and (pair? value) (eq? 'constr-value (car value))))

; One might define nbe-constr-value-to-name here as follows.  However,
; for systematic reasons this is better done locally.

; (define (nbe-constr-value-to-name constr-value)
;   (const-to-name (nbe-constr-value-to-constr constr-value)))

(define (nbe-fam-value? x)
  (and (pair? x) (eq? 'termfam (tag x))))

; To work with term families we need

(define (nbe-make-termfam type proc)
  (list 'termfam type proc))

(define nbe-termfam-to-type cadr)
(define nbe-termfam-to-proc caddr)

(define (nbe-fam-apply termfam k)
  ((nbe-termfam-to-proc termfam) k))

(define (nbe-term-to-termfam term)
  (case (tag term)
    ((term-in-var-form term-in-const-form)
     (nbe-make-termfam (term-to-type term) (lambda (k) term)))
    ((term-in-abst-form)
     (let* ((var (term-in-abst-form-to-var term))
	    (type (var-to-type var))
	    (kernel (term-in-abst-form-to-kernel term)))
       (nbe-make-termfam
	(term-to-type term)
	(lambda (k)
	  (let ((var-k (make-var type k (var-to-t-deg var) (var-to-name var))))
	    (make-term-in-abst-form
	     var-k
	     (nbe-fam-apply
	      (nbe-term-to-termfam
	       (term-subst kernel var (make-term-in-var-form var-k)))
	      (+ 1 k))))))))
    ((term-in-app-form)
     (let ((op (term-in-app-form-to-final-op term))
	   (args (term-in-app-form-to-args term)))
       (nbe-make-termfam
	(term-to-type term)
	(lambda (k)
	  (apply mk-term-in-app-form
		 (map (lambda (x) (nbe-fam-apply (nbe-term-to-termfam x) k))
		      (cons op args)))))))
    ((term-in-pair-form)
     (nbe-make-termfam
      (term-to-type term)
      (lambda (k)
	(make-term-in-pair-form
	 (nbe-fam-apply
	  (nbe-term-to-termfam (term-in-pair-form-to-left term)) k)
	 (nbe-fam-apply
	  (nbe-term-to-termfam (term-in-pair-form-to-right term)) k)))))
    ((term-in-lcomp-form)
     (nbe-make-termfam
      (term-to-type term)
      (lambda (k)
	(make-term-in-lcomp-form
	 (nbe-fam-apply
	  (nbe-term-to-termfam (term-in-lcomp-form-to-kernel term)) k)))))
    ((term-in-rcomp-form)
     (nbe-make-termfam
      (term-to-type term)
      (lambda (k)
	(make-term-in-rcomp-form
	 (nbe-fam-apply
	  (nbe-term-to-termfam (term-in-rcomp-form-to-kernel term)) k)))))
    ((term-in-if-form)
     (let ((test (term-in-if-form-to-test term))
	   (alts (term-in-if-form-to-alts term))
	   (rest (term-in-if-form-to-rest term)))
       (nbe-make-termfam
	(term-to-type term)
	(lambda (k)
	  (apply
	   make-term-in-if-form
	   (cons (nbe-fam-apply (nbe-term-to-termfam test) k)
		 (cons (map (lambda (x)
			      (nbe-fam-apply (nbe-term-to-termfam x) k))
			    alts)
		       rest)))))))
    (else (myerror "nbe-term-to-termfam" "unexpected term" term))))

; nbe-reify takes an object and returns a term family

(define (nbe-reify obj)
  (let ((type (nbe-object-to-type obj))
	(value (nbe-object-to-value obj)))
    (case (tag type)
      ((alg) 
       (cond
	((nbe-constr-value? value)
	 (let ((args (nbe-constr-value-to-args value)))
	   (nbe-make-termfam
	    type
	    (lambda (k)
	      (apply mk-term-in-app-form
		     (cons (make-term-in-const-form
			    (nbe-constr-value-to-constr value))
			   (map (lambda (obj)
				  (nbe-fam-apply (nbe-reify obj) k))
				args)))))))
	((nbe-fam-value? value) value)
	(else (myerror "nbe-reify" "unexpected value" value
		       "for alg type" type))))
      ((tvar) (nbe-object-to-value obj))
      ((tconst)
       (if (string=? "existential" (tconst-to-name type))
	   (cond
	    ((nbe-constr-value? value)
	     (let ((args (nbe-constr-value-to-args value)))
	       (nbe-make-termfam
		type
		(lambda (k)
		  (apply mk-term-in-app-form
			 (cons (make-term-in-const-form
				(nbe-constr-value-to-constr value))
			       (map (lambda (obj)
				      (nbe-fam-apply (nbe-reify obj) k))
				    args)))))))
	    ((nbe-fam-value? value) value)
	    (else (myerror "nbe-reify" "unexpected value for type existential"
			   value)))
	   (nbe-object-to-value obj)))
      ((arrow)
       (let ((type1 (arrow-form-to-arg-type type)))
	 (nbe-make-termfam
	  type
	  (lambda (k)
	    (let ((var-k (make-var type1 k 1 (default-var-name type1))))
	      (make-term-in-abst-form
	       var-k (nbe-fam-apply
		      (nbe-reify
		       (nbe-object-apply
			obj
			(nbe-reflect (nbe-term-to-termfam
				      (make-term-in-var-form var-k)))))
		      (+ k 1))))))))
      ((star)
       (nbe-make-termfam
	type
	(lambda (k)
	  (make-term-in-pair-form
	   (nbe-fam-apply (nbe-reify (nbe-object-car obj)) k)
	   (nbe-fam-apply (nbe-reify (nbe-object-cdr obj)) k)))))
      (else (myerror "nbe-reify" "type expected" type)))))

; nbe-reflect takes a term family and returns an object

(define (nbe-reflect termfam)
  (let ((type (nbe-termfam-to-type termfam)))
    (case (tag type)
      ((tvar tconst alg) (nbe-make-object type termfam))
      ((arrow)
       (nbe-make-object
	type
	(lambda (obj)
	  (nbe-reflect (nbe-make-termfam
			(arrow-form-to-val-type type)
			 (lambda (k)
			   (make-term-in-app-form
			    (nbe-fam-apply termfam k)
			    (nbe-fam-apply (nbe-reify obj) k))))))))
      ((star)
       (nbe-make-object
	type
	(cons (nbe-reflect
	       (nbe-make-termfam
		(star-form-to-left-type type)
		(lambda (k)
		  (make-term-in-lcomp-form (nbe-fam-apply termfam k)))))
	      (nbe-reflect
	       (nbe-make-termfam
		(star-form-to-right-type type)
		(lambda (k)
		  (make-term-in-rcomp-form (nbe-fam-apply termfam k))))))))
      (else (myerror "nbe-reflect" "type expected" type)))))

; We now define nbe-term-to-object.  As a preparation we need some
; procedures dealing with bindings, i.e. association lists associating
; objects to variables.

(define (nbe-make-bindings vars objs)
  (map (lambda (x y) (list x y)) vars objs))

(define (nbe-apply-bindings bindings var)
  (let ((info (assoc var bindings)))
    (if info
	(cadr info)
	(myerror "nbe-apply-bindings" "not bound in bindings" var))))

(define (nbe-extend-bindings bindings var obj) (cons (list var obj) bindings))

(define (nbe-term-to-object term bindings)
  (case (tag term)
    ((term-in-var-form)
     (let* ((var (term-in-var-form-to-var term))
	    (info (assoc var bindings)))
       (if info
	   (cadr info)
	   (nbe-reflect (nbe-term-to-termfam term)))))
    ((term-in-const-form)
     (let ((const (term-in-const-form-to-const term)))
       (case (const-to-kind const)
	 ((constr fixed-rules) (const-to-object-or-arity const))
	 ((pconst) (pconst-name-and-tsubst-to-object
		    (const-to-name const)
		    (const-to-tsubst const)))
	 (else (myerror "nbe-term-to-object" "kind expected"
			(const-to-kind const))))))
    ((term-in-abst-form)
     (let ((var (term-in-abst-form-to-var term))
	   (kernel (term-in-abst-form-to-kernel term))
	   (type (term-to-type term)))
       (nbe-make-object type (lambda (obj)
			       (nbe-term-to-object
				kernel
				(nbe-extend-bindings bindings var obj))))))
    ((term-in-app-form)
     (let ((op (term-in-app-form-to-op term))
	   (arg (term-in-app-form-to-arg term)))
       (nbe-object-app (nbe-term-to-object op bindings)
		       (nbe-term-to-object arg bindings))))
    ((term-in-pair-form)
     (let ((left (term-in-pair-form-to-left term))
	   (right (term-in-pair-form-to-right term))
	   (type (term-to-type term)))
       (nbe-make-object type (cons (nbe-term-to-object left bindings)
				   (nbe-term-to-object right bindings)))))
    ((term-in-lcomp-form)
     (let ((kernel (term-in-lcomp-form-to-kernel term)))
       (nbe-object-car (nbe-term-to-object kernel bindings))))
    ((term-in-rcomp-form)
     (let ((kernel (term-in-lcomp-form-to-kernel term)))
       (nbe-object-cdr (nbe-term-to-object kernel bindings))))
    ((term-in-if-form)
     (let* ((test (term-in-if-form-to-test term))
	    (alts (term-in-if-form-to-alts term))
	    (rest (term-in-if-form-to-rest term))
	    (alg (term-to-type test))
	    (alg-name (alg-form-to-name alg))
	    (typed-constr-names (alg-name-to-typed-constr-names alg-name)))
       (cond
	((alts-from-constructors? alts typed-constr-names)
	 (nbe-term-to-object test bindings))
	((constant-alts? alts typed-constr-names)
	 (nbe-term-to-object
	  (constants-alts-to-const-term alts typed-constr-names)
	  bindings))
	(else
	 (let* ((testobj (nbe-term-to-object test bindings))
		(testval (nbe-object-to-value testobj)))
	   (if
	    (nbe-constr-value? testval)
	    (let* ((name (nbe-constr-value-to-name testval))
		   (args (nbe-constr-value-to-args testval))
		   (alg (term-to-type test))
		   (alg-name (alg-form-to-name alg))
		   (typed-constr-names
		    (alg-name-to-typed-constr-names alg-name))
		   (constr-names
		    (map typed-constr-name-to-name typed-constr-names))
		   (alt (do ((cs constr-names (cdr cs))
			     (as alts (cdr as))
			     (res #f (if (string=? (car cs) name)
					 (car as)
					 res)))
			    ((null? cs) res)))
		   (alt-obj (nbe-term-to-object alt bindings)))
	      (apply nbe-object-app (cons alt-obj args)))
	    (let* ((altobjs (map (lambda (x) (nbe-term-to-object x bindings))
				 alts))
		   (alt-termfams (map nbe-reify altobjs))
		   (norm-alts (map nbe-extract alt-termfams)))
	      (cond
	       ((alts-from-constructors? norm-alts typed-constr-names)
		(nbe-term-to-object test bindings))
	       ((constant-alts? norm-alts typed-constr-names)
		(nbe-term-to-object
		 (constants-alts-to-const-term norm-alts typed-constr-names)
		 bindings))
	       (else
		(nbe-reflect
		 (nbe-make-termfam
		  (term-to-type term)
		  (lambda (k)
		    (apply
		     make-term-in-if-form
		     (cons (nbe-fam-apply (nbe-reify testobj) k)
			   (cons (map (lambda (x) (nbe-fam-apply x k))
				      alt-termfams)
				 rest)))))))))))))))
    (else (myerror "nbe-term-to-object" "unexpected term" term))))

(define (alts-from-constructors? alts typed-constr-names)
  (equal? (map typed-constr-name-to-name typed-constr-names)
	  (map (lambda (alt)
		 (let* ((kernel-and-vars
			 (term-in-abst-form-to-kernel-and-vars alt))
			(kernel (car kernel-and-vars))
			(vars (cdr kernel-and-vars))
			(op (term-in-app-form-to-final-op kernel))
			(args (term-in-app-form-to-args kernel)))
		   (if (and (apply and-op (map term-in-var-form? args))
			    (equal? vars (map term-in-var-form-to-var args))
			    (term-in-const-form? op))
		       (const-to-name (term-in-const-form-to-const op))
		       "")))
	       alts)))

(define (constant-alts? alts typed-constr-names)
  (let* ((constr-types (map typed-constr-name-to-type typed-constr-names))
	 (arg-types-list (map arrow-form-to-arg-types constr-types))
	 (alt-kernels-or-false
	  (do ((l1 alts (cdr l1))
	       (l2 arg-types-list (cdr l2))
	       (res '() (let* ((alt (car l1))
			       (arg-types (car l2))
			       (kernel-and-vars
				(term-in-abst-form-to-kernel-and-vars alt))
			       (kernel (car kernel-and-vars))
			       (vars (cdr kernel-and-vars)))
			  (if (and res
				   (= (length arg-types) (length vars))
				   (null? (intersection
					   vars (term-to-free kernel))))
			      (cons kernel res)
			      #f))))
	      ((or (not res) (null? l1)) res))))
    (and alt-kernels-or-false ;and all alt-kernels are equal
	 (do ((l alt-kernels-or-false (cdr l))
	      (l1 (cdr alt-kernels-or-false) (cdr l1))
	      (res #t (and res (term=? (car l) (car l1)))))
	     ((or (not res) (null? l1)) res)))))

(define (constants-alts-to-const-term alts typed-constr-names)
  (let* ((typed-constr-name (typed-constr-name-to-name typed-constr-names))
	 (constr-type (typed-constr-name-to-type typed-constr-name))
	 (arg-types (arrow-form-to-arg-types constr-type))
	 (alt (car alts))
	 (kernel-and-vars (term-in-abst-form-to-kernel-and-vars alt)))
    (car kernel-and-vars)))

(define (nbe-constructor-pattern? term)
  (or (term-in-var-form? term)
      (and (ground-type? (term-to-type term))
	   (or (and (term-in-const-form? term)
		    (eq? 'constr (const-to-kind
				  (term-in-const-form-to-const term))))
	       (and (term-in-app-form? term)
		    (let ((op (term-in-app-form-to-final-op term))
			  (args (term-in-app-form-to-args term)))
		      (and (term-in-const-form? op)
			   (eq? 'constr (const-to-kind
					 (term-in-const-form-to-const op)))
			   (apply and-op (map nbe-constructor-pattern?
					      args)))))))))

(define (nbe-inst? constr-pattern obj)
  (case (tag constr-pattern)
    ((term-in-var-form) #t)
    ((term-in-const-form)
     (let ((const (term-in-const-form-to-const constr-pattern)))
       (and
	(eq? 'constr (const-to-kind const))
	(let ((value (nbe-object-to-value obj)))
	  (cond ((nbe-constr-value? value)
		 (string=? (const-to-name const)
			   (const-to-name (nbe-constr-value-to-constr value))))
		((nbe-fam-value? value) #f)
		(else (myerror "nbe-inst?" "value expected" value)))))))
    ((term-in-app-form)
     (let ((op (term-in-app-form-to-final-op constr-pattern))
	   (args (term-in-app-form-to-args constr-pattern)))
       (case (tag op)
	 ((term-in-const-form)
	  (let ((const (term-in-const-form-to-const op)))
	    (and
	     (eq? 'constr (const-to-kind const))
	     (let* ((value (nbe-object-to-value obj)))
	       (cond ((nbe-constr-value? value)
		      (let ((vargs (nbe-constr-value-to-args value)))
			(and (string=? (const-to-name const)
				       (const-to-name
					(nbe-constr-value-to-constr value)))
			     (= (length args) (length vargs))
			     (apply and-op (map nbe-inst? args vargs)))))
		     ((nbe-fam-value? value) #f)
		     (else (myerror "nbe-inst?" "value expected" value)))))))
	 (else (myerror "nbe-inst?" "constructor expected" op)))))
    (else
     (myerror "nbe-inst?" "constructor pattern expected" constr-pattern))))

(define (nbe-genargs constr-pattern obj)
  (case (tag constr-pattern)
    ((term-in-var-form) (list obj))
    ((term-in-const-form) '()) ;then of ground type
    ((term-in-app-form)
     (let* ((op (term-in-app-form-to-final-op constr-pattern))
	    (args1 (term-in-app-form-to-args constr-pattern))
	    (value (nbe-object-to-value obj)))
       (cond
	((and (term-in-const-form? op)
	      (eq? 'constr (const-to-kind (term-in-const-form-to-const op)))
	      (nbe-constr-value? value))
	 (let* ((constr1 (term-in-const-form-to-const op))
		(name1 (const-to-name constr1))
		(constr2 (nbe-constr-value-to-constr value))
		(name2 (const-to-name (nbe-constr-value-to-constr value)))
		(args2 (nbe-constr-value-to-args value)))
	   (if
	    (and
	     (string=? name1 name2)
	     (or
	      (not (string=? "Ex-Intro" name1))
	      (and
	       (formula=? (const-to-uninst-type constr1)
			  (const-to-uninst-type constr2))
	       (let ((subst1 (const-to-tsubst constr1))
		     (subst2 (const-to-tsubst constr2)))
		 (and
		  (substitution-equal?
		   (restrict-substitution-wrt subst1 tvar-form?)
		   (restrict-substitution-wrt subst2 tvar-form?))
		  (substitution-equal-wrt?
		   equal? classical-cterm=?
		   (restrict-substitution-wrt subst1 pvar?)
		   (restrict-substitution-wrt subst2  pvar?))))))
	     (= (length args1) (length args2)))
	    (apply append (map nbe-genargs args1 args2))
	    (myerror "nbe-genargs" "matching object expected"
		     constr-pattern))))
	(else (myerror "nbe-genargs" "same constructor kinds expected"
		       op value)))))
    (else (myerror "nbe-genargs" "constructor pattern expected"
		   constr-pattern))))

(define (nbe-extract termfam)
  (let* ((term (nbe-fam-apply termfam 0))
	 (free (term-to-free term))
	 (bound (term-to-bound term))
	 (k (do ((l (append free bound) (cdr l))
		 (res 0 (if (default-var? (car l))
			    (max res (+ 1 (var-to-index (car l))))
			    res)))
		((null? l) res))))
    (nbe-fam-apply termfam k)))

(define (nbe-normalize-term-without-eta term)
  (let* ((free (term-to-free term))
	 (index (+ 1 (max-index free)))
	 (objs (map (lambda (x) (nbe-reflect
				 (nbe-term-to-termfam
				  (make-term-in-var-form x)))) free)))
    (nbe-fam-apply
     (nbe-reify (nbe-term-to-object term (nbe-make-bindings free objs)))
     index)))

(define (term-to-eta-nf term) ;term in long normal form
  (case (tag term)
    ((term-in-app-form)
     (let ((op (term-in-app-form-to-op term))
	   (arg (term-in-app-form-to-arg term)))
       (make-term-in-app-form (term-to-eta-nf op) (term-to-eta-nf arg))))
    ((term-in-abst-form) 
     (let* ((var (term-in-abst-form-to-var term))
	    (kernel (term-in-abst-form-to-kernel term))
	    (prev (term-to-eta-nf kernel)))
       (cond
	((and ;[x]rx -> r, if x not free in r
	  (term-in-app-form? prev)
	  (term=? (term-in-app-form-to-arg prev)
		  (make-term-in-var-form var))
	  (not (member var (term-to-free
			    (term-in-app-form-to-op prev)))))
	 (term-in-app-form-to-op prev))
	(else (make-term-in-abst-form var prev)))))
    ((term-in-pair-form) 
     (let* ((left (term-in-pair-form-to-left term))
	    (right (term-in-pair-form-to-right term))
	    (prev-left (term-to-eta-nf left))
	    (prev-right (term-to-eta-nf right)))
       (cond
	((and ;(left r)@(right r) -> r
	  (term-in-lcomp-form? prev-left)
	  (term-in-rcomp-form? prev-right)
	  (term=? (term-in-lcomp-form-to-kernel prev-left)
		  (term-in-rcomp-form-to-kernel prev-right)))
	 (term-in-lcomp-form-to-kernel prev-left))
	((and ;[if t [ys,zs]r1 ..]@[if t [ys,zs]r2 ..] -> [if t [ys,zs]r1@r2..]
	  (term-in-if-form? prev-left)
	  (term-in-if-form? prev-right)
	  (term=? (term-in-if-form-to-test prev-left)
		  (term-in-if-form-to-test prev-right)))
	 (let* ((test (term-in-if-form-to-test prev-left))
		(alg (term-to-type test))
		(alg-name (alg-form-to-name alg))
		(typed-constr-names (alg-name-to-typed-constr-names alg-name))
		(constr-types
		 (map typed-constr-name-to-type typed-constr-names))
		(ls (map (lambda (x) (length (arrow-form-to-arg-types x)))
			 constr-types))
		(alts1 (term-in-if-form-to-alts prev-left))
		(rest1 (term-in-if-form-to-rest prev-left))
		(constr-arg-vars-list1
		 (map (lambda (alt l) (term-in-abst-form-to-vars alt l))
		      alts1 ls))
		(kernels1
		 (map (lambda (alt l)
			(term-in-abst-form-to-final-kernel alt l))
		      alts1 ls))
		(alts2 (term-in-if-form-to-alts prev-right))
		(rest2 (term-in-if-form-to-rest prev-right))
		(constr-arg-vars-list2
		 (map (lambda (alt l) (term-in-abst-form-to-vars alt l))
		      alts2 ls))
		(kernels2
		 (map (lambda (alt l)
			(term-in-abst-form-to-final-kernel alt l))
		      alts2 ls))
		(equal-constr-arg-vars?-list
		 (map (lambda (vars1 vars2) (equal? vars1 vars2))
		      constr-arg-vars-list1 constr-arg-vars-list2))
		(constr-arg-vars-list
		 (map (lambda (boole vars1 vars2)
			(if boole vars1 (map var-to-new-var vars2)))
		      equal-constr-arg-vars?-list
		      constr-arg-vars-list1 constr-arg-vars-list2))
		(pair-alts
		 (map (lambda (boole vars vars2 kernel1 kernel2)
			(apply
			 mk-term-in-abst-form
			 (append vars (list (make-term-in-pair-form
					     kernel1
					     (if boole
						 kernel2
						 (term-substitute
						  kernel2
						  (map (lambda (x y)
							 (list x y))
						       vars2 vars))))))))
		      equal-constr-arg-vars?-list
		      constr-arg-vars-list constr-arg-vars-list2
		      kernels1 kernels2))
		(pair-alts-nf (map term-to-eta-nf pair-alts)))
	   (make-term-in-if-form
	    test (map term-to-eta-nf pair-alts) (make-and rest1 rest2))))
	(else (make-term-in-pair-form prev-left prev-right)))))
    ((term-in-lcomp-form)
     (let ((prev (term-to-eta-nf (term-in-lcomp-form-to-kernel term))))
       (if (term-in-pair-form? prev)
	   (term-in-pair-form-to-left prev)
	   (make-term-in-lcomp-form prev))))
    ((term-in-rcomp-form)
     (let ((prev (term-to-eta-nf (term-in-rcomp-form-to-kernel term))))
       (if (term-in-pair-form? prev)
	   (term-in-pair-form-to-right prev)
	   (make-term-in-rcomp-form prev))))
    ((term-in-if-form)
     (let* ((test (term-in-if-form-to-test term))
	    (alts (term-in-if-form-to-alts term))
	    (rest (term-in-if-form-to-rest term))
	    (prev (term-to-eta-nf test))
	    (prevs (map term-to-eta-nf alts)))
       (apply make-term-in-if-form (cons prev (cons prevs rest)))))
    (else term)))

; Now: full normalization of terms including permutative conversions.
; In a preprocessing step, eta expand the alternatives of if-terms.
; The result contains if-terms with ground type alternatives only.
; Example: "[if boole ((nat=>nat)_1) ((nat=>nat)_2)]" is rewritten
; into "[n33][if boole ((nat=>nat)_1 n33) ((nat=>nat)_2 n33)]".

(define (term-to-term-with-eta-expanded-if-terms term)
  (case (tag term)
    ((term-in-var-form term-in-const-form)
     term)
    ((term-in-app-form)
     (let ((op (term-in-app-form-to-op term))
	   (arg (term-in-app-form-to-arg term)))
       (make-term-in-app-form (term-to-term-with-eta-expanded-if-terms op)
			      (term-to-term-with-eta-expanded-if-terms arg))))
    ((term-in-abst-form)
     (let ((var (term-in-abst-form-to-var term))
	   (kernel (term-in-abst-form-to-kernel term)))
       (make-term-in-abst-form
	var (term-to-term-with-eta-expanded-if-terms kernel))))
    ((term-in-pair-form)
     (let ((left (term-in-pair-form-to-left term))
	   (right (term-in-pair-form-to-right term)))
       (make-term-in-pair-form
	(term-to-term-with-eta-expanded-if-terms left)
	(term-to-term-with-eta-expanded-if-terms right))))
    ((term-in-lcomp-form)
     (make-term-in-lcomp-form
      (term-to-term-with-eta-expanded-if-terms
       (term-in-lcomp-form-to-kernel term))))
    ((term-in-rcomp-form)
     (make-term-in-rcomp-form
      (term-to-term-with-eta-expanded-if-terms
       (term-in-rcomp-form-to-kernel term))))
    ((term-in-if-form)
     (if-term-to-eta-expansion term))
    (else (myerror "term-to-term-with-eta-expanded-if-terms" "term expected"
		   term))))

; As an auxiliary function we have used:

(define (if-term-to-eta-expansion term)
  (let ((type (term-to-type term)))    
    (case (tag type)
      ((arrow)
       (let* ((arg-types (arrow-form-to-arg-types type))
	      (arg-vars (map type-to-new-var arg-types))
	      (make-intro
	       (lambda (t) (apply mk-term-in-abst-form
				  (append arg-vars (list t)))))
	      (elim-args (map make-term-in-var-form arg-vars)))
	 (if-term-to-eta-expansion-aux term make-intro elim-args)))
      ((star)
       (if-term-to-eta-expansion-aux term
				     make-term-in-pair-form
				     (list 'left) (list 'right)))
      (else term))))

; if-term-to-eta-expansion-aux is a generic helper function, which
; does eta-expansion in an if term over a composite type (arrow or
; star), where the introduction term constructor is make-intro and the
; arguments for elimination are given in elim-args-list

(define (if-term-to-eta-expansion-aux term make-intro . elim-args-list)
  (let* ((test (term-in-if-form-to-test term))
	 (alts (term-in-if-form-to-alts term))
	 (rest (term-in-if-form-to-rest term))
	 (prev-test (term-to-term-with-eta-expanded-if-terms test))
	 (prev-alts (map term-to-term-with-eta-expanded-if-terms alts))
	 (alg (term-to-type test))
	 (alg-name (alg-form-to-name alg))
	 (typed-constr-names (alg-name-to-typed-constr-names alg-name))
	 (constr-types (map typed-constr-name-to-type typed-constr-names))
	 (ls (map (lambda (x) (length (arrow-form-to-arg-types x)))
		  constr-types))
	 (constr-arg-types-list ;without arg-types
	  (map (lambda (l alt)
		 (arrow-form-to-arg-types (term-to-type alt) l))
	       ls alts))
	 (constr-arg-vars-list
	  (map (lambda (types) (map type-to-new-var types))
	       constr-arg-types-list))
	 (applied-alts-list
	  (map (lambda (elim-args)
		 (map (lambda (alt constr-arg-vars)
			(apply
			 mk-term-in-app-form
			 (cons alt (append
				    (map make-term-in-var-form
					 (append constr-arg-vars))
				    elim-args))))
		      prev-alts constr-arg-vars-list))
	       elim-args-list))
	 (abstr-applied-alts-list
	  (map (lambda (applied-alts)		 
		 (map (lambda (constr-arg-vars applied-alt)
			(apply mk-term-in-abst-form
			       (append constr-arg-vars (list applied-alt))))
		      constr-arg-vars-list applied-alts))
	       applied-alts-list)))
    (apply make-intro 
	   (map (lambda (abstr-applied-alt)
		  (if-term-to-eta-expansion
		   (make-term-in-if-form
		    prev-test abstr-applied-alt rest)))
		abstr-applied-alts-list))))

; We now do permutative conversions for if-terms.  Notice that this is
; not possible for recursion terms.  However we can (and do) simplify
; (Rec arrow-types)param-args step-args rec-arg val-args into the term
; [if rec-arg simplified-step-args]val-args.

(define (normalize-term-pi-with-rec-to-if term)
  (let* ((op (term-in-app-form-to-final-op term))
	 (args (term-in-app-form-to-args term)))
    (if ;op is rec with sufficiently many args
     (and (term-in-const-form? op)
	  (let* ((const (term-in-const-form-to-const op))
		 (name (const-to-name const))
		 (uninst-type (const-to-uninst-type const))
		 (arg-types (arrow-form-to-arg-types uninst-type)))
	    (and (string=? "Rec" name)
		 (<= (length arg-types) (length args)))))
     (let* ((rec-or-if-term (rec-op-and-args-to-if-term op args))
	    (new-op (term-in-app-form-to-final-op rec-or-if-term))
	    (new-args (term-in-app-form-to-args rec-or-if-term)))
       (if ;term changed.  Then recursive call and beta-normalization
	(not (and (term-in-const-form? new-op)
		  (string=? "Rec" (const-to-name
				   (term-in-const-form-to-const new-op)))))
	(nbe-normalize-term-without-eta
	 (normalize-term-pi-with-rec-to-if rec-or-if-term))
					;else recursive call on new-args
	(apply mk-term-in-app-form
	       (cons new-op (map normalize-term-pi-with-rec-to-if new-args)))))
     (case (tag term)
       ((term-in-var-form term-in-const-form) term)
       ((term-in-abst-form)
	(let ((var (term-in-abst-form-to-var term))
	      (kernel (term-in-abst-form-to-kernel term)))
	  (make-term-in-abst-form
	   var (normalize-term-pi-with-rec-to-if kernel))))
       ((term-in-pair-form)
	(let ((left (term-in-pair-form-to-left term))
	      (right (term-in-pair-form-to-right term)))
	  (make-term-in-pair-form
	   (normalize-term-pi-with-rec-to-if left)
	   (normalize-term-pi-with-rec-to-if right))))
       ((term-in-app-form) ;f([if t [xs]r ..]s) := [if t [xs]f(r s) ..]
	(normalize-term-pi-with-rec-to-if-aux	   
	 make-term-in-app-form
	 (term-in-app-form-to-op term)
	 (term-in-app-form-to-arg term)))
       ((term-in-lcomp-form)
	(normalize-term-pi-with-rec-to-if-aux
	 make-term-in-lcomp-form
	 (term-in-lcomp-form-to-kernel term)))
       ((term-in-rcomp-form)
	(normalize-term-pi-with-rec-to-if-aux
	 make-term-in-rcomp-form
	 (term-in-rcomp-form-to-kernel term)))
       ((term-in-if-form)
	(normalize-term-pi-with-rec-to-if-aux
	 (lambda (test alts)
	   (make-term-in-if-form test alts (term-in-if-form-to-rest term)))
	 (term-in-if-form-to-test term)
	 (term-in-if-form-to-alts term)))
       (else (myerror "normalize-term-pi-with-rec-to-if"
		      "term expected" term))))))

; normalize-term-pi-with-rec-to-if-aux permutes an elimination over
; another one.

(define (normalize-term-pi-with-rec-to-if-aux make-term op . args)
  (let ((prev (normalize-term-pi-with-rec-to-if op)))
    (if
     (term-in-if-form? prev)
     (let* ((test (term-in-if-form-to-test prev))
	    (alts (term-in-if-form-to-alts prev))
	    (rest (term-in-if-form-to-rest prev))
	    (alg (term-to-type test))
	    (alg-name (alg-form-to-name alg))
	    (typed-constr-names (alg-name-to-typed-constr-names alg-name))
	    (constr-types (map typed-constr-name-to-type typed-constr-names))
	    (ls (map (lambda (x) (length (arrow-form-to-arg-types x)))
		     constr-types))
	    (vars-list (map (lambda (l alt)
			      (term-in-abst-form-to-vars alt l))
			    ls alts))
	    (kernels (map (lambda (l alt)
			    (term-in-abst-form-to-final-kernel alt l))
			  ls alts))
	    (prevs (map (lambda (x)
			  (normalize-term-pi-with-rec-to-if
			   (apply make-term (cons x args))))
			kernels))
	    (new-alts (map (lambda (xs y)
			     (apply mk-term-in-abst-form
				    (append xs (list y))))
			   vars-list prevs)))
       (make-term-in-if-form test new-alts rest))
     (apply make-term
	    (cons prev (map (lambda (arg)
			      (if (term-form? arg)
				  (normalize-term-pi-with-rec-to-if arg)
				  (map normalize-term-pi-with-rec-to-if arg)))
			    args))))))

; As auxiliary function we have used rec-op-and-args-to-if-term

(define (rec-op-and-args-to-if-term op args)
  (if
   (and
    (term-in-const-form? op)
    (string=? "Rec" (const-to-name (term-in-const-form-to-const op))))
   (let* ((const (term-in-const-form-to-const op))
	  (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)) ;f for free
	  (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 ;((ss1->mu1 .. ssn->mun) ..)
	   (map (lambda (l)
		  (list-transform-positive l
		    (lambda (y)
		      (let ((val-type (arrow-form-to-final-val-type y)))
			(and (alg-form? val-type)
			     (member (alg-form-to-name val-type)
				     simalg-names))))))
		step-arg-types))
	  (step-alg-arg-lengths (map length step-alg-arg-types))
	  (param-types-list
	   (map (lambda (l n) (list-head l (- (length l) (* 2 n))))
		step-arg-types step-alg-arg-lengths))
	  (param-types-list-lengths (map length param-types-list))
	  (param-args (list-head args f))
	  (k (length step-types))
	  (step-args (list-tail (list-head args (+ f 1 k)) (+ f 1)))
	  (rec-arg (list-ref args f))
	  (val-args (list-tail args (+ f 1 k)))
	  (arg-vars (map term-in-abst-form-to-vars step-args))
	  (arg-kernels (map term-in-abst-form-to-final-kernel step-args))
	  (prev-arg-vars
	   (map (lambda (p l n)
		  (list-tail (list-head l (+ p (* 2 n))) (+ p n)))
		param-types-list-lengths arg-vars step-alg-arg-lengths)))
     (if
      (apply and-op (map (lambda (vs arg-kernel)
			   (null? (intersection vs (term-to-free arg-kernel))))
			 prev-arg-vars arg-kernels))
      (let* ((simplified-step-args
	      (map (lambda (vs ws arg-kernel)
		     (apply mk-term-in-abst-form
			    (append (set-minus ws vs)
				    (list arg-kernel))))
		   prev-arg-vars arg-vars arg-kernels))
	     (if-term
	      (apply mk-term-in-app-form
		     (cons (make-term-in-if-form rec-arg simplified-step-args)
			   val-args))))
	(if (null? val-args)
	    if-term
	    (term-to-term-with-eta-expanded-if-terms if-term)))
      (apply mk-term-in-app-form (cons op args))))
   (apply mk-term-in-app-form (cons op args))))

(define (term-in-if-normal-form? term)
  (case (tag term)
    ((term-in-var-form term-in-const-form) #t)
    ((term-in-abst-form)
     (let ((kernel (term-in-abst-form-to-kernel term)))
       (term-in-if-normal-form? kernel)))
    ((term-in-app-form)
     (let ((op (term-in-app-form-to-op term))
	   (arg (term-in-app-form-to-arg term)))
       (and (term-in-if-normal-form? op)
	    (term-in-if-normal-form? arg))))
    ((term-in-pair-form)
     (let ((left (term-in-pair-form-to-left term))
	   (right (term-in-pair-form-to-right term)))
       (and (term-in-if-normal-form? left)
	    (term-in-if-normal-form? right))))
    ((term-in-lcomp-form)
     (let ((kernel (term-in-lcomp-form-to-kernel term)))
       (term-in-if-normal-form? kernel)))
    ((term-in-rcomp-form)
     (let ((kernel (term-in-rcomp-form-to-kernel term)))
       (term-in-if-normal-form? kernel)))
    ((term-in-if-form)
     (let ((test (term-in-if-form-to-test term))
	   (alts (term-in-if-form-to-alts term)))
       (and (let ((op (term-in-app-form-to-final-op test)))
	      (not (and (term-in-const-form? op)
			(eq? 'constr (const-to-kind
				      (term-in-const-form-to-const op))))))
	    (term-in-if-normal-form? test)
	    (apply and-op (map term-in-if-normal-form? alts)))))))

; We need to unfold simplified simrec-constants with sufficiently many
; (eta expanded) arguments, for normalization.

(define (unfold-simplified-simrec-appterm term)
  (let*
      ((op (term-in-app-form-to-final-op term))
       (args (term-in-app-form-to-args term))
       (rec-const (if (and (term-in-const-form? op)
			   (string=? "Rec" (const-to-name
					    (term-in-const-form-to-const op))))
		      (term-in-const-form-to-const op)
		      (myerror "unfold-simplified-simrec-appterm"
			       "rec constant expected in" term)))
       (rec-arg (if (pair? args) (car args)
		    (myerror "unfold-simplified-simrec-appterm"
			     "rec argument expected in" term)))
       (rest-args (cdr args))
       (uninst-arrow-types (rec-const-to-uninst-arrow-types rec-const))
       (tsubst (const-to-tsubst rec-const)) ;for tparams and val-tvars
       (uninst-arrow-type (car uninst-arrow-types))
       (alg-name (alg-form-to-name (arrow-form-to-arg-type uninst-arrow-type)))
       (tvars (alg-name-to-tvars alg-name))
       (simalg-names (alg-name-to-simalg-names alg-name))
       (rel-alg-names ;relevant alg-names in the order prescribed by ALGEBRAS
	(list-transform-positive simalg-names
	  (lambda (x)
	    (member x (map (lambda (type)
			     (alg-form-to-name (arrow-form-to-arg-type type)))
			   uninst-arrow-types)))))
       (irrel-alg-names (set-minus simalg-names rel-alg-names))
       (rel-algs (map (lambda (x) (apply make-alg (cons x tvars)))
		      rel-alg-names))
       (rel-val-tvars (map arrow-form-to-val-type uninst-arrow-types))
       (rel-alg-names-with-val-tvars
	(map (lambda (x)
	       (list (alg-form-to-name (arrow-form-to-arg-type x))
		     (arrow-form-to-val-type x)))
	     uninst-arrow-types))
       (alg-names-with-val-types
	(map (lambda (name)
	       (let ((info (assoc name rel-alg-names-with-val-tvars)))
		 (list name
		       (if info
			   (cadr info)
			   (apply make-alg (cons name tvars))))))
	     simalg-names))
       (constr-names (map typed-constr-name-to-name
			  (apply append (map alg-name-to-typed-constr-names
					     rel-alg-names))))
       (step-args (if (<= (length constr-names) (length rest-args))
		      (list-head rest-args (length constr-names))
		      (myerror "unfold-simplified-simrec-appterm"
			       "more arguments expected in" term)))
       (constr-name-to-step-alist (map (lambda (x y) (list x y))
				       constr-names step-args))
       (type-info-or-repro-formulas
	(const-to-type-info-or-repro-formulas rec-const))
       (extended-type-info-or-repro-formulas ;extended for irrel algs
	(cond
	 ((imp-form? (car type-info-or-repro-formulas))
	  (let* ((prems (map imp-form-to-premise
			     type-info-or-repro-formulas))
		 (preds (map predicate-form-to-predicate prems))
		 (names (map idpredconst-to-name preds))
		 (name (car names))
		 (simidpc-names (idpredconst-name-to-simidpc-names name))
		 (added-names (set-minus simidpc-names names))
		 (types (idpredconst-to-types (car preds)))
		 (cterms (idpredconst-to-cterms (car preds)))
		 (added-idpcs (map (lambda (name)
				     (make-idpredconst name types cterms))
				   added-names))
		 (added-arities (map idpredconst-to-arity added-idpcs))
		 (added-type-lists (map arity-to-types added-arities))
		 (added-var-lists (map (lambda (types)
					 (map type-to-new-partial-var types))
				       added-type-lists))
		 (added-varterm-lists (map (lambda (vars)
					     (map make-term-in-var-form vars))
					   added-var-lists))
		 (added-imp-formulas
		  (map (lambda (pred varterms)
			 (let ((predicate-formula
				(apply make-predicate-formula
				       (cons pred varterms))))
			   (make-imp predicate-formula predicate-formula)))
		       added-idpcs added-varterm-lists)))
	    (append type-info-or-repro-formulas added-imp-formulas)))
	 ((all-form? (car type-info-or-repro-formulas))
	  type-info-or-repro-formulas)
	 (else ;type-info has the form fst param-types arrow-types
	  (let ((added-arrow-types ;inst alg=>alg for irrel algs
		 (map (lambda (x)
			(let* ((tparams (map (lambda (x)
					       (type-substitute x tsubst))
					     tvars))
			       (alg (apply make-alg (cons x tparams))))
			  (make-arrow alg alg)))
		      irrel-alg-names)))
	    (append type-info-or-repro-formulas added-arrow-types)))))
       (expanded-steps ;including expanded constructor steps
	(apply
	 append
	 (map
	  (lambda (name)
	    (map
	     (lambda (constr-name)
	       (let ((uninst-constr-type
		      (const-to-uninst-type
		       (constr-name-to-constr constr-name))))
		 (if
		  (member name rel-alg-names)
		  (let*
		      ((uninst-step-type
			 (constructor-type-to-step-type
			 uninst-constr-type
			 alg-names-with-val-types))
		       (arg-types-of-uninst-step-type
			(arrow-form-to-arg-types uninst-step-type))
		       (p+2n (length (arrow-form-to-arg-types
				      (constructor-type-to-step-type
				       uninst-constr-type
				       rel-alg-names-with-val-tvars))))
		       (step
			(cadr (assoc constr-name constr-name-to-step-alist)))
		       (step-vars (term-in-abst-form-to-vars step p+2n))
		       (step-kernel
			(term-in-abst-form-to-final-kernel step p+2n))
		       (irrel-alg-type?
			 (lambda (type)
			   (and (alg-form? type)
				(member (alg-form-to-name type)
					irrel-alg-names))))
		       (expanded-step-vars
			(do ((l arg-types-of-uninst-step-type (cdr l))
			     (i 0 (if (irrel-alg-type?
				       (arrow-form-to-final-val-type (car l)))
				      i
				      (+ i 1)))
			     (res
			      '()
			      (if (irrel-alg-type?
				   (arrow-form-to-final-val-type (car l)))
				  (cons (type-to-new-var
					 (type-substitute (car l) tsubst))
					res)
				  (cons (list-ref step-vars i) res))))
			    ((null? l) (reverse res)))))
		    (apply mk-term-in-abst-form
			   (append expanded-step-vars (list step-kernel))))
					;else expanded constructor term
		  (let*
		      ((uninst-arg-types
			(arrow-form-to-arg-types uninst-constr-type))
		       (arg-types (map (lambda (x) (type-substitute x tsubst))
				       uninst-arg-types))
		       (constr-vars (map type-to-new-var arg-types))
		       (uninst-arg-types-without-param-types
			(list-tail uninst-arg-types
				   (length (constr-type-to-constr-param-types
					    uninst-constr-type))))
		       (rec-var-types
			(do ((l  uninst-arg-types-without-param-types (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)
					  (myerror
					   "unfold-simplified-simrec-appterm"
					   "algebra expected" argvaltype)))
				     (valtype (cadr info)))
				(cons
				 (apply mk-arrow
					(append
					 argargtypes
					 (list (type-substitute valtype
								tsubst))))
				 res))))
			    ((null? l) (reverse res))))
		       (new-rec-vars (map type-to-new-var rec-var-types))
		       (constr-term
			(apply mk-term-in-app-form
			       (cons (make-term-in-const-form
				      (const-substitute
				       (constr-name-to-constr constr-name)
				       tsubst #f))
				     (map make-term-in-var-form
					  constr-vars)))))
		    (apply mk-term-in-abst-form
			   (append constr-vars new-rec-vars
				   (list constr-term)))))))
	     (map typed-constr-name-to-name
		  (alg-name-to-typed-constr-names name))))
	  simalg-names)))
       (expanded-rec-const
	(car (apply type-info-to-rec-consts
		    extended-type-info-or-repro-formulas))))
    (apply mk-term-in-app-form
	   (cons (make-term-in-const-form expanded-rec-const)
		 (cons rec-arg expanded-steps)))))

; We want to fold a simrec-appterm into its simplified form.

(define (simplify-simrec-appterm term)
  (let*
      ((op (term-in-app-form-to-final-op term))
       (args (term-in-app-form-to-args term))
       (rec-const (if (and (term-in-const-form? op)
			   (string=? "Rec" (const-to-name
					    (term-in-const-form-to-const op))))
		      (term-in-const-form-to-const op)
		      (myerror "simplify-simrec-appterm"
			       "rec constant expected in" term)))
       (rec-arg (if (pair? args) (car args)
		    (myerror "simplify-simrec-appterm"
			     "rec argument expected in" term)))
       (rest-args (cdr args))
       (uninst-arrow-types (rec-const-to-uninst-arrow-types rec-const))
       (tsubst (const-to-tsubst rec-const)) ;for tparams and val-tvars
       (uninst-arrow-type (car uninst-arrow-types))
       (alg-name (alg-form-to-name (arrow-form-to-arg-type uninst-arrow-type)))
       (tvars (alg-name-to-tvars alg-name))
       (simalg-names (alg-name-to-simalg-names alg-name))
       (unordered-alg-names-with-val-tvars
	(map (lambda (x)
	       (list (alg-form-to-name (arrow-form-to-arg-type x))
		     (arrow-form-to-val-type x)))
	     uninst-arrow-types))
       (alg-names-with-val-tvars
	(map (lambda (name)
	       (let ((info (assoc name unordered-alg-names-with-val-tvars)))
		 (list name
		       (if info
			   (cadr info)
			   (myerror "simplify-simrec-appterm"
				    "alg name expected" name)))))
	     simalg-names))
       (typed-constr-names (apply append (map alg-name-to-typed-constr-names
					      simalg-names)))
       (constr-names (map typed-constr-name-to-name typed-constr-names))
       (constr-types (map typed-constr-name-to-type typed-constr-names))
       (step-args (if (<= (length constr-names) (length rest-args))
		      (list-head rest-args (length constr-names))
		      (myerror "simplify-simrec-appterm"
			       "more arguments expected in" term)))
       (constr-name-to-step-alist (map (lambda (x y) (list x y))
				       constr-names step-args))
       (irrel-alg-names
	(list-transform-positive simalg-names
	  (lambda (simalg-name)
	    (apply
	     and-op
	     (map
	      (lambda (constr-name constr-type step-arg)
		(if ;step-arg belongs to simalg-name
		 (member constr-name
			 (map typed-constr-name-to-name
			      (alg-name-to-typed-constr-names simalg-name)))
					;step-arg is the extended constructor
		 (let* ((step-kernel
			 (term-in-abst-form-to-final-kernel step-arg))
			(op (term-in-app-form-to-final-op step-kernel)))
		   (and (term-in-const-form? op)
			(string=? (const-to-name
				   (term-in-const-form-to-const op))
				  constr-name)))
					;else simalg-name args not in kernel
		 (let* ((step-vars (term-in-abst-form-to-vars step-arg))
			(step-kernel
			 (term-in-abst-form-to-final-kernel step-arg))
			(uninst-step-arg-types
			 (arrow-form-to-arg-types
			  (constructor-type-to-step-type
			   constr-type alg-names-with-val-tvars)))
			(vars-for-simalg-name
			 (do ((l1 step-vars (cdr l1))
			      (l2 uninst-step-arg-types (cdr l2))
			      (res
			       '()
			       (let ((argvaltype
				      (arrow-form-to-final-val-type (car l2))))
				 (if
				  (or (equal?
				       argvaltype
				       (cadr (assoc simalg-name
						    alg-names-with-val-tvars)))
				      (and (alg-form? argvaltype)
					   (string=? (alg-form-to-name
						      argvaltype)
						     simalg-name)))
				  (cons (car l1) res)
				  res))))
			     ((null? l1) (reverse res)))))
		   (null? (intersection vars-for-simalg-name
					(term-to-free step-kernel))))))
	      constr-names constr-types step-args)))))
       (shortened-step-args-and-constr-types ;those for relevant alg-names
	(do ((l1 step-args (cdr l1))
	     (l2 constr-types (cdr l2))
	     (res '() (if (member (alg-form-to-name
				   (arrow-form-to-final-val-type (car l2)))
				  irrel-alg-names)
			  res
			  (cons (list (car l1) (car l2)) res))))
	    ((null? l1) (reverse res))))
       (shortened-step-args (map car shortened-step-args-and-constr-types))
       (shortened-constr-types (map cadr shortened-step-args-and-constr-types))
       (irrel-val-tvars
	(map cadr (list-transform-positive alg-names-with-val-tvars
		    (lambda (x) (member (car x) irrel-alg-names)))))
       (simplified-shortened-step-args  ;remove abstracted vars for
					;irrel-alg-names and irrel-val-tvars
	(map (lambda (step-arg constr-type)
	       (let* ((step-vars (term-in-abst-form-to-vars step-arg))
		      (step-kernel
		       (term-in-abst-form-to-final-kernel step-arg))
		      (uninst-step-arg-types
		       (arrow-form-to-arg-types
			(constructor-type-to-step-type
			 constr-type alg-names-with-val-tvars)))
		      (vars-for-alg-name
		       (do ((l1 step-vars (cdr l1))
			    (l2 uninst-step-arg-types (cdr l2))
			    (res
			     '()
			     (let ((argvaltype
				    (arrow-form-to-final-val-type (car l2))))
			       (if
				(or (and (alg-form? argvaltype)
					 (member (alg-form-to-name argvaltype)
						 irrel-alg-names))
				    (and (tvar-form? argvaltype)
					 (member argvaltype irrel-val-tvars)))
				res
				(cons (car l1) res)))))
			   ((null? l1) (reverse res)))))
		 (apply mk-term-in-abst-form
			(append vars-for-alg-name (list step-kernel)))))
	     shortened-step-args shortened-constr-types))
       (rel-uninst-arrow-types
	(list-transform-positive uninst-arrow-types
	  (lambda (x)
	    (not (member (alg-form-to-name (arrow-form-to-arg-type x))
			 irrel-alg-names)))))
       (rel-arrow-types (map (lambda (x) (type-substitute x tsubst))
			     rel-uninst-arrow-types))
       (uninst-recop-types-and-new-tsubst
	(apply arrow-types-to-uninst-paramless-recop-types-and-tsubst
	       rel-arrow-types))
       (uninst-recop-type (caar uninst-recop-types-and-new-tsubst))
       (new-tsubst (cadr uninst-recop-types-and-new-tsubst))
       (type-info-or-repro-formulas
	(const-to-type-info-or-repro-formulas rec-const))
       (shortened-type-info-or-repro-formulas
	(cond
	 ((imp-form? (car type-info-or-repro-formulas))
	  (list-transform-positive type-info-or-repro-formulas
	    (lambda (x)
	      (let* ((prem (imp-form-to-premise x))
		     (pred (predicate-form-to-predicate prem))
		     (name (idpredconst-to-name pred))
		     (nbe-alg-name (idpredconst-name-to-nbe-alg-name
				    name)))
		(member nbe-alg-name rel-alg-names)))))
	 ((all-form? (car type-info-or-repro-formulas))
	  type-info-or-repro-formulas)
	 (else ;type-info has the form fst param-types arrow-types
	  (let* ((param-types (rec-const-to-param-types rec-const))
		 (f (length param-types)))
	    (if (zero? f) rel-arrow-types
		(cons f (append param-types rel-arrow-types)))))))
       (simplified-rec-const
	(apply
	 make-const
	 (append
	  (list (const-to-object-or-arity rec-const)
		"Rec" 'fixed-rules uninst-recop-type new-tsubst 1 'const)
	  shortened-type-info-or-repro-formulas))))
    (apply mk-term-in-app-form
	   (cons (make-term-in-const-form simplified-rec-const)
		 (cons rec-arg simplified-shortened-step-args)))))

(define (term-to-outer-eta-expansion term)
  (let ((type (term-to-type term)))
    (case (tag type)
      ((tvar alg tconst) term)
      ((arrow)
       (let* ((arg-type (arrow-form-to-arg-type type))
	      (val-type (arrow-form-to-val-type type))
	      (var (type-to-new-var arg-type)))
	 (make-term-in-abst-form
	  var (term-to-outer-eta-expansion
	       (make-term-in-app-form
		term (term-to-outer-eta-expansion
		      (make-term-in-var-form var)))))))
      ((star)
       (make-term-in-pair-form
	(term-to-outer-eta-expansion (term-in-pair-form-to-left term))
	(term-to-outer-eta-expansion (term-in-pair-form-to-right term))))
      (else (myerror "term-to-outer-eta-expansion" "term expected" term)))))

; (pp (term-to-outer-eta-expansion (pt "(Rec tlist unit=>nat)")))

; Assume term is in long normal form

(define (term-to-eta-nf-with-simplified-simrec-appterms term)
  (case (tag term)
    ((term-in-app-form)
     (let* ((op (term-in-app-form-to-final-op term))
	    (args (term-in-app-form-to-args term))
	    (prev-args
	     (map term-to-eta-nf-with-simplified-simrec-appterms args)))
       (if ;op is simrec-constant
	(and
	 (term-in-const-form? op)
	 (string=? "Rec" (const-to-name (term-in-const-form-to-const op)))
	 (let* ((const (term-in-const-form-to-const op))
		(uninst-type (const-to-uninst-type const))
		(arg-types (arrow-form-to-arg-types uninst-type))
		(param-types (rec-const-to-param-types const))
		(f (length param-types))
		(alg-type-and-step-types (list-tail arg-types f))
		(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)))
	   (< 1 (length simalg-names))))
	(simplify-simrec-appterm
	 (apply mk-term-in-app-form (cons op prev-args)))
	(apply mk-term-in-app-form
	       (cons (term-to-eta-nf-with-simplified-simrec-appterms op)
		     prev-args)))))
    ((term-in-abst-form) 
     (let* ((var (term-in-abst-form-to-var term))
	    (kernel (term-in-abst-form-to-kernel term))
	    (prev (term-to-eta-nf-with-simplified-simrec-appterms kernel)))
       (cond
	((and ;[x]rx -> r, if x not free in r
	  (term-in-app-form? prev)
	  (term=? (term-in-app-form-to-arg prev)
		  (make-term-in-var-form var))
	  (not (member var (term-to-free
			    (term-in-app-form-to-op prev)))))
	 (term-in-app-form-to-op prev))
	(else (make-term-in-abst-form var prev)))))
    ((term-in-pair-form) 
     (let* ((left (term-in-pair-form-to-left term))
	    (right (term-in-pair-form-to-right term))
	    (prev-left (term-to-eta-nf-with-simplified-simrec-appterms left))
	    (prev-right
	     (term-to-eta-nf-with-simplified-simrec-appterms right)))
       (cond
	((and ;(left r)@(right r) -> r
	  (term-in-lcomp-form? prev-left)
	  (term-in-rcomp-form? prev-right)
	  (term=? (term-in-lcomp-form-to-kernel prev-left)
		  (term-in-rcomp-form-to-kernel prev-right)))
	 (term-in-lcomp-form-to-kernel prev-left))
	((and ;[if t [ys,zs]r1 ..]@[if t [ys,zs]r2 ..] -> [if t [ys,zs]r1@r2..]
	  (term-in-if-form? prev-left)
	  (term-in-if-form? prev-right)
	  (term=? (term-in-if-form-to-test prev-left)
		  (term-in-if-form-to-test prev-right)))
	 (let* ((test (term-in-if-form-to-test prev-left))
		(alg (term-to-type test))
		(alg-name (alg-form-to-name alg))
		(typed-constr-names (alg-name-to-typed-constr-names alg-name))
		(constr-types
		 (map typed-constr-name-to-type typed-constr-names))
		(ls (map (lambda (x) (length (arrow-form-to-arg-types x)))
			 constr-types))
		(alts1 (term-in-if-form-to-alts prev-left))
		(rest1 (term-in-if-form-to-rest prev-left))
		(constr-arg-vars-list1
		 (map (lambda (alt l) (term-in-abst-form-to-vars alt l))
		      alts1 ls))
		(kernels1
		 (map (lambda (alt l)
			(term-in-abst-form-to-final-kernel alt l))
		      alts1 ls))
		(alts2 (term-in-if-form-to-alts prev-right))
		(rest2 (term-in-if-form-to-rest prev-right))
		(constr-arg-vars-list2
		 (map (lambda (alt l) (term-in-abst-form-to-vars alt l))
		      alts2 ls))
		(kernels2
		 (map (lambda (alt l)
			(term-in-abst-form-to-final-kernel alt l))
		      alts2 ls))
		(equal-constr-arg-vars?-list
		 (map (lambda (vars1 vars2) (equal? vars1 vars2))
		      constr-arg-vars-list1 constr-arg-vars-list2))
		(constr-arg-vars-list
		 (map (lambda (boole vars1 vars2)
			(if boole vars1 (map var-to-new-var vars2)))
		      equal-constr-arg-vars?-list
		      constr-arg-vars-list1 constr-arg-vars-list2))
		(pair-alts
		 (map (lambda (boole vars vars2 kernel1 kernel2)
			(apply
			 mk-term-in-abst-form
			 (append vars (list (make-term-in-pair-form
					     kernel1
					     (if boole
						 kernel2
						 (term-substitute
						  kernel2
						  (map (lambda (x y)
							 (list x y))
						       vars2 vars))))))))
		      equal-constr-arg-vars?-list
		      constr-arg-vars-list constr-arg-vars-list2
		      kernels1 kernels2))
		(pair-alts-nf
		 (map term-to-eta-nf-with-simplified-simrec-appterms
		      pair-alts)))
	   (make-term-in-if-form
	    test (map term-to-eta-nf-with-simplified-simrec-appterms pair-alts)
	    (make-and rest1 rest2))))
	(else (make-term-in-pair-form prev-left prev-right)))))
    ((term-in-lcomp-form)
     (let ((prev (term-to-eta-nf-with-simplified-simrec-appterms
		  (term-in-lcomp-form-to-kernel term))))
       (if (term-in-pair-form? prev)
	   (term-in-pair-form-to-left prev)
	   (make-term-in-lcomp-form prev))))
    ((term-in-rcomp-form)
     (let ((prev (term-to-eta-nf-with-simplified-simrec-appterms
		  (term-in-rcomp-form-to-kernel term))))
       (if (term-in-pair-form? prev)
	   (term-in-pair-form-to-right prev)
	   (make-term-in-rcomp-form prev))))
    ((term-in-if-form)
     (let* ((test (term-in-if-form-to-test term))
	    (alts (term-in-if-form-to-alts term))
	    (rest (term-in-if-form-to-rest term))
	    (prev (term-to-eta-nf-with-simplified-simrec-appterms test))
	    (prevs (map term-to-eta-nf-with-simplified-simrec-appterms alts)))
       (apply make-term-in-if-form (cons prev (cons prevs rest)))))
    (else term)))

(define (term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs term)
  (case (tag term)
    ((term-in-var-form) term)
    ((term-in-const-form)
     (let ((const (term-in-const-form-to-const term)))
       (if ;simplified simrec constant
	(and (string=? "Rec" (const-to-name const))
	     (let* ((uninst-type (const-to-uninst-type const))
		    (arg-types (arrow-form-to-arg-types 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)))
	       (and (< 1 (length simalg-names))
		    (< (length step-types)
		       (length (apply append
				      (map alg-name-to-typed-constr-names
					   simalg-names)))))))
	(let* ((outer-eta-expansion (term-to-outer-eta-expansion term))
	       (kernel (term-in-abst-form-to-final-kernel outer-eta-expansion))
	       (vars (term-in-abst-form-to-vars outer-eta-expansion)))
	  (apply mk-term-in-abst-form
		 (append vars
			 (list (unfold-simplified-simrec-appterm kernel)))))
	term)))
    ((term-in-app-form)
     (let ((op (term-in-app-form-to-op term))
	   (arg (term-in-app-form-to-arg term)))
       (make-term-in-app-form
	(term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs op)
	(term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs arg))))
    ((term-in-abst-form)
     (let ((var (term-in-abst-form-to-var term))
	   (kernel (term-in-abst-form-to-kernel term)))
       (make-term-in-abst-form
	var (term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs
	     kernel))))
    ((term-in-pair-form)
     (let ((left (term-in-pair-form-to-left term))
	   (right (term-in-pair-form-to-right term)))
       (make-term-in-pair-form
	(term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs left)
	(term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs right))))
    ((term-in-lcomp-form)
     (make-term-in-lcomp-form
      (term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs
       (term-in-lcomp-form-to-kernel term))))
    ((term-in-rcomp-form)
     (make-term-in-rcomp-form
      (term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs
       (term-in-rcomp-form-to-kernel term))))
    ((term-in-if-form)
     (if-term-to-eta-expansion-and-unfolded-simrecs term))
    (else (myerror
	   "term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs"
	   "term expected"
	   term))))

(define (if-term-to-eta-expansion-and-unfolded-simrecs term)
  (let ((type (term-to-type term)))    
    (case (tag type)
      ((arrow)
       (let* ((arg-types (arrow-form-to-arg-types type))
	      (arg-vars (map type-to-new-var arg-types))
	      (make-intro
	       (lambda (t) (apply mk-term-in-abst-form
				  (append arg-vars (list t)))))
	      (elim-args (map make-term-in-var-form arg-vars)))
	 (if-term-to-eta-expansion-and-unfolded-simrecs-aux
	  term make-intro elim-args)))
      ((star)
       (if-term-to-eta-expansion-and-unfolded-simrecs-aux
	term make-term-in-pair-form (list 'left) (list 'right)))
      (else term))))

; if-term-to-eta-expansion-and-unfolded-simrecs-aux is a generic
; helper function, which does eta-expansion in an if term over a
; composite type (arrow or star), where the introduction term
; constructor is make-intro and the arguments for elimination are
; given in elim-args-list

(define (if-term-to-eta-expansion-and-unfolded-simrecs-aux
	 term make-intro . elim-args-list)
  (let* ((test (term-in-if-form-to-test term))
	 (alts (term-in-if-form-to-alts term))
	 (rest (term-in-if-form-to-rest term))
	 (prev-test
	  (term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs test))
	 (prev-alts
	  (map term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs
	       alts))
	 (alg (term-to-type test))
	 (alg-name (alg-form-to-name alg))
	 (typed-constr-names (alg-name-to-typed-constr-names alg-name))
	 (constr-types (map typed-constr-name-to-type typed-constr-names))
	 (ls (map (lambda (x) (length (arrow-form-to-arg-types x)))
		  constr-types))
	 (constr-arg-types-list ;without arg-types
	  (map (lambda (l alt)
		 (arrow-form-to-arg-types (term-to-type alt) l))
	       ls alts))
	 (constr-arg-vars-list
	  (map (lambda (types) (map type-to-new-var types))
	       constr-arg-types-list))
	 (applied-alts-list
	  (map (lambda (elim-args)
		 (map (lambda (alt constr-arg-vars)
			(apply
			 mk-term-in-app-form
			 (cons alt (append
				    (map make-term-in-var-form
					 (append constr-arg-vars))
				    elim-args))))
		      prev-alts constr-arg-vars-list))
	       elim-args-list))
	 (abstr-applied-alts-list
	  (map (lambda (applied-alts)		 
		 (map (lambda (constr-arg-vars applied-alt)
			(apply mk-term-in-abst-form
			       (append constr-arg-vars (list applied-alt))))
		      constr-arg-vars-list applied-alts))
	       applied-alts-list)))
    (apply make-intro 
	   (map (lambda (abstr-applied-alt)
		  (if-term-to-eta-expansion-and-unfolded-simrecs
		   (make-term-in-if-form
		    prev-test abstr-applied-alt rest)))
		abstr-applied-alts-list))))

(define (nbe-normalize-term term)
  (let ((init (normalize-term-pi-with-rec-to-if
	       (nbe-normalize-term-without-eta
		(term-to-term-with-eta-expanded-if-terms-and-unfolded-simrecs
		 term)))))
    (do ((t init (normalize-term-pi-with-rec-to-if
		  (nbe-normalize-term-without-eta t))))
	((term-in-if-normal-form? t)
	 (term-to-eta-nf-with-simplified-simrec-appterms t)))))

(define nt nbe-normalize-term)

; term-to-term-without-predecided-ifs simplifies all if-terms whose
; branch is known because we are in a branch of an outer if-term with
; the same test term.  tests is an alist assigning to a term of an
; algebra type the number of a constructor it is assumed to be built
; with.

(define (term-to-term-without-predecided-ifs term)
  (term-to-term-without-predecided-ifs-aux term '()))

(define (term-to-term-without-predecided-ifs-aux term tests)
  (case (tag term)
    ((term-in-var-form term-in-const-form) term)
    ((term-in-abst-form)
     (let ((var (term-in-abst-form-to-var term))
	   (kernel (term-in-abst-form-to-kernel term)))
       (make-term-in-abst-form
	var (term-to-term-without-predecided-ifs-aux
	     kernel
	     (list-transform-positive tests
	       (lambda (test)
		 (not (member var (term-to-free (car test))))))))))
    ((term-in-app-form)
     (let ((op (term-in-app-form-to-op term))
	   (arg (term-in-app-form-to-arg term)))
       (make-term-in-app-form
	(term-to-term-without-predecided-ifs-aux op tests)
	(term-to-term-without-predecided-ifs-aux arg tests))))
    ((term-in-pair-form)
     (let ((left (term-in-pair-form-to-left term))
	   (right (term-in-pair-form-to-right term)))
       (make-term-in-pair-form
	(term-to-term-without-predecided-ifs-aux left tests)
	(term-to-term-without-predecided-ifs-aux right tests))))
    ((term-in-lcomp-form)
     (let ((kernel (term-in-lcomp-form-to-kernel term)))
       (make-term-in-lcomp-form
	(term-to-term-without-predecided-ifs-aux kernel tests))))
    ((term-in-rcomp-form)
     (let ((kernel (term-in-rcomp-form-to-kernel term)))
       (make-term-in-rcomp-form
	(term-to-term-without-predecided-ifs-aux kernel tests))))
    ((term-in-if-form)
     (let* ((test (term-in-if-form-to-test term))
	    (alts (term-in-if-form-to-alts term))
	    (rest (term-in-if-form-to-rest term))
	    (info (assoc test tests)))
       (if info
	   (term-to-term-without-predecided-ifs-aux
	    (list-ref alts (cadr info))
	    tests)
	   (apply
	    make-term-in-if-form
	    (append
	     (list (term-to-term-without-predecided-ifs-aux test tests)
		   (do ((l alts (cdr l))
			(i 0 (+ 1 i))
			(res '() (cons (term-to-term-without-predecided-ifs-aux
					(car l)
					(cons (list test i) tests))
				       res)))
		       ((null? l) (reverse res))))
	     rest)))))
    (else (myerror "term-to-term-without-predecided-ifs-aux"
		   "term expected" term))))

; Alternative to nbe, if no rewrite rules are applicable.

(define (term-to-one-step-beta-reduct term)
  (case (tag term)
    ((term-in-var-form term-in-const-form) term)
    ((term-in-abst-form)
     (make-term-in-abst-form
      (term-in-abst-form-to-var term)
      (term-to-one-step-beta-reduct (term-in-abst-form-to-kernel term))))
    ((term-in-app-form)
     (let* ((op (term-in-app-form-to-op term))
	    (arg (term-in-app-form-to-arg term)))
       (if (term-in-abst-form? op)
	   (term-subst (term-in-abst-form-to-kernel op)
		       (term-in-abst-form-to-var op)
		       arg)
	   (make-term-in-app-form
	    (term-to-one-step-beta-reduct op)
	    (term-to-one-step-beta-reduct arg)))))
    ((term-in-pair-form)
     (make-term-in-pair-form
      (term-to-one-step-beta-reduct (term-in-pair-form-to-left term))
      (term-to-one-step-beta-reduct (term-in-pair-form-to-right term))))
    ((term-in-lcomp-form)
     (let ((kernel (term-in-lcomp-form-to-kernel term)))
       (if (term-in-pair-form? kernel)
	   (term-in-pair-form-to-left kernel)
	   (make-term-in-lcomp-form
	    (term-to-one-step-beta-reduct kernel)))))
    ((term-in-rcomp-form)
     (let ((kernel (term-in-rcomp-form-to-kernel term)))
       (if (term-in-pair-form? kernel)
	   (term-in-pair-form-to-right kernel)
	   (make-term-in-rcomp-form
	    (term-to-one-step-beta-reduct kernel)))))
    ((term-in-if-form)
     (let ((test (term-in-if-form-to-test term))
	   (alts (term-in-if-form-to-alts term)))
       (make-term-in-if-form
	(term-to-one-step-beta-reduct test)
	(map term-to-one-step-beta-reduct alts))))
    (else (myerror "term-to-one-step-beta-reduct" "unexpected term"
		   term))))

(define (term-in-beta-normal-form? term)
  (case (tag term)
    ((term-in-var-form term-in-const-form) #t)
    ((term-in-abst-form)
     (let ((kernel (term-in-abst-form-to-kernel term)))
       (term-in-beta-normal-form? kernel)))
    ((term-in-app-form)
     (let ((op (term-in-app-form-to-op term))
	   (arg (term-in-app-form-to-arg term)))
       (and (not (term-in-abst-form? op))
	    (term-in-beta-normal-form? op)
	    (term-in-beta-normal-form? arg))))
    ((term-in-pair-form)
     (let ((left (term-in-pair-form-to-left term))
	   (right (term-in-pair-form-to-right term)))
       (and (term-in-beta-normal-form? left)
	    (term-in-beta-normal-form? right))))
    ((term-in-lcomp-form)
     (let ((kernel (term-in-lcomp-form-to-kernel term)))
       (and (not (term-in-pair-form? kernel))
	    (term-in-beta-normal-form? kernel))))
    ((term-in-rcomp-form)
     (let ((kernel (term-in-rcomp-form-to-kernel term)))
       (and (not (term-in-pair-form? kernel))
	    (term-in-beta-normal-form? kernel))))
    ((term-in-if-form)
     (let ((test (term-in-if-form-to-test term))
	   (alts (term-in-if-form-to-alts term)))
       (and (term-in-beta-normal-form? test)
	    (apply and-op (map term-in-beta-normal-form? alts)))))
    (else (myerror "term-in-beta-normal-form?" "term tag expected"
		   (tag term))))) 

(define (term-to-beta-nf term)
  (if (term-in-beta-normal-form? term)
      term
      (term-to-beta-nf (term-to-one-step-beta-reduct term))))

(define (term-to-beta-pi-eta-nf term)
  (let ((init (normalize-term-pi-with-rec-to-if
	       (term-to-beta-nf
		(term-to-term-with-eta-expanded-if-terms term)))))
    (do ((t init (normalize-term-pi-with-rec-to-if
		  (term-to-beta-nf t))))
	((term-in-if-normal-form? t)
	 (term-to-eta-nf t)))))

(define bpe-nt term-to-beta-pi-eta-nf)

(define (term-in-rec-normal-form? term)
  (case (tag term)
    ((term-in-var-form term-in-const-form) #t)
    ((term-in-abst-form)
     (let ((kernel (term-in-abst-form-to-kernel term)))
       (term-in-rec-normal-form? kernel)))
    ((term-in-app-form)
     (let ((op (term-in-app-form-to-final-op term))
	   (args (term-in-app-form-to-args term)))
       (and
	(apply and-op (map term-in-rec-normal-form? args))
	(or
	 (not (and (term-in-const-form? op)
		   (equal? "Rec" (const-to-name
				  (term-in-const-form-to-const op)))))
	 (let* ((const (term-in-const-form-to-const op))
		(uninst-recop-type (const-to-uninst-type const))
		(f-plus-s ;number f of free variables plus number s of steps
		 (- (length (arrow-form-to-arg-types uninst-recop-type)) 1)))
	   (and (< f-plus-s (length args))
		(let* ((rec-arg (list-ref args f-plus-s))
		       (op1 (term-in-app-form-to-final-op rec-arg))
		       (args1 (term-in-app-form-to-args rec-arg)))
		  (or (not (term-in-const-form? op1))
		      (not (eq? 'constr (const-to-kind
					 (term-in-const-form-to-const op1))))
		      (not (= (length (arrow-form-to-arg-types
				       (const-to-uninst-type
                                        (term-in-const-form-to-const op1))))
			      (length args1)))))))))))
    ((term-in-pair-form)
     (let ((left (term-in-pair-form-to-left term))
	   (right (term-in-pair-form-to-right term)))
       (and (term-in-rec-normal-form? left)
	    (term-in-rec-normal-form? right))))
    ((term-in-lcomp-form)
     (let ((kernel (term-in-lcomp-form-to-kernel term)))
       (term-in-rec-normal-form? kernel)))
    ((term-in-rcomp-form)
     (let ((kernel (term-in-rcomp-form-to-kernel term)))
       (term-in-rec-normal-form? kernel)))
    ((term-in-if-form)
     (let ((test (term-in-if-form-to-test term))
	   (alts (term-in-if-form-to-alts term)))
       (apply and-op (cons (term-in-rec-normal-form? test)
			   (map term-in-rec-normal-form? alts)))))
    (else (myerror "term-in-rec-normal-form?" "term tag expected"
		   (tag term)))))

(define (term-to-length term)
  (case (tag term)
    ((term-in-var-form term-in-const-form) 1)
    ((term-in-abst-form)
     (+ 1 (term-to-length (term-in-abst-form-to-kernel term))))
    ((term-in-app-form)
     (let* ((op (term-in-app-form-to-op term))
	    (arg (term-in-app-form-to-arg term)))
       (+ 1 (term-to-length op) (term-to-length arg))))
    ((term-in-pair-form)
     (+ 1
	(term-to-length (term-in-pair-form-to-left term))
	(term-to-length (term-in-pair-form-to-right term))))
    ((term-in-lcomp-form)
     (let ((kernel (term-in-lcomp-form-to-kernel term)))
       (+ 1 (term-to-length kernel))))
    ((term-in-rcomp-form)
     (let ((kernel (term-in-rcomp-form-to-kernel term)))
       (+ 1 (term-to-length kernel))))
    ((term-in-if-form)
     (let ((test (term-in-if-form-to-test term))
	   (alts (term-in-if-form-to-alts term)))
       (+ 1 (term-to-length test)
	  (apply + (map term-to-length alts)))))
    (else (myerror "term-to-length" "unexpected term, tag:"
		   (tag term)))))

(define (term-to-consts-with-repetitions term)
  (case (tag term)
    ((term-in-var-form) '())
    ((term-in-const-form) (list (term-in-const-form-to-const term)))
    ((term-in-app-form)
     (let ((op (term-in-app-form-to-op term))
	   (arg (term-in-app-form-to-arg term)))
       (append (term-to-consts-with-repetitions op)
	       (term-to-consts-with-repetitions arg))))
    ((term-in-abst-form)
     (let ((kernel (term-in-abst-form-to-kernel term)))
       (term-to-consts-with-repetitions kernel)))
    ((term-in-pair-form)
     (let ((left (term-in-pair-form-to-left term))
	   (right (term-in-pair-form-to-right term)))
       (append (term-to-consts-with-repetitions left)
	       (term-to-consts-with-repetitions right))))
    ((term-in-lcomp-form)
     (let ((kernel (term-in-lcomp-form-to-kernel term)))
       (term-to-consts-with-repetitions kernel)))
    ((term-in-rcomp-form)
     (let ((kernel (term-in-rcomp-form-to-kernel term)))
       (term-to-consts-with-repetitions kernel)))
    ((term-in-if-form)
     (let ((test (term-in-if-form-to-test term))
	   (alts (term-in-if-form-to-alts term)))
       (apply append (map term-to-consts-with-repetitions (cons test alts)))))
    (else (myerror "term-to-consts-with-repetitions" "term tag expected"
		   (tag term)))))

(define (term-to-consts term)
  (remove-duplicates-wrt const=? (term-to-consts-with-repetitions term)))

; For tests it might generally be useful to have a level-wise
; decomposition of terms into subterms: one level transforms a term
; N@lambda us.v Ms into the list [N v M1 ... Mn]

(define (term-in-intro-form-to-final-kernels term)
  (cond
   ((term-in-abst-form? term)
    (term-in-intro-form-to-final-kernels
     (term-in-abst-form-to-kernel term)))
   ((term-in-pair-form? term)
    (append (term-in-intro-form-to-final-kernels
	     (term-in-pair-form-to-left term))
	    (term-in-intro-form-to-final-kernels
	     (term-in-pair-form-to-right term))))
   (else (list term))))

(define (term-in-elim-form-to-final-op-and-args term)
  (case (tag term)
    ((term-in-app-form)
     (append (term-in-elim-form-to-final-op-and-args
	      (term-in-app-form-to-op term))
	     (list (term-in-app-form-to-arg term))))
    ((term-in-lcomp-form)
     (append (term-in-elim-form-to-final-op-and-args
	      (term-in-lcomp-form-to-kernel term))
	     (list 'left)))
    ((term-in-rcomp-form)
     (append (term-in-elim-form-to-final-op-and-args
	      (term-in-rcomp-form-to-kernel term))
	     (list 'right)))
    (else (list term))))

(define (term-in-app-form-to-final-op-and-args term)
  (do ((x term (term-in-app-form-to-op x))
       (res '() (cons (term-in-app-form-to-op x)
		      (cons (term-in-app-form-to-arg x)
			    (if (null? res) '() (cdr res))))))
      ((not (term-in-app-form? x)) res)))

(define (term-to-parts-of-level-one term)
  (if
   (term-in-if-form? term)
   (cons (term-in-if-form-to-test term)
	 (term-in-if-form-to-alts term))
   (let* ((final-kernels (term-in-intro-form-to-final-kernels term))
	  (lists (map term-in-elim-form-to-final-op-and-args final-kernels)))
     (apply append lists))))

(define (term-to-subterms term . opt-level)
  (if
   (null? opt-level)
   (term-to-subterms term 1)
   (let ((l (car opt-level)))
     (if (and (integer? l) (not (negative? l)))
	 (if (zero? l)
	     (list term)
	     (let* ((parts (term-to-parts-of-level-one term))
		    (terms (list-transform-positive parts term-form?)))
	       (apply append (map (lambda (x) (term-to-subterms x (- l 1)))
				  terms))))
	 (myerror "term-to-subterms" "non-negative integer expected" l)))))

; term-to-term-with-let hand optimizes a term by searching for its
; longest duplicate subterm, and taking that subterm out via a let.

(define (term-to-let-candidates term)
  (let ((terms
	 (case (tag term)
	   ((term-in-var-form term-in-const-form) '())
	   ((term-in-abst-form)
	    (let* ((var (term-in-abst-form-to-var term))
		   (kernel (term-in-abst-form-to-kernel term))
		   (prev (term-to-let-candidates kernel)))
	      (list-transform-positive prev
		(lambda (s) (not (member var (term-to-free s)))))))
	   ((term-in-app-form)
	    (let ((prev1 (term-to-let-candidates
			  (term-in-app-form-to-op term)))
		  (prev2 (term-to-let-candidates
			  (term-in-app-form-to-arg term))))
	      (append prev1 prev2)))
	   ((term-in-pair-form)
	    (append (term-to-let-candidates
		     (term-in-pair-form-to-left term))
		    (term-to-let-candidates
		     (term-in-pair-form-to-right term))))
	   ((term-in-lcomp-form)
	    (term-to-let-candidates (term-in-lcomp-form-to-kernel term)))
	   ((term-in-rcomp-form)
	    (term-to-let-candidates (term-in-rcomp-form-to-kernel term)))
	   ((term-in-if-form)
	    (apply append (map term-to-let-candidates
			       (cons (term-in-if-form-to-test term)
				     (term-in-if-form-to-alts term)))))
	   (else (myerror "term-to-let-candidates" "term expected" term)))))
    (if (or (term-in-var-form? term)
	    (and (null? (term-to-free term))
		 (term=? (nt term) term))
	    (member-wrt term=? term terms))
	terms
	(cons term terms))))

(define (term-to-term-with-let term)
  (if (term-in-abst-form? term)
      (let* ((vars (term-in-abst-form-to-vars term))
	     (kernel (term-in-abst-form-to-final-kernel term))
	     (prev (term-to-term-with-let kernel)))
	(apply mk-term-in-abst-form (append vars (list prev))))
      (let* ((let-candidates (term-to-let-candidates term))
	     (longest-duplicate
	      (if (pair? let-candidates)
		  (apply terms-to-longest-duplicate let-candidates)
		  #f)))
	(if longest-duplicate
	    (let* ((type (term-to-type longest-duplicate))
		   (var (type-to-new-var type))
		   (pattern
		    (term-gen-subst
		     term longest-duplicate (make-term-in-var-form var)))
		   (cId-const (pconst-name-to-pconst "cId"))
		   (cId-term
		    (make-term-in-const-form
		     (let* ((tvars (const-to-tvars cId-const))
			    (subst (make-substitution
				    tvars (list (make-arrow
						 type
						 (term-to-type term))))))
		       (const-substitute cId-const subst #f)))))
	      (mk-term-in-app-form ;let via cId
	       cId-term
	       (make-term-in-abst-form
		var (term-to-term-with-let-aux pattern))
	       longest-duplicate))
	    (term-to-term-with-let-aux term)))))

; (pp (term-to-term-with-let (pt "(([m]n+m)7)*(([m]n+m)7)")))

(define (term-to-term-with-let-aux term)
  (case (tag term)
    ((term-in-var-form term-in-const-form) term)
    ((term-in-abst-form)
     (term-to-term-with-let term))
    ((term-in-app-form)
     (make-term-in-app-form
      (term-to-term-with-let-aux (term-in-app-form-to-op term))
      (term-to-term-with-let-aux (term-in-app-form-to-arg term))))
    ((term-in-pair-form)
     (make-term-in-pair-form
      (term-to-term-with-let-aux (term-in-pair-form-to-left term))
      (term-to-term-with-let-aux (term-in-pair-form-to-right term))))
    ((term-in-lcomp-form)
     (make-term-in-lcomp-form
      (term-to-term-with-let-aux (term-in-lcomp-form-to-kernel term))))
    ((term-in-rcomp-form)
     (make-term-in-rcomp-form
      (term-to-term-with-let-aux (term-in-rcomp-form-to-kernel term))))
    ((term-in-if-form)
     (make-term-in-if-form
      (term-to-term-with-let-aux (term-in-if-form-to-test term))
      (map term-to-term-with-let-aux (term-in-if-form-to-alts term))))
    (else (myerror "term-to-term-with-let-aux" "term expected" term))))

(define (terms-to-longest-duplicate term . terms)
  (if (null? terms)
      #f
      (let ((prev (apply terms-to-longest-duplicate terms)))
	(if (member-wrt term=? term terms)
	    (if prev
		(if (> (term-to-length term) (term-to-length prev))
		    term
		    prev)
		term)
	    prev))))

; (pp (terms-to-longest-duplicate (pt "n") (pt "n+m")  (pt "n+m")))

(define (term-to-depth term)
  (case (tag term)
    ((term-in-var-form term-in-const-form) 0)
    ((term-in-if-form)
     (+ 1 (apply max (cons (term-to-depth (term-in-if-form-to-test term))
			   (term-to-depth (term-in-if-form-to-alts term))))))
    (else (+ 1 (apply max (map term-to-depth (term-to-subterms term 1)))))))

(define (max-index varlist)
  (do ((l varlist (cdr l))
       (res -1 (max res (let ((x (car l)))
			  (case (tag x)
			    ((var) (var-to-index x))
			    ((avar) (avar-to-index x))
			    (else (myerror "max-index" "var or avar expected"
					   x)))))))
      ((null? l) res)))


; 6-6. Check
; ==========

; check-term is a test function for terms.  If the argument is not a
; term, an error is returned.

(define (check-term x)
  (if (not (pair? x)) (myerror "check-term" "term expected"))
  (cond
   ((term-in-var-form? x)
    (let ((var (term-in-var-form-to-var x)))
      (if (not (var? var))
	  (myerror "check term" "variable expected" var))
      (if (not (equal? (term-to-type x) (var-to-type var)))
	  (myerror "check-term" "equal types expected"
		   (term-to-type x) (var-to-type var))))
    #t)
   ((term-in-const-form? x)
    (let ((const (term-in-const-form-to-const x)))
      (if (not (const? const))
	  (myerror "check-term" "constant expected" const))
      (if (not (equal? (term-to-type x) (const-to-type const)))
	  (myerror "check-term" "equal types expected"
		   (term-to-type x) (const-to-type const))))
    #t)
   ((term-in-abst-form? x)
    (let ((var (term-in-abst-form-to-var x))
	  (kernel (term-in-abst-form-to-kernel x)))
      (if (not (var? var))
	  (myerror "check-term" "variable expected" var))
      (check-term kernel)
      (let ((var-type (var-to-type var))
	    (kernel-type (term-to-type kernel)))
	(if (not (equal? (make-arrow var-type kernel-type)
			 (term-to-type x)))
	    (myerror "check-term" "equal types expected"
		     (make-arrow var-type kernel-type)
		     (term-to-type x)))))
    #t)
   ((term-in-app-form? x)
    (let ((op (term-in-app-form-to-op x))
	  (arg (term-in-app-form-to-arg x)))
      (check-term op)
      (check-term arg)
      (let ((op-type (term-to-type op))
	    (arg-type (term-to-type arg)))
	(if (not (arrow-form? op-type))
	    (myerror "check-term" "arrow type expected" op-type))
	(if (not (equal? (arrow-form-to-arg-type op-type) arg-type))
	    (myerror "check-term" "equal types expected"
		     (arrow-form-to-arg-type op-type)
		     arg-type))
	(if (not (equal? (term-to-type x)
			 (arrow-form-to-val-type op-type)))
	    (myerror "check-term" "equal types expected"
		     (term-to-type x)
		     (arrow-form-to-val-type op-type)))))
    #t)
   ((term-in-pair-form? x)
    (let ((left (term-in-pair-form-to-left x))
	  (right (term-in-pair-form-to-right x)))
      (check-term left)
      (check-term right)
      (let ((left-type (term-to-type left))
	    (right-type (term-to-type right)))
	(if (not (equal? (term-to-type x)
			 (make-star left-type right-type)))
	    (myerror "check-term" "equal types expected"
		     (term-to-type x)
		     (make-star left-type right-type)))))
    #t)
   ((term-in-lcomp-form? x)
    (let ((kernel (term-in-lcomp-form-to-kernel x)))
      (check-term kernel)
      (let ((kernel-type (term-to-type kernel)))
	(if (not (star-form? kernel-type))
	    (myerror "check-term" "star form expected" kernel-type))
	(if (not (equal? (term-to-type x)
			 (star-form-to-left-type kernel-type)))
	    (myerror "check-term" "equal types expected"
		     (term-to-type x)
		     (star-form-to-left-type kernel-type)))))
    #t)
   ((term-in-rcomp-form? x)
    (let ((kernel (term-in-rcomp-form-to-kernel x)))
      (check-term kernel)
      (let ((kernel-type (term-to-type kernel)))
	(if (not (star-form? kernel-type))
	    (myerror "check-term" "star form expected" kernel-type))
	(if (not (equal? (term-to-type x)
			 (star-form-to-right-type kernel-type)))
	    (myerror "check-term" "equal types expected"
		     (term-to-type x)
		     (star-form-to-right-type kernel-type)))))
    #t)
   ((term-in-if-form? x)
    (let ((test (term-in-if-form-to-test x))
	  (alts (term-in-if-form-to-alts x))
	  (rest (term-in-if-form-to-rest x)))
      (check-term test)
      (map check-term alts)
      (let ((test-type (term-to-type test))
	    (alts-types (map term-to-type alts)))
	(if (not (alg-form? test-type))
	    (myerror "check-term" "algebra form expected" test-type))
	(let* ((alg-name (alg-form-to-name test-type))
	       (typed-constr-names
		(alg-name-to-typed-constr-names alg-name))
	       (constr-types
		(map typed-constr-name-to-type 
		     typed-constr-names))
	       (lengths-of-arg-types
		(map (lambda (x)
		       (length (arrow-form-to-arg-types x)))
		     constr-types))
	       (types (map (lambda (alt l)
			     (arrow-form-to-final-val-type
			      (term-to-type alt) l))
			   alts lengths-of-arg-types)))
	  (if (not (apply and-op (map (lambda (x) (equal? x (car types)))
				      types)))
	      (myerror "check-term" "equal types expected" types))
	  (if (not (equal? (term-to-type x) (car types)))
	      (myerror "check-term" "equal types expected"
		       (term-to-type x) (car types))))))
    #t)
   (else (myerror "check-term" "term expected" x))))

; term? is a complete test for terms.  Returns true or false.

(define (term? x)
  (if
   (not (pair? x))
   #f
   (cond
    ((term-in-var-form? x)
     (let ((var (term-in-var-form-to-var x)))
       (and (var? var)
	    (equal? (term-to-type x) (var-to-type var)))))
    ((term-in-const-form? x)
     (let ((const (term-in-const-form-to-const x)))
       (and (const? const)
	    (equal? (term-to-type x) (const-to-type const)))))
    ((term-in-abst-form? x)
     (let ((var (term-in-abst-form-to-var x))
	   (kernel (term-in-abst-form-to-kernel x)))
       (and (var? var)
	    (term? kernel)
	    (let ((var-type (var-to-type var))
		  (kernel-type (term-to-type kernel)))
	      (equal? (make-arrow var-type kernel-type)
		      (term-to-type x))))))
    ((term-in-app-form? x)
     (let ((op (term-in-app-form-to-op x))
	   (arg (term-in-app-form-to-arg x)))
       (and (term? op)
	    (term? arg)
	    (let ((op-type (term-to-type op))
		  (arg-type (term-to-type arg)))
	      (and (arrow-form? op-type)
		   (equal? (arrow-form-to-arg-type op-type)
			   arg-type)
		   (equal? (term-to-type x)
			   (arrow-form-to-val-type op-type)))))))
    ((term-in-pair-form? x)
     (let ((left (term-in-pair-form-to-left x))
	   (right (term-in-pair-form-to-right x)))
       (and (term? left)
	    (term? right)
	    (let ((left-type (term-to-type left))
		  (right-type (term-to-type right)))
	      (equal? (term-to-type x)
		      (make-star left-type right-type))))))
    ((term-in-lcomp-form? x)
     (let ((kernel (term-in-lcomp-form-to-kernel x)))
       (and (term? kernel)
	    (let ((kernel-type (term-to-type kernel)))
	      (and (star-form? kernel-type)
		   (equal? (term-to-type x)
			   (star-form-to-left-type kernel-type)))))))
    ((term-in-rcomp-form? x)
     (let ((kernel (term-in-rcomp-form-to-kernel x)))
       (and (term? kernel)
	    (let ((kernel-type (term-to-type kernel)))
	      (and (star-form? kernel-type)
		   (equal? (term-to-type x)
			   (star-form-to-right-type kernel-type)))))))
    ((term-in-if-form? x)
     (let ((test (term-in-if-form-to-test x))
	   (alts (term-in-if-form-to-alts x))
	   (rest (term-in-if-form-to-rest x)))
       (and (term? test)
	    (map term? alts)
	    (let ((test-type (term-to-type test))
		  (alts-types (map term-to-type alts)))
	      (and (alg-form? test-type)
		   (let* ((alg-name (alg-form-to-name test-type))
			  (typed-constr-names
			   (alg-name-to-typed-constr-names alg-name))
			  (constr-types
			   (map typed-constr-name-to-type
				typed-constr-names))
			  (lengths-of-arg-types
			   (map (lambda (x) 
				  (length (arrow-form-to-arg-types x)))
				constr-types))
			  (types (map (lambda (alt l)
					(arrow-form-to-final-val-type
					 (term-to-type alt) l))
				      alts lengths-of-arg-types)))
		     (and (apply and-op (map (lambda (x)
					       (equal? x (car types)))
					     types))
			  (equal? (term-to-type x) (car types)))))))))
    (else #f))))

(define ct check-term)

; 2006-05-13 Obsolete code
; (define (suc-nodes node n)
;   (do ((i 1 (+ i 1))
;        (res '() (cons (append node (list i)) res)))
;       ((> i n) (reverse res))))

; (define (iterate proc n arg)
;   (do ((i 0 (+ i 1))
;        (res arg (proc res)))
;       ((= n i) res)))


; 6-7. Substitution
; =================

; We define simultaneous substitution for type and object variables in
; a term, via tsubst and subst.  It is assumed that subst only affects
; those vars whose type is not changed by tsubst.

; In the abstraction case of the recursive definition, the abstracted
; variable may need to be renamed.  However, its type can be affected
; by tsubst.  Then the renaming cannot be made part of subst, because
; the condition above would be violated.  Therefore we carry along a
; procedure renaming variables, which remembers the renaming of
; variables done so far.

(define (make-rename tsubst)
  ;returns a procedure renaming variables, 
  ;which remembers the renaming of variables done so far.
  (let ((assoc-list '()))
    (lambda (var)
      (let* ((type (var-to-type var))
	     (new-type (type-substitute type tsubst)))
	(if (equal? type new-type)
	    var
	    (let ((info (assoc var assoc-list)))
	      (if info
		  (cadr info)
		  (let ((new-var (if (t-deg-one? (var-to-t-deg var))
				     (type-to-new-var new-type var)
				     (type-to-new-partial-var new-type var))))
		    (set! assoc-list (cons (list var new-var) assoc-list))
		    new-var))))))))

(define (term-substitute term tosubst)
  (let* ((tsubst-and-subst
	  (do ((l tosubst (cdr l))
	       (tsubst '() (if (tvar? (caar l))
			       (cons (car l) tsubst)
			       tsubst))
	       (subst '() (if (var? (caar l))
			       (cons (car l) subst)
			       subst)))
	      ((null? l) (list (reverse tsubst) (reverse subst)))))
	 (tsubst (car tsubst-and-subst))
	 (subst (cadr tsubst-and-subst))
	 (rename (make-rename tsubst)))
    (term-substitute-aux term tsubst subst rename)))

(define (var-term-equal? var term)
  (and (term-in-var-form? term)
       (equal? var (term-in-var-form-to-var term))))

(define (term-subst term arg val)
  (let ((equality?
	 (cond
	  ((and (tvar? arg) (type? val)) equal?)
	  ((and (var-form? arg) (term-form? val)) var-term-equal?)
	  (else (myerror "term-subst" "unexpected arg" arg "and val" val)))))
    (term-substitute term (make-subst-wrt equality? arg val)))) 

; In term-substitute-aux we always first rename, when a variable is
; encountered.

(define (term-substitute-aux term tsubst subst rename)
  (case (tag term) 
    ((term-in-var-form) 
     (let* ((var (rename (term-in-var-form-to-var term)))
	    (info (assoc var subst)))
       (if info
	   (cadr info)
	   (make-term-in-var-form var))))
    ((term-in-const-form)
     (make-term-in-const-form
      (const-substitute (term-in-const-form-to-const term) tsubst #t)))
    ((term-in-abst-form)
     (let* ((var (rename (term-in-abst-form-to-var term)))
	    (kernel (term-in-abst-form-to-kernel term))
	    (vars (map car subst))
	    (active-vars (intersection vars (map rename (term-to-free term))))
	    (active-subst (list-transform-positive subst
			    (lambda (x) (member (car x) active-vars))))
	    (active-terms (map cadr active-subst))
	    (info (member var (apply union (map term-to-free active-terms))))
	    (new-var (if info (var-to-new-var var) var))
	    (new-subst (if info
			   (cons (list var (make-term-in-var-form new-var))
				 active-subst)
			   active-subst)))
       (make-term-in-abst-form
	new-var
	(term-substitute-aux kernel tsubst new-subst rename))))
    ((term-in-app-form)
     (make-term-in-app-form
      (term-substitute-aux
       (term-in-app-form-to-op term) tsubst subst rename)
      (term-substitute-aux
       (term-in-app-form-to-arg term) tsubst subst rename)))
    ((term-in-pair-form)
     (make-term-in-pair-form
      (term-substitute-aux
       (term-in-pair-form-to-left term) tsubst subst rename)
      (term-substitute-aux
       (term-in-pair-form-to-right term) tsubst subst rename)))
    ((term-in-lcomp-form)
     (make-term-in-lcomp-form
      (term-substitute-aux
       (term-in-lcomp-form-to-kernel term) tsubst subst rename)))
    ((term-in-rcomp-form)
     (make-term-in-rcomp-form
      (term-substitute-aux
       (term-in-rcomp-form-to-kernel term) tsubst subst rename)))
    ((term-in-if-form)
     (apply
      make-term-in-if-form
      (cons (term-substitute-aux
	     (term-in-if-form-to-test term) tsubst subst rename)
	    (cons (map (lambda (x) (term-substitute-aux x tsubst subst rename))
		       (term-in-if-form-to-alts term))
		  (term-in-if-form-to-rest term)))))
    (else (myerror "term-substitute-aux" "term expected" term))))

(define (compose-o-substitutions subst1 subst2)
  (compose-substitutions-wrt
   term-substitute equal? var-term-equal? subst1 subst2))

(define compose-substitutions compose-o-substitutions)

; In extend-subst we assume that var and term are distinct.  The
; result is the composition of subst with (var -> term).

(define (extend-o-subst subst var term)
  (compose-o-substitutions subst (make-subst var term)))

(define extend-subst extend-o-subst)

; Display functions for substitutions:

(define (display-substitution subst)
  (display-comment "Substitution:") (newline)
  (for-each (lambda (x)
	      (let* ((var (car x))
		     (term (cadr x)))
		(if (var? var)
		    (begin (display-comment)
			   (display (var-to-string var)))
		    (myerror "display-substitution" "variable expected" var))
		(display tab)
		(display "->")
		(display tab)
		(if (term-form? term)
		    (display (term-to-string term))
		    (myerror "display-substitution" "term expected" term))
		(newline)))
	    subst))

(define (substitution-to-string subst)
  (do ((l (reverse subst) (cdr l))
       (res ""
	    (let* ((x (car l))
		   (var (if (and (list? x) (= 2 (length x)))
			    (car x)
			    (myerror
			     "substitution-to-string" "subst pair expected"
			     x)))
		   (term (cadr x)))
	      (string-append
	       (if (var? var)
		   (var-to-string var)
		   (myerror "substitution-to-string" "variable expected" var))
	       " -> "
	       (if (term-form? term)
		   (term-to-string term)
		   (myerror "substitution-to-string" "term expected" term))
	       (if (string=? "" res) "" ", ")
	       res))))
      ((null? l) res)))

; (term-gen-substitute term gen-subst) substitutes simultaneously the
; left hand sides of the alist gen-subst at all occurrences in term with
; no free variables captured by the corresponding right hand sides.
; gen-subst is an alist associating terms to terms.  Renaming takes
; place if and only if a free variable would become bound.

(define (term-gen-substitute term gen-subst)
  (car (term-gen-substitute-and-newfreeoccs term gen-subst)))

(define (term-gen-substitute-and-newfreeoccs term gen-subst)
  (let ((info (assoc-wrt term=? term gen-subst)))
    (cond
     ((null? gen-subst) (list term '()))
     (info (list (cadr info) (term-to-free (cadr info))))
     (else
      (case (tag term)
	((term-in-const-form) (list term '()))
	((term-in-abst-form)
	 (let* ((var (term-in-abst-form-to-var term))
		(kernel (term-in-abst-form-to-kernel term))
                ;substitute only those lhss without var
		(new-subst (do ((s gen-subst (cdr s))
				(res '() (if (member var
						     (term-to-free (caar s)))
					     res
					     (cons (car s) res))))
			       ((null? s) (reverse res))))
		(pair (term-gen-substitute-and-newfreeoccs kernel new-subst))
		(new-kernel (car pair))
		(new-free-occs (cadr pair)))
	   (if (member var new-free-occs)
	       (let* ((new-var (var-to-new-var var))
		      (pair1 (term-gen-substitute-and-newfreeoccs
			      kernel
			      (cons (list var new-var) new-subst)))
		      (new-kernel1 (car pair1))
		      (new-free-occs1 (cadr pair1)))
		 (list (make-term-in-abst-form new-var new-kernel1)
		       (remove new-var new-free-occs1)))
	       (list (make-term-in-abst-form var new-kernel)
		     new-free-occs))))
	((term-in-app-form)
	 (let* ((pair1 (term-gen-substitute-and-newfreeoccs
			(term-in-app-form-to-op term) gen-subst))
		(pair2 (term-gen-substitute-and-newfreeoccs
			(term-in-app-form-to-arg term) gen-subst))
		(new-op (car pair1))
		(new-arg (car pair2))
		(new-free-occs (union (cadr pair1) (cadr pair2))))
	   (list (make-term-in-app-form new-op new-arg) new-free-occs)))
	((term-in-pair-form)
	 (let* ((pair1 (term-gen-substitute-and-newfreeoccs
			(term-in-pair-form-to-left term) gen-subst))
		(pair2 (term-gen-substitute-and-newfreeoccs
			(term-in-pair-form-to-right term) gen-subst))
		(new-left (car pair1))
		(new-right (car pair2))
		(new-free-occs (union (cadr pair1) (cadr pair2))))
	   (list (make-term-in-pair-form new-left new-right) new-free-occs)))
	((term-in-lcomp-form)
	 (let* ((pair (term-gen-substitute-and-newfreeoccs
		       (term-in-lcomp-form-to-kernel term) gen-subst))
		(new-kernel (car pair))
		(new-free-occs (cadr pair)))
	   (list (make-term-in-lcomp-form new-kernel) new-free-occs)))
	((term-in-rcomp-form)
	 (let* ((pair (term-gen-substitute-and-newfreeoccs
		       (term-in-rcomp-form-to-kernel term) gen-subst))
		(new-kernel (car pair))
		(new-free-occs (cadr pair)))
	   (list (make-term-in-rcomp-form new-kernel) new-free-occs)))
	((term-in-if-form)
	 (let* ((pair (term-gen-substitute-and-newfreeoccs
		       (term-in-if-form-to-test term) gen-subst))
		(pairs
		 (map (lambda (x)
			(term-gen-substitute-and-newfreeoccs x gen-subst))
		      (term-in-if-form-to-alts term)))
		(new-test (car pair))
		(new-alts (map car pairs))
		(new-free-occs
		 (union (cadr pair) (apply union (map cadr pairs)))))
	   (list (apply make-term-in-if-form
			(cons new-test
			      (cons new-alts
				    (term-in-if-form-to-rest term))))
		 new-free-occs)))
	(else (list term '())))))))

(define (term-gen-subst term term1 term2)
  (term-gen-substitute term (list (list term1 term2))))


; 6-8. First order unification
; ============================

; unify checks whether two terms can be unified.  It returns #f, if this
; is impossible, and a most general unifier otherwise.  unify-list does
; the same for lists of terms.

(define (occurs? var term)
  (let occurs-aux ((term term))
    (case (tag term)
      ((term-in-var-form)
       (equal? var (term-in-var-form-to-var term)))
      ((term-in-const-form) #f)
      ((term-in-abst-form)
       (and (not (equal? var (term-in-abst-form-to-var term)))
	    (occurs-aux (term-in-abst-form-to-kernel term))))
      ((term-in-app-form)
       (or (occurs-aux (term-in-app-form-to-op term))
	   (occurs-aux (term-in-app-form-to-arg term))))
      ((term-in-pair-form)
       (or (occurs-aux (term-in-pair-form-to-left term))
	   (occurs-aux (term-in-pair-form-to-right term))))
      ((term-in-lcomp-form)
       (occurs-aux (term-in-lcomp-form-to-kernel term)))
      ((term-in-rcomp-form)
       (occurs-aux (term-in-rcomp-form-to-kernel term)))
      ((term-in-if-form)
       (or (occurs-aux (term-in-if-form-to-test term))
	   (do ((l (term-in-if-form-to-alts term) (cdr l)))
	       ((or (null? l) (occurs-aux (car l)))
		(not (null? l))))))
      (else (myerror "occurs?" "term expected" term)))))

(define (disagreement-pair term1 term2)
  (cond
   ((and (term-in-var-form? term1) (term-in-var-form? term2))
    (if (equal? (term-in-var-form-to-var term1)
		(term-in-var-form-to-var term2))
	#f
	(list term1 term2)))
   ((and (term-in-const-form? term1) (term-in-const-form? term2))
    (if (const=? (term-in-const-form-to-const term1)
		 (term-in-const-form-to-const term2))
	#f
	(list term1 term2)))
   ((and (term-in-abst-form? term1) (term-in-abst-form? term2))
    (let ((var1 (term-in-abst-form-to-var term1))
	  (var2 (term-in-abst-form-to-var term2))
	  (kernel1 (term-in-abst-form-to-kernel term1))
	  (kernel2 (term-in-abst-form-to-kernel term2)))
      (if (equal? var1 var2)
	  (disagreement-pair kernel1 kernel2)
	  (if (equal? (var-to-type var1)
		      (var-to-type var2))
	      (let ((newvar (var-to-new-var var1)))
		(disagreement-pair
		 (term-substitute kernel1 (list (list var1 newvar)))
		 (term-substitute kernel2 (list (list var2 newvar)))))
	      (list term1 term2)))))
   ((and (term-in-app-form? term1) (term-in-app-form? term2))
    (disagreement-pair-l
     (list (term-in-app-form-to-op term1) (term-in-app-form-to-arg term1))
     (list (term-in-app-form-to-op term2) (term-in-app-form-to-arg term2))))
   ((and (term-in-pair-form? term1) (term-in-pair-form? term2))
    (disagreement-pair-l
     (list (term-in-pair-form-to-left term1)
	   (term-in-pair-form-to-right term1))
     (list (term-in-pair-form-to-left term2)
	   (term-in-pair-form-to-right term2))))
   ((and (term-in-lcomp-form? term1) (term-in-lcomp-form? term2))
    (disagreement-pair (term-in-lcomp-form-to-kernel term1)
		       (term-in-lcomp-form-to-kernel term2)))
   ((and (term-in-rcomp-form? term1) (term-in-rcomp-form? term2))
    (disagreement-pair (term-in-rcomp-form-to-kernel term1)
		       (term-in-rcomp-form-to-kernel term2)))
   ((and (term-in-if-form? term1) (term-in-if-form? term2))
    (disagreement-pair-l
     (cons (term-in-if-form-to-test term1)
	   (term-in-if-form-to-alts term1))
     (cons (term-in-if-form-to-test term2)
	   (term-in-if-form-to-alts term2))))
   (else (list term1 term2))))

(define (disagreement-pair-l terms1 terms2)
  (cond
   ((null? terms1)
    (if (null? terms2)
	#f
	(myerror "disagreement-pair-l" "termlists of equal length expected"
		 terms1 terms2)))
   ((null? terms2)
    (myerror "disagreement-pair-l" "termlists of equal length expected"
	     terms1 terms2))
   (else (let ((a (disagreement-pair (car terms1) (car terms2))))
	   (if a
	       a
	       (disagreement-pair-l (cdr terms1) (cdr terms2)))))))

(define (unify term1 term2)
  (let unify-aux ((t1 term1) (t2 term2))
    (let ((p (disagreement-pair t1 t2)))
      (if (not p)
	  empty-subst
	  (let ((l (car p)) (r (cadr p)))
	    (cond ((and (term-in-var-form? l)
			(not (occurs? (term-in-var-form-to-var l) r)))
		   (let* ((var (term-in-var-form-to-var l))
			  (prev (unify-aux (term-subst t1 var r)
					   (term-subst t2 var r))))
		     (if prev
			 (extend-subst prev var r)
			 #f)))
		   ((and (term-in-var-form? r)
			 (not (occurs? (term-in-var-form-to-var r) l)))
		    (let* ((var (term-in-var-form-to-var r))
			   (prev (unify-aux (term-subst t1 var l)
					    (term-subst t2 var l))))
		      (if prev
			  (extend-subst prev var l)
			  #f)))
		   (else #f)))))))

(define (unify-list terms1 terms2)
  (unify (apply mk-term-in-pair-form terms1)
	 (apply mk-term-in-pair-form terms2)))

; Notice that this algorithm does not yield idempotent unifiers
; (as opposed to the Martelli-Montanari algorithm in modules/type-inf.scm):
; (display-substitution
;  (unify-list (list (pt "boole1") (pt "boole2") (pt "T"))
; 	     (list (pt "boole2") (pt "boole1") (pt "boole1"))))
; boole2	->	True
; boole1	->	boole2


; 6-9. First and second order matching
; ====================================

; match checks whether a given pattern (term or formula with type
; variables in its types) can be transformed by a type substitution
; plus an object variable instantiation - where the latter respects
; totality constraints - into a given instance, such that (1) no type
; variable from a given set of identity variables (2) no object
; variable from a given set of signature variables gets substituted.
; It returns #f, if this is impossible, and the type substitution
; appended to the object instantiation otherwise.

; match-aux is an auxiliary function.  It takes a list of match
; problems, i.e. lists of items (sig-tvars sig-vars pattern instance),
; and the substitutions built so far.  It again returns #f or a type
; substitution appended to an object instantiation.

; Example: pattern: [x]..x..n.., instance: [n]..n..m..  Then x is
; renamed into x0 and we have a recursive call to match-aux with
; pattern: ..x0..n.., instance: ..n..m.., tsubst: alpha -> nat, oinst:
; x0 -> n.

(define (match pattern instance . opt-ignore-deco-flag-and-sig-tovars)
  (let* ((sig-tvars
	  (list-transform-positive opt-ignore-deco-flag-and-sig-tovars
	    tvar-form?))
	 (sig-vars
	  (list-transform-positive opt-ignore-deco-flag-and-sig-tovars
	    var-form?))
	 (rest
	  (list-transform-positive opt-ignore-deco-flag-and-sig-tovars
	    (lambda (x)
	      (not (or (tvar-form? x) (var-form? x))))))
	 (ignore-deco-flag (if (pair? rest) (car rest) #f)))
    (match-aux (list (list sig-tvars sig-vars pattern instance))
	       ignore-deco-flag empty-subst empty-subst)))

(define (match-list patterns instances . opt-ignore-deco-flag-and-sig-tovars)
  (let* ((sig-tvars
	  (list-transform-positive opt-ignore-deco-flag-and-sig-tovars
	    tvar-form?))
	 (sig-vars
	  (list-transform-positive opt-ignore-deco-flag-and-sig-tovars
	    var-form?))
	 (rest
	  (list-transform-positive opt-ignore-deco-flag-and-sig-tovars
	    (lambda (x)
	      (not (or (tvar-form? x) (var-form? x))))))
	 (ignore-deco-flag (if (pair? rest) (car rest) #f)))
    (if (= (length patterns) (length instances))
	(match-aux (map (lambda (p i) (list sig-tvars sig-vars p i))
			patterns instances)
		   ignore-deco-flag empty-subst empty-subst)
	(apply myerror
	       (append (list "match-list" "lists of the same length expected"
			     "patterns")
		       patterns
		       (list "instances")
		       instances)))))

(define (match-aux match-problems ignore-deco-flag tsubst oinst)
  (if
   (null? match-problems)
   (append tsubst oinst)
   (let* ((match-problem (car match-problems))
	  (sig-tvars (car match-problem))
	  (sig-vars (cadr match-problem))
	  (pattern (caddr match-problem))
	  (instance (cadddr match-problem)))
     (cond
      ((term-in-var-form? pattern)
       (let* ((type1 (term-to-type pattern))
	      (type2 (term-to-type instance))
	      (var (term-in-var-form-to-var pattern))
	      (t-deg (var-to-t-deg var))
	      (tvars (type-to-free type1)))
	 (cond
	  ((term=? pattern instance)
	   (if (or (assoc var oinst)
		   (pair? (intersection tvars (map car tsubst))))
	       #f
	       (match-aux
		(map (lambda (mp)
		       (let ((sig-tvars (car mp))
			     (sig-vars (cadr mp)))
			 (cons (append tvars sig-tvars)
			       (cons (cons var sig-vars) (cddr mp)))))
		     (cdr match-problems))
		ignore-deco-flag tsubst oinst)))
	  ((member var sig-vars) #f)
	  ((assoc var oinst)
	   (and (term=? instance (cadr (assoc var oinst)))
		(match-aux (cdr match-problems)
			   ignore-deco-flag tsubst oinst)))
	  (else
	   (let ((prev-tsubst (type-match-aux
			       (list type1) (list type2) sig-tvars tsubst)))
	     (and prev-tsubst
		  (or (t-deg-zero? (var-to-t-deg var))
		      (synt-total? instance))
		  (match-aux (cdr match-problems)
			     ignore-deco-flag  prev-tsubst
			     (append oinst (list (list var instance))))))))))
      ((term-in-const-form? pattern)
       (and (term-in-const-form? instance)
	    (let* ((type1 (term-to-type pattern))
		   (type2 (term-to-type instance))
		   (const1 (term-in-const-form-to-const pattern))
		   (name1 (const-to-name const1))
		   (const2 (term-in-const-form-to-const instance))
		   (name2 (const-to-name const2)))
	      (and (string=? name1 name2)
		   (if (equal? type1 type2)
		       (match-aux (cdr match-problems)
				  ignore-deco-flag tsubst oinst)
		       (let ((prev-tsubst
			      (type-match-aux
			       (list type1) (list type2) sig-tvars tsubst)))
			 (and
			  prev-tsubst
			  (match-aux (cdr match-problems)
				     ignore-deco-flag prev-tsubst oinst))))))))
      ((term-in-abst-form? pattern)
       (and
	(term-in-abst-form? instance)
	(let* ((type1 (term-to-type pattern))
	       (type2 (term-to-type instance))
	       (var1 (term-in-abst-form-to-var pattern))
	       (kernel1 (term-in-abst-form-to-kernel pattern))
	       (var2 (term-in-abst-form-to-var instance))
	       (varterm2 (make-term-in-var-form var2))
	       (kernel2 (term-in-abst-form-to-kernel instance)))
	  (and
	   (= (var-to-t-deg var1) (var-to-t-deg var2))
	   (let* ((tsubst-from-types
		   (type-match-aux
		    (list type1) (list type2) sig-tvars tsubst))
		  (new-var1 (var-to-new-var var1))
		  (new-varterm1 (make-term-in-var-form new-var1))
		  (new-kernel1 (term-subst kernel1 var1 new-varterm1))
		  (prev (and tsubst-from-types
			     (match-aux
			      (cons (list sig-tvars sig-vars
					  new-kernel1 kernel2)
				    (cdr match-problems))
			      ignore-deco-flag
			      tsubst-from-types
			      (append oinst (list (list new-var1
							varterm2)))))))
	     (and prev
		  (let ((prev-tsubst (list-transform-positive prev
				       (lambda (x) (tvar-form? (car x)))))
			(prev-oinst (list-transform-positive prev
				      (lambda (x) (var-form? (car x))))))
		    (append prev-tsubst
			    (list-transform-positive prev-oinst
			      (lambda (x)
				(not (equal? new-var1 (car x)))))))))))))
      ((term-in-app-form? pattern)
       (and (term-in-app-form? instance)
	    (let ((op1 (term-in-app-form-to-op pattern))
		  (op2 (term-in-app-form-to-op instance))
		  (arg1 (term-in-app-form-to-arg pattern))
		  (arg2 (term-in-app-form-to-arg instance)))
	      (match-aux
	       (cons (list sig-tvars sig-vars op1 op2)
		     (cons (list sig-tvars sig-vars arg1 arg2)
			   (cdr match-problems)))
	       ignore-deco-flag tsubst oinst))))
      ((term-in-pair-form? pattern)
       (and (term-in-pair-form? instance)
	    (let ((left1 (term-in-pair-form-to-left pattern))
		  (right1 (term-in-pair-form-to-right pattern))
		  (left2 (term-in-pair-form-to-left instance))
		  (right2 (term-in-pair-form-to-right instance)))
	      (match-aux
	       (cons (list sig-tvars sig-vars left1 left2)
		     (cons (list sig-tvars sig-vars right1 right2)
			   (cdr match-problems)))
	       ignore-deco-flag tsubst oinst))))
      ((term-in-lcomp-form? pattern)
       (and (term-in-lcomp-form? instance)
	    (let ((kernel1 (term-in-lcomp-form-to-kernel pattern))
		  (kernel2 (term-in-lcomp-form-to-kernel instance)))
	      (match-aux
	       (cons (list sig-tvars sig-vars kernel1 kernel2)
		     (cdr match-problems))
	       ignore-deco-flag tsubst oinst))))
      ((term-in-rcomp-form? pattern)
       (and (term-in-rcomp-form? instance)
	    (let ((kernel1 (term-in-rcomp-form-to-kernel pattern))
		  (kernel2 (term-in-rcomp-form-to-kernel instance)))
	      (match-aux
	       (cons (list sig-tvars sig-vars kernel1 kernel2)
		     (cdr match-problems))
	       ignore-deco-flag tsubst oinst))))
      ((term-in-if-form? pattern)
       (and (term-in-if-form? instance)
	    (let* ((test1 (term-in-if-form-to-test pattern))
		   (alts1 (term-in-if-form-to-alts pattern))
		   (test2 (term-in-if-form-to-test instance))
		   (alts2 (term-in-if-form-to-alts instance)))
	      (and (= (length alts1) (length alts2))
		   (let ((new-mps
			  (map (lambda (x y)
				 (list sig-tvars sig-vars x y))
			       (cons test1 alts1) (cons test2 alts2))))
		     (match-aux (append new-mps (cdr match-problems))
				ignore-deco-flag tsubst oinst))))))
      ((bicon-form? pattern) ;to be done before inductively defined predicates
       (and
	(bicon-form? instance)
	(let* ((bicon1 (bicon-form-to-bicon pattern))
	       (bicon2 (bicon-form-to-bicon instance))
	       (bicon-eq-test (or (eq? bicon1 bicon2)
				  (and ignore-deco-flag
				       (case bicon1
					 ((imp impnc)
					  (memq bicon2 '(imp impnc)))
					 ((ord orl orr oru)
					  (memq bicon2 '(ord orl orr oru)))
					 ((andd andl andr andu)
					  (memq bicon2 '(andd andl andr andu)))
					 (else #f))))))
	  (and
	   bicon-eq-test
	   (let* ((left1 (bicon-form-to-left pattern))
		  (right1 (bicon-form-to-right pattern))
		  (left2 (bicon-form-to-left instance))
		  (right2 (bicon-form-to-right instance)))
	     (match-aux (cons (list sig-tvars sig-vars left1 left2)
			      (cons (list sig-tvars sig-vars right1 right2)
				    (cdr match-problems)))
			ignore-deco-flag tsubst oinst))))))
      ((quant-form? pattern) ;to be done before inductively defined predicates
       (and
	(quant-form? instance)
	(let* ((quant1 (quant-form-to-quant pattern))
	       (quant2 (quant-form-to-quant instance))
	       (quant-eq-test (or (eq? quant1 quant2)
				  (and ignore-deco-flag
				       (case quant1
					 ((all allnc)
					  (memq quant2 '(all allnc)))
					 ((exd exl exr exu)
					  (memq quant2 '(exd exl exr exu)))
					 ((exdt exlt exrt exut)
					  (memq quant2 '(exdt exlt exrt exut)))
					 (else #f))))))
	  (and
	   quant-eq-test
	   (let* ((vars1 (quant-form-to-vars pattern))
		  (kernel1 (quant-form-to-kernel pattern))
		  (vars2 (quant-form-to-vars instance))
		  (varterms2 (map make-term-in-var-form vars2))
		  (kernel2 (quant-form-to-kernel instance))
		  (types1 (map var-to-type vars1))
		  (types2 (map var-to-type vars2)))
	     (and
	      (equal? (map var-to-type vars1) (map var-to-type vars2))
	      (equal? (map var-to-t-deg vars1) (map var-to-t-deg vars2))
	      (let* ((tsubst-from-types
		      (type-match-aux types1 types2 sig-tvars tsubst))
		     (new-vars1 (map var-to-new-var vars1))
		     (new-varterms1 (map make-term-in-var-form new-vars1))
		     (new-kernel1 (formula-substitute
				   kernel1 (map (lambda (x y) (list x y))
						vars1 new-varterms1)))
		     (prev (and tsubst-from-types
				(match-aux
				 (cons (list sig-tvars sig-vars
					     new-kernel1 kernel2)
				       (cdr match-problems))
				 ignore-deco-flag
				 tsubst-from-types
				 (append oinst (map (lambda (x y) (list x y))
						    new-vars1 varterms2))))))
		
		(and prev
		     (let ((prev-tsubst (list-transform-positive prev
					  (lambda (x) (tvar-form? (car x)))))
			   (prev-oinst (list-transform-positive prev
					 (lambda (x) (var-form? (car x))))))
		       (append prev-tsubst
			       (list-transform-positive prev-oinst
				 (lambda (x)
				   (not (member (car x) new-vars1))))))))))))))
      ((predicate-form? pattern) ;but not an inductively defined bicon or quant
       (and
	(predicate-form? instance)
	(let* ((pred1 (predicate-form-to-predicate pattern))
	       (args1 (predicate-form-to-args pattern))
	       (pred2 (predicate-form-to-predicate instance))
	       (args2 (predicate-form-to-args instance)))
	  (and
	   (= (length args1) (length args2))
	   (let ((new-mps (map (lambda (x y) (list sig-tvars sig-vars x y))
			       args1 args2)))
	     (cond
	      ((and (pvar-form? pred1) (pvar-form? pred2)
		    (predicate-equal? pred1 pred2))
	       (match-aux (append new-mps (cdr match-problems))
			  ignore-deco-flag tsubst oinst))
	      ((and (predconst-form? pred1) (predconst-form? pred2)
		    (= (predconst-to-index pred1) (predconst-to-index pred2))
		    (string=? (predconst-to-name pred1)
			      (predconst-to-name pred2)))
	       (let* ((arity1 (predconst-to-arity pred1))
		      (arity2 (predconst-to-arity pred2))
		      (types1 (arity-to-types arity1))
		      (types2 (arity-to-types arity2))
		      (prev-tsubst
		       (type-match-aux types1 types2 sig-tvars tsubst)))
		 (and prev-tsubst
		      (match-aux (append new-mps (cdr match-problems))
				 ignore-deco-flag prev-tsubst oinst))))
	      ((and (idpredconst-form? pred1) (idpredconst-form? pred2)
		    (string=? (idpredconst-to-name pred1)
			      (idpredconst-to-name pred2)))
	       (let* ((types1 (idpredconst-to-types pred1))
		      (types2 (idpredconst-to-types pred2))
		      (prev-tsubst
		       (type-match-aux types1 types2 sig-tvars tsubst))
		      (cterms1 (idpredconst-to-cterms pred1))
		      (cterms2 (idpredconst-to-cterms pred2))
		      (aux-flas1
		       (map (lambda (x)
			      (apply mk-all
				     (append (cterm-to-vars x)
					     (list (cterm-to-formula x)))))
			    cterms1))
		      (aux-flas2
		       (map (lambda (x)
			      (apply mk-all
				     (append (cterm-to-vars x)
					     (list (cterm-to-formula x)))))
			    cterms2))
		      (new-mps-aux
		       (map (lambda (x y) (list sig-tvars sig-vars x y))
			    aux-flas1 aux-flas2)))
		 (and prev-tsubst
		      (match-aux (append
				  new-mps-aux new-mps (cdr match-problems))
				 ignore-deco-flag prev-tsubst oinst))))
	      (else #f)))))))
      ((atom-form? pattern)
       (and (atom-form? instance)
	    (let ((kernel1 (atom-form-to-kernel pattern))
		  (kernel2 (atom-form-to-kernel instance)))
	      (match-aux
	       (cons (list sig-tvars sig-vars kernel1 kernel2)
		     (cdr match-problems))
	       ignore-deco-flag tsubst oinst))))
      (else #f)))))

(define (first-match sig-tovars pattern term-or-fla)
  (let ((global-match (apply match
			     (cons pattern (cons term-or-fla sig-tovars)))))
    (if
     global-match global-match
     (case (tag term-or-fla)
       ((term-in-abst-form)
	(let ((var (term-in-abst-form-to-var term-or-fla))
	      (kernel (term-in-abst-form-to-kernel term-or-fla)))
	  (first-match sig-tovars pattern kernel)))
       ((term-in-app-form)
	(let* ((op (term-in-app-form-to-op term-or-fla))
	       (arg (term-in-app-form-to-arg term-or-fla))
	       (match1 (first-match sig-tovars pattern op)))
	  (if match1 match1
	      (first-match sig-tovars pattern arg))))
       ((term-in-pair-form)
	(let* ((left (term-in-pair-form-to-left term-or-fla))
	       (right (term-in-pair-form-to-right term-or-fla))
	       (match1 (first-match sig-tovars pattern left)))
	  (if match1 match1
	      (first-match sig-tovars pattern right))))
       ((term-in-lcomp-form)
	(let ((kernel (term-in-lcomp-form-to-kernel term-or-fla)))
	  (first-match sig-tovars pattern kernel)))
       ((term-in-rcomp-form)
	(let ((kernel (term-in-rcomp-form-to-kernel term-or-fla)))
	  (first-match sig-tovars pattern kernel)))
       ((term-in-if-form)
	(let ((test (term-in-if-form-to-test term-or-fla))
	      (alts (term-in-if-form-to-alts term-or-fla)))
	  (do ((l alts (cdr l))
	       (res (first-match sig-tovars pattern test)
		    (first-match sig-tovars pattern (car l))))
	      ((or res (null? l))
	       (if res res #f)))))
       ((predicate)
	(let ((pred (predicate-form-to-predicate term-or-fla))
	      (args (predicate-form-to-args term-or-fla)))
	  (do ((l args (cdr l))
	       (res #f (first-match
			sig-tovars pattern (car l))))
	      ((or res (null? l))
	       (if res res #f)))))
       ((atom)
	(let ((kernel (atom-form-to-kernel term-or-fla)))
	  (first-match sig-tovars pattern kernel)))
       ((imp)
	(let* ((prem (imp-form-to-premise term-or-fla))
	       (concl (imp-form-to-conclusion term-or-fla))
	       (match1 (first-match
			sig-tovars pattern prem)))
	  (if match1 match1 
	      (first-match sig-tovars pattern concl))))
       ((and)
	(let* ((left (and-form-to-left term-or-fla))
	       (right (and-form-to-right term-or-fla))
	       (match1 (first-match
			sig-tovars pattern left)))
	  (if match1 match1
	      (first-match sig-tovars pattern right))))
       ((tensor)
	(let* ((left (tensor-form-to-left term-or-fla))
	       (right (tensor-form-to-right term-or-fla))
	       (match1 (first-match sig-tovars pattern left)))
	  (if match1 match1
	      (first-match sig-tovars pattern right))))
       ((all ex allnc exnc exca excl)
	(let ((var (car (quant-form-to-vars term-or-fla)))
	      (kernel (quant-form-to-kernel term-or-fla)))
	  (first-match sig-tovars pattern kernel)))
       (else #f)))))


; match2 decides whether there is a solution.  In the positive case it
; returns one "most detailed" solution.  Heuristics: Fit largest rigid
; arguments first.  Ignore flexible arguments.

; In more detail: 

; (match2-for-tsubst pattern instance . sig-topvars) returns either #f
; or a tsubst.  In the first case instance does not match (passt nicht
; zum) pattern.  In the second case instance matches pattern if and
; only if it matches pattern substituted by tsubst, without any
; further type substitution.

; match2-for-tsubst-aux is an auxiliary function.  It takes a list of
; match2-for-tsubst problems, i.e., lists of items (sig-tvars sig-vars
; sig-pvars pattern instance), and the type substitution and object
; instantiation built so far.  It returns either #f or a type
; substitution appended to an object instantiation.

(define DIALECTICA-FLAG #t)

; We temporarily stipulate that inductively defined predicates have
; neither positive nor negative content.

(define (formula-of-nulltypep? formula)
  (cond
   ((bicon-form? formula)
    (let ((bicon (bicon-form-to-bicon formula))
	  (left (bicon-form-to-left formula))
	  (right (bicon-form-to-right formula)))
      (case bicon
	((imp impnc)
	 (and (formula-of-nulltypen? left) (formula-of-nulltypep? right)))
	((and tensor andd andl andr andu)
	 (and (formula-of-nulltypep? left) (formula-of-nulltypep? right)))
	((ord orl orr oru) #f)
	(else (myerror "formula-of-nulltypep?" "bicon expected" bicon)))))
   ((quant-form? formula)
    (let ((quant (quant-form-to-quant formula))
	  (kernel (quant-form-to-kernel formula)))
      (case quant
	((all allnc) (formula-of-nulltypep? kernel))
	((ex exd exl exdt exlt) #f)
	((exr exu exrt exut exnc) (formula-of-nulltypep? kernel))
	((exca excl excu) (formula-of-nulltypep? (unfold-formula formula)))
	(else (myerror "formula-of-nulltypep?" "quant expected" quant)))))
   ((predicate-form? formula)
    (let ((pred (predicate-form-to-predicate formula)))
      (cond ((pvar-form? pred) (not (pvar-with-positive-content? pred)))
	    ((predconst-form? pred) #t)
	    ((idpredconst-form? pred) #t))))
   ((atom-form? formula) #t)
   (else (myerror "formula-of-nulltypep?" "formula expected" formula))))

(define (formula-of-nulltypen? formula)
  (cond
   ((bicon-form? formula)
    (let ((bicon (bicon-form-to-bicon formula))
	  (left (bicon-form-to-left formula))
	  (right (bicon-form-to-right formula)))
      (case bicon
	((imp impnc)
	 (and (formula-of-nulltypep? left) (formula-of-nulltypen? right)))
	((and tensor andd andl andr andu)
	 (and (formula-of-nulltypen? left) (formula-of-nulltypen? right)))
	((ord orl orr oru)
	 (and (formula-of-nulltypen? left) (formula-of-nulltypen? right)))
	(else (myerror "formula-of-nulltypen?" "bicon expected" bicon)))))
   ((quant-form? formula)
    (let ((quant (quant-form-to-quant formula))
	  (kernel (quant-form-to-kernel formula)))
      (case quant
	((all allnc) #f)
	((ex exd exl exdt exlt exr exu exrt exut exnc)
	 (formula-of-nulltypen? kernel))
	((exca excl excu) (formula-of-nulltypen? (unfold-formula formula)))
	(else (myerror "formula-of-nulltypen?" "quant expected" quant)))))
   ((predicate-form? formula)
    (let ((pred (predicate-form-to-predicate formula)))
      (cond ((pvar-form? pred) (not (pvar-with-negative-content? pred)))
	    ((predconst-form? pred) #t)
	    ((idpredconst-form? pred) #t))))
   ((atom-form? formula) #t)
   (else (myerror "formula-of-nulltypen?" "formula expected" formula))))

; Tests

; (formula-to-etd-types (pf "(ex boole (Pvar boole)boole -> bot) -> bot"))
; ((alg "boole") (tconst "nulltype"))

; (formula-of-nulltypep? (pf "T"))
; (formula-of-nulltypen? (pf "T"))
; (formula-of-nulltypep? (pf "bot"))
; (formula-of-nulltypen? (pf "bot"))
; (formula-of-nulltypep? (pf "ex boole T"))
; (formula-of-nulltypen? (pf "ex boole T"))
; (formula-of-nulltypep? (pf "excl boole T"))
; (formula-of-nulltypen? (pf "excl boole T"))
; (formula-of-nulltypep? (pf "all boole0,boole1(T -> T)"))
; (formula-of-nulltypen? (pf "all boole0,boole1(T -> T)"))
; (pp (formula-to-etdn-type (pf "all boole0,boole1(T -> T)")))

(set! DIALECTICA-FLAG #f)

(define (match2-for-tsubst
	 pattern instance . opt-ignore-deco-flag-and-sig-topvars)
  (let* ((sig-tvars
	  (list-transform-positive opt-ignore-deco-flag-and-sig-topvars
	    tvar-form?))
	 (sig-vars
	  (list-transform-positive opt-ignore-deco-flag-and-sig-topvars
	    var-form?))
	 (sig-pvars
	  (list-transform-positive opt-ignore-deco-flag-and-sig-topvars
	    pvar-form?))
	 (rest
	  (list-transform-positive opt-ignore-deco-flag-and-sig-topvars
	    (lambda (x)
	      (not (or (tvar-form? x) (var-form? x) (pvar-form? x))))))
	 (ignore-deco-flag (if (pair? rest) (car rest) #f))
	 (prev (match2-for-tsubst-aux
		(list (list sig-tvars sig-vars sig-pvars pattern instance))
		ignore-deco-flag empty-subst empty-subst)))
    (and prev
	 (list-transform-positive prev
	   (lambda (x) (tvar-form? (car x)))))))

(define (match2-for-tsubst-aux match-problems ignore-deco-flag tsubst oinst)
  (if
   (null? match-problems)
   (append tsubst oinst)
   (let* ((match-problem (car match-problems))
	  (sig-tvars (car match-problem))
	  (sig-vars (cadr match-problem))
	  (sig-pvars (caddr match-problem))
	  (pattern (cadddr match-problem))
	  (instance (car (cddddr match-problem))))
     (cond
      ((and (term-form? pattern)
	    (term-in-var-form? (term-in-app-form-to-final-op pattern)))
       (let* ((type1 (term-to-type pattern))
	      (type2 (term-to-type instance))
	      (op (term-in-app-form-to-final-op pattern))
	      (var (term-in-var-form-to-var op))
	      (args (term-in-app-form-to-args pattern))
	      (t-deg (var-to-t-deg var))
	      (tvars (type-to-free type1)))
	 (cond
	  ((term=? pattern instance)
	   (if (or (assoc var oinst)
		   (pair? (intersection tvars (map car tsubst))))
	       #f
	       (match2-for-tsubst-aux
		(map (lambda (mp)
		       (let ((sig-tvars (car mp))
			     (sig-vars (cadr mp))
			     (sig-pvars (caddr mp)))
			 (cons (append tvars sig-tvars)
			       (cons (cons var sig-vars)
				     (cons sig-pvars (cdddr mp))))))
		     (cdr match-problems))
		ignore-deco-flag tsubst oinst)))
	  ((member var sig-vars)
	   (and (pair? args)
		(term-in-app-form? instance)
		(let ((op2 (term-in-app-form-to-final-op instance))
		      (args2 (term-in-app-form-to-args instance)))
		  (and (= (length args) (length args2))
		       (let ((new-mps
			      (map (lambda (x y)
				     (list sig-tvars sig-vars sig-pvars x y))
				   args args2)))
			 (and (equal? op op2)
			      (match2-for-tsubst-aux
			       (append new-mps (cdr match-problems))
			       ignore-deco-flag tsubst oinst)))))))
	  ((assoc var oinst)
	   (let* ((val (cadr (assoc var oinst)))
		  (subst-pattern (term-subst-and-beta0-nf pattern var val))
		  (new-mp (list sig-tvars sig-vars sig-pvars
				subst-pattern instance)))
	     (match2-for-tsubst-aux
	      (cons new-mp (cdr match-problems))
	      ignore-deco-flag tsubst oinst)))
	  ((not (or (t-deg-zero? (var-to-t-deg var)) (synt-total? instance)))
	   #f)
	  ((null? args)
	   (if (equal? type1 type2)
	       (match2-for-tsubst-aux
		(cdr match-problems)
		ignore-deco-flag tsubst
		(append oinst (list (list var instance))))
	       (let ((prev-tsubst
		      (type-match-aux
		       (list type1) (list type2) sig-tvars tsubst)))
		 (and prev-tsubst
		      (match2-for-tsubst-aux
		       (cdr match-problems)
		       ignore-deco-flag prev-tsubst
		       (append oinst (list (list var instance))))))))
	  ((term-in-app-form? instance)
	   (let* ((op1 (term-in-app-form-to-op pattern))
		  (arg1 (term-in-app-form-to-arg pattern))
		  (op2 (term-in-app-form-to-op instance))
		  (arg2 (term-in-app-form-to-arg instance))
		  (new-mp-op (list sig-tvars sig-vars sig-pvars op1 op2))
		  (new-mp-arg (list sig-tvars sig-vars sig-pvars arg1 arg2)))
	     (match2-for-tsubst-aux
	      (cons new-mp-op (cons new-mp-arg (cdr match-problems)))
	      ignore-deco-flag tsubst oinst)))
	  (else ;x rs and c
	   (if (equal? type1 type2)
	       (match2-for-tsubst-aux
		(cdr match-problems) ignore-deco-flag tsubst oinst)
	       (let ((prev-tsubst
		      (type-match-aux
		       (list type1) (list type2) sig-tvars tsubst)))
		 (and prev-tsubst
		      (match2-for-tsubst-aux
		       (cdr match-problems)
		       ignore-deco-flag prev-tsubst oinst))))))))
      ((term-in-const-form? pattern)
       (and (term-in-const-form? instance)
	    (let* ((type1 (term-to-type pattern))
		   (type2 (term-to-type instance))
		   (const1 (term-in-const-form-to-const pattern))
		   (name1 (const-to-name const1))
		   (const2 (term-in-const-form-to-const instance))
		   (name2 (const-to-name const2)))
	      (and (string=? name1 name2)
		   (if (equal? type1 type2)
		       (match2-for-tsubst-aux
			(cdr match-problems) ignore-deco-flag tsubst oinst)
		       (let ((prev-tsubst
			      (type-match-aux
			       (list type1) (list type2) sig-tvars tsubst)))
			 (and prev-tsubst
			      (match2-for-tsubst-aux
			       (cdr match-problems)
			       ignore-deco-flag prev-tsubst oinst))))))))
      ((term-in-abst-form? pattern)
       (and
	(term-in-abst-form? instance)
	(let* ((type1 (term-to-type pattern))
	       (type2 (term-to-type instance))
	       (var1 (term-in-abst-form-to-var pattern))
	       (kernel1 (term-in-abst-form-to-kernel pattern))
	       (var2 (term-in-abst-form-to-var instance))
	       (varterm2 (make-term-in-var-form var2))
	       (kernel2 (term-in-abst-form-to-kernel instance)))
	  (and
	   (= (var-to-t-deg var1) (var-to-t-deg var2))
	   (let* ((tsubst-from-types
		   (type-match-aux
		    (list type1) (list type2) sig-tvars tsubst))
		  (new-var1 (var-to-new-var var1))
		  (new-varterm1 (make-term-in-var-form new-var1))
		  (new-kernel1 (term-subst kernel1 var1 new-varterm1))
		  (prev
		   (and tsubst-from-types
			(match2-for-tsubst-aux
			 (cons (list sig-tvars sig-vars sig-pvars
				     new-kernel1 kernel2)
			       (cdr match-problems))
			 ignore-deco-flag tsubst-from-types
			 (append oinst (list (list new-var1 varterm2)))))))
	     (and prev
		  (let ((prev-tsubst (list-transform-positive prev
				       (lambda (x) (tvar-form? (car x)))))
			(prev-oinst (list-transform-positive prev
				      (lambda (x) (var-form? (car x))))))
		    (append
		     prev-tsubst
		     (list-transform-positive prev-oinst
		       (lambda (x) (not (equal? new-var1 (car x)))))))))))))
      ((term-in-app-form? pattern)
       (and (term-in-app-form? instance)
	    (let ((op1 (term-in-app-form-to-op pattern))
		  (op2 (term-in-app-form-to-op instance))
		  (arg1 (term-in-app-form-to-arg pattern))
		  (arg2 (term-in-app-form-to-arg instance)))
	      (match2-for-tsubst-aux
	       (cons (list sig-tvars sig-vars sig-pvars op1 op2)
		     (cons (list sig-tvars sig-vars sig-pvars arg1 arg2)
			   (cdr match-problems)))
	       ignore-deco-flag tsubst oinst))))
      ((term-in-pair-form? pattern)
       (and (term-in-pair-form? instance)
	    (let ((left1 (term-in-pair-form-to-left pattern))
		  (right1 (term-in-pair-form-to-right pattern))
		  (left2 (term-in-pair-form-to-left instance))
		  (right2 (term-in-pair-form-to-right instance)))
	      (match2-for-tsubst-aux
	       (cons (list sig-tvars sig-vars sig-pvars left1 left2)
		     (cons (list sig-tvars sig-vars sig-pvars right1 right2)
			   (cdr match-problems)))
	       ignore-deco-flag tsubst oinst))))      
      ((term-in-lcomp-form? pattern)
       (and (term-in-lcomp-form? instance)
	    (let ((kernel1 (term-in-lcomp-form-to-kernel pattern))
		  (kernel2 (term-in-lcomp-form-to-kernel instance)))
	      (match2-for-tsubst-aux
	       (cons (list sig-tvars sig-vars sig-pvars kernel1 kernel2)
		     (cdr match-problems))
	       ignore-deco-flag tsubst oinst))))
      ((term-in-rcomp-form? pattern)
       (and (term-in-rcomp-form? instance)
	    (let ((kernel1 (term-in-rcomp-form-to-kernel pattern))
		  (kernel2 (term-in-rcomp-form-to-kernel instance)))
	      (match2-for-tsubst-aux
	       (cons (list sig-tvars sig-vars sig-pvars kernel1 kernel2)
		     (cdr match-problems))
	       ignore-deco-flag tsubst oinst))))
      ((term-in-if-form? pattern)
       (and (term-in-if-form? instance)
	    (let* ((test1 (term-in-if-form-to-test pattern))
		   (alts1 (term-in-if-form-to-alts pattern))
		   (test2 (term-in-if-form-to-test instance))
		   (alts2 (term-in-if-form-to-alts instance)))
	      (and (= (length alts1) (length alts2))
		   (let ((new-mps
			  (map (lambda (x y)
				 (list sig-tvars sig-vars sig-pvars x y))
			       (cons test1 alts1) (cons test2 alts2))))
		     (match2-for-tsubst-aux
		      (append new-mps (cdr match-problems))
		      ignore-deco-flag tsubst oinst))))))
      ((and (predicate-form? pattern)
	    (pvar-form? (predicate-form-to-predicate pattern)))
       (let* ((pvar (predicate-form-to-predicate pattern))
	      (args (predicate-form-to-args pattern))
	      (arity1 (pvar-to-arity pvar))
	      (types (arity-to-types arity1))
	      (tvars (apply append (map type-to-free types))))
	 (cond
	  ((formula=? pattern instance)
	   (if (pair? (intersection tvars (map car tsubst)))
	       #f
	       (match2-for-tsubst-aux
		(map (lambda (mp)
		       (let ((sig-tvars (car mp))
			     (sig-vars (cadr mp))
			     (sig-pvars (caddr mp)))
			 (cons sig-tvars
			       (cons sig-vars
				     (cons (cons pvar sig-pvars)
					   (cdddr mp))))))
		     (cdr match-problems))
		ignore-deco-flag tsubst oinst)))
	  ((member pvar sig-pvars)
	   (and (pair? args)
		(predicate-form? instance)
		(let ((pred2 (predicate-form-to-predicate instance))
		      (args2 (predicate-form-to-args instance)))
		  (and (= (length args) (length args2))
		       (let ((new-mps
			      (map (lambda (x y)
				     (list sig-tvars sig-vars sig-pvars x y))
				   args args2)))
			 (and (equal? pvar pred2)
			      (match2-for-tsubst-aux
			       (append new-mps (cdr match-problems))
			       ignore-deco-flag tsubst oinst)))))))
	  (else
	   (and (if DIALECTICA-FLAG
		    (and (or (formula-of-nulltypep? instance)
			     (pvar-with-positive-content? pvar))
			 (or (formula-of-nulltypen? instance)
			     (pvar-with-negative-content? pvar)))
		    (or (formula-of-nulltype? instance)
			(pvar-with-positive-content? pvar)))
		(match2-for-tsubst-aux
		 (cdr match-problems)
		 ignore-deco-flag tsubst oinst))))))
      ((bicon-form? pattern)
       (and
	(bicon-form? instance)
	(let* ((bicon1 (bicon-form-to-bicon pattern))
	       (bicon2 (bicon-form-to-bicon instance))
	       (bicon-eq-test (or (eq? bicon1 bicon2)
				  (and ignore-deco-flag
				       (case bicon1
					 ((imp impnc)
					  (memq bicon2 '(imp impnc)))
					 ((ord orl orr oru)
					  (memq bicon2 '(ord orl orr oru)))
					 ((andd andl andr andu)
					  (memq bicon2 '(andd andl andr andu)))
					 (else #f))))))
	  (and
	   bicon-eq-test
	   (let* ((left1 (bicon-form-to-left pattern))
		  (right1 (bicon-form-to-right pattern))
		  (left2 (bicon-form-to-left instance))
		  (right2 (bicon-form-to-right instance)))
	     (match2-for-tsubst-aux
	      (cons (list sig-tvars sig-vars sig-pvars left1 left2)
		    (cons (list sig-tvars sig-vars sig-pvars right1 right2)
			  (cdr match-problems)))
	      ignore-deco-flag tsubst oinst))))))
      ((quant-form? pattern)
       (and
	(quant-form? instance)
	(let* ((quant1 (quant-form-to-quant pattern))
	       (quant2 (quant-form-to-quant instance))
	       (quant-eq-test (or (eq? quant1 quant2)
				  (and ignore-deco-flag
				       (case quant1
					 ((all allnc)
					  (memq quant2 '(all allnc)))
					 ((exd exl exr exu)
					  (memq quant2 '(exd exl exr exu)))
					 ((exdt exlt exrt exut)
					  (memq quant2 '(exdt exlt exrt exut)))
					 (else #f))))))
	  (and
	   quant-eq-test
	   (let* ((vars1 (quant-form-to-vars pattern))
		  (kernel1 (quant-form-to-kernel pattern))
		  (vars2 (quant-form-to-vars instance))
		  (varterms2 (map make-term-in-var-form vars2))
		  (kernel2 (quant-form-to-kernel instance))
		  (types1 (map var-to-type vars1))
		  (types2 (map var-to-type vars2)))
	     (and
	      (equal? (map var-to-t-deg vars1) (map var-to-t-deg vars2))
	      (let* ((tsubst-from-types
		      (type-match-aux types1 types2 sig-tvars tsubst))
		     (new-vars1 (map var-to-new-var vars1))
		     (new-varterms1 (map make-term-in-var-form new-vars1))
		     (new-kernel1 (formula-substitute
				   kernel1 (map (lambda (x y) (list x y))
						vars1 new-varterms1)))
		     (prev (and tsubst-from-types
				(match2-for-tsubst-aux
				 (cons (list sig-tvars sig-vars sig-pvars
					     new-kernel1 kernel2)
				       (cdr match-problems))
				 ignore-deco-flag tsubst-from-types
				 (append oinst
					 (map (lambda (x y) (list x y))
					      new-vars1 varterms2))))))
		(and prev
		     (let ((prev-tsubst (list-transform-positive prev
					  (lambda (x) (tvar-form? (car x)))))
			   (prev-oinst (list-transform-positive prev
					 (lambda (x) (var-form? (car x))))))
		       (append prev-tsubst
			       (list-transform-positive prev-oinst
				 (lambda (x)
				   (not (member (car x) new-vars1))))))))))))))
      ((predicate-form? pattern) ;but not with a predicate variable
       (and
	(predicate-form? instance)
	(let ((pred1 (predicate-form-to-predicate pattern))
	      (args1 (predicate-form-to-args pattern))
	      (pred2 (predicate-form-to-predicate instance))
	      (args2 (predicate-form-to-args instance)))
	  (and
	   (= (length args1) (length args2))
	   (let ((new-mps
		  (map (lambda (x y) (list sig-tvars sig-vars sig-pvars x y))
		       args1 args2)))
	     (cond
	      ((and (predconst-form? pred1) (predconst-form? pred2)
		    (= (predconst-to-index pred1) (predconst-to-index pred2))
		    (string=? (predconst-to-name pred1)
			      (predconst-to-name pred2)))
	       (let* ((arity1 (predconst-to-arity pred1))
		      (arity2 (predconst-to-arity pred2))
		      (types1 (arity-to-types arity1))
		      (types2 (arity-to-types arity2))
		      (prev-tsubst
		       (type-match-aux types1 types2 sig-tvars tsubst)))
		 (and prev-tsubst
		      (match2-for-tsubst-aux
		       (append new-mps (cdr match-problems))
		       ignore-deco-flag prev-tsubst oinst))))
	      ((and (idpredconst-form? pred1) (idpredconst-form? pred2)
		    (string=? (idpredconst-to-name pred1)
			      (idpredconst-to-name pred2)))
	       (let* ((types1 (idpredconst-to-types pred1))
		      (types2 (idpredconst-to-types pred2))
		      (prev-tsubst
		       (type-match-aux types1 types2 sig-tvars tsubst)))
		 (and prev-tsubst
		      (match2-for-tsubst-aux
		       (append new-mps (cdr match-problems))
		       ignore-deco-flag prev-tsubst oinst))))
	      (else #f)))))))
      ((atom-form? pattern)
       (and (atom-form? instance)
	    (let ((kernel1 (atom-form-to-kernel pattern))
		  (kernel2 (atom-form-to-kernel instance)))
	      (match2-for-tsubst-aux
	       (cons (list sig-tvars sig-vars sig-pvars kernel1 kernel2)
		     (cdr match-problems))
	       ignore-deco-flag tsubst oinst))))
      (else #f)))))

; match2 checks whether a given pattern (term or formula with type
; variables in its types) can be transformed by a type substitution
; plus an at most second order object variable instantiation plus an
; at most second order predicate variable instantiation - where the
; latter two respect totality constraints - into a given instance,
; such that no variable from three given sets of signature type,
; object and predicate gets substituted.  It returns #f, if this is
; impossible, and the type substitution appended to the object and
; predicate instantiation otherwise.

; To do this, match2 first applies match2-for-tsubst.  If a tsubst is
; found, pattern is substituted by tsubst, and object and predicate
; variables are renamed accordingly.  Then match2-aux is called.  It
; takes a list of match problems, i.e., lists of items (sig-vars
; sig-pvars pattern instance), and the substitutions built so far.  It
; returns #f or a substitution appended to a predicate instantiation.
; These substitutions are then composed with with renaming-subst and
; renaming-psubst (and cleaned), and tsubst is appended.

(define (match2 pattern instance . opt-ignore-deco-flag-and-sig-topvars)
  (let ((tsubst (apply match2-for-tsubst
		       (append (list pattern instance)
			       opt-ignore-deco-flag-and-sig-topvars))))
    (and
     tsubst
     (let* ((sig-vars
	     (list-transform-positive opt-ignore-deco-flag-and-sig-topvars
	       var-form?))
	    (sig-pvars
	     (list-transform-positive opt-ignore-deco-flag-and-sig-topvars
	       pvar-form?))
	    (rest
	     (list-transform-positive opt-ignore-deco-flag-and-sig-topvars
	       (lambda (x)
		 (not (or (tvar-form? x) (var-form? x) (pvar-form? x))))))
	    (ignore-deco-flag (if (pair? rest) (car rest) #f))
	    (rename (make-rename tsubst))
	    (prename (make-prename tsubst))
	    (subst-pattern
	     (if (term-form? pattern)
		 (term-substitute-aux pattern tsubst empty-subst rename)
		 (formula-substitute-aux
		  pattern tsubst empty-subst empty-subst rename prename)))
	    (prev (match2-aux
		   (list (list sig-vars sig-pvars
			       subst-pattern
			       instance))
		   ignore-deco-flag empty-subst empty-subst)))
       (and prev
	    (let* ((free (if (term-form? pattern)
			     (term-to-free pattern)
			     (formula-to-free pattern)))
		   (renaming-subst
		    (map (lambda (var)
			   (list var (make-term-in-var-form (rename var))))
			 free))
		   (pvars (if (term-form? pattern)
			      '()
			      (formula-to-pvars pattern)))
		   (renaming-psubst
		    (map (lambda (pvar)
			   (list pvar (predicate-to-cterm (prename pvar))))
			 pvars))
		   (subst (list-transform-positive prev
			    (lambda (x) (var-form? (car x)))))
		   (psubst (list-transform-positive prev
			     (lambda (x) (pvar-form? (car x)))))
		   (composed-subst
		    (compose-substitutions renaming-subst subst))
		   (cleaned-composed-subst
		    (list-transform-positive composed-subst
		      (lambda (x) (member (car x) free))))
		   (composed-psubst
		    (compose-p-substitutions renaming-psubst psubst))
		   (cleaned-composed-psubst
		    (list-transform-positive composed-psubst
		      (lambda (x) (member (car x) pvars)))))
	      (append tsubst
		      cleaned-composed-subst
		      cleaned-composed-psubst)))))))

(define (match2-aux match-problems ignore-deco-flag subst psubst)
  (if
   (null? match-problems)
   (append subst psubst)
   (let* ((match-problem (car match-problems))
	  (sig-vars (car match-problem))
	  (sig-pvars (cadr match-problem))
	  (pattern (caddr match-problem))
	  (instance (cadddr match-problem)))
     (cond
      ((and (term-form? pattern)
	    (term-in-var-form? (term-in-app-form-to-final-op pattern)))
       (let* ((type1 (term-to-type pattern))
	      (type2 (term-to-type instance))
	      (op (term-in-app-form-to-final-op pattern))
	      (var (term-in-var-form-to-var op))
	      (args (term-in-app-form-to-args pattern))
	      (t-deg (var-to-t-deg var))
	      (tvars (type-to-free type1)))
	 (cond
	  ((term=? pattern instance)
	   (if (assoc var subst)
	       #f
	       (match2-aux
		(map (lambda (mp)
		       (let ((sig-vars (car mp)))
			 (cons (cons var sig-vars) (cdr mp))))
		     (cdr match-problems))
		ignore-deco-flag subst psubst)))
	  ((member var sig-vars)
	   (and (pair? args)
		(term-in-app-form? instance)
		(let ((op2 (term-in-app-form-to-final-op instance))
		      (args2 (term-in-app-form-to-args instance)))
		  (let ((new-mps
			 (map (lambda (x y)
				(list sig-vars sig-pvars x y))
			      args args2)))
		    (and (equal? op op2)
			 (match2-aux
			  (append new-mps (cdr match-problems))
			  ignore-deco-flag subst psubst))))))
	  ((assoc var subst)
	   (let* ((val (cadr (assoc var subst)))
		  (subst-pattern (term-subst-and-beta0-nf pattern var val))
		  (new-mp (list sig-vars sig-pvars subst-pattern instance)))
	     (match2-aux
	      (cons new-mp (cdr match-problems))
	      ignore-deco-flag subst psubst)))
	  ((or (t-deg-zero? (term-to-t-deg pattern))
	       (synt-total? instance))
	   (let* ((args-and-new-vars
		   (map (lambda (arg)
			  (list arg (type-to-new-var (term-to-type arg))))
			args))
		  (new-vars (map cadr args-and-new-vars))
		  (rigid-args-and-new-vars
		   (list-transform-positive args-and-new-vars
		     (lambda (arg-and-new-var)
		       (let* ((arg (car arg-and-new-var))
			      (head (term-in-app-form-to-final-op arg)))
			 (or (not (term-in-var-form? head))
			     (let ((var (term-in-var-form-to-var head)))
			       (or (member var sig-vars)
				   (assoc var subst))))))))
		  (sorted-rigid-args-and-new-vars
		   (insertsort (lambda (x y) (> (term-to-length (car x))
						(term-to-length (car y))))
			       rigid-args-and-new-vars))
		  (sorted-rigid-args (map car sorted-rigid-args-and-new-vars))
		  (sorted-new-vars (map cadr sorted-rigid-args-and-new-vars))
		  (subst-sorted-rigid-args
		   (map (lambda (arg) (term-substitute arg subst))
			sorted-rigid-args))
		  (new-orig-instance
		   (do ((ts subst-sorted-rigid-args (cdr ts))
			(xs (map make-term-in-var-form sorted-new-vars)
			    (cdr xs))
			(res instance
			     (term-gen-subst res (car ts) (car xs))))
		       ((null? ts) res)))
		  (abstr-new-orig-instance
		   (apply mk-term-in-abst-form
			  (append new-vars (list new-orig-instance)))))
	     (match2-aux
	      (cdr match-problems)
	      ignore-deco-flag
	      (if (equal? (make-term-in-var-form var)
			  (nt abstr-new-orig-instance))
		  subst
		  (append subst (list (list var abstr-new-orig-instance))))
	      psubst)))
	  (else #f))))
      ((term-in-const-form? pattern)
       (and (term-in-const-form? instance)
	    (let* ((type1 (term-to-type pattern))
		   (type2 (term-to-type instance))
		   (const1 (term-in-const-form-to-const pattern))
		   (name1 (const-to-name const1))
		   (const2 (term-in-const-form-to-const instance))
		   (name2 (const-to-name const2)))
	      (and (string=? name1 name2)
		   (equal? type1 type2)
		   (match2-aux (cdr match-problems)
			       ignore-deco-flag subst psubst)))))
      ((term-in-abst-form? pattern)
       (and
	(term-in-abst-form? instance)
	(let* ((type1 (term-to-type pattern))
	       (type2 (term-to-type instance))
	       (var1 (term-in-abst-form-to-var pattern))
	       (kernel1 (term-in-abst-form-to-kernel pattern))
	       (var2 (term-in-abst-form-to-var instance))
	       (varterm2 (make-term-in-var-form var2))
	       (kernel2 (term-in-abst-form-to-kernel instance)))
	  (and
	   (equal? type1 type2)
	   (= (var-to-t-deg var1) (var-to-t-deg var2))
	   (let* ((new-var1 (var-to-new-var var1))
		  (new-varterm1 (make-term-in-var-form new-var1))
		  (new-kernel1 (term-subst kernel1 var1 new-varterm1))
		  (prev (match2-aux
			 (cons (list sig-vars sig-pvars new-kernel1 kernel2)
			       (cdr match-problems))
			 ignore-deco-flag
			 (append subst (list (list new-var1 varterm2)))
			 psubst)))
	     (and prev
		  (let ((prev-subst (list-transform-positive prev
				      (lambda (x) (var-form? (car x)))))
			(prev-psubst (list-transform-positive prev
				       (lambda (x) (pvar-form? (car x))))))
		    (append (list-transform-positive prev-subst
			      (lambda (x) (not (equal? new-var1 (car x)))))
			    psubst))))))))
      ((term-in-app-form? pattern)
       (and (term-in-app-form? instance)
	    (let ((op1 (term-in-app-form-to-op pattern))
		  (op2 (term-in-app-form-to-op instance))
		  (arg1 (term-in-app-form-to-arg pattern))
		  (arg2 (term-in-app-form-to-arg instance)))
	      (match2-aux
	       (cons (list sig-vars sig-pvars op1 op2)
		     (cons (list sig-vars sig-pvars arg1 arg2)
			   (cdr match-problems)))
	       ignore-deco-flag subst psubst))))
      ((term-in-pair-form? pattern)
       (and (term-in-pair-form? instance)
	    (let ((left1 (term-in-pair-form-to-left pattern))
		  (right1 (term-in-pair-form-to-right pattern))
		  (left2 (term-in-pair-form-to-left instance))
		  (right2 (term-in-pair-form-to-right instance)))
	      (match2-aux
	       (cons (list sig-vars sig-pvars left1 left2)
		     (cons (list sig-vars sig-pvars right1 right2)
			   (cdr match-problems)))
	       ignore-deco-flag subst psubst))))      
      ((term-in-lcomp-form? pattern)
       (and (term-in-lcomp-form? instance)
	    (let ((kernel1 (term-in-lcomp-form-to-kernel pattern))
		  (kernel2 (term-in-lcomp-form-to-kernel instance)))
	      (match2-aux (cons (list sig-vars sig-pvars kernel1 kernel2)
				(cdr match-problems))
			  ignore-deco-flag subst psubst))))
      ((term-in-rcomp-form? pattern)
       (and (term-in-rcomp-form? instance)
	    (let ((kernel1 (term-in-rcomp-form-to-kernel pattern))
		  (kernel2 (term-in-rcomp-form-to-kernel instance)))
	      (match2-aux (cons (list sig-vars sig-pvars kernel1 kernel2)
				(cdr match-problems))
			  ignore-deco-flag subst psubst))))
      ((term-in-if-form? pattern)
       (and (term-in-if-form? instance)
	    (let* ((test1 (term-in-if-form-to-test pattern))
		   (alts1 (term-in-if-form-to-alts pattern))
		   (test2 (term-in-if-form-to-test instance))
		   (alts2 (term-in-if-form-to-alts instance)))
	      (and (= (length alts1) (length alts2))
		   (let ((new-mps
			  (map (lambda (x y) (list sig-vars sig-pvars x y))
			       (cons test1 alts1) (cons test2 alts2))))
		     (match2-aux (append new-mps (cdr match-problems))
				 ignore-deco-flag subst psubst))))))
      ((and (predicate-form? pattern)
	    (pvar-form? (predicate-form-to-predicate pattern)))
       (let* ((pvar (predicate-form-to-predicate pattern))
	      (args (predicate-form-to-args pattern)))
	 (cond
	  ((formula=? pattern instance)
	   (if (assoc pvar psubst)
	       #f
	       (match2-aux
		(map (lambda (mp)
		       (let ((sig-vars (car mp))
			     (sig-pvars (cadr mp)))
			 (cons sig-vars
			       (cons (cons pvar sig-pvars)
				     (cddr mp)))))
		     (cdr match-problems))
		ignore-deco-flag subst psubst)))
	  ((member pvar sig-pvars)
	   (and (pair? args)
		(predicate-form? instance)
		(let ((pred2 (predicate-form-to-predicate instance))
		      (args2 (predicate-form-to-args instance)))
		  (and (= (length args) (length args2))
		       (let ((new-mps
			      (map (lambda (x y)
				     (list sig-vars sig-pvars x y))
				   args args2)))
			 (and (equal? pvar pred2)
			      (match2-aux
			       (append new-mps (cdr match-problems))
			       ignore-deco-flag subst psubst)))))))
	  ((assoc pvar psubst)
	   (let* ((val (cadr (assoc pvar psubst)))
		  (pattern-as-cterm (predicate-to-cterm
				     (predicate-form-to-predicate pattern)))
		  (subst-pattern (cterm-to-formula
				  (cterm-subst pattern-as-cterm pvar val)))
		  (new-mp (list sig-vars sig-pvars subst-pattern instance)))
	     (match2-aux (cons new-mp (cdr match-problems))
			 ignore-deco-flag subst psubst)))
	  ((if DIALECTICA-FLAG
	       (and (or (formula-of-nulltypep? instance)
			(pvar-with-positive-content? pvar))
		    (or (formula-of-nulltypen? instance)
			(pvar-with-negative-content? pvar)))
	       (or (formula-of-nulltype? instance)
		   (pvar-with-positive-content? pvar)))
	   (let* ((free-vars-of-instance (formula-to-free instance))
		  (args-and-new-vars
		   (map (lambda (arg)
			  (if (and (term-in-var-form? arg)
				   (member (term-in-var-form-to-var arg)
					   free-vars-of-instance))
			      (list arg (term-in-var-form-to-var arg))
			      (list arg (if (synt-total? arg)
					    (type-to-new-var
					     (term-to-type arg))
					    (type-to-new-partial-var
					     (term-to-type arg))))))
			args))
		  (new-vars (map cadr args-and-new-vars))
		  (rigid-args-and-new-vars
		   (list-transform-positive args-and-new-vars
		     (lambda (arg-and-new-var)
		       (let* ((arg (car arg-and-new-var))
			      (head (term-in-app-form-to-final-op arg)))
			 (or (not (term-in-var-form? head))
			     (let ((var (term-in-var-form-to-var head)))
			       (or (member var sig-vars)
				   (assoc var subst))))))))
		  (sorted-rigid-args-and-new-vars
		   (insertsort (lambda (x y) (> (term-to-length (car x))
						(term-to-length (car y))))
			       rigid-args-and-new-vars))
		  (sorted-rigid-args (map car sorted-rigid-args-and-new-vars))
		  (sorted-new-vars (map cadr sorted-rigid-args-and-new-vars))
		  (subst-sorted-rigid-args
		   (map (lambda (arg) (term-substitute arg subst))
			sorted-rigid-args))
		  (new-orig-instance
		   (do ((ts subst-sorted-rigid-args (cdr ts))
			(xs (map make-term-in-var-form sorted-new-vars)
			    (cdr xs))
			(res instance
			     (formula-gen-subst res (car ts) (car xs))))
		       ((null? ts) res)))
		  (new-orig-cterm
		   (apply make-cterm
			  (append new-vars (list new-orig-instance)))))
	     (match2-aux
	      (cdr match-problems)
	      ignore-deco-flag
	      subst (append psubst (list (list pvar new-orig-cterm))))))
	  (else #f))))
      ((bicon-form? pattern) ;to be done before inductively defined predicates
       (and
	(bicon-form? instance)
	(let* ((bicon1 (bicon-form-to-bicon pattern))
	       (bicon2 (bicon-form-to-bicon instance))
	       (bicon-eq-test (or (eq? bicon1 bicon2)
				  (and ignore-deco-flag
				       (case bicon1
					 ((imp impnc)
					  (memq bicon2 '(imp impnc)))
					 ((ord orl orr oru)
					  (memq bicon2 '(ord orl orr oru)))
					 ((andd andl andr andu)
					  (memq bicon2 '(andd andl andr andu)))
					 (else #f))))))
	  (and
	   bicon-eq-test
	   (let* ((left1 (bicon-form-to-left pattern))
		  (right1 (bicon-form-to-right pattern))
		  (left2 (bicon-form-to-left instance))
		  (right2 (bicon-form-to-right instance)))
	     (match2-aux (cons (list sig-vars sig-pvars left1 left2)
			       (cons (list sig-vars sig-pvars right1 right2)
				     (cdr match-problems)))
			 ignore-deco-flag subst psubst))))))
      ((quant-form? pattern) ;to be done before inductively defined predicates
       (and
	(quant-form? instance)
	(let* ((quant1 (quant-form-to-quant pattern))
	       (quant2 (quant-form-to-quant instance))
	       (quant-eq-test (or (eq? quant1 quant2)
				  (and ignore-deco-flag
				       (case quant1
					 ((all allnc)
					  (memq quant2 '(all allnc)))
					 ((exd exl exr exu)
					  (memq quant2 '(exd exl exr exu)))
					 ((exdt exlt exrt exut)
					  (memq quant2 '(exdt exlt exrt exut)))
					 (else #f))))))
	  (and
	   quant-eq-test
	   (let* ((vars1 (quant-form-to-vars pattern))
		  (kernel1 (quant-form-to-kernel pattern))
		  (vars2 (quant-form-to-vars instance))
		  (varterms2 (map make-term-in-var-form vars2))
		  (kernel2 (quant-form-to-kernel instance))
		  (types1 (map var-to-type vars1))
		  (types2 (map var-to-type vars2)))
	     (and
	      (equal? (map var-to-type vars1) (map var-to-type vars2))
	      (equal? (map var-to-t-deg vars1) (map var-to-t-deg vars2))
	      (let* ((new-vars1 (map var-to-new-var vars1))
		     (new-varterms1 (map make-term-in-var-form new-vars1))
		     (new-kernel1 (formula-substitute
				   kernel1 (map (lambda (x y) (list x y))
						vars1 new-varterms1)))
		     (prev (match2-aux
			    (cons (list sig-vars sig-pvars new-kernel1 kernel2)
				  (cdr match-problems))
			    ignore-deco-flag
			    (append subst (map (lambda (x y) (list x y))
					       new-vars1 varterms2))
			    psubst)))
		(and prev
		     (let ((prev-subst (list-transform-positive prev
					 (lambda (x) (var-form? (car x)))))
			   (prev-psubst (list-transform-positive prev
					  (lambda (x) (pvar-form? (car x))))))
		       (append (list-transform-positive prev-subst
				 (lambda (x) (not (member (car x) new-vars1))))
			       prev-psubst))))))))))
      ((predicate-form? pattern) ;but not with a predicate variable
       (and
	(predicate-form? instance)
	(let ((pred1 (predicate-form-to-predicate pattern))
	      (args1 (predicate-form-to-args pattern))
	      (pred2 (predicate-form-to-predicate instance))
	      (args2 (predicate-form-to-args instance)))
	  (and
	   (= (length args1) (length args2))
	   (let ((new-mps (map (lambda (x y) (list sig-vars sig-pvars x y))
			       args1 args2)))
	     (cond
	      ((and (predconst-form? pred1) (predconst-form? pred2)
		    (= (predconst-to-index pred1) (predconst-to-index pred2))
		    (string=? (predconst-to-name pred1)
			      (predconst-to-name pred2)))
	       (let* ((arity1 (predconst-to-arity pred1))
		      (arity2 (predconst-to-arity pred2))
		      (types1 (arity-to-types arity1))
		      (types2 (arity-to-types arity2)))
		 (and (equal? types1 types2)
		      (match2-aux
		       (append new-mps (cdr match-problems))
		       ignore-deco-flag subst psubst))))
	      ((and (idpredconst-form? pred1) (idpredconst-form? pred2)
		    (string=? (idpredconst-to-name pred1)
			      (idpredconst-to-name pred2)))
	       (let* ((types1 (idpredconst-to-types pred1))
		      (types2 (idpredconst-to-types pred2))
		      (cterms1 (idpredconst-to-cterms pred1))
		      (cterms2 (idpredconst-to-cterms pred2))
		      (aux-flas1
		       (map (lambda (x)
			      (apply mk-all
				     (append (cterm-to-vars x)
					     (list (cterm-to-formula x)))))
			    cterms1))
		      (aux-flas2
		       (map (lambda (x)
			      (apply mk-all
				     (append (cterm-to-vars x)
					     (list (cterm-to-formula x)))))
			    cterms2))
		      (new-mps-aux
		       (map (lambda (x y) (list sig-vars sig-pvars x y))
			    aux-flas1 aux-flas2)))
		 (and (equal? types1 types2)
		      (match2-aux (append
				   new-mps-aux new-mps (cdr match-problems))
				  ignore-deco-flag subst psubst))))
	      (else #f)))))))
      ((atom-form? pattern)
       (and (atom-form? instance)
	    (let ((kernel1 (atom-form-to-kernel pattern))
		  (kernel2 (atom-form-to-kernel instance)))
	      (match2-aux (cons (list sig-vars sig-pvars kernel1 kernel2)
				(cdr match-problems))
			  ignore-deco-flag subst psubst))))
      (else #f)))))


; 6-10. Pattern unification
; =========================

; A pattern (more precisely a higher order pattern) is an expression
; (i.e. a term or a formula) in beta normal form with the property
; that every ``flexible'' variable y occurs in a context yx1...xn with
; distinct ``forbidden'' (for substitutions) variables x1...xn.
; Forbidden variables are the ones bound further outside, or given
; explicitely as forbidden.  Comments:
; - yx1...xn need not be of ground type.
; - eta-expansion of the xi is not allowed (for simplicity).

(define (pattern? expr flex-vars forb-vars)
  (cond
   ((term-form? expr)
    (case (tag expr)
      ((term-in-app-form)
       (let* ((op (term-in-app-form-to-final-op expr))
	      (args (term-in-app-form-to-args expr)))
	 (if (and (term-in-var-form? op)
		  (member (term-in-var-form-to-var op) flex-vars))
	     (and (apply and-op (map term-in-var-form? args))
		  (let ((argvars (map term-in-var-form-to-var args)))
		    (and (equal? argvars (remove-duplicates argvars))
			 (null? (set-minus argvars forb-vars)))))
	     (apply and-op (map (lambda (x) (pattern? x flex-vars forb-vars))
				args)))))
      ((term-in-abst-form)
       (let ((var (term-in-abst-form-to-var expr))
	     (kernel (term-in-abst-form-to-kernel expr)))
	 (if (or (member var flex-vars) (member var forb-vars))
	     (let* ((new-var (var-to-new-var var))
		    (new-kernel
		     (term-subst kernel var (make-term-in-var-form new-var))))
	       (pattern? new-kernel flex-vars (cons new-var forb-vars)))
	     (pattern? kernel flex-vars (cons var forb-vars)))))
      ((term-in-var-form term-in-const-form)
       #t)
      ((term-in-pair-form)
       (and (pattern? (term-in-pair-form-to-left expr) flex-vars forb-vars)
	    (pattern? (term-in-pair-form-to-right expr) flex-vars forb-vars)))
      ((term-in-lcomp-form)
       (pattern? (term-in-lcomp-form-to-kernel expr) flex-vars forb-vars))
      ((term-in-rcomp-form)
       (pattern? (term-in-rcomp-form-to-kernel expr) flex-vars forb-vars))
      ((term-in-if-form)
       (apply and-op (map (lambda (x) (pattern? x flex-vars forb-vars))
			  (cons (term-in-if-form-to-test expr)
				(term-in-if-form-to-alts expr)))))
      (else (myerror "pattern?" "term expected" expr))))
   ((formula-form? expr)
    (case (tag expr)
      ((atom)
       (pattern? (atom-form-to-kernel expr) flex-vars forb-vars))
      ((predicate)
       (apply and-op (map (lambda (x) (pattern? x flex-vars forb-vars))
			  (predicate-form-to-args expr))))
      ((imp)
       (and (pattern? (imp-form-to-premise expr) flex-vars forb-vars)
	    (pattern? (imp-form-to-conclusion expr) flex-vars forb-vars)))
      ((and)
       (and (pattern? (and-form-to-left expr) flex-vars forb-vars)
	    (pattern? (and-form-to-right expr) flex-vars forb-vars)))
      ((tensor)
       (and (pattern? (tensor-form-to-left expr) flex-vars forb-vars)
	    (pattern? (tensor-form-to-right expr) flex-vars forb-vars)))
      ((all ex allnc exnc exca excl)
       (let ((vars (quant-form-to-vars expr))
	     (kernel (quant-form-to-kernel expr)))
	 (if (or (pair? (intersection vars flex-vars))
		 (pair? (intersection vars forb-vars)))
	     (let* ((new-vars (map var-to-new-var vars))
		    (new-kernel
		     (formula-substitute
		      kernel (make-substitution
			      vars (map make-term-in-var-form new-vars)))))
	       (pattern? new-kernel flex-vars (append new-vars forb-vars)))
	     (pattern? kernel flex-vars (append vars forb-vars)))))
      (else (myerror "pattern?" "formula expected" expr))))
   (else (myerror "pattern?" "term or formula expected" expr))))

; The main function pattern-unify implements in a slightly modified form
; Miller's pattern unification algorithm from Miller (J. Logic Computat.
; Vol. 1, 1991).  The modification consists in changing the order of
; steps: raising is postponed until it is needed, to avoid unnecessary
; creation of new variables.  It is obtained by iterating a one-step
; function pattern-unify1, implementing the step from a state formula S
; to either #f, indicating that there is no unifier, or else a pair
; (rho, S') with a ``transition'' substitution rho.  A state formula S
; consists of a prefix Q of the form all sig-vars ex flex-vars all
; forb-vars, followed by a list of unification pairs.  All terms in this
; list are patterns w.r.t. Q.  We call

; - sig-vars the signature variables (to avoid unnecessary renaming), 

; - flex-vars the flexible variables (to be substituted), 

; - forb-vars the forbidden variables (not allowed in substitution terms).  

; The domain of rho consists of flexible variables from S only, and its
; value terms never contain a forbidden variable (of either S or S')
; free.  Moreover, rho is idempotent.  pattern-unify1 satifies the
; following property.  Assume (pattern-unify1 S) = (rho S').  Then for
; every S'-solution phi', (rho composed phi')restricted Q_exists is an
; S-solution, and every S-solution can be obtained in this way.

(define (pattern-unify sig-vars flex-vars forb-vars . unif-pairs)
  (if
   (null? unif-pairs)
   (list empty-subst sig-vars flex-vars forb-vars)
   (let ((one-step
	  (apply
	   pattern-unify1
	   (cons sig-vars (cons flex-vars (cons forb-vars unif-pairs))))))
     (if (pair? one-step)
	 (let* ((rho1 (car one-step))
		(state1 (cdr one-step))
		(prev (apply pattern-unify state1)))
	   (if (pair? prev)
	       (let ((rho (car prev))
		     (final-state (cdr prev)))
		 (cons (compose-substitutions-and-beta0-nf rho1 rho)
		       final-state))
	       #f))
	 #f))))

(define (pattern-unify1 sig-vars flex-vars forb-vars . unif-pairs)
  (if
   (null? unif-pairs)
   (myerror "pattern-unify1" "non null unif-pairs expected")
   (let ((expr1 (caar unif-pairs))
	 (expr2 (cadar unif-pairs))
	 (rest-unif-pairs (cdr unif-pairs)))
     (pattern-unify-equality
      sig-vars flex-vars forb-vars expr1 expr2 rest-unif-pairs))))

; or more generally

; (define (pattern-unify-list sig-vars flex-vars forb-vars exprs1 exprs2)
;   (cond ((and (null? exprs1) (null? exprs2))
; 	 (list sig-vars flex-vars forb-vars empty-subst))
; 	((not (= (length exprs1) (length exprs2)))
; 	 (myerror "pattern-unify-list: equal lengths expected"
; 		  (length exprs1) (length exprs2)))
; 	(else (pattern-unify-equality
; 	       sig-vars flex-vars forb-vars (car exprs1) (car exprs2)
; 	       (map (lambda (x y) (list x y)) (cdr exprs1) (cdr exprs2))
; 	       empty-subst)))) 

; pattern-unify-equality checks whether its two expression arguments are
; equal.  If so, continue with the remaining unification pairs.  If not,
; call pattern-unify-xi.

(define (pattern-unify-equality
	 sig-vars flex-vars forb-vars expr1 expr2 rest-unif-pairs)
  (if (or (and (term-form? expr1) (term-form? expr2) (term=? expr1 expr2))
	  (and (formula-form? expr1) (formula-form? expr2)
	       (formula=? expr1 expr2)))
      (if (pair? rest-unif-pairs)
          (pattern-unify-equality
           sig-vars flex-vars forb-vars
           (caar rest-unif-pairs) (cadar rest-unif-pairs)
           (cdr rest-unif-pairs))
          (list empty-subst sig-vars flex-vars forb-vars))
      (pattern-unify-xi
       sig-vars flex-vars forb-vars expr1 expr2 rest-unif-pairs)))

; pattern-unify-xi removes common bound variables and adds them to the 
; prefix.  Then pattern-unify-rigid-rigid is called.

(define (pattern-unify-xi
	 sig-vars flex-vars forb-vars expr1 expr2 rest-unif-pairs)
  (cond
   ((or (term-in-abst-form? expr1) (term-in-abst-form? expr2))
    (let* ((vars-and-kernels (common-lambda-vars-and-kernels expr1 expr2))
	   (lambda-vars (car vars-and-kernels))
	   (kernel1 (cadr vars-and-kernels))
	   (kernel2 (caddr vars-and-kernels))
	   (info (pair? (intersection
			 (append sig-vars flex-vars forb-vars) lambda-vars)))
	   (new-vars (if info
			 (map var-to-new-var lambda-vars)
			 lambda-vars))
	   (subst (make-substitution-wrt
		   var-term-equal?
		   lambda-vars (map make-term-in-var-form new-vars)))
	   (new-kernel1 (if info
			    (term-substitute kernel1 subst)
			    kernel1))
	   (new-kernel2 (if info
			    (term-substitute kernel2 subst)
			    kernel2)))
      (if (null? flex-vars)
	  (pattern-unify-rigid-rigid
	   (append sig-vars new-vars) '() forb-vars
	   new-kernel1 new-kernel2 rest-unif-pairs)
	  (pattern-unify-rigid-rigid
	   sig-vars flex-vars (append forb-vars new-vars)
	   new-kernel1 new-kernel2 rest-unif-pairs))))
   ((or (and (all-form? expr1) (all-form? expr2))
	(and (allnc-form? expr1) (allnc-form? expr2))
	(and (ex-form? expr1) (ex-form? expr2))
	(and (exnc-form? expr1) (exnc-form? expr2)))
    (let ((var1 (cond ((all-form? expr1) (all-form-to-var expr1))
		      ((allnc-form? expr1) (allnc-form-to-var expr1))
		      ((ex-form? expr1) (ex-form-to-var expr1))
		      ((exnc-form? expr1) (exnc-form-to-var expr1))))
	  (kernel1 (cond ((all-form? expr1) (all-form-to-kernel expr1))
			 ((allnc-form? expr1) (allnc-form-to-kernel expr1))
			 ((ex-form? expr1) (ex-form-to-kernel expr1))
			 ((exnc-form? expr1) (exnc-form-to-kernel expr1))))
	  (var2 (cond ((all-form? expr2) (all-form-to-var expr2))
		      ((allnc-form? expr2) (allnc-form-to-var expr2))
		      ((ex-form? expr2) (ex-form-to-var expr2))
		      ((exnc-form? expr2) (exnc-form-to-var expr2))))
	  (kernel2 (cond ((all-form? expr2) (all-form-to-kernel expr2))
			 ((allnc-form? expr2) (allnc-form-to-kernel expr2))
			 ((ex-form? expr2) (ex-form-to-kernel expr2))
			 ((exnc-form? expr2) (exnc-form-to-kernel expr2)))))
      (cond
       ((equal? var1 var2)
	(let* ((info (member var1 (append sig-vars flex-vars forb-vars)))
	       (new-var (if info (var-to-new-var var1) var1))
	       (new-kernel1
		(if info
		    (formula-subst
		     kernel1 var1 (make-term-in-var-form new-var))
		    kernel1))
	       (new-kernel2
		(if info
		    (formula-subst
		     kernel2 var2 (make-term-in-var-form new-var))
		    kernel2)))
	  (if (null? flex-vars)
	      (pattern-unify-xi
	       (append sig-vars (list new-var)) '() forb-vars
	       new-kernel1 new-kernel2 rest-unif-pairs)
	      (pattern-unify-xi
	       sig-vars flex-vars (append forb-vars (list new-var))
	       new-kernel1 new-kernel2 rest-unif-pairs))))
       ((and (equal? (var-to-type var1) (var-to-type var2))
	     (= (var-to-t-deg var1) (var-to-t-deg var2)))
	(let* ((new-var (var-to-new-var var1))
	       (new-kernel1 (formula-subst
			     kernel1 var1 (make-term-in-var-form new-var)))
	       (new-kernel2 (formula-subst
			     kernel2 var2 (make-term-in-var-form new-var))))
	  (if (null? flex-vars)
	      (pattern-unify-xi
	       (append sig-vars (list new-var)) '() forb-vars
	       new-kernel1 new-kernel2 rest-unif-pairs)
	      (pattern-unify-xi
	       sig-vars flex-vars (append forb-vars (list new-var))
	       new-kernel1 new-kernel2 rest-unif-pairs))))
       (else #f))))
   (else (pattern-unify-rigid-rigid
	  sig-vars flex-vars forb-vars expr1 expr2 rest-unif-pairs))))

; We need an auxiliary function common-lambda-vars-and-kernels.  For
; terms term1 and term2 of the same type it yields alpha-eta-equivalent
; representations lambda vec{x} s1 and lambda vec{x} s2 with the same
; variables vec{x} and non-lambda-kernels s1 and s2 (i.e. applications).
; Examples: [x](f1 x) , f2 => ((x) (f1 x) (f2 x))
; [x](f1 x) , [y](f2 y) => ((x) (f1 x) (f2 x))

(define (common-lambda-vars-and-kernels term1 term2)
  (let ((type (term-to-type term1)))
    (if
     (ground-type? type)
     (list '() term1 term2)
     (if
      (term-in-abst-form? term1)
      (let ((var1 (term-in-abst-form-to-var term1))
	    (kernel1 (term-in-abst-form-to-kernel term1)))
	(if
	 (term-in-abst-form? term2)
	 (let* ((var2 (term-in-abst-form-to-var term2))
		(kernel2 (term-in-abst-form-to-kernel term2))
		(prev (common-lambda-vars-and-kernels kernel1 kernel2)))
	   (list
	    (cons var1 (car prev))
	    (cadr prev)
	    (if (or (equal? var1 var2) (member var2 (car prev)))
; 	    (if (equal? var1 var2)
		(caddr prev)
		(term-subst (caddr prev) var2 (make-term-in-var-form var1)))))
	 (let ((prev (common-lambda-vars-and-kernels
		      kernel1
		      (mk-term-in-app-form term2
					   (make-term-in-var-form var1)))))
	   (list (cons var1 (car prev)) 
		 (cadr prev)
		 (caddr prev)))))
      (if
       (term-in-abst-form? term2)
       (let* ((var2 (term-in-abst-form-to-var term2))
	      (kernel2 (term-in-abst-form-to-kernel term2))
	      (prev (common-lambda-vars-and-kernels
		     (mk-term-in-app-form term1 (make-term-in-var-form var2))
		     kernel2)))
	 (list (cons var2 (car prev)) (cadr prev) (caddr prev)))
       (list '() term1 term2))))))

; The function pattern-unify-rigid-rigid checks whether both heads are
; rigid.  If then they are equal, the list rest-unif-pairs is extended
; by their arguments (which both must be of the same length, since the
; types are the same, and cannot be null, since the original call was
; pattern-unify-equality), and pattern-unify-equality is called.  If
; they are different, #f is returned.  If it is not true that both heads
; are rigid, pattern-unify-flex-flex is called.

(define (pattern-unify-rigid-rigid
         sig-vars flex-vars forb-vars expr1 expr2 rest-unif-pairs)
  (cond
   ((and (term-form? expr1) (term-form? expr2))
    (let* ((op1 (term-in-app-form-to-final-op expr1))
	   (args1 (term-in-app-form-to-args expr1))
	   (op2 (term-in-app-form-to-final-op expr2))
	   (args2 (term-in-app-form-to-args expr2)))
      (if ;both heads are rigid
       (and (not (and (term-in-var-form? op1)
		      (member (term-in-var-form-to-var op1) flex-vars)))
	    (not (and (term-in-var-form? op2)
		      (member (term-in-var-form-to-var op2) flex-vars))))
       (cond
	((term=? op1 op2) ;both heads are equal
	 (pattern-unify-equality
	  sig-vars flex-vars forb-vars (car args1) (car args2)
	  (append (map (lambda (x y) (list x y)) (cdr args1) (cdr args2))
		  rest-unif-pairs)))
	((and (term-in-pair-form? op1)
	      (term-in-pair-form? op2))
	 (let ((left1 (term-in-pair-form-to-left op1))
	       (right1 (term-in-pair-form-to-right op1))
	       (left2 (term-in-pair-form-to-left op2))
	       (right2 (term-in-pair-form-to-right op2)))
	   (pattern-unify-equality
	    sig-vars flex-vars forb-vars left1 left2
	    (cons (list right1 right2) rest-unif-pairs))))
	((and (term-in-lcomp-form? op1)
	      (term-in-lcomp-form? op2))
	 (let ((kernel1 (term-in-lcomp-form-to-kernel op1))
	       (kernel2 (term-in-lcomp-form-to-kernel op2)))
	   (pattern-unify-equality
	    sig-vars flex-vars forb-vars kernel1 kernel2
	    (append (map (lambda (x y) (list x y)) args1 args2)
		    rest-unif-pairs))))
	((and (term-in-rcomp-form? op1)
	      (term-in-rcomp-form? op2))
	 (let ((kernel1 (term-in-rcomp-form-to-kernel op1))
	       (kernel2 (term-in-rcomp-form-to-kernel op2)))
	   (pattern-unify-equality
	    sig-vars flex-vars forb-vars kernel1 kernel2
	    (append (map (lambda (x y) (list x y)) args1 args2)
		    rest-unif-pairs))))
	((and (term-in-if-form? op1)
	      (term-in-if-form? op2))
	 (let ((test1 (term-in-if-form-to-test op1))
	       (alts1 (term-in-if-form-to-alts op1))
	       (test2 (term-in-if-form-to-test op2))
	       (alts2 (term-in-if-form-to-alts op2)))
	   (pattern-unify-equality
	    sig-vars flex-vars forb-vars test1 test2
	    (append (map (lambda (x y) (list x y))
			 (append alts1 args1)
			 (append alts2 args2))
		    rest-unif-pairs))))
	(else #f))
       (pattern-unify-flex-flex
	sig-vars flex-vars forb-vars expr1 expr2 rest-unif-pairs))))
   ((and (atom-form? expr1) (atom-form? expr2))
    (let ((kernel1 (atom-form-to-kernel expr1))
	  (kernel2 (atom-form-to-kernel expr2)))
      (pattern-unify-equality
       sig-vars flex-vars forb-vars kernel1 kernel2 rest-unif-pairs)))
   ((and (predicate-form? expr1) (predicate-form? expr2))
    (let ((pred1 (predicate-form-to-predicate expr1))
	  (args1 (predicate-form-to-args expr1))
	  (pred2 (predicate-form-to-predicate expr2))
	  (args2 (predicate-form-to-args expr2)))
      (if ;both preds are equal
       (predicate-equal? pred1 pred2)
       (pattern-unify-equality
	sig-vars flex-vars forb-vars (car args1) (car args2)
	(append (map (lambda (x y) (list x y)) (cdr args1) (cdr args2))
		rest-unif-pairs))
       #f)))
   ((and (imp-form? expr1) (imp-form? expr2))
    (let ((prem1 (imp-form-to-premise expr1))
	  (concl1 (imp-form-to-conclusion expr1))
	  (prem2 (imp-form-to-premise expr2))
	  (concl2 (imp-form-to-conclusion expr2)))
      (pattern-unify-equality
       sig-vars flex-vars forb-vars prem1 prem2
       (cons (list concl1 concl2) rest-unif-pairs))))
   ((and (and-form? expr1) (and-form? expr2))
    (let ((left1 (and-form-to-left expr1))
	  (right1 (and-form-to-right expr1))
	  (left2 (and-form-to-left expr2))
	  (right2 (and-form-to-right expr2)))
      (pattern-unify-equality
       sig-vars flex-vars forb-vars left1 left2
       (cons (list right1 right2) rest-unif-pairs))))
   ((and (tensor-form? expr1) (tensor-form? expr2))
    (let ((left1 (tensor-form-to-left expr1))
	  (right1 (tensor-form-to-right expr1))
	  (left2 (tensor-form-to-left expr2))
	  (right2 (tensor-form-to-right expr2)))
      (pattern-unify-equality
       sig-vars flex-vars forb-vars left1 left2
       (cons (list right1 right2) rest-unif-pairs))))
   (else #f)))

; pattern-unify-flex-flex checks whether both heads are flexible.  

; Case 1.  If the heads are equal, the pointwise intersection new-vars
; of the argument vars is formed.  Then a new variable y' is formed and
; the new term lambda vars (y' new-vars) is substituted for the flexible
; variables.  This substitution must also be carried out in
; rest-unif-pairs. Then a beta0 normalization is done (beta0 because the
; special form of patterns implies that no new redexes are generated by
; the beta conversion).  With the result pattern-unify-equality is called.  

; Case 2.  If the heads are different, first check whether one list of
; argument variables is contained in the other.  If so, the head of the
; term with more variables is substituted accordingly.  If not, the
; intersection of the argument variables is computed, a new variable of
; the corresponding type is formed and both heads are substituted with
; the new term formed from it.  Then one proceeds as before.  (Note that
; the check whether one argument list is contained in the other is only
; done to avoid unneccessary substitution of variables: in this case we
; can keep the variable with fewer arguments).

; Otherwise pattern-unify-by-occurs-check-and-pruning is called.

(define (pattern-unify-flex-flex
         sig-vars flex-vars forb-vars term1 term2 rest-unif-pairs)
  ;(display "f")
  (let* ((op1 (term-in-app-form-to-final-op term1))
	 (vars1 (map term-in-var-form-to-var
		     (term-in-app-form-to-args term1)))
	 (op2 (term-in-app-form-to-final-op term2))
	 (vars2 (map term-in-var-form-to-var
		     (term-in-app-form-to-args term2))))
    (if
     (and (term-in-var-form? op1)
	  (member (term-in-var-form-to-var op1) flex-vars))
     (let ((opvar1 (term-in-var-form-to-var op1)))
       (if
	(and (term-in-var-form? op2)
	     (member (term-in-var-form-to-var op2) flex-vars))
	(let ((opvar2 (term-in-var-form-to-var op2)))
	  (if ;equal heads
	   (equal? opvar1 opvar2)
           ;since pattern-unify-equality was called first, the argument
           ;lists must be different.
	   (let* ((new-vars (pointwise-intersection vars1 vars2))
		  (new-type
		   (apply mk-arrow (append (map term-to-type new-vars)
					   (list (term-to-type term1)))))
		  (new-var (type-to-new-var new-type))
		  (new-app-term
		   (apply mk-term-in-app-form
			  (cons (make-term-in-var-form new-var)
				(map make-term-in-var-form new-vars))))
		  (new-term (apply mk-term-in-abst-form
				   (append vars1 (list new-app-term))))
		  (rho (list (list opvar1 new-term)))
		  (new-flex-vars
		   (append (remove opvar1 flex-vars) (list new-var)))
		  (substituted-rest-unif-pairs
		   (unif-pairs-subst-and-beta0-nf
		    rest-unif-pairs opvar1 new-term)))
	     (append (list rho sig-vars new-flex-vars forb-vars)
		     substituted-rest-unif-pairs))
	   ;now the case of different heads
	   (let ((vars1-in-vars2 (null? (set-minus vars1 vars2)))
		 (vars2-in-vars1 (null? (set-minus vars2 vars1))))
	     (cond
	      (vars1-in-vars2
	       (let* ((new-term (apply mk-term-in-abst-form
				       (append vars2 (list term1))))
		      (rho (list (list opvar2 new-term)))
		      (new-flex-vars (remove opvar2 flex-vars))
		      (substituted-rest-unif-pairs
		       (unif-pairs-subst-and-beta0-nf
			rest-unif-pairs opvar2 new-term)))
		 (append (list rho sig-vars new-flex-vars forb-vars)
			 substituted-rest-unif-pairs)))
	      (vars2-in-vars1
	       (let* ((new-term (apply mk-term-in-abst-form
				       (append vars1 (list term2))))
		      (rho (list (list opvar1 new-term)))
		      (new-flex-vars (remove opvar1 flex-vars))
		      (substituted-rest-unif-pairs
		       (unif-pairs-subst-and-beta0-nf
			rest-unif-pairs opvar1 new-term)))
		 (append (list rho sig-vars new-flex-vars forb-vars)
			 substituted-rest-unif-pairs)))
	      (else ;pruning
	       (let* ((new-vars (intersection vars1 vars2))
		      (new-type (apply mk-arrow
				       (append (map term-to-type new-vars)
					       (list (term-to-type term1)))))
		      (new-var (type-to-new-var new-type))
		      (new-app-term
		       (apply mk-term-in-app-form
			      (cons (make-term-in-var-form new-var)
				    (map make-term-in-var-form new-vars))))
		      (new-term1 (apply mk-term-in-abst-form
					(append vars1 (list new-app-term))))
		      (new-term2 (apply mk-term-in-abst-form
					(append vars2 (list new-app-term))))
		      (rho (list (list opvar1 new-term1)
				 (list opvar2 new-term2)))
		      (new-flex-vars
		       (cons new-var (set-minus flex-vars
						(list opvar1 opvar2))))
		      (substituted-rest-unif-pairs
		       (unif-pairs-subst-and-beta0-nf
			(unif-pairs-subst-and-beta0-nf
			 rest-unif-pairs opvar1 new-term1)
			opvar2 new-term2)))
		 (append (list rho sig-vars new-flex-vars forb-vars)
			 substituted-rest-unif-pairs)))))))
	;case op2 not flexible
	(pattern-unify-by-occurs-check-and-pruning
	 sig-vars flex-vars forb-vars opvar1 vars1 term2 rest-unif-pairs)))
     ;case op1 not flexible
     (if (and (term-in-var-form? op2)
	      (member (term-in-var-form-to-var op2) flex-vars))
	 (pattern-unify-by-occurs-check-and-pruning
	  sig-vars flex-vars forb-vars (term-in-var-form-to-var op2)
	  vars2 term1 rest-unif-pairs)
	 (myerror "pattern-unify-flex-flex applied with heads" op1 op2)))))

; Here we have used some auxiliary functions:

(define (pointwise-intersection-wrt equality? list1 list2)
  (do ((l1 list1 (cdr l1))
       (l2 list2 (cdr l2))
       (res '() (if (equality? (car l1) (car l2)) (cons (car l1) res) res)))
      ((or (null? l1) (null? l2)) (reverse res))))

(define (pointwise-intersection list1 list2)
  (pointwise-intersection-wrt equal? list1 list2))

(define (pointwise-intersecq list1 list2)
  (pointwise-intersection-wrt eq? list1 list2))

(define (pointwise-intersecv list1 list2)
  (pointwise-intersection-wrt eqv? list1 list2))

(define (term-substitute-and-beta0-nf term subst)
  (if
   (null? subst)
   term
   (if
    (term-in-abst-form? term)
    (let* ((var (term-in-abst-form-to-var term))
	   (kernel (term-in-abst-form-to-kernel term))
	   (vars (map car subst))
	   (active-vars (intersection vars (term-to-free term)))
	   (active-subst
	    (do ((l subst (cdr l))
		 (res '() (if (member (caar l) active-vars)
			      (cons (car l) res)
			      res)))
		((null? l) (reverse res))))
	   (active-terms (map cadr active-subst)))
      (if (member var (apply union (map term-to-free active-terms)))
	  (let ((new-var (var-to-new-var var)))
	    (make-term-in-abst-form
	     new-var
	     (term-substitute-and-beta0-nf
	      kernel (cons (list var (make-term-in-var-form new-var))
			   active-subst))))
	  (make-term-in-abst-form
	   var (term-substitute-and-beta0-nf kernel active-subst))))
    (let* ((op (term-in-app-form-to-final-op term))
	   (args (term-in-app-form-to-args term))
	   (info (if (term-in-var-form? op)
		     (assoc (term-in-var-form-to-var op) subst)
		     #f)))
      (if ;term of the form yr1...rm with y left in subst
       info 
       (let* ((kernel-and-vars
	       (term-in-abst-form-to-kernel-and-vars (cadr info)))
	      (kernel (car kernel-and-vars))
	      (vars (cdr kernel-and-vars))
	      (subst (do ((rs args (cdr rs))
			  (vs vars (cdr vs))
			  (res '() (cons (list (car vs) (car rs)) res)))
			 ((or (null? rs) (null? vs)) res)))
	      (new-kernel (term-substitute-and-beta0-nf kernel subst))
	      (n (length vars))
	      (m (length args)))
	 (if
	  (<= m n)
	  (apply mk-term-in-abst-form
		 (append (list-tail vars m) (list new-kernel)))
	  (apply mk-term-in-app-form (cons new-kernel (list-tail args n)))))
       ;otherwise substitution as usual
       (case (tag term)
	 ((term-in-var-form term-in-const-form) term)
	 ((term-in-app-form)
	  (make-term-in-app-form
	   (term-substitute-and-beta0-nf
	    (term-in-app-form-to-op term) subst)
	   (term-substitute-and-beta0-nf
	    (term-in-app-form-to-arg term) subst)))
	 ((term-in-pair-form)
	  (make-term-in-pair-form
	   (term-substitute-and-beta0-nf
	    (term-in-pair-form-to-left term) subst)
	   (term-substitute-and-beta0-nf
	    (term-in-pair-form-to-right term) subst)))
	 ((term-in-lcomp-form)
	  (make-term-in-lcomp-form
	   (term-substitute-and-beta0-nf
	    (term-in-lcomp-form-to-kernel term) subst)))
	 ((term-in-rcomp-form)
	  (make-term-in-rcomp-form
	   (term-substitute-and-beta0-nf
	    (term-in-rcomp-form-to-kernel term) subst)))
	 ((term-in-if-form)
	  (apply
	   make-term-in-if-form
	   (cons (term-substitute-and-beta0-nf
		  (term-in-if-form-to-test term) subst)
		 (cons (map (lambda (x) (term-substitute-and-beta0-nf x subst))
			    (term-in-if-form-to-alts term))
		       (term-in-if-form-to-rest term)))))
	 (else (myerror "term-substitute-and-beta0-nf" "term expected"
			term))))))))

(define (term-subst-and-beta0-nf term var term1)
  (term-substitute-and-beta0-nf term (list (list var term1))))

(define (unif-pairs-subst-and-beta0-nf unif-pairs var term)
  (do ((ps unif-pairs (cdr ps))
       (res '()
	    (let ((expr1 (caar ps))
		  (expr2 (cadar ps)))
	      (cons (list (cond ((term-form? expr1) 
				 (term-subst-and-beta0-nf expr1 var term))
				((formula-form? expr1)
				 (formula-subst-and-beta0-nf expr1 var term))
				(else
				 (myerror "unif-pairs-subst-and-beta0-nf"
					  "term or formula expected" expr1)))
			  (cond ((term-form? expr2) 
				 (term-subst-and-beta0-nf expr2 var term))
				((formula-form? expr2)
				 (formula-subst-and-beta0-nf expr2 var term))
				(else
				 (myerror "unif-pairs-subst-and-beta0-nf"
					  "term or formula expected" expr2))))
		    res))))
      ((null? ps) (reverse res))))

(define (compose-substitutions-and-beta0-nf subst1 subst2)
  (compose-substitutions-wrt
   term-substitute-and-beta0-nf equal? var-term-equal? subst1 subst2))

; pattern-unify-by-occurs-check-and-pruning deals with a situation
; yx1...xn=r not of the form flex-flex.  First search r for a ``critical
; subterm'', i.e. a subterm that either
; - has head y, or
; - contains an unallowed dependency, i.e. an occurrence (as argument of
;   a flexible variable) of a variable not among x1...xn that is free
;   in the total term.
; If a critical subterm starting with y is found, return #f (occurs check).
; If a critical subterm with unallowed dependencies is found, delete these
; dependencies by introducing a new flexible variable new-var and call
; pattern-unify-by-occurs-check-and-pruning again.  If there is no
; critical subterm, check whether new-term := [x1,...,xn]r has a free
; occurrence of a forbidden variable.  If so, return #f, and otherwise
; return the extended substitution.

(define (pattern-unify-by-occurs-check-and-pruning
         sig-vars flex-vars forb-vars head vars rigid-term rest-unif-pairs)
  ;(display "p")
  (let ((test (term-to-critical-subterm-as-list-with-type
               flex-vars head vars rigid-term)))
    (if ;critical subterm found
     (pair? test)
     (let* ((type (car test))
	    (h (cadr test))
	    (args (cddr test)))
       (if ;occurs check
	(equal? head h)
	#f
	(let* ((new-vars (intersection args vars))
	       (new-type (apply mk-arrow (append (map term-to-type new-vars)
						 (list type))))
	       (new-var (type-to-new-var new-type))
	       (new-app-term
		(apply mk-term-in-app-form
		       (cons (make-term-in-var-form new-var)
			     (map make-term-in-var-form new-vars))))
	       (new-term
		(apply mk-term-in-abst-form (append args (list new-app-term))))
	       (rho (list (list h new-term)))
	       (new-flex-vars (cons new-var (remove h flex-vars)))
	       (substituted-rest-unif-pairs
		(unif-pairs-subst-and-beta0-nf rest-unif-pairs h new-term))
	       (app-term
		(apply mk-term-in-app-form
		       (cons (make-term-in-var-form head)
			     (map make-term-in-var-form vars))))
	       (substituted-rigid-term
		(term-subst-and-beta0-nf rigid-term h new-term)))
	  (append (list rho sig-vars new-flex-vars forb-vars)
		  (cons (list app-term substituted-rigid-term)
			substituted-rest-unif-pairs)))))
     ;no critical subterm found
     (let ((new-term (apply mk-term-in-abst-form
			    (append vars (list rigid-term)))))
       (if (pair? (intersection (term-to-free new-term) forb-vars))
	   #f
	   (let* ((rho (list (list head new-term)))
		  (new-flex-vars (remove head flex-vars))
		  (substituted-rest-unif-pairs
		   (unif-pairs-subst-and-beta0-nf
		    rest-unif-pairs head new-term)))
	     (append (list rho sig-vars new-flex-vars forb-vars)
		     substituted-rest-unif-pairs)))))))

; term-to-critical-subterm-as-list-with-type gets flex-vars head vars term
; as input, with term in beta normal form.  It returns the first
; critical subterm with its type, if there is any, and the empty list
; otherwise.  As before a subterm is critical if it starts with head y
; or contains unallowed dependencies.  Examples:
; y x1 x2 = a([x3](z x3 x1 x x2))  => (obj->obj z x3 x1 x)
; y x1 x2 = b([x3](y x3))          => (obj->obj->obj y)
; y x1 x2 = a([x3](z x3 x1 x2))    => ()

(define (term-to-critical-subterm-as-list-with-type
         flex-vars head vars term)
  (if
   (term-in-abst-form? term)
   (term-to-critical-subterm-as-list-with-type
    flex-vars head (cons (term-in-abst-form-to-var term) vars)
    (term-in-abst-form-to-kernel term))
   (let* ((op (term-in-app-form-to-final-op term))
	  (args (term-in-app-form-to-args term)))
     (if ;critical subterm with operator head found
      (and (term-in-var-form? op)
	   (equal? (term-in-var-form-to-var op) head))
      (list (term-to-type op) (term-in-var-form-to-var op))
      (let* ((op-flex? (and (term-in-var-form? op)
			    (member (term-in-var-form-to-var op) flex-vars)))
	     (argvars (if op-flex? (map term-in-var-form-to-var args))))
	(if ;critical subterm with unallowed dependencies found
	 (and op-flex? (pair? (set-minus argvars vars)))
	 (let ((opvar (term-in-var-form-to-var op)))
	   (do ((x argvars (cdr x))
		(type (term-to-type op) (arrow-form-to-val-type type))
		(l (list opvar) (cons (car x) l)))
	       ((not (member (car x) vars)) ;critical subterm found
		(cons (arrow-form-to-val-type type)
		      (reverse (cons (car x) l))))))
	 (if op-flex?
	     #f ;continue search
	     (let aux ((x args))
	       (if (null? x)
		   #f ;continue search
		   (let ((prev (term-to-critical-subterm-as-list-with-type
				flex-vars head vars (car x))))
		     (if (pair? prev)
			 prev
			 (aux (cdr x)))))))))))))

; 6-11. Huets unification algorithm
; =================================

; Huets unification algorithm needs: simpl, match.  simpl needs
; rigid heads and decomposes the problem to the arguments.  A term is
; rigid if its head is either a constant or a bound variable.

; match gets a flexible and a rigid argument.  It consists of two
; parts: imitation and projections.

; Imitation gets f r1 ... rm and A s1 ... sn as arguments.  It
; produces a substitution, for the flexible head f: f mapsto lambda
; xs.A (hs xs).  This only works if A is a constant.

; Projection gets f r1 ... rm and A s1 ... sn as arguments.  There are
; m projections; each of these pulls one of the rs in front.  So the
; i-th projection maps f to lambda x1 ... xm.xi (hs xs), where the
; types are as follows: Let beta_i = alpha_{i1} => ... => alpha{i k_i}
; => iota.  f : beta_1 => ... => beta_m => iota.  ri, xi : beta_i.  hj
; : beta_1 => ... => beta_m => alpha_{i j}.

; Notice that for matching f r1 ... rm and A s1 ... sn, up to one
; imitation and m projections is possible.

; Organization: Work with lists of unification pairs.  Take the first
; one, say (r s).  First simp decomposes the structure if possible, or
; stops with failure.  Then match gets a flex rigid pair.  It calls
; imitate and then all projections.  For each answer it gets it
; produces a new unification problem by applying the substitution to
; all unif-pairs.  Then it recursively calls simpl for each of these,
; and generates a `match tree' in this way.  The subsitution needs to
; be carried along (on each path separately), which will finally yield
; the desired unifier.

(define MATCH-TREE-BOUND 20)
(define INITIAL-MATCH-TREE-BOUND MATCH-TREE-BOUND)

(define (huet-unifiers sig-vars flex-vars forb-vars . unif-pairs)
  (if
   (null? unif-pairs)
   (myerror "huet-unifiers" "non null unif-pairs expected")
   (let* ((unif-results ;((rho1 sig-vars1 flex-vars1 forb-vars1) ...)
	   (huet-unifiers-init
	    sig-vars flex-vars forb-vars unif-pairs '() empty-subst
	    MATCH-TREE-BOUND))
	  (restr-unif-results
	   (map (lambda (res)
		  (let ((subst (car res))
			(state (cdr res)))
		    (cons (restrict-substitution-to-args subst flex-vars)
			  state)))
		unif-results)))
     restr-unif-results)))

(define (huet-unifiers-init sig-vars flex-vars forb-vars
			    unif-pairs flex-flex-pairs subst bd)
  (if (null? unif-pairs) ;solution found
      (let* ((terms (apply append flex-flex-pairs))
	     (ops (map term-in-app-form-to-final-op terms))
	     (vars (map (lambda (op)
			  (if (term-in-var-form? op)
			      (term-in-var-form-to-var op)
			      (myerror "huet-unifiers-init" "variable expected"
				       op)))
			ops))
	     (types (map term-to-type ops))
	     (groundtypes
	      (apply union (map type-to-final-groundtypes types)))
	     (new-flex-vars (map type-to-new-var groundtypes))
	     (groundtype-var-alist
	      (map (lambda (type var) (list type var))
		   groundtypes new-flex-vars))
	     (can-terms
	      (map (lambda (x) (type-to-canonical-term x groundtype-var-alist))
		   types))
	     (can-subst (map (lambda (var term) (list var term))
			     vars can-terms)))
	(list (list (compose-substitutions-and-beta-nf subst can-subst)
		    sig-vars (append flex-vars new-flex-vars) forb-vars)))
      (let ((expr1 (caar unif-pairs))
	    (expr2 (cadar unif-pairs))
	    (rest-unif-pairs (cdr unif-pairs)))
	(huet-unifiers-equality sig-vars flex-vars forb-vars expr1 expr2
				rest-unif-pairs flex-flex-pairs subst bd))))

(define (huet-unifiers-equality sig-vars flex-vars forb-vars expr1 expr2
				rest-unif-pairs flex-flex-pairs subst bd)
  (if (or (and (term-form? expr1) (term-form? expr2) (term=? expr1 expr2))
	  (and (formula-form? expr1) (formula-form? expr2)
	       (formula=? expr1 expr2)))
      (huet-unifiers-init sig-vars flex-vars forb-vars
			  rest-unif-pairs flex-flex-pairs subst bd)
      (huet-unifiers-xi sig-vars flex-vars forb-vars expr1 expr2
			rest-unif-pairs flex-flex-pairs subst bd)))

(define (huet-unifiers-xi sig-vars flex-vars forb-vars expr1 expr2
			  rest-unif-pairs flex-flex-pairs subst bd)
  (cond
   ((or (term-in-abst-form? expr1) (term-in-abst-form? expr2))
    (let* ((vars-and-kernels (common-lambda-vars-and-kernels expr1 expr2))
	   (lambda-vars (car vars-and-kernels))
	   (kernel1 (cadr vars-and-kernels))
	   (kernel2 (caddr vars-and-kernels))
	   (info (pair? (intersection forb-vars lambda-vars)))
	   (new-vars (if info
			 (map var-to-new-var lambda-vars)
			 lambda-vars))
	   (var-subst (make-substitution-wrt
		       var-term-equal?
		       lambda-vars (map make-term-in-var-form new-vars)))
	   (new-kernel1 (if info
			    (term-substitute kernel1 var-subst)
			    kernel1))
	   (new-kernel2 (if info
			    (term-substitute kernel2 var-subst)
			    kernel2)))
      (huet-unifiers-rigid-rigid
       sig-vars flex-vars (append forb-vars new-vars)
       new-kernel1 new-kernel2 rest-unif-pairs flex-flex-pairs subst bd)))
   ((or (and (all-form? expr1) (all-form? expr2))
	(and (allnc-form? expr1) (allnc-form? expr2))
	(and (ex-form? expr1) (ex-form? expr2))
	(and (exnc-form? expr1) (exnc-form? expr2)))
    (let ((var1 (cond ((all-form? expr1) (all-form-to-var expr1))
		      ((allnc-form? expr1) (allnc-form-to-var expr1))
		      ((ex-form? expr1) (ex-form-to-var expr1))
		      ((exnc-form? expr1) (exnc-form-to-var expr1))))
	  (kernel1 (cond ((all-form? expr1) (all-form-to-kernel expr1))
			 ((allnc-form? expr1) (allnc-form-to-kernel expr1))
			 ((ex-form? expr1) (ex-form-to-kernel expr1))
			 ((exnc-form? expr1) (exnc-form-to-kernel expr1))))
	  (var2 (cond ((all-form? expr2) (all-form-to-var expr2))
		      ((allnc-form? expr2) (allnc-form-to-var expr2))
		      ((ex-form? expr2) (ex-form-to-var expr2))
		      ((exnc-form? expr2) (exnc-form-to-var expr2))))
	  (kernel2 (cond ((all-form? expr2) (all-form-to-kernel expr2))
			 ((allnc-form? expr2) (allnc-form-to-kernel expr2))
			 ((ex-form? expr2) (ex-form-to-kernel expr2))
			 ((exnc-form? expr2) (exnc-form-to-kernel expr2)))))
      (cond
       ((equal? var1 var2)
	(let* ((info (member var1 forb-vars))
	       (new-var (if info (var-to-new-var var1) var1))
	       (new-kernel1
		(if info
		    (formula-subst
		     kernel1 var1 (make-term-in-var-form new-var))
		    kernel1))
	       (new-kernel2
		(if info
		    (formula-subst
		     kernel2 var2 (make-term-in-var-form new-var))
		    kernel2)))
	  (huet-unifiers-xi
	   sig-vars flex-vars (append forb-vars (list new-var))
	   new-kernel1 new-kernel2 rest-unif-pairs flex-flex-pairs subst bd)))
       ((and (equal? (var-to-type var1) (var-to-type var2))
	     (= (var-to-t-deg var1) (var-to-t-deg var2)))
	(let* ((new-var (var-to-new-var var1))
	       (new-kernel1 (formula-subst
			     kernel1 var1 (make-term-in-var-form new-var)))
	       (new-kernel2 (formula-subst
			     kernel2 var2 (make-term-in-var-form new-var))))
	  (huet-unifiers-xi
	   sig-vars flex-vars (append forb-vars (list new-var))
	   new-kernel1 new-kernel2 rest-unif-pairs flex-flex-pairs subst bd)))
       (else '()))))
   (else (huet-unifiers-rigid-rigid
	  sig-vars flex-vars forb-vars expr1 expr2
	  rest-unif-pairs flex-flex-pairs subst bd))))

; The function huet-unifiers-rigid-rigid checks whether both heads are
; rigid.  If then they are equal, the list rest-unif-pairs is extended
; by their arguments (which both must be of the same length, since the
; types are the same, and cannot be null, since the original call was
; huet-unifiers-equality), and huet-unifiers-equality is called.  If they
; are different, '() is returned.  If it is not true that both heads
; are rigid, huet-unifiers-flex-flex is called.

(define (huet-unifiers-rigid-rigid sig-vars flex-vars forb-vars expr1 expr2
				   rest-unif-pairs flex-flex-pairs subst bd)
  (cond
   ((and (term-form? expr1) (term-form? expr2))
    (let* ((op1 (term-in-app-form-to-final-op expr1))
	   (args1 (term-in-app-form-to-args expr1))
	   (op2 (term-in-app-form-to-final-op expr2))
	   (args2 (term-in-app-form-to-args expr2)))
      (if ;both heads are rigid
       (and (or (not (term-in-var-form? op1))
		(not (member (term-in-var-form-to-var op1) flex-vars)))
	    (or (not (term-in-var-form? op2))
		(not (member (term-in-var-form-to-var op2) flex-vars))))
       (if ;both heads are equal
	(term=? op1 op2)
	(huet-unifiers-equality
	 sig-vars flex-vars forb-vars (car args1) (car args2)
	 (append (map (lambda (x y) (list x y)) (cdr args1) (cdr args2))
		 rest-unif-pairs)
	 flex-flex-pairs subst bd)
	(if (and (term-in-if-form? op1)
		 (term-in-if-form? op2))
	    (let ((test1 (term-in-if-form-to-test op1))
		  (alts1 (term-in-if-form-to-alts op1))
		  (test2 (term-in-if-form-to-test op2))
		  (alts2 (term-in-if-form-to-alts op2)))
	      (huet-unifiers-equality
	       sig-vars flex-vars forb-vars test1 test2
	       (append (map (lambda (x y) (list x y))
			    (append alts1 args1)
			    (append alts2 args2))
		       rest-unif-pairs)
	       flex-flex-pairs subst bd))
	    '()))
       (huet-unifiers-flex-flex sig-vars flex-vars forb-vars expr1 expr2
				rest-unif-pairs flex-flex-pairs subst bd))))
   ((and (atom-form? expr1) (atom-form? expr2))
    (let ((kernel1 (atom-form-to-kernel expr1))
	  (kernel2 (atom-form-to-kernel expr2)))
      (huet-unifiers-equality
       sig-vars flex-vars forb-vars kernel1 kernel2
       rest-unif-pairs flex-flex-pairs subst bd)))
   ((and (predicate-form? expr1) (predicate-form? expr2))
    (let ((pred1 (predicate-form-to-predicate expr1))
	  (args1 (predicate-form-to-args expr1))
	  (pred2 (predicate-form-to-predicate expr2))
	  (args2 (predicate-form-to-args expr2)))
      (if ;both preds are equal
       (predicate-equal? pred1 pred2)
       (huet-unifiers-equality
	sig-vars flex-vars forb-vars (car args1) (car args2)
	(append (map (lambda (x y) (list x y)) (cdr args1) (cdr args2))
		rest-unif-pairs)
	flex-flex-pairs subst bd)
       '())))
   ((and (imp-form? expr1) (imp-form? expr2))
    (let ((prem1 (imp-form-to-premise expr1))
	  (concl1 (imp-form-to-conclusion expr1))
	  (prem2 (imp-form-to-premise expr2))
	  (concl2 (imp-form-to-conclusion expr2)))
      (huet-unifiers-equality
       sig-vars flex-vars forb-vars prem1 prem2
       (cons (list concl1 concl2) rest-unif-pairs) flex-flex-pairs subst bd)))
   ((and (and-form? expr1) (and-form? expr2))
    (let ((left1 (and-form-to-left expr1))
	  (right1 (and-form-to-right expr1))
	  (left2 (and-form-to-left expr2))
	  (right2 (and-form-to-right expr2)))
      (huet-unifiers-equality
       sig-vars flex-vars forb-vars left1 left2
       (cons (list right1 right2) rest-unif-pairs) flex-flex-pairs subst bd)))
   ((and (tensor-form? expr1) (tensor-form? expr2))
    (let ((left1 (tensor-form-to-left expr1))
	  (right1 (tensor-form-to-right expr1))
	  (left2 (tensor-form-to-left expr2))
	  (right2 (tensor-form-to-right expr2)))
      (huet-unifiers-equality
       sig-vars flex-vars forb-vars left1 left2
       (cons (list right1 right2) rest-unif-pairs) flex-flex-pairs subst bd)))
   (else '())))

(define (huet-unifiers-flex-flex sig-vars flex-vars forb-vars term1 term2
				 rest-unif-pairs flex-flex-pairs subst bd)
  (let* ((op1 (term-in-app-form-to-final-op term1))
	 (args1 (term-in-app-form-to-args term1))
	 (op2 (term-in-app-form-to-final-op term2))
	 (args2 (term-in-app-form-to-args term2))
	 (term1-is-flex?
	  (and (term-in-var-form? op1)
	       (member (term-in-var-form-to-var op1) flex-vars)))
	 (term2-is-flex?
	  (and (term-in-var-form? op2)
	       (member (term-in-var-form-to-var op2) flex-vars))))
    (cond
     ((and term1-is-flex? term2-is-flex?)
      (huet-unifiers-init sig-vars flex-vars forb-vars rest-unif-pairs
			  (cons (list term1 term2) flex-flex-pairs) subst bd))
     (term2-is-flex? ;but term1 is rigid
      (huet-unifiers-match sig-vars flex-vars forb-vars term2 term1
			   rest-unif-pairs flex-flex-pairs subst bd))
     (else
      (huet-unifiers-match sig-vars flex-vars forb-vars term1 term2
			   rest-unif-pairs flex-flex-pairs subst bd)))))

(define (huet-unifiers-match sig-vars flex-vars forb-vars flex rigid
			     rest-unif-pairs flex-flex-pairs subst bd)
 (if
   (zero? bd)
   (begin (if VERBOSE-SEARCH
	      (begin (display-comment "MATCH-TREE-BOUND reached")
		     (newline)))
	  '())
   (let* ((flex-head
	   (term-in-var-form-to-var (term-in-app-form-to-final-op flex)))
	  (rigid-head (term-in-app-form-to-final-op rigid))
	  (betas (arrow-form-to-arg-types (var-to-type flex-head)))
	  (xs (map (lambda (type) (type-to-new-var type)) betas))
	  (n (length betas))
	  (one-to-n (do ((i 1 (+ i 1))
		       (res '() (cons i res)))
		      ((< n i) (reverse res))))
	  (relevant-is (list-transform-positive one-to-n
			 (lambda (i)
			   (equal? (term-to-type rigid)
				   (arrow-form-to-final-val-type
				    (list-ref betas (- i 1)))))))
	  (proj-substs (map (lambda (i) (huet-project i flex-head betas xs))
			    relevant-is))
	  (substs
	   (if (member rigid-head (map make-term-in-var-form forb-vars))
	       proj-substs
	       (cons (huet-imitate flex-head rigid-head betas xs)
		     proj-substs)))
	  (val-terms (map cadr (apply append substs)))
	  (new-flex-vars
	   (set-minus (apply union (map term-to-free val-terms)) sig-vars))
	  (subst-unif-pairs-list
	   (map (lambda (x) (unif-pairs-substitute-and-beta-nf
			     (cons (list flex rigid) rest-unif-pairs) x))
		substs))
	  (subst-flex-flex-pairs-list
	   (map (lambda (x)
		  (unif-pairs-substitute-and-beta-nf flex-flex-pairs x))
		substs))
	  (new-subst-list
	   (map (lambda (x) (compose-substitutions-and-beta-nf subst x))
		substs)))
     (apply append
	    (map (lambda (subst-unif-pairs subst-flex-flex-pairs new-subst)
		   (huet-unifiers-init
		    sig-vars (append flex-vars new-flex-vars) forb-vars
		    (append subst-unif-pairs subst-flex-flex-pairs)
		    '() new-subst (- bd 1)))
		 subst-unif-pairs-list
		 subst-flex-flex-pairs-list
		 new-subst-list)))))

(define (huet-imitate flex-head rigid-head betas xs)
  (let* ((alphas (arrow-form-to-arg-types (term-to-type rigid-head)))
	 (hs (map (lambda (type)
		    (type-to-new-var
		     (apply mk-arrow (append betas (list type)))))
		  alphas))
	 (args ;(hs xs)
	  (map (lambda (h) (apply mk-term-in-app-form
				  (cons (make-term-in-var-form h)
					(map make-term-in-var-form xs))))
	       hs))
	 (valterm ;lambda xs.A (hs xs)
	  (apply mk-term-in-abst-form
		 (append xs (list (apply mk-term-in-app-form
					 (cons rigid-head args)))))))
    (list (list flex-head valterm))))

(define (huet-project i flex-head betas xs)
  (let* ((xi-term (make-term-in-var-form (list-ref xs (- i 1))))
	 (betai (list-ref betas (- i 1)))
	 (alphas (arrow-form-to-arg-types betai))
	 (hs (map (lambda (type)
		    (type-to-new-var
		     (apply mk-arrow (append betas (list type)))))
		  alphas))
	 (args ;(hs xs)
	  (map (lambda (h) (apply mk-term-in-app-form
				  (cons (make-term-in-var-form h)
					(map make-term-in-var-form xs))))
	       hs))
	 (valterm ;lambda xs.x_i (hs xs)
	  (apply mk-term-in-abst-form
		 (append xs (list (apply mk-term-in-app-form
					 (cons xi-term args)))))))
    (list (list flex-head valterm))))

(define (compose-substitutions-and-beta-nf subst1 subst2)
  (compose-substitutions-wrt
   (lambda (term subst)
     (term-to-beta-nf (term-substitute term subst)))
   equal? var-term-equal? subst1 subst2))

(define (unif-pairs-substitute-and-beta-nf unif-pairs subst)
  (do ((ps unif-pairs (cdr ps))
       (res '()
	    (let ((expr1 (caar ps))
		  (expr2 (cadar ps)))
	      (cons (list (cond ((term-form? expr1)
				 (term-to-beta-nf
				  (term-substitute expr1 subst)))
				((formula-form? expr1)
				 (formula-to-beta-nf
				  (formula-substitute expr1 subst)))
				(else
				 (myerror "unif-pairs-substitute-and-beta-nf"
					  "term or formula expected" expr1)))
			  (cond ((term-form? expr2)
				 (term-to-beta-nf
				  (term-substitute expr2 subst)))
				((formula-form? expr2)
				 (formula-to-beta-nf
				  (formula-substitute expr2 subst)))
				(else
				 (myerror "unif-pairs-substitute-and-beta-nf"
					  "term or formula expected" expr2))))
		    res))))
      ((null? ps) (reverse res))))
