; $Id: typ.scm 2257 2008-06-06 09:27:48Z schwicht $
; 2. Types
; ========

; Generally we consider typed theories only.  Types are built from
; type variables and type constants by algebra type formation (alg
; rho_1 ...  rho_n), arrow type formation (rho=>sigma) and product
; type formation (rho@@sigma) (and possibly other type constructors).
; We always have type constants atomic, existential, prop and
; nulltype.  They will be used to assign types to formulas.  For
; instance, all n n=0 receives the type nat=>atomic, and all n,m ex k
; n+m=k receives the type nat=>nat=>existential.  The type prop is
; used for predicate variables, e.g. R of arity nat,nat=>prop.  Types
; of formulas will be necessary for normalization by evaluation of
; proof terms.  The type nulltype will be useful when assigning to a
; formula the type of a program to be extracted from a proof of this
; formula.  Types not involving the types atomic, existential, prop
; and nulltype are called object types.

; Types always have the form (tag ...) where tag is one of tvar, tconst,
; alg, arrow, star, and ... is a list with further information.

(define tag car)

(define RESERVED-NAMES
  (list
   (list "Equal")
   (list "=")
   (list "Total")
   (list "STotal")
   (list "E")
   (list "Rec")
   (list "Cases")
   (list "Ex-Elim")
   (list "Ex-Intro")
   (list "or")))

