; $Id: natinf.scm,v 1.4 2008/01/25 13:30:21 logik Exp $
(display "loading natinf.scm ...") (newline)

; The natural numbers plus an infinite object
; ===========================================

; We need the type nat yplus unit as range of the weight function.
; Since we want to use e.g. + for this type, we only load parts of nat.scm

; (load "~/minlog/init.scm")

(add-alg "nat" '("Zero" "nat") '("Succ" "nat=>nat"))

(define (make-numeric-term n)
  (if (= n 0)
      (pt "Zero")
      (make-term-in-app-form
       (pt "Succ")
       (make-numeric-term (- n 1)))))

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

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

(add-program-constant "NatPlus" (py "nat=>nat=>nat") t-deg-one)

(add-token
 "+++" 'add-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "NatPlus")) x y)))

(add-display
 (py "nat")
 (lambda (x)
   (if (term-in-app-form? 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=? "NatPlus"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'add-op "+++"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))

(add-computation-rule (pt "nat+++0") (pt "nat"))
(add-computation-rule (pt "nat1+++Succ nat2") (pt "Succ(nat1+++nat2)"))

(quote (begin
(set-goal (pf "all nat 0+++nat=nat"))
(ind)
(use "Truth-Axiom")
(assume "nat" "IH")
(use "IH")

(set-goal (pf "all nat1,nat2 Succ nat1+++nat2=Succ(nat1+++nat2)"))
(assume "nat1")
(ind)
(use "Truth-Axiom")
(assume "nat2" "IH")
(use "IH")

(set-goal (pf "all nat1,nat2,nat3 nat1+++(nat2+++nat3)=nat1+++nat2+++nat3"))
(assume "nat1" "nat2")
(ind)
(use "Truth-Axiom")
(assume "nat3" "IH")
(use "IH")
)) ;matches quote

(add-rewrite-rule (pt "0+++nat") (pt "nat"))
(add-rewrite-rule (pt "Succ nat1+++nat2") (pt "Succ(nat1+++nat2)"))
(add-rewrite-rule (pt "nat1+++(nat2+++nat3)") (pt "nat1+++nat2+++nat3"))

(quote (begin
; "NatPlusComm"
(set-goal (pf "all nat1,nat2.nat1+++nat2=nat2+++nat1"))
(assume "nat1")
(ind)
(use "Truth-Axiom")
(assume "nat2" "IH")
(use "IH")
(save "NatPlusComm")
)) ;matches quote


(add-program-constant "NatLt" (py "nat=>nat=>boole") t-deg-one)

(add-token
 "<<" 'rel-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "NatLt")) x y)))

(add-display
 (py "boole")
 (lambda (x)
   (if (term-in-app-form? 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=? "NatLt"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'rel-op "<<"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))

(add-computation-rule (pt "nat<<0") (pt "False"))
(add-computation-rule (pt "0<<Succ nat") (pt "True"))
(add-computation-rule (pt "Succ nat1<<Succ nat2") (pt "nat1<<nat2"))

(add-rewrite-rule (pt "nat<<nat") (pt "False"))
(add-rewrite-rule (pt "nat<<Succ nat") (pt "True"))

(add-program-constant "Pred" (py "nat=>nat") t-deg-one)

(add-computation-rule (pt "Pred 0") (pt "0"))
(add-computation-rule (pt "Pred(Succ nat)") (pt "nat"))

(add-program-constant "NatMinus" (py "nat=>nat=>nat") t-deg-one)

(add-token
 "-" 'add-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "NatMinus")) x y)))

(add-display
 (py "nat")
 (lambda (x)
   (if (term-in-app-form? 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=? "NatMinus"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'add-op "-"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))

(add-computation-rule (pt "nat-0") (pt "nat"))
(add-computation-rule (pt "nat1-Succ nat2") (pt "Pred(nat1-nat2)"))

(add-rewrite-rule (pt "nat-nat") (pt "0"))
(add-rewrite-rule (pt "0-nat") (pt "0"))
(add-rewrite-rule (pt "Pred(Succ nat1-nat2)") (pt "nat1-nat2"))
(add-rewrite-rule (pt "nat1+++nat2-nat1") (pt "nat2"))
(add-rewrite-rule (pt "nat1+++nat2-nat2") (pt "nat1"))
(add-rewrite-rule (pt "nat1+++(nat2 - nat3)") (pt "nat1+++nat2-nat3"))

(add-var-name "n" "m" "k" (py "nat"))

; Now the general sum type-operator:

(add-param-alg "yplus" 'sum-typeop
	       '("Inleft" "alpha1=>yplus")
	       '("Inright" "alpha2=>yplus"))

(add-var-name "x" "y" "z" (py "nat yplus unit"))

; (pp (pt "(Inleft nat unit) 0"))
; (pp (pt "(Inleft nat unit) 1"))
; (pp (pt "(Inright unit nat) Dummy"))

(add-token
 "Inl"
 'prefix-op
 (lambda (x) (mk-term-in-app-form (pt "(Inleft nat unit)") x)))

(add-token
 "Inr"
 'prefix-op
 (lambda (x) (mk-term-in-app-form (pt "(Inright unit nat)") x)))

(add-display
 (py "nat yplus unit")
 (lambda (x)
   (let* ((op (term-in-app-form-to-final-op x))
	  (args (term-in-app-form-to-args x)))
     (cond ((and (term-in-const-form? op)
		 (string=? "Inleft"
			   (const-to-name (term-in-const-form-to-const op)))
		 (= 1 (length args)))
	    (list 'prefix-op "Inl" (term-to-token-tree (car args))))
	   ((and (term-in-const-form? op)
		 (string=? "Inright"
			   (const-to-name (term-in-const-form-to-const op)))
		 (= 1 (length args)))
	    (list 'prefix-op "Inr" (term-to-token-tree (car args))))
	   (else #f)))))

; (pp (pt "Inl 0"))
; (pp (pt "Inl 1"))
; (pp (pt "Inr Dummy"))

(add-program-constant
 "NatinfPlus"
 (py "nat yplus unit=>nat yplus unit=>nat yplus unit") t-deg-one)

(add-token
 "+" 'add-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "NatinfPlus")) x y)))

(add-display
 (py "nat yplus unit")
 (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=? "NatinfPlus"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'add-op "+"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

(add-computation-rule (pt "x+Inl 0") (pt "x"))
(add-computation-rule (pt "Inl n+Inl(Succ m)") (pt "Inl(Succ(n+++m))"))
(add-computation-rule (pt "Inr Dummy+Inl(Succ m)") (pt "Inr Dummy"))
(add-computation-rule (pt "x+Inr Dummy") (pt "Inr Dummy"))

(add-rewrite-rule (pt "Inl 0+x") (pt "x"))
(add-rewrite-rule (pt "Inl(Succ n)+Inl m") (pt "Inl(Succ(n+++m))"))
(add-rewrite-rule (pt "x1+(x2+x3)") (pt "x1+x2+x3"))

(add-program-constant
 "NatinfLe" (py "nat yplus unit=>nat yplus unit=>boole") t-deg-one)

(add-token
 "<=" 'rel-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "NatinfLe")) x y)))

(add-display
 (py "boole")
 (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=? "NatinfLe"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'rel-op "<="
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

(add-computation-rule (pt "Inl 0<=y") (pt "True"))
(add-computation-rule (pt "Inl(Succ n)<=Inl 0") (pt "False"))
(add-computation-rule (pt "Inl(Succ n)<=Inl(Succ m)") (pt "Inl n<=Inl m"))
(add-computation-rule (pt "Inl(Succ n)<=Inr Dummy") (pt "True"))
(add-computation-rule (pt "Inr Dummy<=Inl m") (pt "False"))
(add-computation-rule (pt "Inr Dummy<=Inr Dummy") (pt "True"))

(add-rewrite-rule (pt "x<=x") (pt "True"))
(add-rewrite-rule (pt "x<=Inr Dummy") (pt "True"))
(add-rewrite-rule (pt "x<=x+y") (pt "True"))

(add-program-constant
 "NatinfLt" (py "nat yplus unit=>nat yplus unit=>boole") t-deg-one)

(add-token
 "<" 'rel-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "NatinfLt")) x y)))

(add-display
 (py "boole")
 (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=? "NatinfLt"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'rel-op "<"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

(add-computation-rule (pt "x<Inl 0") (pt "False"))
(add-computation-rule (pt "Inl 0<Inl(Succ m)") (pt "True"))
(add-computation-rule (pt "Inl(Succ n)<Inl(Succ m)") (pt "Inl n<Inl m"))
(add-computation-rule (pt "Inr Dummy<Inl(Succ m)") (pt "False"))
(add-computation-rule (pt "Inl n<Inr Dummy") (pt "True"))
(add-computation-rule (pt "Inr Dummy<Inr Dummy") (pt "False"))

(add-rewrite-rule (pt "x<x") (pt "False"))
(add-rewrite-rule (pt "x+y<x") (pt "False"))
(add-rewrite-rule (pt "Inr unit<y") (pt "False"))
(add-rewrite-rule (pt "Inl m<Inl(Succ m)") (pt "True"))


(add-program-constant
 "NatinfMin" (py "nat yplus unit=>nat yplus unit=>nat yplus unit") t-deg-one)

(add-token
 "min" 'mul-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "NatinfMin")) x y)))

(add-display
 (py "nat yplus unit")
 (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=? "NatinfMin"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'mul-op "min"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

(add-computation-rule (pt "Inl 0 min y") (pt "Inl 0"))
(add-computation-rule (pt "Inl(Succ n)min Inl 0") (pt "Inl 0"))
(add-computation-rule (pt "Inl(Succ n)min Inl(Succ m)")
		      (pt "(Inl n min Inl m)+Inl 1"))
(add-computation-rule (pt "Inl(Succ n)min Inr Dummy") (pt "Inl(Succ n)"))
(add-computation-rule (pt "Inr Dummy min y") (pt "y"))

(add-rewrite-rule (pt "x min Inl 0") (pt "Inl 0"))
(add-rewrite-rule (pt "x min x") (pt "x"))
(add-rewrite-rule (pt "(x+y) min x") (pt "x"))
(add-rewrite-rule (pt "x min (x+y)") (pt "x"))

(add-rewrite-rule (pt "x min y<=x") (pt "True"))
(add-rewrite-rule (pt "x min y<=y") (pt "True"))
(add-rewrite-rule (pt "x min y<x") (pt "True"))
(add-rewrite-rule (pt "x min y<y") (pt "True"))


