; ***********************************************************
; ; 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")
;
; NOTICE: Uncomment modules only when file is run on its own
; ***********************************************************


; ============================================
;  Section: Definition of the Lambda Calculus
; ============================================
; contains the basic definition for the simply typed lambda calculus 
; in de Bruijn style


; Subsection: Definition of the Types and the Lambda-Terms
; ========================================================

; Definition: "type"
; ------------------
; the types of the lambda terms

(add-alg "type"
	 '("Iota" "type")
	 '("Arrow" "type=>type=>type"))

(add-var-name "rho" "sig" "tau" (py "type"))


; ________________________ INTERNAL ________________________
; Allows the infix notation with "to" instead of "Arrow"

(add-token
 "to"
 'pair-op
 (lambda (x y)
   (let* ((type1 (term-to-type x))
	  (type2 (term-to-type y))
	  (type (types-lub type1 type2)))
     (mk-term-in-app-form
      (make-term-in-const-form (constr-name-to-constr "Arrow"))
      x y))))

(add-display
 (py "type")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "Arrow"
			(const-to-name 
			 (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'pair-op "to"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))
; _________________________________________________________


; Definition: "term"
; ------------------
; represents lambda terms in "de Bruijn" style

(add-alg "term"
	 '("Var" "nat=>term")
	 '("App" "term=>term=>term")
	 '("Abs" "type=>term=>term"))

(add-var-name "r" "s" "t" (py "term"))

; Definition: Lists of Terms
; --------------------------
(add-var-name "rs" "ss" "ts" (py "list term"))


; ________________________ INTERNAL ________________________
; Allows the simplier notation for application without constructor

(add-new-application 
 (lambda (type) (equal? type (py "term")))
 (lambda (term1 term2) 
  (mk-term-in-app-form (pt "App") term1 term2)))

(add-new-application-syntax
 ; predicate
 (lambda (term)
   (and (term-in-app-form? term)
	(let ((op (term-in-app-form-to-op term)))
	  (term-in-app-form? op)
	  (term=? (pt "App") (term-in-app-form-to-op op)))))
 ; to arg
 (lambda (term)
   (term-in-app-form-to-arg term))
 ; to op
 (lambda (term)
   (term-in-app-form-to-arg
    (term-in-app-form-to-op term))))

; Example
(define term1 (pt "Var 0(Abs tau(Var 3(Var 2)(Var 0)))"))
(pp term1)

(define rhos1 
 (pt "(rho to tau to sig)::rho::((tau to sig)to rho):"))
(pp rhos1)

(define revrhos1 
 (pt "((tau to sig)to rho)::rho::(rho to tau to sig):"))
(pp revrhos1)
; _________________________________________________________


; Subsection: Typechecking
; ========================

; Definition: "contexts"
; ----------------------
; contexts are used as simple (predefined) lists of elements
; of type "type".

(add-var-name "rhos" "sigs" "taus" (py "list type"))

; Definition: "Arrowtyp"
; ----------------------
; checks, if a type is an arrow type

(add-program-constant "Arrowtyp" (py "type=>boole") 1)
(add-computation-rule (pt "Arrowtyp Iota") (pt "False"))
(add-computation-rule (pt "Arrowtyp(rho to sig)") (pt "True"))

; Definition: "Argtyp"
; --------------------
; returns the first part of an arrow type

(add-program-constant "Argtyp" (py "type=>type") 1)
(add-computation-rule (pt "Argtyp Iota") (pt "Iota"))
(add-computation-rule (pt "Argtyp(rho to sig)") (pt "rho"))

; Definition: "Valtyp"
; --------------------
; returns the second part of an arrow type

(add-program-constant "Valtyp" (py "type=>type") 1)
(add-computation-rule (pt "Valtyp Iota") (pt "Iota"))
(add-computation-rule (pt "Valtyp(rho to sig)") (pt "sig"))

; ________________________ INTERNAL ________________________
; Numeral

(define (typealg-numeral-to-type typealg-numeral)
  (let* ((op (term-in-app-form-to-final-op typealg-numeral))
	 (args (term-in-app-form-to-args typealg-numeral)))
    (if (not (and (term-in-const-form? op)
		  (eq? 'constr (const-to-kind
				(term-in-const-form-to-const op)))))
	(myerror 
         "typealg-numeral-to-type" "constructor expected" op))
    (let ((name (const-to-name (term-in-const-form-to-const op))))
      (cond
       ((string=? "Iota" name) (py "nat=>term"))
       ((string=? "Arrow" name)
	(if (= 2 (length args))
	    (make-arrow (typealg-numeral-to-type (car args))
			(typealg-numeral-to-type (cadr args)))
	    (myerror 
             "typealg-numeral-to-type" "2 arguments expected"
		     typealg-numeral)))
       (else (myerror "typealg-numeral-to-type" 
        "typealg numeral expected"
		      typealg-numeral))))))

(define (typealg-numeral? term) 
 ;should be done generally for algebras
  (or
   (and (term-in-const-form? term)
	(string=? "Iota" 
         (const-to-name (term-in-const-form-to-const term))))
   (and (term-in-app-form? term)
	(let ((op (term-in-app-form-to-final-op term))
	      (args (term-in-app-form-to-args term)))
	  (and
	   (string=? "Arrow" (const-to-name 
	    (term-in-const-form-to-const op)))
	   (= 2 (length args))
	   (typealg-numeral? (car args))
	   (typealg-numeral? (cadr args)))))))

(define (type-to-typealg-numeral type)
  (if (not (arrow-form? type))
     (myerror "type-to-typealg-numeral" "arrow form expected" type))
  (let ((arg-type (arrow-form-to-arg-type type))
	(val-type (arrow-form-to-val-type type)))
    (if ;(equal? (py "nat=>term") type), that is
     (and (alg-form? arg-type)
	  (alg-form? val-type)
	  (string=? "nat" (alg-form-to-name arg-type))
	  (string=? "term" (alg-form-to-name val-type)))
     (make-term-in-const-form (constr-name-to-constr "Iota"))
     (mk-term-in-app-form
      (make-term-in-const-form (constr-name-to-constr "Arrow"))
      (type-to-typealg-numeral arg-type)
      (type-to-typealg-numeral val-type)))))
; _________________________________________________________


; Definition: "Typ"
; -----------------
(add-program-constant "Typ" (py "list type=>term=>type") 1)

(add-computation-rule (pt "Typ(Nil type)(Var n)") (pt "Iota"))
(add-computation-rule (pt "Typ(rho::rhos)(Var 0)") (pt "rho"))
(add-computation-rule (pt "Typ(rho::rhos)(Var(Succ n))")
		      (pt "Typ rhos(Var n)"))
(add-computation-rule (pt "Typ rhos(r s)") 
		      (pt "Valtyp(Typ rhos r)"))
(add-computation-rule (pt "Typ rhos(Abs rho r)")
		      (pt "rho to Typ(rho::rhos)r"))

; Definition: "Cor"
; -----------------
; checks, if a term is correctly typed 
; with respect to a given context

(add-program-constant "Cor" (py "list type=>term=>boole") 1)

(add-computation-rule (pt "Cor rhos(Var n)") (pt "n<Lh rhos"))
(add-computation-rule (pt "Cor rhos(r s)")
 (pt "Cor rhos r and Cor rhos s and
      Typ rhos r=(Typ rhos s to Valtyp(Typ rhos r))"))
(add-computation-rule (pt "Cor rhos(Abs rho r)") 
                      (pt "Cor(rho::rhos)r"))


; Definition: "TypJ"
; ------------------
; Checks if a term has a given type with respect to a given context
; (and if the term is correctly typed at all)

(add-program-constant "TypJ" (py "list type=>term=>type=>boole") 1)

(add-computation-rule (pt "TypJ rhos r rho")
		      (pt "Cor rhos r and Typ rhos r=rho"))
