; ***********************************************************
; ; Adapt path if necessary:
; (define path "~/minlog/examples/tait/diplomarbeit_schlenker/")

; ; Defines the function "pload" to load files 
; ; from the path defined above
; (define pload (lambda (x) (load (string-append path x))))

; ; Used Modules:
; (pload "./initiate.scm")
; (pload "./defsLamCalc.scm")
; (pload "./defsSubst.scm")
;
; NOTICE: Uncomment modules only when file is run on its own
; ***********************************************************


; ================
;  Section: Omega
; ================
; contains definition of omega, OmegaPart, Mod, Hat etc.

; Addition of type constants
; --------------------------
; In typ.scm

; addition of type constants generally allowed

(define (add-tconst-name . x)
  (if (null? x)
      (myerror "add-tconst-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 '() 'type-constant)
		  *the-non-printing-object*
		  (begin
		    (set! TYPE-CONSTANTS
			  (append TYPE-CONSTANTS 
                            (list (list string))))
		    (add-token string 'tconst string)
		    (comment "ok, type constant " string " added")))
	   (myerror "add-tconst-name: string expected" string)))))) 

(define atc add-tconst-name)

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

(define rtc remove-tconst-name)

; Definition: "OmegaIn"
; ---------------------
; In pconst.scm

; The treatment of constructors is to be extended to also cover
; constructors for sumtypes.

; Notice that we do not have dependent types.  Hence we need a
; numeral-string to be part of the name of a constructor.  Form
; e.g. "Arrow(Iota)(Iota)", which can be parsed.  So
; "OmegaInIota to Iota" would be a constructor name, of type
; ((nat=>term)=>(nat=>term))=>omega.

; nbe-reify and nbe-reflect are changed only in that the tag sumtype
; is treated exactly as alg.

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

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