(define (is-used? string additional-info sort)
  (let ((display-for-true (lambda x (apply comment x) #t)))
    (cond
     ((not (string? string))
      (myerror "is-used?" "string expected" string))
     ((assoc string RESERVED-NAMES)
      (myerror "is-used?" "reserved name" string))
     ((assoc string TYPE-VARIABLES)
      (if (eq? 'tvar sort)
	  (display-for-true "warning: already a type variable " string)
	  (myerror "is-used?" "already a type variable" string)))
     ((assoc string TYPE-CONSTANTS)
      (if (eq? 'type-constant sort)
	  (display-for-true "warning: already a type constant " string)
	  (myerror "is-used?" "already a type constant" string)))
     ((assoc string ALGEBRAS)
      (if (eq? 'algebra sort)
	  (display-for-true "warning: already an algebra " string)
	  (myerror "is-used?" "already an algebra" string)))
     ((assoc string CONSTRUCTORS)
      (if (eq? 'constructor sort)
	  (let* ((info (assoc string CONSTRUCTORS))
		 (constr (constr-name-and-tsubst-to-constr string '()))
		 (uninst-type (const-to-uninst-type constr)))
	    (myerror "is-used" "already a different constructor" string
		     "of type" uninst-type))
	  (myerror "is-used" "already a constructor" string)))
     ((assoc string VARIABLES)
      (let ((info (assoc string VARIABLES)))
	(if (eq? 'var sort)
	    (if (equal? (cadr info) additional-info)
 		(display-for-true
		 "warning: " string " already is a variable of type "
		 (type-to-string additional-info))
		(myerror
 		 "is-used?" "already a variable of different type"
 		 string additional-info))
	    (myerror "is-used?" "already a variable" string
		     "of type" (cadr info)))))
     ((assoc string PROGRAM-CONSTANTS)
      (let ((info (assoc string PROGRAM-CONSTANTS)))
	(if (eq? 'program-constant sort)
	    (let* ((pconst (cadr info))
		   (uninst-type (const-to-uninst-type pconst))
		   (t-deg (const-to-t-deg pconst))
		   (token-type (const-to-token-type pconst))
		   (arity (const-to-object-or-arity pconst)))
	      (if (equal? additional-info
			  (list uninst-type t-deg token-type arity))
		  (display-for-true "warning: program constant " string
				    " already introduced")
		  (myerror
		   "is-used?" "already a program constant with different data" 
		   string)))
	    (myerror "is-used?" "already a program constant" string))))
     ((assoc string PREDCONST-NAMES)
      (let ((info (assoc string PREDCONST-NAMES)))
	(if (eq? 'predconst sort)
	    (let ((uninst-type (cadr info)))
	      (if (equal? additional-info uninst-type)
		  (display-for-true "warning: predconst " string
				    " already introduced")
		  (myerror
		   "is-used?" "already a predconst with different data" 
		   string)))
	    (myerror "is-used?" "already a predconst" string))))
     ((assoc string IDS)
      (if (eq? 'idpredconst sort)
	  (display-for-true "warning: already an idpredconst " string)
	  (myerror "is-used?" "already an idpredconst" string)))
     ((assoc string PVAR-NAMES)
      (let ((info (assoc string PVAR-NAMES)))
	(if (eq? 'pvar sort)
	    (if (equal? (cadr info) additional-info)
		(display-for-true
		 "warning: " string
		 " already is a predicate variable of arity "
		 (arity-to-string additional-info))
		(myerror
		 "is-used?" "already a predicate variable of different arity"
		 string additional-info))
	    (myerror "is-used?" "already a predicate variable" string
		     "of arity" (cadr info)))))
     ((assoc string THEOREMS)
      (let ((formula (aconst-to-formula (cadr (assoc string THEOREMS)))))
	(if (eq? 'theorem sort)
	    (if (and (formula-form? additional-info)
		     (classical-formula=? formula additional-info))
		(display-for-true 
		 "warning: " string " already is a theorem constant for "
		 (formula-to-string formula))
		(myerror
		 "is-used?" string "already is a theorem constant for"
		 formula))
	    (myerror "is-used?" "already a theorem constant" string))))
     ((assoc string GLOBAL-ASSUMPTIONS)
      (let ((formula (aconst-to-formula
		      (cadr (assoc string GLOBAL-ASSUMPTIONS)))))
	(if (eq? 'global-assumption sort)
	    (if (and (formula-form? additional-info)
		     (classical-formula=? formula additional-info))
		(display-for-true 
		 "warning: " string " already is a global assumption for "
		 (formula-to-string formula))
		(myerror
		 "is-used?" string "already is a global assumption for"
		 formula))
	    (myerror "is-used?" "already a global assumption" string))))
     (else #f))))

; Type variables

; Type variable names are alpha, beta etc.  alpha is provided by default.
; To have infinitely many type variables available, we allow appended
; indices: alpha1, alpha2, alpha3,... will be type variables.

(define DEFAULT-TVAR-NAME "alpha")

(define TYPE-VARIABLES (list (list DEFAULT-TVAR-NAME)))
(define INITIAL-TYPE-VARIABLES TYPE-VARIABLES)

(define (add-tvar-name . x)
  (if (null? x)
      (myerror "add-tvar-name" "arguments expected")
      (do ((l x (cdr l)))
	  ((null? l))
	(let ((string (car l)))
	  (if (and (string? string) (not (string=? string "")))
	      (if (is-used? string '() 'tvar)
		  *the-non-printing-object*
		  (begin
		    (set! TYPE-VARIABLES
			  (append TYPE-VARIABLES (list (list string))))
		    (add-token string 'tvar-name string)
		    (comment "ok, type variable " string " added")))
	      (myerror "add-tvar-name" "string expected" string)))))) 

(define atv add-tvar-name)

(define (remove-tvar-name . x)
  (define (rtv1 tvar-name)
    (if (assoc tvar-name TYPE-VARIABLES)
	(begin (do ((l TYPE-VARIABLES (cdr l))
		    (res '() (let* ((info (car l))
				    (string (car info)))
			       (if (string=? string tvar-name)
				   res
				   (cons info res)))))
		   ((null? l) (set! TYPE-VARIABLES (reverse res))))
	       (remove-token tvar-name)
	       (comment
		"ok, type variable " tvar-name " is removed"))
	(myerror "remove-type-variable" "type variable expected" tvar-name)))
  (do ((l x (cdr l)))
      ((null? l) *the-non-printing-object*)
    (rtv1 (car l))))

(define rtv remove-tvar-name)

; Type variables are implemented as lists ('tvar index name).  If a type
; variable carries no index, we let the index be -1.  name is a string
; (the name of the type variable), to be used for output.

; To make sure that type variables generated by the system are different
; from all previously introduced variables, we maintain a global counter
; MAXTVARINDEX.  Whenever a type variable is created, e.g.alpha27, then
; MAXTVARINDEX is incremented to at least 27.

(define MAXTVARINDEX -1)
(define INITIAL-MAXTVARINDEX MAXTVARINDEX)

; Constructor, accessors and tests for type variables:

(define (make-tvar index name)
  (set! MAXTVARINDEX (max index MAXTVARINDEX))
  (list 'tvar index name))

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

(define tvar-to-index cadr)
(define tvar-to-name caddr)

; Complete test:

(define (tvar? x)
  (and (list? x)
       (= 3 (length x))
       (let ((tag (car x))
	     (index (cadr x))
	     (name (caddr x)))
	 (and (eq? 'tvar tag)
	      (integer? index)
	      (<= -1 index)
	      (assoc name TYPE-VARIABLES)))))

; For display we use

(define (tvar-to-string tvar)
  (let ((index (tvar-to-index tvar))
	(name (tvar-to-name tvar)))
    (if (= index -1)
	name
	(string-append name (number-to-string index)))))

; To generate new type variables we use

(define (new-tvar)
  (make-tvar (+ 1 MAXTVARINDEX) DEFAULT-TVAR-NAME))

; Type constants are implemented as lists ('tconst name).

(define TYPE-CONSTANTS
  (list (list "atomic") (list "existential") (list "prop") (list "nulltype")))
(define INITIAL-TYPE-CONSTANTS TYPE-CONSTANTS)

(define (make-tconst name) (list 'tconst name))
(define (tconst-form? x) (and (pair? x) (eq? 'tconst (car x))))
(define tconst-to-name cadr)

(define (nulltype? x) ;x is ('tconst "nulltype")
  (and (list? x) (= 2 (length x)) (eq? 'tconst (car x))
       (string? (cadr x)) (string=? "nulltype" (cadr x))))

; Complete test:

(define (tconst? x)
  (and (list? x)
       (= 2 (length x))
       (let ((tag (car x))
	     (name (cadr x)))
	 (and (eq? 'tconst tag)
	      (assoc name TYPE-CONSTANTS)))))

; Constructor, accessors and test for alg types:

(define (make-alg name . types) (cons 'alg (cons name types)))

(define alg-form-to-name cadr)
(define alg-form-to-types cddr)
(define (alg-form? x) (and (pair? x) (eq? 'alg (car x))))

; Complete test:

(define (alg? x)
  (and (list? x)
       (<= 2 (length x))
       (let ((tag (car x))
	     (name (cadr x)))
	 (and (eq? 'alg tag)
	      (assoc name ALGEBRAS)
              (= (alg-name-to-arity name)
                 (length (alg-form-to-types x)))
	      (apply and-op (map type? (alg-form-to-types x)))))))

(define (ground-type? type) (memq (tag type) '(tvar tconst alg)))

; Constructor and accessors for arrow types:

(define (make-arrow type1 type2) (list 'arrow type1 type2))

(define arrow-form-to-arg-type cadr)
(define arrow-form-to-val-type caddr)

(define (mk-arrow x . rest)
  (if (null? rest)
      x
      (make-arrow x (apply mk-arrow rest))))

; arrow-form-to-arg-types computes the first (car x) arg-types from x

(define (arrow-form-to-arg-types type . x)
  (cond ((null? x)
	 (if (arrow-form? type)
	     (cons (arrow-form-to-arg-type type)
		   (arrow-form-to-arg-types (arrow-form-to-val-type type)))
	     '()))
	((and (integer? (car x)) (not (negative? (car x))))
	 (let ((n (car x)))
	   (do ((rho type (arrow-form-to-val-type rho))
		(i 0 (+ 1 i))
		(res '() (cons (arrow-form-to-arg-type rho) res)))
	       ((or (= n i) (not (arrow-form? rho)))
		(if (= n i)
		    (reverse res)
		    (myerror "arrow-form-to-arg-types:"
			     n "arg-types expected in"
			     type))))))
	(else (myerror "arrow-form-to-arg-types" "number expected" (car x)))))

; arrow-form-to-final-val-type computes the final val-type (val-type
; after removing the first (car x) arguments) 

(define (arrow-form-to-final-val-type type . x)
  (cond ((null? x)
	 (if (arrow-form? type)
	     (arrow-form-to-final-val-type (arrow-form-to-val-type type))
	     type))
	((and (integer? (car x)) (not (negative? (car x))))
	 (let ((n (car x)))
	   (do ((rho type (arrow-form-to-val-type rho))
		(i 0 (+ 1 i))
		(res type (arrow-form-to-val-type res)))
	       ((or (= n i) (not (arrow-form? rho)))
		(if (= n i)
		    res
		    (myerror "arrow-form-to-final-val-type:"
			     n "arg-types expected in"
			     type))))))
	(else (myerror "arrow-form-to-final-val-type" "number expected"
		       (car x)))))

(define (type-to-arity type)
  (if (arrow-form? type)
      (+ 1 (type-to-arity (arrow-form-to-val-type type)))
      0))

; Test:

(define (arrow-form? x)
  (and (list? x) (= 3 (length x)) (eq? 'arrow (car x))))

; Constructor, accessors and test for star types:

(define (make-star type1 type2) (list 'star type1 type2))
(define star-form-to-left-type cadr)
(define star-form-to-right-type caddr)
(define (star-form? x) (and (list? x) (= 3 (length x)) (eq? 'star (car x))))

(define (mk-star x . rest)
  (if (null? rest)
      x
      (make-star x (apply mk-star rest))))

; Moreover we need

(define (type-form? x)
  (or (tvar-form? x)
      (tconst-form? x)
      (alg-form? x)
      (arrow-form? x)
      (star-form? x)))

; Complete test:

(define (type? x)
  (and (type-form? x)
       (case (tag x)
	 ((tvar) (tvar? x))
	 ((tconst) (tconst? x))
	 ((alg) (alg? x))
	 ((arrow) (and (type? (arrow-form-to-arg-type x))
		       (type? (arrow-form-to-val-type x))))
	 ((star) (and (type? (star-form-to-left-type x))
		      (type? (star-form-to-right-type x))))
	 (else #f))))  

(define (object-type? type)
  (case (tag type)
    ((tvar alg) #t)
    ((tconst) #f)
    ((arrow)
     (and (object-type? (arrow-form-to-arg-type type))
	  (object-type? (arrow-form-to-val-type type))))
    ((star)
     (and (object-type? (star-form-to-left-type type))
	  (object-type? (star-form-to-right-type type))))
    (else (myerror "object-type?" "type expected" type))))

(define (type-to-alg-names type)
  (case (tag type)
    ((tvar tconst) '())
    ((alg)
     (adjoin (alg-form-to-name type)
	     (apply union (map type-to-alg-names (alg-form-to-types type)))))
    ((arrow)
     (union (type-to-alg-names (arrow-form-to-arg-type type))
	    (type-to-alg-names (arrow-form-to-val-type type))))
    ((star)
     (union (type-to-alg-names (star-form-to-left-type type))
	    (type-to-alg-names (star-form-to-right-type type))))
    (else (myerror "type-to-alg-names" "type expected" type))))

(define (type-to-free type)
  (case (tag type)
    ((tvar) (list type))
    ((tconst) '())
    ((alg)
     (apply union (map type-to-free (alg-form-to-types type))))
    ((arrow)
     (union (type-to-free (arrow-form-to-arg-type type))
	    (type-to-free (arrow-form-to-val-type type))))
    ((star)
     (union (type-to-free (star-form-to-left-type type))
	    (type-to-free (star-form-to-right-type type))))
    (else (myerror "type-to-free" "type expected" type))))

; As an intermediate step for the display functons we use token trees.

(define (make-token-tree tttag op-string . args)
  (cons tttag (cons op-string args)))
(define token-tree-to-tag car)
(define token-tree-to-op-string cadr)
(define token-tree-to-args cddr)

(define (type-to-token-tree type)
  (case (tag type)
    ((tvar) (make-token-tree 'atomic-type (tvar-to-string type)))
    ((tconst) (make-token-tree 'atomic-type (tconst-to-name type)))
    ((alg)
     (let* ((name (alg-form-to-name type))
	    (types (alg-form-to-types type))
	    (token-type (alg-name-to-token-type name)))
       (apply make-token-tree
	      (cons token-type
		    (cons name (map type-to-token-tree types))))))
    ((arrow)
     (make-token-tree 'arrow-typeop "=>"
		      (type-to-token-tree (arrow-form-to-arg-type type))
		      (type-to-token-tree (arrow-form-to-val-type type))))
    ((star)
     (make-token-tree 'prod-typeop "@@"
		      (type-to-token-tree (star-form-to-left-type type))
		      (type-to-token-tree (star-form-to-right-type type))))
    (else (myerror "type-to-token-tree" "type expected" type))))

; 2006-05-13 The following is superseded by pp.scm
; To display types we use (type-to-string type) (following Robert Staerk).

; (define (type-to-string type)
;   (if (not (type? type))
;       (myerror "type-to-string" "type expected" type))
;   (apply string-append (type-to-string-list type 0 '() "(" ")" " ")))

; (define (type-to-space-free-string type)
;   (if (not (type? type))
;       (myerror "type-to-space-free-string" "type expected" type))
;   (apply string-append (type-to-string-list type 0 '() "(" ")" "-")))

; (define (type-to-string-list type n string-list lpar rpar sep)
;   (case (tag type)
;     ((tvar) (cons (tvar-to-string type) string-list))
;     ((tconst) (cons (tconst-to-name type) string-list))
;     ((alg arrow star)
;      (if ;infix
;       (or (and (eq? 'alg (tag type))
; 	       (memq (alg-name-to-token-type (alg-form-to-name type))
; 		     '(prod-typeop tensor-typeop sum-typeop)))
; 	  (memq (tag type) '(arrow star)))
;       (let* ((token-type
; 	      (case (tag type)
; 		((alg) (alg-name-to-token-type (alg-form-to-name type)))
; 		((arrow) 'arrow)
; 		((star) 'prod-typeop)))
; 	     (opstring (case (tag type)
; 			 ((alg)
; 			  (string-append sep (alg-form-to-name type) sep))
; 			 ((arrow) "=>")
; 			 ((star) "@@")))
; 	     (type-infix-precedences
; 	      '((prod-typeop 16 left-associative)
; 		(tensor-typeop 12 left-associative)
; 		(sum-typeop 8 left-associative)
; 		(arrow 4 right-associative)))
; 	     (info (assq token-type type-infix-precedences))
; 	     (type1 (case (tag type)
; 		      ((alg) (car (alg-form-to-types type)))
; 		      ((arrow) (arrow-form-to-arg-type type))
; 		      ((star) (star-form-to-left-type type))))
; 	     (type2 (case (tag type)
; 		      ((alg) (cadr (alg-form-to-types type)))
; 		      ((arrow) (arrow-form-to-val-type type))
; 		      ((star) (star-form-to-right-type type))))
; 	     (m (cadr info))
; 	     (left? (eq? (caddr info) 'left-associative))
; 	     (string-list1
; 	      (if (< m n) (cons rpar string-list) string-list))
; 	     (string-list2
; 	      (if left?
; 		  (type-to-string-list
; 		   type2 (+ m 1) string-list1 lpar rpar sep)
; 		  (type-to-string-list
; 		   type2 m string-list1 lpar rpar sep)))
; 	     (string-list3 (cons opstring string-list2))
; 	     (string-list4
; 	      (if left?
; 		  (type-to-string-list
; 		   type1 m string-list3 lpar rpar sep)
; 		  (type-to-string-list
; 		   type1 (+ m 1) string-list3 lpar rpar sep))))
; 	(if (< m n) (cons lpar string-list4) string-list4))
;       ;not infix, hence alg form not as above
;       (let* ((name (alg-form-to-name type))
; 	     (types (alg-form-to-types type))
; 	     (token-type (alg-name-to-token-type name))
; 	     (atomictype? (lambda (x)
; 			    (or (memq (tag x) '(tvar tconst))
; 				(and (eq? 'alg (tag x))
; 				     (null? (alg-form-to-types x))))))
; 	     (atomic-or-posttype? (lambda (x)
; 				    (or (atomictype? x)
; 					(eq? 'postfix-typeop x))))
; 	     (atomic-or-post-or-pretype? (lambda (x)
; 					   (or (atomic-or-posttype? x)
; 					       (eq? 'prefix-typeop x)))))
; 	(cond
; 	 ((null? types) (cons name string-list))
; 	 ((eq? 'alg-typeop token-type)
; 	  (append
; 	   (cons name (apply
; 		       append
; 		       (map (lambda (x)
; 			      (let ((prev (type-to-string-list
; 					   x 0 '() lpar rpar sep)))
; 				(cons
; 				 sep 
; 				 (if (atomictype? x)
; 				     prev
; 				     (cons lpar (append prev (list rpar)))))))
; 			    types)))
; 	   string-list))
; 	 ((eq? 'postfix-typeop token-type)
; 	  (let* ((argtype (car types))
; 		 (prev (type-to-string-list argtype 0 '() lpar rpar sep)))
; 	    (append (if (atomic-or-posttype? argtype)
; 			(append prev (list sep))
; 			(cons lpar (append prev (list rpar))))
; 		    (cons name string-list))))
; 	 ((eq? 'prefix-typeop token-type)
; 	  (let* ((argtype (car types))
; 		 (prev (type-to-string-list argtype 0 '() lpar rpar sep)))
; 	    (cons name
; 		  (append (if (atomic-or-post-or-pretype? argtype)
; 			      (cons sep prev)
; 			      (cons lpar (append prev (list rpar))))
; 			  string-list))))
; 	 (else (myerror "type-to-string-list" "token type expected"
; 			token-type))))))))

; (define (dy type) (display (type-to-string type)))


; Generalities for substitutions

; A substitution is a list ((x_1 t_1) ... (x_n t_n)) with distinct
; variables x_i and such that for each i, x_i is different from to t_i.
; The default domain equality is equal?

(define (make-substitution-wrt arg-val-equal? args vals)
  (if (not (and (list? args) (list? vals) (= (length args) (length vals))))
      (myerror "make-substitution-wrt" "lists of equal lengths expected"
	       args vals))
  (do ((l1 args (cdr l1))
       (l2 vals (cdr l2))
       (res '() (if (arg-val-equal? (car l1) (car l2))
		    res
		    (cons (list (car l1) (car l2)) res))))
      ((null? l1) (reverse res))))

(define (make-substitution args vals)
  (make-substitution-wrt equal? args vals))

(define (make-subst-wrt arg-val-equal? arg val)
  (make-substitution-wrt arg-val-equal? (list arg) (list val)))

(define (make-subst arg val) (make-subst-wrt equal? arg val))

(define empty-subst '())

(define (restrict-substitution-to-args subst args)
  (do ((l subst (cdr l))
       (res '() (if (member (caar l) args)
		    (cons (car l) res)
		    res)))
      ((null? l) (reverse res))))

(define (restrict-substitution-wrt subst test?)
  (do ((l subst (cdr l))
       (res '() (if (test? (caar l))
		    (cons (car l) res)
		    res)))
      ((null? l) (reverse res))))

(define (substitution-equal? subst1 subst2)
  (substitution-equal-wrt? equal? equal? subst1 subst2))

(define (substitution-equal-wrt? arg-equal? val-equal? subst1 subst2)
  (multiset-equal-wrt?
   (lambda (substpair1 substpair2)
     (let ((arg1 (car substpair1)) (val1 (cadr substpair1))
	   (arg2 (car substpair2)) (val2 (cadr substpair2)))
       (and (arg-equal? arg1 arg2) (val-equal? val1 val2))))
   subst1 subst2))

(define (subst-item-equal-wrt? arg-equal? val-equal? item1 item2)
  (and (arg-equal? (car item1) (car item2))
       (val-equal? (cadr item1) (cadr item2))))

(define (consistent-substitutions-wrt? arg-equal? val-equal? subst1 subst2)
  (let* ((args1 (map car subst1))
	 (args2 (map car subst2))
	 (common-args (intersection-wrt arg-equal? args1 args2)))
    (do ((l common-args (cdr l))
	 (res #t (let* ((arg (car l))
			(info1 (assoc-wrt arg-equal? arg subst1))
			(info2 (assoc-wrt arg-equal? arg subst2)))
		   (if (and info1 info2)
		       (val-equal? (cadr info1) (cadr info2))
		       #t))))
	((null? l) res))))

; Composition of two substitutions theta = ((x_1 s_1) ... (x_m s_m)) and
; sigma = ((y_1 t_1) ... (y_n t_n)) is defined as follows.  In the list
; ((x_1 (s_1 sigma)) ... (x_m (s_m sigma)) (y_1 t_1) ... (y_n t_n))
; remove all bindings (x_i (s_i sigma)) with (s_i sigma) = x_i, and
; also all bindings (y_j t_j) with y_j in (x_1 ... x_n).

(define (compose-substitutions-wrt substitution-proc arg-equal? arg-val-equal?
				   subst1 subst2)
  (let ((new-subst1
	 (do ((l subst1 (cdr l))
	      (res '() (let ((val (substitution-proc (cadar l) subst2)))
			 (if (arg-val-equal? (caar l) val)
			     res
			     (cons (list (caar l) val) res)))))
	     ((null? l) (reverse res))))
	(new-subst2
	 (do ((l subst2 (cdr l))
	      (res '() (if (assoc-wrt arg-equal? (caar l) subst1)
			   res
			   (cons (car l) res))))
	     ((null? l) (reverse res)))))
    (append new-subst1 new-subst2)))


; Type substitutions.  Complete test:

(define (tsubst? x)
  (and (list? x)
       (apply and-op (map (lambda (item)
			    (and (list? item)
				 (= 2 (length item))
				 (tvar? (car item))
				 (type? (cadr item))
				 (not (equal? (car item) (cadr item)))))
			  x))
       (= (length (remove-duplicates (map car x)))
	  (length x))))

(define (type-substitute type tsubst)
  (if
   (null? tsubst)
   type
   (case (tag type)
     ((tvar) (let ((info (assoc type tsubst)))
	       (if info (cadr info) type)))
     ((tconst) type)
     ((alg)
      (apply make-alg
	     (cons (alg-form-to-name type)
		   (map (lambda (x) (type-substitute x tsubst))
			(alg-form-to-types type)))))
     ((arrow)
      (make-arrow (type-substitute (arrow-form-to-arg-type type) tsubst)
		  (type-substitute (arrow-form-to-val-type type) tsubst)))
     ((star)
      (make-star (type-substitute (star-form-to-left-type type) tsubst)
		 (type-substitute (star-form-to-right-type type) tsubst)))
     (else (myerror "type-substitute" "type expected" type)))))

(define (type-subst type tvar type1)
  (type-substitute type (make-subst tvar type1)))

(define (compose-t-substitutions tsubst1 tsubst2)
  (compose-substitutions-wrt type-substitute equal? equal? tsubst1 tsubst2))

(define (extend-t-subst tsubst tvar type)
  (compose-t-substitutions tsubst (make-subst tvar type)))

; A display function for type substitutions

(define (display-t-substitution tsubst)
  (display-comment "Type substitution:") (newline)
  (for-each
   (lambda (x)
     (let* ((tvar (car x))
	    (type (cadr x)))
       (comment
	(tvar-to-string tvar) tab "->" tab (type-to-string type))))
   tsubst))

; Type unification
; ================

; We need type-unify for object types only, that is, types built from
; type variables and algebra types by arrow and star.  However, the
; type constants "atomic" "existential" "prop" "nulltype" do not do
; any harm and can be included.

; modules/type-inf.scm contains a function type-unify as well.
; However, there it is assumed that types are built from type
; variables by arrow and star, hence equal type constants do not
; unify.

(define (type-occurs? tvar type)
  (case (tag type)
    ((tvar) (equal? tvar type))
    ((alg) (apply or-op (map (lambda (x) (type-occurs? tvar x))
			     (alg-form-to-types type))))
    ((tconst) #f)
    ((arrow)
     (or (type-occurs? tvar (arrow-form-to-arg-type type))
	 (type-occurs? tvar (arrow-form-to-val-type type))))
    ((star)
     (or (type-occurs? tvar (star-form-to-left-type type))
	 (type-occurs? tvar (star-form-to-right-type type))))
    (else (myerror "type-occurs?" "type expected" type))))

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

(define (type-disagreement-pair type1 type2)
  (cond
   ((and (tvar-form? type1) (tvar-form? type2))
    (if (equal? type1 type2) #f (list type1 type2)))
   ((and (alg-form? type1) (alg-form? type2))	 
    (if (string=? (alg-form-to-name type1) (alg-form-to-name type2))
	(type-disagreement-pair-l (alg-form-to-types type1)
				  (alg-form-to-types type2))
	(list type1 type2)))
   ((and (tconst-form? type1) (tconst-form? type2))
    (if (equal? type1 type2) #f (list type1 type2)))
   ((and (arrow-form? type1) (arrow-form? type2))
    (type-disagreement-pair-l
     (list (arrow-form-to-arg-type type1) (arrow-form-to-val-type type1))
     (list (arrow-form-to-arg-type type2) (arrow-form-to-val-type type2))))
   ((and (star-form? type1) (arrow-form? type2))
    (type-disagreement-pair-l
     (list (star-form-to-left-type type1) (star-form-to-right-type type1))
     (list (star-form-to-left-type type2) (star-form-to-right-type type2))))
   (else (list type1 type2))))

(define (type-disagreement-pair-l types1 types2)
  (cond
   ((null? types1)
    (if (null? types2)
	#f
	(myerror "type-disagreement-pair-l"
		 "typelists of equal length expected"
		 types1 types2)))
   ((null? types2)
    (myerror "type-disagreement-pair-l" "typelists of equal length expected"
	     types1 types2))
   (else (let ((a (type-disagreement-pair (car types1) (car types2))))
	   (if a
	       a
	       (type-disagreement-pair-l (cdr types1) (cdr types2)))))))

(define (type-unify type1 type2)
  (let type-unify-aux ((t1 type1) (t2 type2))
    (let ((p (type-disagreement-pair t1 t2)))
      (if (not p)
	  empty-subst
	  (let ((l (car p)) (r (cadr p)))
	    (cond ((and (tvar? l)
			(not (type-occurs? l r)))
		   (let* ((var l)
			  (prev (type-unify-aux (type-subst t1 var r)
						(type-subst t2 var r))))
		     (if prev
			 (extend-t-subst prev var r)
			 #f)))
		   ((and (tvar? r)
			 (not (type-occurs? r l)))
		    (let* ((var r)
			   (prev (type-unify-aux (type-subst t1 var l)
						 (type-subst t2 var l))))
		      (if prev
			  (extend-t-subst prev var l)
			  #f)))
		   (else #f)))))))

(define (type-unify-list types1 types2)
  (type-unify (apply mk-arrow types1)
	      (apply mk-arrow types2)))

; Notice that this algorithm does not yield idempotent unifiers
; (as opposed to the Martelli-Montanari algorithm in modules/type-inf.scm):
(quote
(display-t-substitution
 (type-unify (py "alpha1=>alpha2=>boole") (py "alpha2=>alpha1=>alpha1")))
)
; alpha2	->	boole
; alpha1	->	alpha2


; Type-matching
; =============

; type-match checks whether a given pattern can be transformed by a
; substitution into a given instance.  It returns #f, if this is
; impossible, and the substitution otherwise.

; type-match-aux is an auxiliary function.  It takes a list of patterns,
; a list of instances, a list of identical variables at corresponding
; locations, and the substitution built so far.

(define (type-match pattern instance)
  (type-match-aux (list pattern) (list instance) '() empty-subst))

(define (type-match-aux patterns instances sig-tvars tsubst)
  (if
   (null? patterns)
   tsubst
   (let ((pattern (car patterns))
	 (instance (if (pair? instances) (car instances)
		       (apply myerror
			      (append (list
				       "type-match-aux"
				       "more instances expected for")
				      patterns)))))
     (case (tag pattern)
       ((tvar)
	(cond
	 ((equal? pattern instance)
	  (type-match-aux (cdr patterns) (cdr instances)
			  (cons pattern sig-tvars) tsubst))
	 ((member pattern sig-tvars) #f)
	 ((assoc pattern tsubst)
	  (if (equal? instance (cadr (assoc pattern tsubst)))
	      (type-match-aux (cdr patterns) (cdr instances)
			      sig-tvars tsubst)
	      #f))
	 (else (type-match-aux
		(cdr patterns) (cdr instances) sig-tvars
		(append tsubst (list (list pattern instance)))))))
       ((tconst)
	(if (equal? pattern instance)
	    (type-match-aux (cdr patterns) (cdr instances) sig-tvars tsubst)
	    #f))
       ((alg)
	(if (alg-form? instance)
	    (let ((name1 (alg-form-to-name pattern))
		  (name2 (alg-form-to-name instance)))
	      (if (string=? name1 name2)
		  (let ((types1 (alg-form-to-types pattern))
			(types2 (alg-form-to-types instance)))
		    (type-match-aux 
		     (append types1 (cdr patterns))
		     (append types2 (cdr instances))
		     sig-tvars tsubst))
		  #f))
	    #f))
       ((arrow)
	(if (arrow-form? instance)
	    (let ((arg-type1 (arrow-form-to-arg-type pattern))
		  (val-type1 (arrow-form-to-val-type pattern))
		  (arg-type2 (arrow-form-to-arg-type instance))
		  (val-type2 (arrow-form-to-val-type instance)))
	      (type-match-aux 
	       (cons arg-type1 (cons val-type1 (cdr patterns)))
	       (cons arg-type2 (cons val-type2 (cdr instances)))
	       sig-tvars tsubst))
	    #f))
       ((star)
	(if (star-form? instance)
	    (let ((left-type1 (star-form-to-left-type pattern))
		  (right-type1 (star-form-to-right-type pattern))
		  (left-type2 (star-form-to-left-type instance))
		  (right-type2 (star-form-to-right-type instance)))
	      (type-match-aux 
	       (cons left-type1 (cons right-type1 (cdr patterns)))
	       (cons left-type2 (cons right-type2 (cdr instances)))
	       sig-tvars tsubst))
	    #f))
       (else #f)))))

; We also provide

(define (type-match-list patterns instances)
  (cond
   ((and (null? patterns) (null? instances))
     empty-subst)
   ((= (length patterns) (length instances))
    (type-match-aux patterns instances '() empty-subst))
   (else (apply myerror (append (list "type-match-list"
				      "equal lengths expected")
				(append patterns instances))))))

(define (tsubst-match pattern-tsubst instance-tsubst)
  (let* ((tvars (remove-duplicates
		 (map car (append pattern-tsubst instance-tsubst))))
	 (patterns
	  (map (lambda (tvar) (let ((info (assoc tvar pattern-tsubst)))
				(if info (cadr info) tvar)))
	       tvars))
	 (instances
	  (map (lambda (tvar) (let ((info (assoc tvar instance-tsubst)))
				(if info (cadr info) tvar)))
	       tvars)))
    (type-match-list patterns instances)))
	
; type-match-modulo-coercion checks whether a given pattern can be
; transformed modulo coercion by a substitution into a given instance.
; It returns #f, if this is impossible, and the substitution
; otherwise.

; type-match-modulo-coercion-aux is an auxiliary function.  It takes a
; list of patterns, a list of instances, a list of identical variables
; at corresponding locations, and the substitution built so far.

(define (type-match-modulo-coercion pattern instance)
  (type-match-modulo-coercion-aux
   (list pattern) (list instance) '() empty-subst))

(define (type-match-modulo-coercion-aux patterns instances sig-tvars tsubst)
  (if
   (null? patterns)
   tsubst
   (let ((pattern (car patterns))
	 (instance (if (pair? instances) (car instances)
		       (apply myerror
			      (append (list
				       "type-match-modulo-coercion-aux"
				       "more instances expected for")
				      patterns)))))
     (case (tag pattern)
       ((tvar)
	(cond
	 ((equal? pattern instance)
	  (type-match-modulo-coercion-aux (cdr patterns) (cdr instances)
					  (cons pattern sig-tvars) tsubst))
	 ((member pattern sig-tvars) #f)
	 ((assoc pattern tsubst)
	  (if (type-le? (cadr (assoc pattern tsubst)) instance)
	      (type-match-modulo-coercion-aux (cdr patterns) (cdr instances)
					      sig-tvars tsubst)
	      #f))
	 (else (type-match-modulo-coercion-aux
		(cdr patterns) (cdr instances) sig-tvars
		(append tsubst (list (list pattern instance)))))))
       ((tconst)
	(if (type-le? pattern instance)
	    (type-match-modulo-coercion-aux
	     (cdr patterns) (cdr instances) sig-tvars tsubst)
	    #f))
       ((alg)
	(if (alg-form? instance)
	    (if (type-le? pattern instance)
		(type-match-modulo-coercion-aux
		 (cdr patterns) (cdr instances) sig-tvars tsubst)
		(let ((name1 (alg-form-to-name pattern))
		      (name2 (alg-form-to-name instance)))
		  (if (string=? name1 name2)
		      (let ((types1 (alg-form-to-types pattern))
			    (types2 (alg-form-to-types instance)))
			(type-match-modulo-coercion-aux 
			 (append types1 (cdr patterns))
			 (append types2 (cdr instances))
			 sig-tvars tsubst))
		      #f)))
	    #f))
       ((arrow)
	(if (arrow-form? instance)
	    (let ((arg-type1 (arrow-form-to-arg-type pattern))
		  (val-type1 (arrow-form-to-val-type pattern))
		  (arg-type2 (arrow-form-to-arg-type instance))
		  (val-type2 (arrow-form-to-val-type instance)))
	      (type-match-modulo-coercion-aux 
	       (cons arg-type1 (cons val-type1 (cdr patterns)))
	       (cons arg-type2 (cons val-type2 (cdr instances)))
	       sig-tvars tsubst))
	    #f))
       ((star)
	(if (star-form? instance)
	    (let ((left-type1 (star-form-to-left-type pattern))
		  (right-type1 (star-form-to-right-type pattern))
		  (left-type2 (star-form-to-left-type instance))
		  (right-type2 (star-form-to-right-type instance)))
	      (type-match-modulo-coercion-aux 
	       (cons left-type1 (cons right-type1 (cdr patterns)))
	       (cons left-type2 (cons right-type2 (cdr instances)))
	       sig-tvars tsubst))
	    #f))
       (else #f)))))

; We allow (simultaneously defined) finitary and infinitary free
; algebras as types.  They may depend on other type parameters
; (e.g. list rho).  The freeness of the constructors is expressed by
; requiring that their domains are disjoint, and that they are injective
; (in particular non-strict) and total.

; Equality is decidable for finitary algebras only.  Infinitary algebras
; are to be treated similarly to arrow types.  For infinitary algebras
; (extensional) equality is given by a predicate constant (schema), with
; appropriate axioms.  In a finitary algebra equality is a (recursively
; defined) constant.

; The standard example for a finitary free algebra is the type nat of
; unary natural numbers, with constructors Zero and Succ.  Objects of
; type nat are essentially 
; - Zero or lists (Succ obj) 
; - term families

(define ALGEBRAS '())
(define INITIAL-ALGEBRAS ALGEBRAS)

(define OLD-ALGEBRAS '())
(define INITIAL-OLD-ALGEBRAS OLD-ALGEBRAS)

; Format of ALGEBRAS:
; ((alg-name simalg-names token-type
;            (constr-name1 type1 <token-type1>)
;            (constr-name2 type2 <token-type2>) ...) ...)
; simalgs are the algebras defined simultaneously with alg (including
; alg), and token-type is one of
; postfix-typeop (arity 1)
; prefix-typeop  (arity 1)
; prod-typeop    (arity 2)
; tensor-typeop  (arity 2)
; sum-typeop     (arity 2)
; alg     (arity an integer >=0)

(define (alg-name-to-simalg-names alg-name) (cadr (assoc alg-name ALGEBRAS)))
(define (alg-name-to-token-type alg-name) (caddr (assoc alg-name ALGEBRAS)))
(define (alg-name-to-typed-constr-names alg-name)
  (cdddr (assoc alg-name ALGEBRAS)))

(define (typed-constr-name-to-name y) (car y))
(define (typed-constr-name-to-type y) (cadr y))
(define (typed-constr-name-to-optional-token-type y) (cddr y))

(define (alg-name-to-tvars alg-name)
  (let* ((typed-constr-names (alg-name-to-typed-constr-names alg-name))
	 (typed-constr-name (typed-constr-name-to-name typed-constr-names))
	 (type (typed-constr-name-to-type typed-constr-name))
	 (val-type (arrow-form-to-final-val-type type)))
    (alg-form-to-types val-type)))

(define (alg-name-to-arity alg-name) (length (alg-name-to-tvars alg-name)))

(define (finalg? type)
  (and
   (alg-form? type)
   (apply and-op (map finalg? (alg-form-to-types type)))
   (let* ((name (alg-form-to-name type))
	  (names (if (assoc name ALGEBRAS)
		     (alg-name-to-simalg-names name)
		     (myerror "finalg?" "alg name expected" name)))
	  (typed-constr-names
           (apply union (map alg-name-to-typed-constr-names names)))
	  (constr-types (map typed-constr-name-to-type typed-constr-names))
	  (argtypes (apply union (map arrow-form-to-arg-types constr-types)))
	  (tsubst (map (lambda (x y) (list x y))
		       (alg-name-to-tvars name)
		       (alg-form-to-types type)))
	  (tsubst-argtypes (map (lambda (x) (type-substitute x tsubst))
				argtypes))
          (test (lambda (type1)
                  (if (alg-form? type1)
                      (or (member (alg-form-to-name type1) names)
                          (finalg? type1))
                      #f))))
     (apply and-op (map test tsubst-argtypes)))))

; sfinalg? checks whether type is a structure-finitary algebra.

(define (sfinalg? type)
  (and
   (alg-form? type)
   (let* ((name (alg-form-to-name type))
          (names (if (assoc name ALGEBRAS)
		     (alg-name-to-simalg-names name)
		     (myerror "sfinalg?" "alg name expected" name)))
          (typed-constr-names ;all constructors are relevant
           (apply union (map alg-name-to-typed-constr-names names)))
          (constr-types (map typed-constr-name-to-type typed-constr-names))
          (argtypes-lists (map arrow-form-to-arg-types constr-types))
          (not-param-type? ;filters non parameter types
           (lambda (x)
             (let ((val-type (arrow-form-to-final-val-type x)))
               (if (alg-form? val-type)
                   (member (alg-form-to-name val-type) names)
                   #f))))
          (argtypes-lists-wo-params
           (map (lambda (lst)
                  (list-transform-positive lst not-param-type?))
                argtypes-lists))
          (argargtypes-lists
           (map (lambda (lst)
                  (apply union (map arrow-form-to-arg-types lst)))
                argtypes-lists-wo-params))
          (argargtypes-union (apply union argargtypes-lists)))
     (null? argargtypes-union))))

; To introduce simultaneous free algebras we use add-param-algs.  Example
; (add-param-algs (list "labtree" "labtlist") 'alg-typeop 2
; 		'("LabLeaf" "alpha1=>labtree")
; 		'("LabBranch" "labtlist=>alpha2=>labtree")
; 		'("LabEmpty" "labtlist")
; 		'("LabTcons" "labtree=>labtlist=>labtlist" pairscheme-op))

(define (string-to-last-name string)
  (do ((l (reverse (string->list string)) (cdr l))
       (res '() (cons (car l) res)))
      ((or (null? l) (not (char-alphabetic? (car l))))
       (list->string res))))

(define (add-algebras-with-parameters alg-names token-type . rest)
  (if (not (and (list? alg-names)
		(apply and-op
		       (map (lambda (s) (and (string? s)
					     (not (is-used? s '() 'algebra))))
			    alg-names))))
      (apply myerror
	     (cons "add-algebras-with-parameters: list of new strings expected"
		   alg-names)))
  (if (not (memq token-type
		 (list 'postfix-typeop 'prefix-typeop 'prod-typeop
		       'tensor-typeop 'sum-typeop 'alg 'alg-typeop)))
      (myerror
       "add-algebras-with-parameters" "token type expected" token-type))
  (if (null? rest)
      (myerror "add-algebras-with-parameters"
	       "stringtyped constructor names expected"))
  (if (and (eq? 'alg-typeop token-type)
	   (not (and (integer? (car rest)) (positive? (car rest)))))
      (myerror "add-algebras-with-parameters" "positive integer expected"
	       (car rest)))
  (if (and (not (eq? 'alg-typeop token-type))
	   (integer? (car rest))
	   (not (= (car rest) (token-type-to-arity token-type))))
      (myerror "add-algebras-with-parameters" "expected arity is"
	       (token-type-to-arity token-type)))
  (let ((stringtyped-constr-names (if (integer? (car rest)) (cdr rest) rest))
	(arity (if (integer? (car rest))
		   (car rest)
		   (token-type-to-arity token-type))))
    (if
     (null? stringtyped-constr-names)
     (myerror
      "add-algebras-with-parameters" "stringtyped constructor names expected"))
    (for-each (lambda (x) (is-used? (car x) '() 'constructor))
	      stringtyped-constr-names)
    (for-each
     (lambda (x)
       (if
	(not (and (list? x) (< 1 (length x))
		  (string? (car x)) (string? (cadr x))))
	(myerror
	 "add-algebras-with-parameters" "not a possible list constructor-type"
	 x)))
     stringtyped-constr-names)
    (let* ((stringtypes (map cadr stringtyped-constr-names))
	   (val-alg-names-with-duplicates
	    (map string-to-last-name stringtypes))
	   (val-alg-names (remove-duplicates val-alg-names-with-duplicates)))
      (if (pair? (set-minus alg-names val-alg-names))
	  (myerror "add-algebras-with-parameters" "too many alg-names"
		   (set-minus alg-names val-alg-names)))
      (if (pair? (set-minus val-alg-names alg-names))
	  (myerror "add-algebras-with-parameters" "too many alg names"
		   (set-minus val-alg-names alg-names)))
      ;for parsing, temporarily add alg-names with token type alg to ALGEBRAS
      (set! OLD-ALGEBRAS ALGEBRAS)
      (for-each (lambda (x)
		  (set! ALGEBRAS
			(cons (list x alg-names 'alg) ALGEBRAS)))
		alg-names)
					;and add them as tokens 
      (for-each (lambda (x) (add-token x 'alg x))
		alg-names)
      (let* ((prelim-types (map py stringtypes))
	     (prelim-typed-constr-names
	      (map (lambda (x y) (cons (car x) (cons y (cddr x))))
		   stringtyped-constr-names prelim-types))
	     (free (apply union (map type-to-free prelim-types))))
	(set! ALGEBRAS OLD-ALGEBRAS)
	(for-each remove-token alg-names)
	(if (and (> (length free) arity) (not (zero? arity)))
	    (myerror "add-algebras-with-parameters" "too many type parameters"
		     (map type-to-string free)))
	(if (< (length free) arity)
	    (myerror "add-algebras-with-parameters" "too few type parameters"
		     (map type-to-string free)))
	;check whether the prelim-types are correct
	(for-each
	 (lambda (prelim-type)
	   (let ((test (set-minus (type-to-alg-names prelim-type)
				  (append (map car TYPE-CONSTANTS)
					  (map car OLD-ALGEBRAS)
					  alg-names))))
	     (if
	      (pair? test)
	      (myerror "add-algebras-with-parameters" "undefined alg-names"
		       test)
	      (let* ((args (arrow-form-to-arg-types prelim-type))
		     (argargs (apply union (map arrow-form-to-arg-types
						args)))
		     (test1 (intersection
			     (apply union (map type-to-alg-names argargs))
			     alg-names)))
		(if
		 (pair? test1)
		 (myerror
		  "add-algebras-with-parameters" "non strictly positive occ of"
		  test1 "in argument types"))))))
	 prelim-types)
	;check for non-emptyness (added 2007-09-06)
	(let ((remove-safe-types
	       (lambda (types)
		 (let* ((val-algs (map arrow-form-to-final-val-type types))
			(types-wo-rec-calls-to-val-algs
			 (list-transform-positive types
			   (lambda (type)
			     (let* ((args (arrow-form-to-arg-types type))
				    (argvals
				     (map arrow-form-to-final-val-type args)))
			       (null? (intersection val-algs argvals))))))
			(safe-val-algs
			 (map arrow-form-to-final-val-type
			      types-wo-rec-calls-to-val-algs))
			(safe-types
			 (list-transform-positive types
			   (lambda (type)
			     (member (arrow-form-to-final-val-type type)
				     safe-val-algs)))))
		   (if (null? types-wo-rec-calls-to-val-algs)
		       (apply
			myerror
			(append
			 (list "add-algebras-with-parameters"
			       "nullary constructor missing for type(s)")
			 types))
		       (set-minus types safe-types))))))
	  (do ((types prelim-types (remove-safe-types types)))
	      ((null? types))))
	(let* ((alg-names-with-prelim-typed-constr-names
		;((alg1 prelim-typed-constr11 prelim-typed-constr12 ...) ...)
		(map (lambda (alg-name)
		       (do ((l prelim-typed-constr-names (cdr l))
			    (res
			     '()
			     (if (let ((final-val-type
					(arrow-form-to-final-val-type
					 (cadr (car l)))))
				   (and (alg-form? final-val-type)
					(string=?
					 alg-name
					 (alg-form-to-name final-val-type))))
				 (cons (car l) res)
				 res)))
			   ((null? l) (cons alg-name (reverse res)))))
		     alg-names))
	       (alg-names-with-typed-constr-names
		(letrec
		    ((subst
		      (lambda (type)
			(case (tag type)
			  ((tvar tconst) type)
			  ((alg)
			   (if (member (alg-form-to-name type) alg-names)
			       (apply make-alg
				      (cons (alg-form-to-name type) free))
			       type))
			  ((arrow)
			   (make-arrow (subst (arrow-form-to-arg-type type))
				       (subst (arrow-form-to-val-type type))))
			  ((star)
			   (make-star (subst (star-form-to-left-type type))
				      (subst (star-form-to-right-type type))))
			  (else (myerror
				 "add-algebras-with-parameters" "type expected"
				 type))))))
		  (map (lambda (x)
			 (let ((alg-name (car x))
			       (prelim-typed-constr-names (cdr x)))
			   (cons
			    alg-name
			    (map (lambda (y)
				   (let ((constr-name
					  (typed-constr-name-to-name y))
					 (constr-type
					  (typed-constr-name-to-type y)))
				     (cons constr-name
					   (cons (subst constr-type)
						 (cddr y)))))
				 prelim-typed-constr-names))))
		       alg-names-with-prelim-typed-constr-names)))
	       (alg-names-with-immed-pd-alg-names
		(map
		 (lambda (alg-name)
		   (do ((l1 stringtyped-constr-names (cdr l1))
			(l2 val-alg-names-with-duplicates (cdr l2))
			(l3 prelim-types (cdr l3))
			(res
			 '()
			 (if
			  (string=? alg-name (car l2))
			  (let* ((stringtyped-constr-name (car l1))
				 (constr-name (car stringtyped-constr-name))
				 (type (car l3))
				 (argtypes (arrow-form-to-arg-types type))
				 (argvaltypes
				  (map arrow-form-to-final-val-type argtypes))
				 (final-pd-names-without-old-alg-names
				  (do ((l argvaltypes (cdr l))
				       (res1
					'()
					(if (alg-form? (car l))
					    (let ((name (alg-form-to-name
							 (car l))))
					      (if (assoc name ALGEBRAS)
						  res1
						  (cons name res1)))
					    res1)))
				      ((null? l) (reverse res1)))))
			    (union final-pd-names-without-old-alg-names res))
			  res)))
		       ((null? l1) (cons alg-name (reverse res)))))
		 alg-names))
	       (alg-names-with-simalg-names
		(let ((closure-op
		       (lambda (names)
			 (apply
			  union
			  (cons
			   names
			   (map (lambda (name)
				  (let ((info
					 (assoc
					  name
					  alg-names-with-immed-pd-alg-names)))
				    (if info (cdr info) '())))
				names))))))
		  (map (lambda (name)
			 (cons name
			       (set-closure (list name) closure-op)))
		       alg-names))))
	  ;check whether unneccessary simultaneous definition
	  (for-each (lambda (x)
		      (let ((alg-name (car x))
			    (cl (cdr x)))
			(if (not (null? (set-minus alg-names cl)))
			    (myerror "unnecessary simultaneous definition for"
				     alg-name))))
		    alg-names-with-simalg-names)
	  ;update ALGEBRAS, extend CONSTRUCTORS by constructors
	  (for-each ;of alg-names-with-typed-constr-names
	   (lambda (x)
	     (let ((alg-name (car x))
		   (typed-constr-names (cdr x)))
	       (for-each ;of typed-constr-names
		(lambda (y)
		  (let* ((name (typed-constr-name-to-name y))
			 (type (typed-constr-name-to-type y))
			 (token-type (if (null? (cddr y))
					 (if (null? free) 'const 'constscheme)
					 (caddr y)))
			 (argtypes (arrow-form-to-arg-types type))
			 (arity (length argtypes))
			 (valtype (arrow-form-to-final-val-type type))
			 (del-constr 
			  (eval-once (lambda () (constr-name-to-constr name))))
			 (obj
			  (nbe-make-object
			   type
			   (if
			    (zero? arity)
			    (nbe-make-constr-value name '() del-constr)
			    (nbe-curry
			     (lambda objs ;as many as argtypes
			       (nbe-make-object valtype
						(nbe-make-constr-value
						 name objs del-constr)))
			     type
			     arity))))
			 (constr (make-const obj name 'constr type
					     empty-subst 1 token-type)))
		    (set! CONSTRUCTORS
			  (cons (list name (list (list empty-subst constr)))
				CONSTRUCTORS))
		    (add-token name
			       token-type
			       (if (null? free)
				   (const-to-token-value constr)
				   constr))))
		typed-constr-names)
	       (if (not (member alg-name (list "unit" "boole")))
		   (comment "ok, algebra " alg-name " added"))
	       (set! ALGEBRAS
		     (cons (cons alg-name
				 (cons alg-names
				       (cons token-type typed-constr-names)))
			   ALGEBRAS))
	       (add-token alg-name
			  token-type
			  (alg-name-to-token-value alg-name))))
	   alg-names-with-typed-constr-names))))))

(define (add-alg alg-name . stringtyped-constr-names)
  (apply add-algebras-with-parameters (append (list (list alg-name) 'alg 0)
					      stringtyped-constr-names)))

(define (add-algs alg-names . stringtyped-constr-names)
  (apply add-algebras-with-parameters (append (list alg-names 'alg 0)
					      stringtyped-constr-names)))

(define (add-param-alg alg-name token-type . rest)
  (apply add-algebras-with-parameters (append (list (list alg-name) token-type)
					      rest)))

(define add-param-algs add-algebras-with-parameters)

(define (remove-alg-name . x)
  (define (ran1 alg-name)
    (let* ((simalg-names (alg-name-to-simalg-names alg-name))
	   (affected-constr-names
	    (list-transform-positive (map car CONSTRUCTORS)
	      (lambda (x)
		(pair? (intersection simalg-names
				     (type-to-alg-names
				      (const-to-type
				       (constr-name-to-constr x))))))))
	   (affected-pconst-names
	    (list-transform-positive (map car PROGRAM-CONSTANTS)
	      (lambda (x)
		(pair? (intersection simalg-names
				     (type-to-alg-names
				      (const-to-type
				       (pconst-name-to-pconst x)))))))))
      (set! ALGEBRAS
	    (list-transform-positive ALGEBRAS
	      (lambda (x) (not (member (car x) simalg-names)))))
      (for-each (lambda (x)
		  (remove-token x)
		  (comment "ok, algebra " x " removed"))
		simalg-names)
      (set! CONSTRUCTORS
	    (list-transform-positive CONSTRUCTORS
	      (lambda (x) (not (member (car x) affected-constr-names)))))
      (for-each (lambda (x)
		  (remove-token x)
		  (comment "ok, constructor " x " removed"))
		affected-constr-names)
      (apply remove-program-constant affected-pconst-names)))
  (for-each (lambda (alg-name)
	      (if (not (assoc alg-name ALGEBRAS))
		  (myerror "remove-alg-name" "algebra name expected"
			   alg-name)))
	    x)
  (let* ((list-of-simalgs (map alg-name-to-simalg-names x))
	 (reduced-list-of-simalgs (remove-duplicates list-of-simalgs))
	 (reduced-x (map car reduced-list-of-simalgs)))
    (for-each ran1 reduced-x))    )

(define ran remove-alg-name)

(define (type-to-canonical-inhabitant type)
  (case (tag type)
    ((tvar tconst)
     (make-term-in-const-form
      (let* ((inhab-pconst (pconst-name-to-pconst "Inhab"))
	     (tvars (const-to-tvars inhab-pconst))
	     (tsubst (make-substitution tvars (list type))))
	(const-substitute inhab-pconst tsubst #f))))
    ((alg)
     (let* ((name (alg-form-to-name type))
	    (typed-constr-names (alg-name-to-typed-constr-names name))
	    (constr-types
	     (map typed-constr-name-to-type typed-constr-names))
	    (first-nullary-constr-name
	     (do ((l typed-constr-names (cdr l))
		  (res #f
		       (if
			res
			res
			(let* ((typed-constr-name (car l))
			       (name (typed-constr-name-to-name
				      typed-constr-name))
			       (type (typed-constr-name-to-type
				      typed-constr-name))
			       (arg-types (arrow-form-to-arg-types type)))
			  (if (null? arg-types) name res)))))
		 ((null? l)
		  (if res res #f)))))
       (make-term-in-const-form
	(if first-nullary-constr-name
	    (let ((tsubst (map (lambda (x y) (list x y))
			       (alg-name-to-tvars name)
			       (alg-form-to-types type))))
	      (const-substitute
	       (constr-name-to-constr first-nullary-constr-name) tsubst #t))
	    (let* ((inhab-pconst (pconst-name-to-pconst "Inhab"))
		   (tvars (const-to-tvars inhab-pconst))
		   (tsubst (make-substitution tvars (list type))))
	      (const-substitute inhab-pconst tsubst #f))))))
    ((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 (type-to-canonical-inhabitant val-type))))
    ((star)
     (let ((left-type (star-form-to-left-type type))
	   (right-type (star-form-to-right-type type)))
       (make-term-in-pair-form
	(type-to-canonical-inhabitant left-type)
	(type-to-canonical-inhabitant right-type))))
    (else
     (myerror "type-to-canonical-inhabitant" "type expected" type))))

; For Huets unification algorithm we need

(define (type-to-canonical-term type groundtype-var-alist)
  (case (tag type)
    ((tvar tconst alg)
     (let ((info (assoc type groundtype-var-alist)))
       (if (not info)
	   (myerror "type-to-canonical-term" "no variable assigned to"
		    type))
       (make-term-in-var-form (cadr info))))
    ((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 (type-to-canonical-term val-type groundtype-var-alist))))
    ((star)
     (let ((left-type (star-form-to-left-type type))
	   (right-type (star-form-to-right-type type)))
       (make-term-in-pair-form
	(type-to-canonical-term left-type groundtype-var-alist)
	(type-to-canonical-term right-type groundtype-var-alist))))
    (else
     (myerror "type-to-canonical-term" "type expected" type))))

(define (type-to-final-groundtypes type)
  (case (tag type)
    ((tvar tconst alg) (list type))
    ((arrow) (type-to-final-groundtypes (arrow-form-to-val-type type)))
    ((star)
     (union (type-to-final-groundtypes (star-form-to-left-type type))
	    (type-to-final-groundtypes (star-form-to-right-type type))))
    (else (myerror "type-to-final-groundtypes" "type expected" type))))

; We need a subtype relation generated from pos < nat< int < rat <
; real < cpx

; View pos, nat, int, rat, real and cpx as algebras, with constructors
; pos: One SZero SOne 
; nat: Zero Succ
; int: IntPos IntZero IntNeg
; rat: RatConstr (written # infix) and destructors RatN RatD
; real: RealConstr and Destructors RealSeq RealMod
; cpx: CpxConstr (written ## infix) and destructors RealPart ImagPart

; We use a global variable ALGEBRA-EDGE-TO-EMBED-TERM-ALIST
; initially set to '().

(define ALGEBRA-EDGE-TO-EMBED-TERM-ALIST '())
(define INITIAL-ALGEBRA-EDGE-TO-EMBED-TERM-ALIST
  ALGEBRA-EDGE-TO-EMBED-TERM-ALIST)

(define (alg-le? alg1 alg2)
  (or (equal? alg1 alg2)
      (do ((l ALGEBRA-EDGE-TO-EMBED-TERM-ALIST (cdr l))
	   (res #f (let* ((item (car l))
			  (edge (car item))
			  (lhs (car edge))
			  (rhs (cadr edge)))
		     (and (equal? rhs alg2)
			  (alg-le? alg1 lhs)))))
	  ((or res (null? l)) res))))

(define (type-le? type1 type2)
  (or (equal? type1 type2)
      (and (alg-form? type1) (alg-form? type2)
	   (let ((types1 (alg-form-to-types type1))
		 (types2 (alg-form-to-types type2)))
	     (if (and (null? types1) (null? types2))
		 (alg-le? type1 type2)
		 (and (= (length types1) (length types2))
		      (string=? (alg-form-to-name type1)
				(alg-form-to-name type2))
		      (apply and-op (map type-le? types1 types2))))))
      (and (arrow-form? type1) (arrow-form? type2)
	   (type-le? (arrow-form-to-arg-type type2)
		     (arrow-form-to-arg-type type1))
	   (type-le? (arrow-form-to-val-type type1)
		     (arrow-form-to-val-type type2)))
      (and (star-form? type1) (star-form? type2)
	   (type-le? (star-form-to-left-type type1)
		     (star-form-to-left-type type2))
	   (type-le? (star-form-to-right-type type1)
		     (star-form-to-right-type type2)))))

; For compatibility we (temporarily) define
(define type-leq? type-le?)

; The original of a term under possibly repeated embeddings stored in
; ALGEBRA-EDGE-TO-EMBED-TERM-ALIST

(define (term-to-original term)
  (do ((l ALGEBRA-EDGE-TO-EMBED-TERM-ALIST (cdr l))
       (res #f (let* ((item (car l))
		      (edge (car item))
		      (lhs (car edge))
		      (rhs (cadr edge)))
		 (if (equal? rhs (term-to-type term))
		     (let* ((embed-term (cadr item))
			    (var (term-in-abst-form-to-var embed-term))
			    (kernel (term-in-abst-form-to-kernel embed-term))
			    (match-res (match kernel term)))
		       (if match-res
			   (term-to-original
			    (let ((info (assoc var match-res)))
			      (if info
				  (cadr info)
				  (make-term-in-var-form var))))
			   #f))
		     #f))))
      ((or res (null? l)) (if res res term))))

; The following returns #f in case alg1 not <= alg2

(define (algebras-to-embedding alg1 alg2)
  (if (equal? alg1 alg2)
      (lambda (term) term)
      (do ((l ALGEBRA-EDGE-TO-EMBED-TERM-ALIST (cdr l))
	   (res #f (let* ((item (car l))
			  (edge (car item))
			  (lhs (car edge))
			  (rhs (cadr edge)))
		     (if (equal? rhs alg2)
			 (let ((prev (algebras-to-embedding alg1 lhs)))
			   (and prev
				(let* ((embed-term (cadr item))
				       (var (term-in-abst-form-to-var
					     embed-term))
				       (kernel (term-in-abst-form-to-kernel
						embed-term)))
				  (lambda (term)
				    (term-subst kernel var (prev term))))))
			 #f))))
	  ((or res (null? l)) res))))

(define (types-to-embedding type1 type2)
  (if
   (equal? type1 type2)
   (lambda (term) term)
   (cond
    ((and (alg-form? type1) (alg-form? type2))
     (let ((types1 (alg-form-to-types type1))
	   (types2 (alg-form-to-types type2)))
       (if (not (= (length types1) (length types2)))
	   (apply myerror
		  (append (list "types-to-embedding"
				"types of equal lengths expected")
			  types1 (list "and") types2)))
       (if
	(null? types1)
	(algebras-to-embedding type1 type2)
	(let ((name1 (alg-form-to-name type1))
	      (name2 (alg-form-to-name type2)))
	  (if (not (string=? name1 name2))
	      (myerror "types-to-embedding" "equal alg names expected"
		       type1 type2))
	  (let* ((tvars (alg-name-to-tvars name1))
		 (tvar-to-embedding-alist
		  (map (lambda (tvar type1 type2)
			 (list tvar (types-to-embedding type1 type2)))
		       tvars types1 types2))
		 (tsubst1 (make-substitution tvars types1))
		 (tsubst2 (make-substitution tvars types2))
		 (rec-const (type-info-to-rec-const (make-arrow type1 type2)))
		 (uninst-type (const-to-uninst-type rec-const))
		 (arg-types (arrow-form-to-arg-types uninst-type))
		 (step-types (cdr arg-types))
		 (alg-type (car arg-types))
		 (step-arg-type-lists (map arrow-form-to-arg-types step-types))
		 (step-alg-arg-type-lists ;((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? y)
				    (string=? (alg-form-to-name y) name1))))))
		       step-arg-type-lists))
		 (step-alg-arg-lengths (map length step-alg-arg-type-lists))
		 (step-param-arg-tvar-lists
		  (map (lambda (l n) (list-head l (- (length l) (* 2 n))))
		       step-arg-type-lists step-alg-arg-lengths))
		 (subst-step-alg-arg-type-lists
		  (map (lambda (types)
			 (map (lambda (type)
				(type-substitute type tsubst1)) types))
		       step-alg-arg-type-lists))
		 (subst-step-param-arg-type-lists
		  (map (lambda (types)
			 (map (lambda (type)
				(type-substitute type tsubst1)) types))
		       step-param-arg-tvar-lists))
		 (subst-step-alg-arg-var-lists
		  (map (lambda (types) (map type-to-new-var types))
		       subst-step-alg-arg-type-lists))
		 (subst-step-param-arg-var-lists
		  (map (lambda (types) (map type-to-new-var types))
		       subst-step-param-arg-type-lists))
		 (embedded-subst-step-param-arg-varterm-lists
		  (map
		   (lambda (tvars ps)
		     (map (lambda (tvar p)
			    (let* ((info (assoc tvar tvar-to-embedding-alist))
				   (f (if info (cadr info)
					  (myerror
					   "types-to-embedding" "unknown tvar"
					   tvar))))
			      (f (make-term-in-var-form p))))
			  tvars ps))
		   step-param-arg-tvar-lists
		   subst-step-param-arg-var-lists))
		 (typed-constr-names (alg-name-to-typed-constr-names name1))
		 (constr-names (map typed-constr-name-to-name
				    typed-constr-names))
		 (constrs (map constr-name-to-constr constr-names))
		 (subst-constrs
		  (map (lambda (c) (const-substitute c tsubst2 #t))
		       constrs))
		 (step-terms
		  (map (lambda (ps rs c ts)
			 (apply
			  mk-term-in-abst-form
			  (append
			   ps rs (list (apply
					mk-term-in-app-form
					(cons (make-term-in-const-form c)
					      ts))))))
		       subst-step-param-arg-var-lists
		       subst-step-alg-arg-var-lists
		       subst-constrs
		       embedded-subst-step-param-arg-varterm-lists)))
	    (lambda (term)
	      (apply
	       mk-term-in-app-form
	       (append
		(list (make-term-in-const-form rec-const) term)
		step-terms))))))))
    ((and (arrow-form? type1) (arrow-form? type2))
     (lambda (r)
       (let* ((argtype1 (arrow-form-to-arg-type type1))
	      (valtype1 (arrow-form-to-val-type type1))
	      (argtype2 (arrow-form-to-arg-type type2))
	      (valtype2 (arrow-form-to-val-type type2))
	      (var (type-to-new-var argtype2))
	      (varterm (make-term-in-var-form var))
	      (incr-varterm ((types-to-embedding argtype2 argtype1) varterm))
	      (term (if (term-in-abst-form? r)
			(term-subst (term-in-abst-form-to-kernel r)
				    (term-in-abst-form-to-var r)
				    incr-varterm)
			(make-term-in-app-form r incr-varterm)))
	      (incr-term ((types-to-embedding valtype1 valtype2) term)))
	 (make-term-in-abst-form var incr-term))))
    ((and (star-form? type1) (star-form? type2))
     (let ((prev-left (types-to-embedding (star-form-to-left-type type1)
					  (star-form-to-left-type type2)))
	   (prev-right (types-to-embedding (star-form-to-right-type type1)
					   (star-form-to-right-type type2))))
       (lambda (x)
	 (make-term-in-pair-form
	  (prev-left (if (term-in-pair-form? x)
			 (term-in-pair-form-to-left x)
			 (make-term-in-lcomp-form x)))
	  (prev-right (if (term-in-pair-form? x)
			  (term-in-pair-form-to-right x)
			  (make-term-in-rcomp-form x)))))))
    (else (myerror "types-to-embedding" "increasing types expected"
		   type1 type2)))))

; For compatibility (temporarily)

(define types-to-coercion types-to-embedding)

(define (types-lub type . types)
  (if (null? types)
      type
      (types-lub-aux type (apply types-lub types))))

(define (types-lub-aux type1 type2)
  (cond
   ((type-le? type1 type2) type2)
   ((type-le? type2 type1) type1)
   ((and (arrow-form? type1) (arrow-form? type2))
    (make-arrow (types-glb-aux (arrow-form-to-arg-type type1)
			       (arrow-form-to-arg-type type2))
		(types-lub-aux (arrow-form-to-val-type type1)
			       (arrow-form-to-val-type type2))))
   ((and (star-form? type1) (star-form? type2))
    (make-star (types-lub-aux (star-form-to-left-type type1)
			      (star-form-to-left-type type2))
	       (types-lub-aux (star-form-to-right-type type1)
			      (star-form-to-right-type type2))))
   (else (myerror "types-lub-aux" "types with least upper bound expected"
		  type1 type2))))

(define (types-glb-aux type1 type2)
  (cond
   ((type-le? type1 type2) type1)
   ((type-le? type2 type1) type2)
   ((and (arrow-form? type1) (arrow-form? type2))
    (make-arrow (types-lub-aux (arrow-form-to-arg-type type1)
			       (arrow-form-to-arg-type type2))
		(types-glb-aux (arrow-form-to-val-type type1)
			       (arrow-form-to-val-type type2))))
   ((and (star-form? type1) (star-form? type2))
    (make-star (types-glb-aux (star-form-to-left-type type1)
			      (star-form-to-right-type type1))
	       (types-glb-aux (star-form-to-left-type type2)
			      (star-form-to-right-type type2))))
   (else (myerror "types-glb-aux" "types with greatest upper bound expected"
		  type1 type2))))


