; nat2.scm contains the type nat with the constructors: Zero, Succ
; and Constants: +,*,<,<=, Pred, -,

; (= nat.scm + rewrite rules + Constants <=, Pred, -)

(display "loading nat2.scm ...") (newline)

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

(av "n" "m" "k" (py "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-token "++" 'prefix-op 
	   (lambda (x) (make-term-in-app-form (pt "Succ") x)))

; Tests:
; (term-to-string (pt "Succ (Succ (Succ 0))"))
; (term-to-string (pt "++ ++ ++ 3"))
; (term-to-string (pt "Succ (Succ (Succ n))"))
; (term-to-string (pt "++ ++ ++ n"))
; (term-to-string (pt "Succ  ((++ ++ ++ n)+m)"))

(add-program-constant
 "natPlus"
 (mk-arrow (make-alg "nat") (make-alg "nat") (make-alg "nat")) 1 'const 2)

(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)
   (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))))

(add-computation-rule (pt "n + 0") (pt "n"))
(add-computation-rule (pt "n + ++m") (pt "++(n + m)"))

(add-rewrite-rule (pt "0 + n") (pt "n"))
(add-rewrite-rule (pt "++n + m") (pt "++(n + m)"))
(add-rewrite-rule (pt "n1 + (n2 + n3)") (pt "n1 + n2 + n3"))

(add-program-constant
 "natTimes" (mk-arrow (make-alg "nat") (make-alg "nat") (make-alg "nat"))
 1 'const 2)

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

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

(add-computation-rule (pt "n * 0") (pt "0"))
(add-computation-rule (pt "n * ++m") (pt "(n * m)+n"))

(add-rewrite-rule (pt "0 * n") (pt "0"))
(add-rewrite-rule (pt "++n*m") (pt "(n*m)+m"))
(add-rewrite-rule (pt "n1*(n2*n3)") (pt "n1*n2*n3"))

(add-program-constant
 "natLess" (mk-arrow (make-alg "nat") (make-alg "nat") (make-alg "boole"))
 1 'const 2)

(add-token
 "<"
 'rel-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "natLess")) 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=? "natLess"
			(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 "n < 0") (pt "False"))
(add-computation-rule (pt "0 < ++ n") (pt "True"))
(add-computation-rule (pt "++n < ++m") (pt "n < m"))
(add-rewrite-rule (pt "n < ++n") (pt "True"))
(add-rewrite-rule (pt "n < n") (pt "F"))
;(add-rewrite-rule (pt "n < ++m") (pt "n<=m"))
(add-program-constant
 "natEqLess" (mk-arrow (make-alg "nat") (make-alg "nat") (make-alg "boole"))
 1 'const 2)

(add-token
 "<="
 'rel-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "natEqLess")) 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=? "natEqLess"
			(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 "0 <= n") (pt "True"))
(add-computation-rule (pt "++n <= ++m") (pt "n <= m"))
(add-rewrite-rule (pt "n <= n") (pt "True"))
(add-rewrite-rule (pt "n <= n+k") (pt "True"))
(add-rewrite-rule (pt "++m<=m")(pt "False"))
(add-rewrite-rule (pt "++m<=0")(pt "False"))


(add-program-constant "Pred" (mk-arrow (py "nat")(py "nat")) 1)
(add-computation-rule (pt "Pred (Succ n)")(pt "n"))

(add-program-constant
 "natMinus"
 (mk-arrow (make-alg "nat") (make-alg "nat") (make-alg "nat")) 1 'const 2)

(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)
   (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))))

(aga "minus-lemma1" (pf "all m,n,k.m<n ->(m<k -> F) ->(m - k) < (n - k)"))
(add-computation-rule (pt "n-0")(pt "n"))
(add-computation-rule (pt "n-(Succ m)")(pt "Pred(n-m)"))
(add-rewrite-rule (pt "n-n")(pt "0"))
(add-rewrite-rule (pt "Succ n-n")(pt "1"))