(define (constr-name-to-inst-constructors name)
  (let ((info (assoc name CONSTRUCTORS)))
    (cond
     (info (cadr info))
     ((initial-substring? "OmegaIn" name)
      (let* ((typestring
	      (substring name (string-length "OmegaIn") 
               (string-length name)))
	     (typealg-numeral (pt typestring))
	     (type (typealg-numeral-to-type typealg-numeral))
	     (del-constr 
	      (eval-once (lambda () (constr-name-to-constr name))))
	     (obj
	      (nbe-make-object
	       (mk-arrow type (py "omega"))
	       (lambda (obj1)
		 (nbe-make-object (py "omega")
				  (nbe-make-constr-value
				   name (list obj1) del-constr)))))
	     (constr (make-const obj name 'constr 
              (mk-arrow type (py "omega"))
				 empty-subst 1 'const)))
	(list (list empty-subst constr))))
     (else
(myerror 
 "constr-name-to-inst-constructors: constructor name expected"
	       name)))))

(define (constr-name? string)
  (or (assoc string CONSTRUCTORS)
      (and
       (initial-substring? "OmegaIn" string)
       (typealg-numeral?
	(pt (substring
	     string (string-length "OmegaIn") 
              (string-length string)))))))

(define (constr-name-and-tsubst-to-constr name tsubst)
  (let ((info (assoc name CONSTRUCTORS)))
    (cond
     (info
      (let ((info1 (assoc-wrt substitution-equal? tsubst 
       (cadr info))))
	(if info1
	    (cadr info1)
	 (myerror "constr-name-and-tsubst-to-constr: unknown tsubst"
		     tsubst "for constructor" name))))
     ((initial-substring? "OmegaIn" name)
      (let* ((typestring
	      (substring name (string-length "OmegaIn") 
               (string-length name)))
	     (typealg-numeral (pt typestring))
	     (type (typealg-numeral-to-type typealg-numeral))
	     (del-constr 
	      (eval-once (lambda () (constr-name-to-constr name))))
	     (obj
	      (nbe-make-object
	       (mk-arrow type (py "omega"))
	       (lambda objs
		 (nbe-make-object (py "omega")
				  (nbe-make-constr-value
				   name objs del-constr)))))
	     (constr (make-const obj name 'constr (mk-arrow type 
              (py "omega"))
				 empty-subst 1 'const)))
	constr))
     (else
(myerror 
 "constr-name-and-tsubst-to-constr: constructor name expected"
	       name)))))

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

; Definition: "OmegaOut"
; ----------------------
; The treatment of program constants is to be extended to also allow
; the infinitely many program constants OmegaOut... with ... a 
; string denoting a typealg-numeral.

(define (pconst-name-to-pconst name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (cond
     (info (cadr info))
     ((initial-substring? "OmegaOut" name)
      (let* ((typestring
	      (substring name (string-length "OmegaOut") 
               (string-length name)))
	     (typealg-numeral (pt typestring))
	     (type (typealg-numeral-to-type typealg-numeral)))
	(type-to-omegaout-pconst type)))
     (else (myerror "pconst-name-to-pconst: pconst name expected"
		    name)))))

(define (type-to-omegaout-pconst type)
  (let* ((typealg-numeral (type-to-typealg-numeral type))
	 (string (term-to-string typealg-numeral))
	 (name (string-append "OmegaOut" string)))    
    (make-const
     (nbe-make-object
      (mk-arrow (py "omega") type) (type-to-omegaout-value type))
   name 'pconst (mk-arrow (py "omega") type) empty-subst 1 'const)))

(define (type-to-omegaout-value type)
  (lambda (obj)
    (let ((val (nbe-object-to-value obj)))
      (cond
       ((nbe-fam-value? val) ;reproduce
	(let* ((op-obj (nbe-reflect (nbe-term-to-termfam
				     (make-term-in-const-form
				  (type-to-omegaout-pconst type)))))
	       (op-val (nbe-object-to-value op-obj)))
	  (op-val obj)))
       ((nbe-constr-value? val)
	(let* ((name (nbe-constr-value-to-name val))
	       (typestring1
		(substring
		 name (string-length "OmegaIn") 
                  (string-length name)))
	       (typealg-numeral1 (pt typestring1))
	       (type1 (typealg-numeral-to-type typealg-numeral1)))
	  (if (equal? type1 type)
	      (car (nbe-constr-value-to-args val))
	      (nbe-reflect
	       (nbe-make-termfam
		type (lambda (k) 
                 (type-to-canonical-inhabitant type)))))))
       (else 
    (myerror "type-to-omegaout-value" "unexpected object" obj))))))

(define (pconst-name-to-comprules name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (cond
     (info (caddr info))
     ((initial-substring? "OmegaOut" name) '())
     (else (myerror "pconst-name-to-comprules: pconst name expected"
		    name)))))

(define (pconst-name-to-rewrules name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (cond
     (info (cadddr info))
     ((initial-substring? "OmegaOut" name) '())
     (else (myerror "pconst-name-to-rewrules: pconst name expected"
		    name)))))

(define (pconst-name-to-inst-objs name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (cond
     (info (car (cddddr info)))
     ((initial-substring? "OmegaOut" name) '())
     (else (myerror "pconst-name-to-inst-objs: pconst name expected"
		    name)))))

(define (pconst-name-and-tsubst-to-object name tsubst)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (cond
     (info
      (let ((info1
	     (assoc-wrt substitution-equal? tsubst 
              (car (cddddr info)))))
	(if info1
	    (cadr info1)
	    (let ((pconst (pconst-name-to-pconst name)))
	      (const-substitute pconst tsubst #f) 
               ;updates PROGRAM-CONSTANTS
	      (pconst-name-and-tsubst-to-object name tsubst)))))
     ((initial-substring? "OmegaOut" name)
      (let* ((typestring
	      (substring name (string-length "OmegaOut") 
               (string-length name)))
	     (typealg-numeral (pt typestring))
	     (type (typealg-numeral-to-type typealg-numeral)))
	(nbe-make-object
	 (mk-arrow (py "omega") type) 
          (type-to-omegaout-value type))))
     (else 
(myerror "pconst-name-and-tsubst-to-object: pconst name expected"
		    name)))))

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

; Empty-Test
; ----------
; const-substitute now needs an initial test whether the type
; substitution is empty.

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

(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 (or (string=? "existential" (tconst-to-name type))
	       (string=? "omega" (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"
			   (tconst-to-name type)
			   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)))))

; Definition: "omega"
; -------------------
; The parser cannot handle these constructor names.  However, 
; we want that at least "OmegaInIota" is known to the parser.

(add-tconst-name "omega")

(add-var-name "a" "b" "c" (py "omega"))
(add-var-name "as" "bs"  (py "list omega"))

(add-token "OmegaInIota"
	   'const (const-to-token-value 
            (constr-name-to-constr "OmegaInIota")))

; We want to be able to overwrite the value of a pconst, assuming 
; that there are no type parameters in pconst,

(define (overwrite-pconst name val)
  (let* ((uninst-pconst (pconst-name-to-pconst name))
	 (type (const-to-type uninst-pconst))
	 (obj (nbe-make-object type val))
	 (assoc-list (pconst-name-to-inst-objs name))
	 (external-code (pconst-name-to-external-code name))
	 (pconsts-exept-name
	  (do ((l PROGRAM-CONSTANTS (cdr l))
	       (res '() (if (string=? (caar l) name)
			    res
			    (cons (car l) res))))
	      ((null? l) (reverse res))))
	 (new-alist-for-name
	  (map (lambda (x) (if (equal? empty-subst (car x))
			       (list empty-subst obj) x))
	       assoc-list)))
    (set! PROGRAM-CONSTANTS
	  (cons (if external-code
		    (list name uninst-pconst '() '()
			  new-alist-for-name external-code)
		    (list name uninst-pconst '() '()
			  new-alist-for-name))
		pconsts-exept-name))))

; Definition: "OmegaPart"
; -----------------------
(add-program-constant "OmegaPart" (py "omega=>type") 1)

; OmegaPart applied to a constr-value returns the typealg-numeral.

(define (omegapart-value obj)
  (let ((val (nbe-object-to-value obj)))
    (cond
     ((nbe-fam-value? val) ;reproduce
      (nbe-reflect
       (nbe-make-termfam
	(make-alg "type")
	(lambda (k)
	  (mk-term-in-app-form
	   (make-term-in-const-form omegapart-pconst)
	   (nbe-fam-apply (nbe-reify obj) k))))))
     ((nbe-constr-value? val)
      (let* ((name (nbe-constr-value-to-name val))
	     (typestring
	      (substring name (string-length "OmegaIn") 
               (string-length name)))
	     (typealg-numeral (pt typestring)))
	(nbe-reflect
	 (nbe-make-termfam
	  (make-alg "type")
	  (lambda (k) typealg-numeral)))))
     (else (myerror "omegapart-value" "unexpected object" obj)))))

(define omegapart-pconst
  (make-const
   (nbe-make-object (py "omega=>type") omegapart-value)
   "OmegaPart" 'pconst (py "omega=>type") empty-subst 1 'const))

(overwrite-pconst "OmegaPart" omegapart-value)

; Definition: Hat
; ---------------
(add-program-constant "Hat" 
 (py "type=>type=>(omega=>omega)=>omega"))

; For (hat-value type-obj1 type-obj2 fct-obj) check whether 
; type-obj1 and type-obj2 come from typealg-numerals rho and sig.  
; If so, form the object for 
; In_{rho=>sig}(Out_sig o fct-term o In_rho)

(define (hat-value obj1)
  (nbe-make-object
   (py "type=>(omega=>omega)=>omega")
   (lambda (obj2)
     (nbe-make-object
      (py "(omega=>omega)=>omega")
      (lambda (fct-obj)
	(let* ((reified-obj1 (nbe-reify obj1))
	       (extracted-term1 (nbe-extract reified-obj1))
	       (reified-obj2 (nbe-reify obj2))
	       (extracted-term2 (nbe-extract reified-obj2))
	       (reified-fct-obj (nbe-reify fct-obj))
	       (extracted-fct-term (nbe-extract reified-fct-obj)))
	  (if ;the first two extracted terms are typealg-numerals
	   (and (typealg-numeral? extracted-term1)
		(typealg-numeral? extracted-term2))
	   (let* ((omegain-constr
		   (typealg-numeral-to-omegain-constr
		    (mk-term-in-app-form
		     (make-term-in-const-form 
                      (constr-name-to-constr "Arrow"))
		     extracted-term1 extracted-term2)))
		  (omegain-constr1
		   (typealg-numeral-to-omegain-constr 
                    extracted-term1))
		  (omegaout-pconst2
		   (type-to-omegaout-pconst
		    (typealg-numeral-to-type extracted-term2)))
		  (type1 (typealg-numeral-to-type extracted-term1))
		  (new-var (type-to-new-var type1))
		  (free (term-to-free extracted-fct-term))
		  (objs (map (lambda (x) (nbe-reflect
					  (nbe-term-to-termfam
			     (make-term-in-var-form x)))) free))
		  (bindings (nbe-make-bindings free objs))
		  (abst-term
		   (make-term-in-abst-form
		    new-var
		    (make-term-in-app-form
		     (make-term-in-const-form omegaout-pconst2)
		     (make-term-in-app-form
		      extracted-fct-term
		      (make-term-in-app-form
		       (make-term-in-const-form omegain-constr1)
		       (make-term-in-var-form new-var))))))
		  (final-term (make-term-in-app-form
			    (make-term-in-const-form omegain-constr)
			    abst-term)))
	     (nbe-term-to-object final-term bindings))
					;else reproduce
	   (let* ((obj (nbe-reflect (nbe-term-to-termfam
			(make-term-in-const-form hat-pconst))))
		  (val (nbe-object-to-value obj)))
	     (apply (nbe-uncurry val 3) 
              (list obj1 obj2 fct-obj))))))))))
		 
(define (typealg-numeral-to-omegain-constr typealg-numeral)
  (constr-name-to-constr (string-append
   "OmegaIn" (term-to-string typealg-numeral))))

(define hat-pconst
  (let ((hat-type (py "type=>type=>(omega=>omega)=>omega")))
    (make-const (nbe-make-object hat-type hat-value)
		"Hat" 'pconst hat-type empty-subst 0 'const)))

(overwrite-pconst "Hat" hat-value)

; Definition: Mod
; ---------------
(add-program-constant "Mod" (py "omega=>omega=>omega"))

; For (mod-value obj) check whether obj is a constr-object of the 
; form In_{rho=>sig} s.  If so, form the object for 
; In_sig o s o Out_rho.
; Else reproduce.

(define (mod-value obj1)
  (let ((val1 (nbe-object-to-value obj1)))
    (if ;obj1 is a constr-object of the form In_{rho=>sig} arg
     (and (nbe-constr-value? val1)
	  (let* ((args (nbe-constr-value-to-args val1))
		 (arg (if (= 1 (length args))
			  (car args)
		(myerror "mod-value" "unexpected object" obj1)))
		 (type (nbe-object-to-type arg)))
	    (not (equal? (py "nat=>term") type))))
     (let* ((constr (nbe-constr-value-to-constr val1))
	    (args (nbe-constr-value-to-args val1))
	    (type (nbe-object-to-type (car args)))
	    (type1 (arrow-form-to-arg-type type))
	    (type2 (arrow-form-to-val-type type))
	    (typealg-numeral1 (type-to-typealg-numeral type1))
	    (typealg-numeral2 (type-to-typealg-numeral type2))
	    (omegaout-pconst1
	     (type-to-omegaout-pconst
	      (typealg-numeral-to-type typealg-numeral1)))
	    (omegain-constr2
	     (typealg-numeral-to-omegain-constr typealg-numeral2))
	    (new-var (type-to-new-var (py "omega")))
	    (arg-term (nbe-extract (nbe-reify (car args))))
	    (free (term-to-free arg-term))
	    (objs (map (lambda (x) (nbe-reflect
				    (nbe-term-to-termfam
				 (make-term-in-var-form x)))) free))
	    (bindings (nbe-make-bindings free objs))
	    (abst-term
	     (make-term-in-abst-form
	      new-var
	      (make-term-in-app-form
	       (make-term-in-const-form omegain-constr2)
	       (make-term-in-app-form
		arg-term
		(make-term-in-app-form
		 (make-term-in-const-form omegaout-pconst1)
		 (make-term-in-var-form new-var)))))))
       (nbe-term-to-object abst-term bindings))
     					;else reproduce
     (let* ((obj (nbe-reflect (nbe-term-to-termfam
		          (make-term-in-const-form mod-pconst))))
	    (val (nbe-object-to-value obj)))
       (val obj1)))))

(define mod-pconst
  (make-const
   (nbe-make-object (py "omega=>omega=>omega") mod-value)
   "Mod" 'pconst (py "omega=>omega=>omega") empty-subst 0 'const))

(overwrite-pconst "Mod" mod-value)

; Definition: ModIota
; -------------------
(add-program-constant "ModIota" (py "omega=>nat=>term"))

; (modiota-val obj1) checks whether obj1 is a constructor value of
; type Iota.  If so, return its argument.  Else reproduce.

(define (modiota-value obj1)
  (let ((val1 (nbe-object-to-value obj1)))
    (if ;constructor values, of type Iota
     (and (nbe-constr-value? val1)
	  (let* ((args (nbe-constr-value-to-args val1))
		 (arg (if (= 1 (length args))
			  (car args)
		   (myerror "mod-value" "unexpected object" obj1)))
		 (type (nbe-object-to-type arg)))
	    (equal? (py "nat=>term") type)))
     (car (nbe-constr-value-to-args val1))
					;else reproduce
     (let* ((obj (nbe-reflect (nbe-term-to-termfam
			 (make-term-in-const-form modiota-pconst))))
	    (val (nbe-object-to-value obj)))
       (val obj1)))))

(define modiota-pconst
  (make-const
   (nbe-make-object (py "omega=>nat=>term") modiota-value)
   "ModIota" 'pconst (py "omega=>nat=>term") empty-subst 0 'const))

(overwrite-pconst "ModIota" modiota-value)

; Definition: h
; -------------
(add-var-name "h" (py "omega=>omega"))

; Lemma: "TypeHat"
; ----------------
(add-global-assumption "TypeHat" 
 (pf "all rho,sig,h^ OmegaPart(Hat rho sig h^)=(rho to sig)"))


(add-var-name "g" (py "nat=>term"))

; Definition: InOut
; -----------------
(add-program-constant "InOut" (py "type=>omega=>omega"))

; Lemma: "InOutId"
; ----------------
(add-global-assumption "InOutId" 
 (pf "all sig,a^.OmegaPart a^ =sig -> Equal(InOut sig a^)a^"))

; Lemma: "InOutPart"
; ------------------
(add-global-assumption
 "InOutPart" (pf "all sig,a^ OmegaPart(InOut sig a^)=sig"))

; Lemma: "ModHat"
; ---------------
(add-global-assumption "ModHat" 
(pf "all rho,sig,h^,a^ Equal(Mod(Hat rho sig h^)a^)
                            (InOut sig(h^(InOut rho a^)))"))


; Subsection: STotal
; ==================

; Definition: "OmegaOutIota"
; --------------------------
(add-token "OmegaOutIota"
	   'const (const-to-token-value
		   (pconst-name-to-pconst "OmegaOutIota")))

; Lemma: "OmegaOutIota"
; ---------------------
(add-global-assumption
 "STotalNilOmega" (pf "STotal(Nil omega)"))

; Lemma: "OmegaOutIota"
; ---------------------
(add-global-assumption
 "STotalConsOmega" (pf "all a^,as^.STotal as^ -> STotal(a^ ::as^)"))

