
; positive.scm

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

(display"
Begin of positive.scm

")


(display"
First some boolean RW-rules and THMS:

")




(mload "abbrev.scm")



(begin

(define (boole? term)
  (equal? (term-to-type term) '(alg "boole")))

;;  CONSTANTS

(add-token "⊥" 'const (make-term-in-const-form false-const))

;; BOOLEAN FUNCTIONS


; Conjunction ∧
; already define in src/boole.scm

(define (andboole bl1 bl2)
  (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "AndConst")) bl1 bl2))

(add-token
 "∧"
 'and-op
 (lambda (x y) (andboole x y)))

(define (and-boole? term)
  (if (term-in-app-form? term)
      (let ((op (term-in-app-form-to-final-op term))
	    (args (term-in-app-form-to-args term)))
	(and (term-in-const-form? op)
	     (string=? "AndConst" (const-to-name (term-in-const-form-to-const op)))
	     (= 2 (length args))))
      #f))

(define (and-boole-to-kernel term)
  (cond ((and-boole? term)
		 (make-term-in-pair-form
		  (term-in-app-form-to-arg (term-in-app-form-to-op term))
		  (term-in-app-form-to-arg term)))
		(else term)))

(define (ANDB . booles)
  (letrec ((andboole (lambda (bt)
		       (cond ((= (length bt) 0) "T")
			     ((= (length bt) 1) (car bt))
			     (else (string-append (car bt) " and " (andboole (cdr bt))))))))
    (andboole booles)))




; Negation ¬


(add-program-constant "¬" (py "boole=>boole") 1)

(acrs "¬True"  "False")
(acrs "¬False" "True")

(set! OLD-COMMENT-FLAG COMMENT-FLAG)
(set! COMMENT-FLAG #t)
(display-program-constants "¬")
(set! COMMENT-FLAG OLD-COMMENT-FLAG)

(define (negboole x)
  (mk-term-in-app-form
   (make-term-in-const-form (pconst-name-to-pconst "¬")) x ))

(define (neg-boole? 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 (= 1 (length args))
	      (term-in-const-form? op)
	      (string=? "¬" (const-to-name (term-in-const-form-to-const op)))))))

(define (neg-boole-to-kernel term)
  (cond ((neg-boole? term) (car(term-in-app-form-to-args term)))
	(else term)))




; Disjunction p∨q  :≡  ¬(¬q ∧ ¬p)

(define (orboole bl1 bl2)
  (negboole
   (mk-term-in-app-form
    (mk-term-in-app-form
     (make-term-in-const-form(pconst-name-to-pconst "AndConst"))
     (negboole bl1)
     (negboole bl2)))))

(add-token
 "∨"
 'or-op
 (lambda (x y) (orboole x y)))

(define (or-boole? term)
  (and (neg-boole? term)
       (term-in-app-form? (neg-boole-to-kernel term))
       (let ((op (term-in-app-form-to-op (neg-boole-to-kernel term))))
	 (and (term-in-app-form? op)
	      (string=? (term-to-string(term-in-app-form-to-op op))
			"AndConst")
	      (neg-boole? (term-in-app-form-to-arg op))
	      (neg-boole? (term-in-app-form-to-arg (neg-boole-to-kernel term)))))))

(define (or-boole-to-kernel term)
  (cond ((or-boole? term)
		 (let ((conjunct (neg-boole-to-kernel term)))
		   (make-term-in-pair-form
		    (neg-boole-to-kernel
		     (term-in-app-form-to-arg
		      (term-in-app-form-to-op conjunct)))
		    (neg-boole-to-kernel(term-in-app-form-to-arg conjunct)))))
	(else term)))



; ORB: boolean disjunction

(define (ORB . booles)
  (letrec ((disjunction (lambda (bt)
			  (cond ((= (length bt) 0) "False")
				((= (length bt) 1) (car bt))
				(else (string-append  "( " (car bt) " ) ∨ ( " (disjunction (cdr bt)) " ) "))))))
    (disjunction booles)))





; Implication p→q  :≡  ¬(p ∧ ¬q)

(define (impboole bl1 bl2)
  (negboole
   (mk-term-in-app-form
    (mk-term-in-app-form
     (make-term-in-const-form(pconst-name-to-pconst "AndConst"))
     bl1 (negboole bl2)))))

(add-token
 "→"
 'or-op
 (lambda (x y) (impboole x y)))

(define (imp-boole? term)
  (and (neg-boole? term)
       (and-boole? (neg-boole-to-kernel term))
       (neg-boole? (term-in-pair-form-to-right(and-boole-to-kernel (neg-boole-to-kernel term))))))


(define (imp-boole-to-kernel term)
  (cond ((imp-boole? term)
	 (let ((conjunct (and-boole-to-kernel(neg-boole-to-kernel term))))
	   (make-term-in-pair-form
	    (term-in-pair-form-to-left conjunct)
	    (neg-boole-to-kernel(term-in-pair-form-to-right conjunct)))))
	(else term)))




; DISPLAY

(add-display
 (py "boole")
 (lambda (x)
   (cond ((or-boole? x)
	  (let* ((args (or-boole-to-kernel x)))
	    (list 'or-op "∨"
		  (term-to-token-tree (term-in-pair-form-to-left  args))
		  (term-to-token-tree (term-in-pair-form-to-right  args)))))
	 ((imp-boole? x)
	  (let* ((args (imp-boole-to-kernel x)))
	    (list 'imp-op "→"
		  (term-to-token-tree (term-in-pair-form-to-left  args))
		  (term-to-token-tree (term-in-pair-form-to-right  args)))))
	 ((and-boole? x)
	  (let* ((args (term-in-app-form-to-args x)))
	    (list 'and-op "∧"
		  (term-to-token-tree (car args))
		  (term-to-token-tree (cadr args)))))
	 (else #f))))



; TO ADD RW-RULES

(define (trw string)
  (if (boole? (pt string))
	  (arw string "True")
	  (myerror "trw: Boolean term expected !")))


(define (nrw string)
  (let ((term (pt string))
		(free-avar (proof-to-free-avars(pproof-state-to-proof))))
	(cond ((null? PPROOF-STATE)
		   (myerror "arw" "proof under construction expected"))
		  ((not(null? free-avar))
		   (myerror (cons "unexpected free assumptions" free-avar)))
		  ((not (neg-boole? term))
		   (myerror "nrw: Negated boole expected !"))
		  (else
		   (add-rewrite-rule (neg-boole-to-kernel term) (pt "False"))))))

)




(set! OLD-COMMENT-FLAG COMMENT-FLAG)
(set! COMMENT-FLAG #f)

; Trivial but important

(begin

; True=boole  = boole
(sg "(True=boole)=boole")
(cases)
(auto)
; Proof finished.
(save "BooleTrueLeft")
(display-theorems "BooleTrueLeft")


; boole=True  = boole
(sg "(boole=True)=boole")
(cases)
(auto)
; Proof finished.
(save "BooleTrueRight")
(display-theorems "BooleTrueRight")


; boole=False  = ¬boole
(sg "(boole=False)=(¬boole)")
(cases)
(auto)
; Proof finished.
(save "BooleFalseRight")
(display-theorems "BooleFalseRight")

; ¬boole = boole=False
(sg "(False=boole)=(¬boole)")
(cases)
(auto)
; Proof finished.
(save "BooleFalseLeft")
(display-theorems "BooleFalseLeft")


; (p -> False) -> ¬p
(sg "(boole->False)->(¬boole)")
(cases)
(auto)
; Proof finished.
(save "BooleNegationTwo")
(display-theorems "BooleNegationTwo")

; p ∧ q  = q ∧ p
(sg "(boole1∧boole2)=(boole2∧boole1)")
(cases)
(auto)
; Proof finished.
(save "ANDcomm")
(display-theorems "ANDcomm")


; Efq-Boole: ¬p -> p -> q

(sg "¬boole1 -> boole1 -> boole2")
(cases)
(cases)
(auto)
(assume "boole2" "Verum")
(use "Efq-Atom")
; Proof finished.
(save "Efq-Boole")
(display-theorems "Efq-Boole")

)


(display "

Some boolean RW-RULES

")

(begin

(sg "boole=False∨boole=True")
(cases)
(auto)
; Proof finished.
(nrw "boole=False∨boole=True")

(sg "boole=True∨boole=False")
(cases)
(auto)
; Proof finished.
(nrw "boole=True∨boole=False")

; ¬¬boole → boole

(sg "¬(¬boole) = boole")
(cases)
(auto)
; Proof finished.
(arw "¬(¬boole)"  "boole")




; p ∨ p=False
(sg "boole∨boole=False")
(cases)
(auto)
; Proof finished.
(nrw "boole∨boole=False")



; ¬ ( p ∧ ¬p)
(sg "¬(boole ∧ ¬boole)")
(cases)
(auto)
; Proof finished.
(nrw "¬(boole ∧ ¬boole)")

(sg "¬(¬boole ∧ boole)")
(cases)
(auto)
; Proof finished.
(nrw "¬(¬boole ∧ boole)")

; ¬(¬p ∧ q ∧ p)
(sg "¬(¬boole1∧boole2∧boole1)")
(cases)
(auto)
; Proof finished.
(nrw "¬(¬boole1∧boole2∧boole1)")




; iff
(sg "((boole1→boole2) ∧ (boole2→boole1))=(boole1=boole2)")
(cases)
(cases)
(auto)
(cases)
(auto)
; Proof finished.
(arw "(boole1→boole2) ∧ (boole2→boole1)"
     "boole1=boole2")



; (p ∧ q) ∧ q  =  p ∧ q
(sg "(boole1 ∧ boole2 ∧ boole2)=(boole1 ∧ boole2)")
(cases)
(auto)
;Proof finished.
(arw "boole1 ∧ boole2 ∧ boole2"  "boole1 ∧ boole2")



; p∧(q∧r) = p∧q∧r
(sg "all boole1,boole2,boole3.(boole1∧(boole2∧boole3))=(boole1∧boole2∧boole3)")
(cases)
(auto)
; Proof finished.
(arw "boole1∧(boole2∧boole3)"
     "boole1∧boole2∧boole3")





; ¬( p ∧ ¬q ∧ q )
(sg "all boole1.¬(boole1 ∧ ¬boole2 ∧ boole2)")
(cases)
(auto)
; Proof finished.
(nrw "¬(boole1 ∧ ¬boole2 ∧ boole2)")





; p∨(q∨r) = p∨q∨r
(sg "all boole1,boole2,boole3.(boole1∨(boole2∨boole3))=(boole1∨boole2∨boole3)")
(cases)
(auto)
; Proof finished.
(arw "boole1∨(boole2∨boole3)"
     "boole1∨boole2∨boole3")





; (p→q)∧q = q
(sg "((boole1→boole2)∧boole2)=boole2")
(cases)
(auto)
; Proof finished.
(arw "(boole1→boole2)∧boole2"
     "boole2")



; q∧(p→q) = q
(sg "(boole2∧(boole1→boole2))=boole2")
(cases)
(auto)
; Proof finished.
(arw "boole2∧(boole1→boole2)"  "boole2")






; ((p→q)∧p) = p∧q
(sg "((boole1→boole2)∧boole1)=(boole2∧boole1)")
(cases)
(auto)
; Proof finished.
(arw "(boole1→boole2)∧boole1"  "boole2∧boole1")





; (p∧(p→q))→q
(sg "(boole1 ∧ (boole1→boole2)) = (boole1∧boole2)")
(cases)
(auto)
; Proof finished.
(arw "boole1∧(boole1→boole2)" "boole1∧boole2")


; (p ∧ q) → p
(sg "(boole1∧boole2)→boole1")
(cases)
(auto)
; Proof finished.
(nrw "(boole1∧boole2)→boole1")



; (p ∧ q) → q
(sg "(boole1∧boole2)→boole2")
(cases)
(auto)
; Proof finished.
(nrw "(boole1∧boole2)→boole2")


; (p ∧ q ∧ r) → p
(sg "(boole1∧boole2∧boole3)→boole1")
(cases)
(auto)
; Proof finished.
(nrw "(boole1∧boole2∧boole3)→boole1")




; ( (p→q) ∧ (q→r) ∧ p ) → r
(sg "(boole1→boole2)∧(boole2→boole3)∧boole1→boole3")
(cases)
(auto)
; Proof finished.
(nrw "(boole1→boole2)∧(boole2→boole3)∧boole1→boole3")


; ∧-transitivity follows from:
(sg "all boole1,boole3.boole1∧boole2∧boole3→boole1∧boole3")
(cases)
(auto)
; Proof finished.
(nrw "boole1∧boole2∧boole3→boole1∧boole3")


; (p → q) → ((p∧r)→ q)
(sg "all boole2,boole3.(boole2→boole3)∧boole1∧boole2→boole3")
(cases)
(auto)
; Proof finished.
(nrw "(boole2→boole3)∧boole1∧boole2→boole3")


(sg "boole=True→boole")
(cases)
(auto)
; Proof finished.
(nrw "boole=True→boole")


(sg "¬(¬boole=boole)")
(cases)
(auto)
; Proof finished.
(trw "¬(¬boole=boole)")


; (¬p ∧ q) ∨ p   =   p ∨ q
(sg "((¬boole1∧boole2)∨boole1)=(boole1∨boole2)")
(cases)
(auto)
; Proof finished.
(arw "(¬boole1∧boole2)∨boole1" "boole1∨boole2")


(sg "(¬(¬boole1∧boole2))=boole2→boole1")
(cases)
(auto)
; Proof finished.
; (arw "¬(¬boole1∧boole2)" "boole2→boole1")


(sg "all boole1.[if boole1 boole2 False]→boole1")
(cases)
(auto)
; Proof finished.
(nrw "[if boole1 boole2 False]→boole1")


(sg "all boole1.[if boole1 boole2 False]→boole2")
(cases)
(auto)
; Proof finished.
(nrw "[if boole1 boole2 False]→boole2")





(sg "boole2∧boole1→boole1∧boole2")
(cases)
(auto)
; Proof finished.
(nrw "boole2∧boole1→boole1∧boole2")


(display "

End of RW -RULES

")
)



; FROM BOOLES TO FORMULAE

(begin

; BooleImp: ( p→q ) -> p -> q

(sg "all boole1,boole2.
    ((boole1→boole2)->boole1->boole2)
  & ((boole1->boole2)->(boole1→boole2))")
(cases)
(auto)
(cases)
(auto)
; Proof finished.
(save "BooleImp")
(display-theorems "BooleImp")

(define (booleimp termstring)
  (use "BooleImp" (pt termstring)))



(define (ass hypstring)
  (let* ((err "ass: Goal formula must be a boolean implication !!!")
	 (gf (goal-to-formula(current-goal))))
    (if (atom-form? gf)
	(let* ((gb (atom-form-to-kernel gf)))
	  (if (imp-boole? gb)
	      (begin (set! OLD-COMMENT-FLAG COMMENT-FLAG)
		     (set! COMMENT-FLAG #f)
		     (use "BooleImp" 'right)
		     (set! COMMENT-FLAG OLD-COMMENT-FLAG)
		     (newline)
		     (assume hypstring))
	      (myerror err)))
	(myerror err))))




; BooleImp2: ( (p∧q)→r ) -> p -> q -> r

(sg "all boole3,boole2,boole1.
    (((boole1∧boole2)→boole3)->boole1->boole2->boole3)
  & ((boole1->boole2->boole3) -> (boole1∧boole2)→boole3)")
(cases)
(auto)
(cases)
(cases)
(auto)
; Proof finished.
(save "BooleImp2")
(display-theorems "BooleImp2")



; booleimptrans:  ( (p→q) ∧ (q→r) ∧ p ) → r

(sg "(boole1→boole2) -> (boole2→boole3) -> (boole1→boole3)")
(assume "boole1" "boole2" "boole3")
(cut(pf"(boole1→boole2)∧(boole2→boole3)→(boole1→boole3)"))
(use-with "BooleImp2" (pt"boole1→boole3") (pt"boole2→boole3") (pt"boole1→boole2") 'left)
(use "Truth-Axiom")
; Proof finished.
(save "booleimptrans")
(display-theorems "booleimptrans")


; p ∧ q  ->  p
(set-goal (pf"all boole2,boole1.(boole1 ∧ boole2) -> boole1"))
(cases)
   (search)
(cases)
(auto)
; Proof finished.
(save "AndElimLeft")
(display-theorems "AndElimLeft")



; p ∧ q  ->  q
(set-goal (pf"all boole1,boole2.(boole1 ∧ boole2) -> boole2"))
(cases)
   (search)
(cases)
(auto)
; Proof finished.
(save "AndElimRight")
(display-theorems "AndElimRight")




(sg "[if boole1 boole2 False] = (boole1∧boole2)")
(cases)
(auto)
; Proof finished.
(save "booleIfAnd")
(display-theorems "booleIfAnd")





(define (trans termstring)
  (let ((gf (goal-to-formula(current-goal))))
    (cond ((atom-form? gf)
	   (let ((term (pt termstring)))
	     (cond ((or-boole? (atom-form-to-kernel gf))
		    (let* ((bt (neg-boole-to-kernel(atom-form-to-kernel gf)))
			   (args (term-in-app-form-to-args bt))
			   (lcon (orboole (neg-boole-to-kernel(car args)) term))
			   (rcon (orboole term (neg-boole-to-kernel(cadr args))))
			   (newgoal (andboole lcon rcon)))
		      (use "BooleImp" newgoal)
		      (use "Truth-Axiom")))
		   ((imp-boole? (atom-form-to-kernel gf))
		    (let* ((bt (neg-boole-to-kernel(atom-form-to-kernel gf)))
			   (args (term-in-app-form-to-args bt))
			   (lcon (impboole (car args) term))
			   (rcon (impboole term (neg-boole-to-kernel(cadr args))))
			   (newgoal (andboole lcon rcon)))
		      (use "BooleImp" newgoal)
		      (use "Truth-Axiom")))
		   ((and-boole? (atom-form-to-kernel gf))
		    (let* ((bt (atom-form-to-kernel gf))
			   (args (term-in-app-form-to-args bt))
			   (lcon (andboole (car args) term))
			   (rcon (andboole term (cadr args)))
			   (newgoal (andboole lcon rcon)))
		      (use "BooleImp" newgoal)
		      (use "Truth-Axiom")))
		   ((boole? term) (myerror (string-append "trans: " termstring " is of type boole.")
					   "trans: This is NOT supported (yet)."))
		   (else (if (neg-boole? (atom-form-to-kernel gf))
			     (let* ((bt (neg-boole-to-kernel(atom-form-to-kernel gf)))
				    (args (term-in-app-form-to-args bt))
				    (op (term-in-app-form-to-final-op bt))
				    (rcon (negboole(mk-term-in-app-form op (car args) term)))
				    (lcon (negboole(mk-term-in-app-form op term(cadr args))))
				    (newgoal
				     (mk-term-in-app-form
				      (make-term-in-const-form
				       (pconst-name-to-pconst "AndConst"))
				      lcon rcon)))
			       (use "BooleImp" newgoal)
			       (use "Truth-Axiom"))
			     (let* ((bt (atom-form-to-kernel gf))
				    (args (term-in-app-form-to-args bt))
				    (op (term-in-app-form-to-final-op bt))
				    (lcon (mk-term-in-app-form op (car args) term))
				    (rcon (mk-term-in-app-form op term (cadr args)))
				    (newgoal
				     (mk-term-in-app-form
				      (make-term-in-const-form
				       (pconst-name-to-pconst "AndConst"))
				      lcon rcon)))
			       (use "BooleImp" newgoal)
			       (use "Truth-Axiom")))))))
	   (else (myerror "trans: Goal formula must be an atom !!!")))))


)


(set! COMMENT-FLAG OLD-COMMENT-FLAG)


(begin

(add-alg "pos"
	 '("One" "pos")
	 '("SZero" "pos=>pos")
	 '("SOne" "pos=>pos"))
(display-constructors "pos")

;   M A K E - N U M E R I C - T E R M

(define (make-numeric-term k)
  (cond ((= k 1)
	 (pt "One"))
	((even? k)
	 (make-term-in-app-form
	  (pt "SZero")
	  (make-numeric-term (/ k 2))))
	((odd? k)
	 (make-term-in-app-form
	  (pt "SOne")
	  (make-numeric-term (/ (- k 1) 2))))
	(else
	 (myerror "make-numeric-term"
		  "positive integer expected"
		  k))))


(display"
Test of (make-numeric-term)

")
(display "  42 = ")
(pp (pt"42"))
(display "1024 = ")
(pp (pt"1024"))


(define (is-numeric-term? term)
  (or
   (and (term-in-const-form? term)
	(string=? "One"
		  (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)
	       (let ((name (const-to-name (term-in-const-form-to-const op))))
		 (or (string=? "SZero" name) (string=? "SOne" name)))
	       (is-numeric-term? (term-in-app-form-to-arg term)))))))

(define (numeric-term-to-number term)
  (if (equal? term (pt "One"))
      1
      (let* ((op (term-in-app-form-to-op term))
	     (arg (term-in-app-form-to-arg term))
	     (name (const-to-name (term-in-const-form-to-const op))))
	(if (string=? "SZero" name)
	    (* 2 (numeric-term-to-number arg))
	    (+ 1 (* 2 (numeric-term-to-number arg)))))))



(display"
Test of (numeric-term-to-number)

")
(display(string-append"  42 = "
(number-to-string(numeric-term-to-number(pt "42")))))
(display(string-append"
1024 = "
(number-to-string(numeric-term-to-number (pt "1024")))"

"))
)


(begin

(sg "(pos1=pos2)=(pos2=pos1)")
(assume "pos1" "pos2")
(cases (pt"pos1=pos2"))
(assume "1=2")
(simp "1=2")
(auto)
(assume "1≠2")
(simp(pf"pos2=pos1->F"))
(auto)
(assume "2=1")
(use "1≠2")
(simp "2=1")
(auto)
; Proof finished.
(save "posEQsym")
(display-theorems "posEQsym")
)



(begin

(add-program-constant
 "posLESS"
 (mk-arrow (py "pos") (py "pos") (py "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 "posLESS")) x y)))

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

(add-display
 (py "boole")
 (lambda (x)
   (cond ((neg-boole? x)
	  (let* ((op (term-in-app-form-to-final-op(neg-boole-to-kernel x)))
		 (args (term-in-app-form-to-args(neg-boole-to-kernel x))))
	    (if (and (term-in-const-form? op)
		     (string=? "posLESS"
			       (const-to-name (term-in-const-form-to-const op)))
		     (= 2 (length args)))
		(list 'rel-op "≤"
		      (term-to-token-tree (cadr args))
		      (term-to-token-tree (car args)))
		#f)))
	 (else
	  (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=? "posLESS"
			       (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))))))

; Computation Rules For posLESS

(acrs "pos < 1"                  "False")

(acrs "1 < SZero pos"            "True" )
(acrs "SZero pos1 < SZero pos2"  "pos1<pos2")
(acrs "SOne pos1 < SZero pos2"   "pos1<pos2")

(acrs "1 < SOne pos"             "True")
(acrs "SZero pos1 < SOne pos2"   "pos1≤pos2")
(acrs "SOne pos1  < SOne pos2"   "pos1<pos2")

(display-program-constants "posLESS")

(display "
NOTA BENE !   pos1 ≤ pos2  :≡   ¬(pos2<pos1)
")
)


(display "

Some RW-rules for < and ≤

")

(begin

(sg "1<pos ∨ 1=pos")
(cases)
(auto)
; Proof finished.
(nrw "1<pos ∨ 1=pos")



(display "
< is irrflexsive
≤ is reflexsive

")


(sg "pos≤pos")
(ind)
(auto)
; Proof finished.
(nrw "pos ≤ pos")


(display "
< is antisymmetric

")
(sg "¬(pos1<pos2 ∧ pos2<pos1)")

(ind)
(search)
(assume "pos1" "IH1")
(cases)
(auto)
(assume "pos1" "IH1")
(cases)
(auto)
; Proof finished.
(nrw "¬(pos1<pos2 ∧ pos2<pos1)")


(sg "pos1<pos2→(pos2<pos1)=False")
(assume "pos1" "pos2")
(cd "pos1<pos2" "1k2")
(simp(pf "False=(pos1<pos2 ∧ pos2<pos1)"))
(simp "1k2")
(use "Truth-Axiom")
(simp "BooleFalseLeft")
(auto)
; Proof finished.
(nrw "pos1<pos2→(pos2<pos1)=False")


(sg "(pos2≤pos1∧pos1≤pos2)→pos1=pos2")
(ind)
   (cases)
   (auto)
(assume "pos1" "IH1")
(cases)
  (auto)
(assume "pos1" "IH1")
(cases)
(auto)
; Proof finished.
(nrw "(pos2≤pos1∧pos1≤pos2)→pos1=pos2")


(display "
COROLLARY   < is linear:

(pos1<pos2) ∨ (pos2<pos1) ∨ (pos1=pos2)    ")
(pp(nt(pt"(pos1<pos2) ∨ (pos2<pos1) ∨ (pos1=pos2)")))


)







(display "

Extraction of cposMAX: pos@pos -> pos

")

(begin

(sg "ex pos.pos1≤pos ∧ ((pos2<pos ∧ pos1=pos) ∨ (pos=pos2))")
(assume "pos1" "pos2")
(cases(pt"pos1<pos2"))
(assume "1<2")
(ex-intro(pt"pos2"))
(ng #t)
(booleimp "pos1<pos2")
(auto)
(assume "2≤1")
(ex-intro(pt"pos1"))
(ng #t)
(booleimp "pos2≤pos1")
(use "Truth-Axiom")
(simp "2≤1")
(auto)
; Proof finished.
(save "posMAX")
(display-theorems "posMAX")


(set! OLD-COMMENT-FLAG COMMENT-FLAG)
(set! COMMENT-FLAG #t)
(animate "posMAX")
(display"

Test of cposMAX:

")
(display "cposMAX     3     1    :    ")
(pp(nt(pt"cposMAX     3     1")))
(display "cposMAX    42    42    :   ")
(pp(nt(pt"cposMAX    42    42")))
(display "cposMAX  1023  1024    : ")
(pp(nt(pt"cposMAX  1023  1024")))
(set! COMMENT-FLAG OLD-COMMENT-FLAG)
(deanimate "posMAX")
)


(display "

Some Theorems concerning cposMAX :

")

(begin

(animate"posMAX")
(sg "cposMAX 1 pos = pos")
(cases)
(auto)
; Proof finished.
(save "posMAX1n")
(display-theorems "posMAX1n")


(sg "cposMAX pos1 pos2 = cposMAX pos2 pos1")
(assume "pos1" "pos2")
(ng)
(cd "pos1<pos2" "1k2")
    (simp (pf"(pos2<pos1)=F"))
    (use "Truth-Axiom")
    (booleimp "pos1<pos2")
    (auto)
(assume "1≮2")
(cd "pos2<pos1" "2k1")
    (use "Truth-Axiom")
(assume "2≮1")
(booleimp "(pos1<pos2) ∨ (pos2<pos1) ∨ (pos1=pos2)")
(simp "1≮2")
(simp "2≮1")
(auto)
; Proof finished.
(save "posMAXcomm")
(deanimate"posMAX")
(display-theorems "posMAXcomm")


(sg "cposMAX pos 1 = pos")
(strip)
(simp "posMAXcomm")
(simp "posMAX1n")
(use "Truth-Axiom")
; Proof finished.
(save "posMAXn1")
(display-theorems "posMAXn1")
)



(display "

posLE_LESSorEQUAL: (pos1≤pos2)=((pos1<pos2)∨(pos1=pos2))

")

(begin
(sg "(pos1≤pos2)=((pos1<pos2)∨(pos1=pos2))")
(ind)
(cases)
(auto)
(assume "pos2" "IH2")
(cases)
(auto)
(assume "pos2" "IH2")
(cases)
(auto)
; Proof finished.
(save "posLE_LESSorEQUAL")
(display-theorems "posLE_LESSorEQUAL")
)



(display "

< is transitive:

(pos1<pos2 ∧ pos2<pos3) → pos1<pos3

")

(begin

(sg "all pos2,pos1.(pos1<pos2)→(1<pos2)")
(cases)
(auto)
; Proof finished.
(nrw"(pos1<pos2)→(1<pos2)")


(sg "all pos3,pos1,pos2.((pos1<pos2) ∧ (pos2<pos3)) → (pos1<pos3)")
(ind)
(auto)
(assume "pos3" "IH3")
(cases)
(auto)
(assume "pos1")
(cases)
(auto)
(assume "pos2")
(ng)
(simp "posLE_LESSorEQUAL")
(cd "pos1=pos2" "1=2")
(simp "1=2")
(auto)
(assume "pos1")
(cases)
(auto)
(assume "pos3" "IH3")
(assert(pf"all pos1,pos2.¬(pos1<pos2∧pos2<pos3∧pos3<pos1)"))
(begin
  (assume "pos1" "pos2")
  (simp (pf"(¬(pos1<pos2∧pos2<pos3∧pos3<pos1))=((pos1<pos2∧pos2<pos3)→(pos1≤pos3))"))
  (simp "posLE_LESSorEQUAL")
  (cases(pt"pos1=pos3"))
  (auto))
(assume "IH3'")
(cases)
(auto)
(assume "pos1")
(cases)
(auto)
(assume "pos2")
(ng)
(simp "posLE_LESSorEQUAL")
(cd "pos2=pos3"  "2=3")
(simp "2=3")
(auto)
(assume "pos2")
(ng)
(simp "posLE_LESSorEQUAL")
(cd "pos1=pos2" "1=2")
(simp "1=2")
(auto)
(assume "pos1")
(cases)
(auto)
(assume "pos2")
(ng)
(simp "posLE_LESSorEQUAL")
(cd "pos2=pos3" "2=3")
(simp "2=3")
(auto)
; Proof finished.
(nrw"((pos1<pos2) ∧ ((pos2<pos3)) → (pos1<pos3))")
)



(display"
Extraction of Successor function

cposS: pos -> pos .

")

(begin
(sg "all pos1.ex pos.all pos2.(pos1<pos) ∧ (pos1<pos2 → pos≤pos2)")
(ind)
  (ex-intro(pt"2"))
  (cases)
  (auto)
; n -> 2n
(assume "pos1" "IH")
(drop "IH")
(ex-intro(pt"SOne pos1"))
(cases)
(auto)

; n -> 2n+1
(assume "pos1" "IH")
(by-assume-with "IH" "pos0" "IH_pos0")
(ex-intro(pt"SZero pos0"))
(cases)
(use-with "IH_pos0" (pt"pos0"))
(auto)
; Proof finished.
(save "posS")
(display-theorems "posS")

(set! OLD-COMMENT-FLAG COMMENT-FLAG)
(set! COMMENT-FLAG #t)
(animate "posS")
(display"

Test of cposS:

")
(display "cposS    1 =    ")
(pp(nt(pt"cposS 1")))
(display "cposS   42 =   ")
(pp(nt(pt"cposS 42")))
(display "cposS 1023 = ")
(pp(nt(pt"cposS 1023")))
(display "cposS 123456789098765432123456789  =   ")
(pp(nt(pt"cposS 123456789098765432123456789")))
(set! COMMENT-FLAG OLD-COMMENT-FLAG)
(deanimate "posS")
)



(begin

(animate "posS")

(sg "cposS 1=2")
(use"Truth-Axiom")
(save"S1")
(display-theorems"S1")


(sg "¬(cposS pos=1)")
(cases)
(auto)
; Proof finished
(deanimate "posS")
(trw "¬(cposS pos = 1)")
(trw"¬((Rec pos=>pos)2([pos0,pos1]SOne pos0)([pos0]SZero)pos=1)")

)

(animate "posS")

(display"
Extraction of Predecessor function

cposP: pos -> pos

")

(begin

(sg "ex pos2. (pos1=1 ∧ pos2=1) ∨ (pos1=cposS pos2)")
(ind)
(ex-intro(pt"1"))
(auto)
(assume "pos1" "IH1")
(cd "pos1=1" "1=1")
    (simp "1=1")
    (drop "IH1")
    (ex-intro(pt"1"))
    (auto)
(assume "1≠1")
(by-assume-with "IH1" "pos" "IH")
(ex-intro(pt"SOne pos"))
(booleimp "(pos1=1∧pos=1)∨(pos1=cposS pos)")
(ng)
(simp "1≠1")
(auto)
(assume "pos1" "IH1")
(drop "IH1")
(ex-intro(pt"SZero pos1"))
(auto)
; Proof finished.
(save "posP")
(display-theorems "posP")

(display "
   PROBLEM WITH (proof-to-soundness-proof ) !!!
")


(add-theorem "posP_Soundness"
	     (np(proof-to-soundness-proof 
		 (theorem-name-to-proof "posP"))))
(deanimate "posS")


(deanimate "posP")
(set! OLD-COMMENT-FLAG COMMENT-FLAG)
(set! COMMENT-FLAG #t)
(animate "posP")

(display"

Test of cposP:

")

(display "cposP    1 =    ")
(pp(nt(pt"cposP 1")))
(display "cposP   42 =   ")
(pp(nt(pt"cposP 42")))
(display "cposP 1023 = ")
(pp(nt(pt"cposP 1023")))
(display "cposP 123456789098765432123456789   = ")
(pp(nt(pt"cposP 123456789098765432123456789")))
(set! COMMENT-FLAG OLD-COMMENT-FLAG)
(deanimate "posP")
)

(deanimate "posS")
(animate "posS")
(animate "posP")

(display "

Some Theorems concerning cposP :

")

(begin

(sg "SZero pos=cposS(cposP(SZero pos))")
(assume "pos")
(ng)
(use-with  "posP_Soundness" (pt"SZero pos"))
; Proof finished.
(save "SP2n")
(display-theorems  "SP2n")


(sg "SOne pos=cposS(cposP(SOne pos))")
(auto)
; Proof finished.
(save "SP2n+1")
(display-theorems  "SP2n+1")


(sg "all pos.cposP(cposS pos)=pos")
(ind)
  (auto)
(cases)
(auto)
; Proof finished.
(save"posPS")
(deanimate"posS")
(deanimate"posP")
(display-theorems "posPS")

)


(display"

ADDITION

")


(add-ids
  (list
   (list "posADD"
	 (make-arity (py "pos") (py "pos") (py "pos"))))
  '("allnc pos.posADD pos 1 (cposS pos)")
  '("allnc pos1,pos2,pos3.
       posADD pos1 pos2 pos3
    -> posADD pos1 (cposS pos2) (cposS pos3)"))


(begin

(add-program-constant
 "posPlus"
 (mk-arrow (py "pos") (py "pos") (py "pos"))
 1 'const 2
)

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

(add-display
 (py "pos")
 (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=? "posPlus"
                        (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))))

; Computation Rules For posPlus

(acrs "1+1"              "2")
(acrs "(SZero pos) + 1"  "SOne pos")
(acrs "(SOne pos) + 1"   "SZero (pos + 1)")

(acrs "1+(SZero pos2)"               "SOne pos2")
(acrs "(SZero pos1) + (SZero pos2)"  "SZero(pos1 + pos2)")
(acrs "(SOne pos1) + (SZero pos2)"   "SOne(pos1 + pos2)")

(acrs "1 + (SOne pos2)"              "SZero (pos2 + 1)")
(acrs "(SZero pos1) + (SOne pos2)"   "SOne(pos1 + pos2)")
(acrs "(SOne pos1) + (SOne pos2)"    "SZero((pos1 + pos2) + 1)")

(set! OLD-COMMENT-FLAG COMMENT-FLAG)
(set! COMMENT-FLAG #t)

(display-program-constants "posPlus")

(display"

 Test of posPlus +

")

(display "    3 +    1 =    ")
(pp(nt(pt"3+1")))
(display "   42 +   42 =   ")
(pp(nt(pt"42+42")))
(display " 1024 + 1023 = ")
(pp(nt(pt"1024+1023")))
(set! COMMENT-FLAG OLD-COMMENT-FLAG)
)


(display "
Some RW-rules concerning posPlus +

")

(begin

(display"
 1 < pos+1
")
(sg "1<(pos+1)")
(cases)
(auto)
; Proof finished.
(trw "1<(pos+1)")



(sg "¬(pos1+pos2=1)")
(cases)
(cases)
(auto)
(assume "pos1")
(cases)
(auto)
(assume "pos1")
(cases)
(auto)
; Proof finished.
(trw "¬(pos1+pos2=1)")


(sg "(pos1<pos2+1)=(pos1≤pos2)")
(ind)
(auto)
(assume "pos1" "IH1")
(cases)
(auto)
(assume "pos1" "IH1")
(cases)
(auto)
; Proof finished.
(arw "pos1<pos2+1" "pos1≤pos2")
)



(animate "posS")

(begin

(display"
Sn = 1+n
")

(sg "cposS pos=1+pos")
(ind)
(auto)
(cases)
(auto)
; Proof finished.
(save "1+pos")
(display-theorems "1+pos")



(sg "cposS pos=pos+1")
(ind)
(auto)
; Proof finished.
(save "pos+1")
(deanimate "posS")
(display-theorems "pos+1")

)


(display"

n=1 ∨ n=1+Pn
")

(begin

(sg " pos=1 ∨ pos=1+(cposP pos)")
(cases)
(auto)
(assume "pos")
(simp "<-" "1+pos")
(ng #t)
(simp "SP2n")
(use "Truth-Axiom")

(assume "pos")
(simp "<-" "1+pos")
(ng #t)
(simp "SP2n+1")
(use "Truth-Axiom")
; Proof finished.
(nrw "pos=1 ∨ pos=1+(cposP pos)")
(nrw "pos=1 ∨ pos=1+((Rec pos=>pos)1([pos0,pos1][if (pos0=1) 1 (SOne pos1)]) ([pos0,pos1]SZero pos0) pos)")
)



(display"

posPLUScomm:  k+n = n+k
")

(begin

(sg "pos1+pos2=pos2+pos1")
(ind)
(ind)
(auto)
(assume "pos1" "IH")
(ind)
(auto)
(assume "pos1" "IH")
(ind)
(auto)
(assume "pos2")
(ng #t)
(simp(pf"pos1+pos2=pos2+pos1"))
(auto)
; Proof finished.
(save "posPLUScomm")
(display-theorems "posPLUScomm")
)


(display"

posPLUS is associative:
pos1+(pos2+pos3)=pos1+pos2+pos3

")

(begin
(sg "1+(pos2+pos3)=1+pos2+pos3")
(ind)
(cases)
(auto)
(assume "pos3")
(ng)
(simp-with "posPLUScomm" (pt"1") (pt"pos3"))
(auto)
(assume "pos3")
(ng)
(simp-with "posPLUScomm" (pt"1") (pt"pos3"))
(auto)
(assume "pos2" "IH2")
(cases)
(auto)
(assume "pos2" "IH2")
(cases)
(auto)
(ng)
(assume "pos3")
(simp-with "<-" "posPLUScomm" (pt"1") (pt"pos2"))
(simp "<-" (pf"1+(pos2+pos3)=1+pos2+pos3"))
(simp-with  "posPLUScomm" (pt"1") (pt"pos2+pos3"))
(auto)
(assume "pos3")
(ng)
(simp-with "<-" "posPLUScomm" (pt"1") (pt"pos2"))
(simp "<-" (pf"1+(pos2+pos3)=1+pos2+pos3"))
(simp-with  "posPLUScomm" (pt"1") (pt"pos2+pos3"))
(auto)
; Proof finished.
(arw "1+(pos2+pos3)" "1+pos2+pos3")



(sg "pos1+(pos2+pos3)=pos1+pos2+pos3")
(ind)
(auto)
(assume "pos1" "IH1")
(ind)
(cases)
(auto)
(assume "pos2" "IH2")
(cases)
(auto)
(assume "pos2" "IH2")
(cases)
(auto)
(ng)
(assume "pos3")
(simp-with "IH1" (pt"pos2+pos3") (pt"1"))
(simp-with "IH1" (pt"pos2") (pt"pos3"))
(auto)

(assume "pos1" "IH1")
(ind)
(cases)
(auto)
(ng)
(assume "pos3")
(simp-with "<-" "IH1" (pt"pos3") (pt"1"))
(simp-with "<-" "posPLUScomm" (pt"1") (pt"pos3"))
(auto)
(assume "pos3")
(ng #t)
(simp-with "<-" "posPLUScomm" (pt"1") (pt"pos3"))
(auto)
(assume "pos2" "IH2")
(cases)
(auto)
(assume "pos3")
(ng #t)
(simp "IH1")
(auto)
(assume "pos2" "IH2")
(cases)
(auto)
(assume "pos3")
(ng)
(simp "IH1")
(simp-with "posPLUScomm" (pt"pos1+pos2+pos3") (pt"1"))
(simp-with "posPLUScomm" (pt"pos1+pos2") (pt"1"))
(auto)
(assume "pos3")
(ng)
(simp-with "posPLUScomm" (pt"pos2+pos3") (pt"1"))
(simp-with "<-" "IH1" (pt"pos2") (pt"1"))
(simp-with  "posPLUScomm" (pt"pos2") (pt"1"))
(auto)
; Proof finished.
(arw "pos1+(pos2+pos3)" "pos1+pos2+pos3")

)


(display"
 k < k+l   and   k < l+k
")


(begin

(sg "pos1<(pos1+pos2)")
(ind)
(cases)
(auto)
(assume "pos1" "IH1")
(cases)
(auto)
(assume "pos2")
(booleimp "pos1<pos1+pos2")
(auto)
(assume "pos1" "IH1")
(cases)
(auto)
(assume "pos2")
(ng #t)
(simp(pf"(pos1≤pos1+pos2)=(pos1<pos1+pos2+1)"))
(simp(pf"pos1+pos2+1=pos1+(pos2+1)"))
(use "IH1")
(auto)
; Proof finished.
(trw "pos1<(pos1+pos2)")


(sg "pos1<(pos2+pos1)")
(assume "pos1" "pos2")
(simp "posPLUScomm")
(use "Truth-Axiom")
; Proof finished.
(trw "pos1<(pos2+pos1)")

)


; (sg "(pos1≤pos2)=(pos1<pos2 ∨ pos1=pos2)")
; ;(begin
;   (cases)
;   (auto)
;   (assume "pos1")
;   (cases)
;   (auto)
;   (assume "pos2")
;   (use "posLE_LESSorEQUAL")
;   (auto)
;   (assume "pos1")
;   (cases)
;   (auto)
;   (assume "pos2")
;   (use "posLE_LESSorEQUAL"))
; ; Proof finished.
; (save "poslessS1")
; (display-theorems "poslessS1")



(display "

We add the algebra upos
of unary postive numbers
in order to simplify
the successor induction
on the binary represention.

")


(add-alg "upos"
	 '("Unum" "upos")
	 '("SUCC" "upos=>upos"))
(display-constructors "upos")

(begin

(add-program-constant
 "uposP"
 (mk-arrow (py "upos") (py "upos"))
 1 'const 1
)
(acrs "uposP Unum"         "Unum")
(acrs "uposP (SUCC upos)"  "upos")

(display-program-constants "uposP")
)



(begin

(add-program-constant
 "Upostopos"
 (mk-arrow (py "upos") (py "pos"))
 1 'const 1
)

; Computation Rules For Upostopos

(acrs "Upostopos Unum"         "1")
(acrs "Upostopos (SUCC upos)"  "(Upostopos upos)+1")

(display-program-constants "Upostopos")

(display"

Test of Upostopos:

")

(display "
Upostopos            Unum    =   ")
(pp(nt(pt"Upostopos            Unum")))
(display "
Upostopos  SUCC(SUCC Unum)   =   ")
(pp(nt(pt"Upostopos  (SUCC(SUCC Unum))")))
)



(begin

(add-program-constant
 "uposPLUS"
 (mk-arrow (py "upos") (py "upos") (py "upos"))
 1 'const 2
)

; Computation Rules For uposPLUS

(acrs "uposPLUS upos Unum"           "SUCC upos")
(acrs "uposPLUS upos1 (SUCC upos2)"  "SUCC (uposPLUS upos1 upos2)")

(display-program-constants "uposPLUS")
)


(display "
Some RW-rules .
")

(begin

(sg "¬(uposPLUS upos1 upos2 = Unum)")
(assume "upos1")
(cases)
(auto)
; Proof finished.
(trw "¬(uposPLUS upos1 upos2 = Unum)")


(sg "all upos2,upos1.uposPLUS(SUCC upos1)upos2=SUCC(uposPLUS upos1 upos2)")
(ind)
(auto)
; Proof finished.
(arw "uposPLUS(SUCC upos1)upos2" "SUCC(uposPLUS upos1 upos2)")


(sg "Upostopos(uposPLUS upos upos)=SZero(Upostopos upos)")
(ind)
  (prop)
(assume "upos" "IH")
(ng #t)
(simp "IH")
(auto)
; Proof finished.
(arw "Upostopos(uposPLUS upos upos)" "SZero(Upostopos upos)")

)


(display"
Upostopos is surjective
exnc upos.pos=Upostopos upos

")

(begin

(sg "ex upos.pos=Upostopos upos")
(ind)
  (ex-intro(pt "Unum"))
  (use "Truth-Axiom")
(assume "pos" "IH")
(by-assume-with "IH" "upos" "IHn")
(ex-intro(pt "uposPLUS upos upos"))
(simp "IHn")
(use "Truth-Axiom")

(assume "pos" "IH")
(by-assume-with "IH" "upos" "IHn")
(ex-intro(pt "SUCC(uposPLUS upos upos)"))
(simp "IHn")
(use "Truth-Axiom")
; Proof finished.
(save "Upostopossurjective")
(display-theorems "Upostopossurjective")

(set! OLD-COMMENT-FLAG COMMENT-FLAG)
(set! COMMENT-FLAG #t)
(animate "Upostopossurjective")

(display"

Test of cUpostopossurjective:

")

(display "cUpostopossurjective    1 =  ")
(pp(nt(pt"cUpostopossurjective 1")))
(display "cUpostopossurjective    4 =  ")
(pp(nt(pt"cUpostopossurjective 4")))
(display "cUpostopossurjective   13 =  ")
(pp(nt(pt"cUpostopossurjective 13")))
(deanimate "Upostopossurjective")
(set! COMMENT-FLAG OLD-COMMENT-FLAG)
)



(begin

(sg "(all upos (Pvar pos)^(Upostopos upos)) -> all pos.(Pvar pos)^ pos")

(assume "Aupos" "pos")
(inst-with-to "Upostopossurjective" (pt"pos") "preimg")
(by-assume-with "preimg" "upos2" "equ")
(simp "equ")
(inst-with-to "Aupos" (pt"upos2") "Aupos2")
(use "Aupos2")
; Proof finished.
(save"FromUpostopos")
(display-theorems"FromUpostopos")


(define (uposind varstring formulastring)
  (inst-with-to "FromUpostopos"
		(make-cterm (pv varstring)
			    (pf formulastring))
		"upos2pos")
  (use "upos2pos")
  (drop "upos2pos")
  (ind))

)

(display"

posPLUSposADD: posADD pos1 pos2 (pos1+pos2)

")

(begin

(sg "all pos1,pos2.posADD pos1 pos2 (pos1+pos2)")
(assume "pos1")
(uposind "pos2" "posADD pos1 pos2 (pos1+pos2)")
    (ng #t)
    (simp "<-" "pos+1")
    (intro 0)
(assume "upos" "IH")
(ng #t)
(simp "<-" "pos+1")
(simp "<-" "pos+1")
(intro 1)
(auto)
; Proof finished.
(save"posPLUSposADD")
(display-theorems"posPLUSposADD")
)


(display"

posADDposPLUS: posADD pos1 pos2 pos3 -> (pos1+pos2=pos3)

")

(begin

(sg "posADD pos1 pos2 pos3 -> (pos1+pos2=pos3)")
(assume "pos1" "pos2" "pos3")
(elim)
(assume "pos")
(simp "pos+1")
(auto)
(assume "pos4" "pos5" "pos6" "add" "4+5=6")
(simp "pos+1")
(simp "pos+1")
(auto)
(simp "<-" "4+5=6")
(auto)
; Proof finished.
(save"posADDposPLUS")
(display-theorems"posADDposPLUS")

)


; (display"
; n+1=k -> k=Sn

; PROOF:
; ")

; (animate "posS")
; (set-goal
;  (pf"posADD pos1 pos2 pos3 -> pos2=1 -> pos3=cposS pos1"))
; (begin
; (assume "pos2" "pos1" "pos3")
; (elim)
; (auto)
; (assume "pos4" "pos5" "pos6" "+" "IH")
; (simp "OneNonSucS")
; (use "Efq-Atom")
; ; ok, ?_6 is proved.  Proof finished.
; )
; (save "posPlusOne")
; (display-theorems "posPlusOne")
; (deanimate "posS")





; (display"
; n+k=1 -> F

; ")

; (set-goal
;  (pf"posADD pos1 pos2 pos3->pos3=1->F"))
; (begin
; (assume "pos1" "pos2" "pos3")
; (elim)
; (assume "pos4")
; (simp "OneNonSucS")
; (auto)
; (strip 5)
; (simp "OneNonSucS")
; (auto)

; ; Proof finished.
; )
; (save "PosOneNoSum")
; (display-theorems "PosOneNoSum")




; (sg "posADD pos1 pos2 1->F")
; (begin
; (assume "pos1" "pos2")
; (inst-with-to "PosOneNoSum"
; 	      (pt"pos1")
; 	      (pt"pos2")
; 	      (pt "1") "PosOneNoSum121")
; (auto)

; ; Proof finished.
; )
; (save "PosOneNoSum1")
; (display-theorems "PosOneNoSum1")





; (display"
; k+l=m -> m+l=n -> k+2l=n

; PROOF:
; ")

; (begin

; (display "
; Left as an exercise
; for the MiNLOG newcomer.
; ")

; (aga "posPlusDouble" (pf "all pos1,pos2,pos3,pos4.
;                            posADD pos1 pos2 pos3
;                         -> posADD pos3 pos2 pos4
;                         -> posADD pos1 (SZero pos2) pos4"))
; (display-global-assumptions  "posPlusDouble")

;(set-goal
; (pf"all pos1.posADD pos1 pos2 pos3
;           -> posADD pos3 pos2 pos4
;           -> posADD pos1 (SZero pos2) pos4"))
; (cases)
; (simp(pf"2=cposS 1"))
; (assume "pos3" "pos4" "pos1")
; (assume "S1" "SS1")
; (simp(pf"pos4=cposS pos3"))
; (intro 1)
; (auto)
; (use "posPlusOne" (pt"1"))
; (use "SS1")
; (auto)

; (assume "pos2" "pos3" "pos4" "pos1" "1+2*2=3" "3+2*2=4")


; (display"

; Until here !!!
; ")


; (simp
;  (pf"SZero (SZero pos2)
;      = cposS(cposP (SZero (SZero pos2)))"))
; (simp(pf"pos4=cposS(cposP pos4)"))
; (intro 1)
; (ng #t)
; (cases(pt"pos2=1"))
; (assume "2=1")
; (ng #t)
; (simp (pf"3=cposS 2"))
;)


; (display"
; n = k+2l -> Sn = k+(2l+1)

; PROOF"
; )
; (animate "posS")
; (set-goal
;  (pf"posADD pos1 (SZero pos2) pos3
;   -> posADD pos1 (SOne pos2) (cposS pos3)"))
; (begin
; (assume "pos1" "pos2" "pos3" "3=1+2*2")
; (simp (pf"SOne pos2 = cposS(SZero pos2)"))
; (intro 1)
; (auto)

; ; Proof finished.
; )
; (save"posPlusDoubleToDouble1")
; (display-theorems"posPlusDoubleToDouble1")
; (deanimate "posS")









; (define(PROG var function Predicate)
;   (string-append "(all "var"."Predicate"("var") -> "
;                   Predicate"("function"))"))


; (begin
; (display"

; Three more global assumptions to be shown:
; ")
; (aga "k+2n"
;      (pf"all pos1,pos2.
;              pos1+SZero pos2 = (pos1+pos2)+pos2"))
; (display-global-assumptions "k+2n")
; (aga "S(k+2n)"
;      (pf"all pos1,pos2.
;              pos1+SOne  pos2 = cposS(pos1+SZero pos2)"))
; (display-global-assumptions "S(k+2n)")
; (aga "k+2n+1"
;      (pf"all pos1,pos2.
;              pos1+SOne  pos2 = (pos1+SZero pos2)+1"))
; (display-global-assumptions "k+2n+1")
; )

; (display"


; A(k) -> Prog(n,n+1,A) -> A(k+n)

; PROOF:
; ")

; (set-goal
;  (pf
;   (string-append
;    "all pos0.A^ pos0 -> "
;     (PROG "pos" "pos+1" "A^") "-> A^(pos0+pos1)" )))
; (time(begin
; (cut
;  (pf"all pos0.A^pos0
;      -> (all pos.A^pos -> A^(pos+1)) -> A^(pos0+1)"))
; (assume "IH1base")
; (cut
;  (pf"all pos1.
;        (all pos0.A^pos0
;         -> (all pos.A^pos -> A^(pos+1))
;         -> A^(pos0+pos1))
;      -> all pos0. A^pos0
;                -> (all pos.A^pos -> A^(pos+1))
;                -> A^(pos0+SZero pos1)"))
; (assume "IH1step0")
; (ind)
; (auto)

; ; IH1step1
; (assume "pos1" "IH1" "pos0" "A0" "PROG")
; (simp "k+2n+1")
; (auto)

; ; IHstep0

; (assume "pos1" "IH1" "pos0" "A0" "PROG")
; (simp "k+2n")
; (auto)

; ; Proof finished.
; ))
; (save "posIndAdd")
; (display-theorems "posIndAdd")







; (display"
; INDUCTION on pos
; A(1) -> Prog(n,n+1,A) -> A(n)

; PROOF:
; ")

; (set-goal
;  (pf
;   (string-append
;    "A^ 1 -> " (PROG "pos" "pos+1" "A^") "-> A^ pos" )))
; (time(begin
; (assume "pos")
; (cases (pt"pos=1"))
;   (assume "1")
;   (simp "1")
;   (search)
; (assume "not1")
; (simp (pf"pos = 1+(cposP pos)"))
; (use "posIndAdd")
; (cut
;  (pf"((pos=1)=False and (pos=1+(cposP pos))=False)=False"))
; (simp"not1")
; (ng #t)
; (simp"BooleStab")
; (auto)

; ; Proof finished.
; ))
; (save "posInd")
; (display-theorems "posInd")






(begin

(add-program-constant
 "uposLESS"
 (mk-arrow (py "upos") (py "upos") (py "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 "uposLESS")) 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=? "uposLESS"
		(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))))

; Computation Rules For uposLESS

(acrs "upos ◁ Unum"              "False")

(acrs "Unum ◁ SUCC upos"          "True")
(acrs "SUCC upos1 ◁ SUCC upos2"  "upos1◁upos2")

(display-program-constants "uposLESS")

)


(begin

(sg "upos◁SUCC upos")
(ind)
(auto)
; Proof finished.
(trw "upos◁SUCC upos")

(sg "¬(upos◁ upos)")
(ind)
(auto)
; Proof finished.
(nrw "¬(upos◁ upos)")


(sg "(upos1◁SUCC upos2)=(upos1◁upos2 ∨ upos1=upos2)")
(ind)
(cases)
(auto)
(assume "upos1" "IH1")
(cases)
(auto)
; Proof finished.
(save "uposlessS1")
(display-theorems "uposlessS1")

)

(begin

(add-program-constant
 "Postoupos"
 (mk-arrow (py "pos") (py "upos"))
 1 'const 1
)

; Computation Rules For Postoupos

(acrs "Postoupos 1"      "Unum")

(acrs "Postoupos (SZero pos)"
     "uposPLUS(Postoupos pos)(Postoupos pos)")

(acrs "Postoupos (SOne pos)"
     "SUCC(uposPLUS(Postoupos pos)(Postoupos pos))")

(display-program-constants "Postoupos")

(display"

Test of Postoupos:

")

(display "Postoupos   1    =   ")
(pp(nt(pt"Postoupos   1")))
(display "Postoupos  13   =   ")
(pp(nt(pt"Postoupos  13")))
)


(sg "Upostopos(Postoupos pos)=pos")
(ind)
(auto)
; Proof finished.
(arw "Upostopos(Postoupos pos)" "pos")


; (set-goal
;  (pf"Upostopos(uposPLUS Unum (Postoupos pos))=pos+1"))
; (ind)
; (auto)
; (assume "pos" "IH")
; (ng #t)


; (set-goal
;  (pf"all pos1.Upostopos(uposPLUS (Postoupos pos1) (Postoupos pos2))=pos1+pos2"))
; (ind)
; (cases)
; (auto)
; (assume "pos2" "IH2")
; (cases)
; (auto)
; (ng #t)

; (auto)


; (sg "Postoupos(pos+1)=SUCC(Postoupos pos)")
; (cases)
; (auto)
; (assume "pos")
; (ng #t)

; (arw "Postoupos(pos+1)" "SUCC(Postoupos pos)")




; (sg "Postoupos(Upostopos upos)=upos")
; (ind)
; (auto)
; (assume "upos" "IH")
; (ng #t)

; ; Proof finished.
; (arw "Upostopos(Postoupos pos)" "pos")



(display "
Postoupos(k+1) = SUCC(Postoupos k)

")

(begin

(sg "Postoupos(pos+1)=SUCC(Postoupos pos)")
(ind)
(auto)
(assume "pos1" "IH")
(ng)
(simp "IH")
(use "Truth-Axiom")
; Proof finished.
(arw "Postoupos(pos+1)" "SUCC(Postoupos pos)")
)


; (display"
; Postoupos is surjective
; exnc pos.upos=Postoupos pos

; PROOF:
; ")
; (sg "ex pos.upos=Postoupos pos")
; (begin
; (ind)
; (ex-intro(pt "1"))
; (use "Truth-Axiom")
; (assume "upos" "IH")
; (ex-elim "IH")
; (drop "IH")
; (assume "pos" "IHn")
; (ex-intro(pt "pos+1"))
; (simp "IHn")
; (use "Truth-Axiom")
; ; Proof finished.
; )
; (save "Postoupossurjective")
; (display-theorems "Postoupossurjective")


(display "
Some more RW-rules and THMs .

")

(begin

(deanimate "Upostopossurjective")
(animate "Upostopossurjective")

(sg "cUpostopossurjective pos = Postoupos pos")
(ind)
(auto)
(assume "pos" "hyp")
(ng #t)
(simp "hyp")
(auto)
(assume "pos" "hyp")
(ng #t)
(simp "hyp")
(auto)
; Proof finished.
(save "UpostoposPreimg")
(deanimate "Upostopossurjective")
(display-theorems "UpostoposPreimg")


(sg "(¬(upos1◁upos2) ∧ upos1◁SUCC upos2)=(upos1=upos2)")
(ind)
  (ind)
  (auto)
(assume "upos1" "IH1")
(ind)
(auto)
; Proof finished.
(arw "¬(upos1◁upos2) ∧ upos1◁SUCC upos2" "upos1=upos2")


)




; (add-pvar-name "B" (make-arity (py "upos")))


; (sg "(all pos B^(Postoupos pos)) -> all upos.B^ upos")
; (begin
; (assume "Bupos" "upos")
; (inst-with-to "Postoupossurjective" (pt"upos") "preimg")
; (ex-elim "preimg")
; (assume "pos2" "equ")
; (simp "equ")
; (use "Bupos")
; ; Proof finished.
; )
; (save"FromPostoupos")
; (display-theorems"FromPostoupos")




; (begin
; (display "
; Remains to be shown
; Upostopos(Postoupos k) = k

; ")
; (arw "Upostopos(Postoupos pos)" "pos")
; )



; (display"
; INDUCTION on pos
; A(1) -> Prog(n,n+1,A) -> A(n)

; PROOF:
; ")

; (set-goal
;  (pf
;   (string-append
;    "A^ 1 -> " (PROG "pos" "pos+1" "A^") "-> A^ pos" )))
; (begin
; (assume "pos" "A1" "prog")
; (use "FromUpostopos")
; (ind)
;   (use "A1")
; (cut(pf"all pos.A^(Upostopos(Postoupos pos)) -> A^(Upostopos(SUCC(Postoupos pos)))"))
; (use-with "FromPostoupos" (make-cterm (pv "upos") (pf "A^(Upostopos upos) -> A^(Upostopos(SUCC upos))")))
; (use "prog")
; ; Proof finished.
; )
; (save "posuposInd")
; (display-theorems "posuposInd")


; (define (animate-posuposind)
;   (begin
;     (deanimate-posuposind)
;     (animate "Postoupossurjective")
;     (animate "Upostopossurjective")
;     (animate "FromPostoupos")
;     (animate "FromUpostopos")
;     (animate "posuposInd")))


; (define (deanimate-posuposind)
;   (begin
;     (deanimate "Postoupossurjective")
;     (deanimate "Upostopossurjective")
;     (deanimate "FromPostoupos")
;     (deanimate "FromUpostopos")
;     (deanimate "posuposInd")))


; (begin
; (animate-posuposind)
; (deanimate "posuposInd")
; (animate "posP")
; (animate "posIndAdd")

; (display "
; _______________

; Comparing posInd with posSuccind .

; posInd:
; ")
; (animate "posInd")
; (display "
; _______________

; posuposInd:
; ")

; (animate "posuposInd")
; (newline)
; (display "_______________

; ")
; (deanimate-posuposind)
; (deanimate "posInd")
; (deanimate "posIndAdd")
; (deanimate "posP")
; )






; (arw "upos◁upos" "False")
; (arw "Upostopos(uposPLUS (Postoupos pos1) (Postoupos pos2))" "pos1+pos2")

; (aga "SmallerposPlusOne"
;      (pf"all pos1,pos2.(pos1<pos2+1)=(¬(pos2<pos1))"))
; (display-global-assumptions "SmallerposPlusOne")
; (aga "LargerposPlusOne"
;      (pf"all pos1,pos2.(pos2+1<pos1)=(pos2<pos1 and (pos1=pos2+1)=False)"))
; (display-global-assumptions "LargerposPlusOne")
; (aga "uposlessS1"
;      (pf "all upos1,upos2.(upos1◁SUCC upos2)=(((upos1◁upos2)=False and (upos1=upos2)=False)=False)"))
; (display-global-assumptions "uposlessS1")
; (aga "uposlessS2"
;      (pf "all upos1,upos2.(upos1◁SUCC upos2)=(((upos1◁upos2)=False and (upos1=upos2)=False)=False)"))
; (display-global-assumptions "uposlessS2")
; (aga "poslessS1"
;      (pf "all pos1,pos2.(pos1<pos2+1)=(((pos1<pos2)=False and (pos1=pos2)=False)=False)"))
; (display-global-assumptions "poslessS1")
; (aga "poslessS2"
;      (pf "all pos1,pos2.(pos1<pos2+1)=(((pos1<pos2)=False and (pos2=pos1)=False)=False)"))
; (display-global-assumptions "poslessS2")
; (aga "n-1+1"
;      (pf"all upos. Unum◁upos -> upos = SUCC(uposP upos)"))
; (display-global-assumptions "n-1+1")






; (display"
; CV-Induction
; A^ One -> (all pos.(all pos1.pos1<pos -> A^pos1) -> A^pos) -> all pos A^pos
; PROOF:
; ")

; (set-goal
;  (pf "A^ One -> (all pos.(all pos1.pos1<pos -> A^pos1) -> A^pos) -> all pos A^pos"))
; (begin
; (assume "A1" "prog" "pos")
; (use (pf "all pos1,pos2.(pos1<pos2)=False -> A^ pos2") (pt"pos"))
; (assume "pos1")
; (cut(pf"all pos.(all pos2.(pos<pos2)=False -> A^pos2) -> all pos2.(pos+1<pos2)=False -> A^pos2"))
; (cut(pf"all pos2.(1<pos2)=False -> A^pos2"))
; (use-with "posuposInd" (make-cterm (pv "pos1") (pf "all pos2.(pos1<pos2)=False -> A^pos2")) (pt "pos1"))

; (cases)
; (auto)
; (assume "pos3")
; (prop)
; (assume "pos3")
; (prop)

; (assume "pos2" "A<2" "pos3")
; (simp "LargerposPlusOne")
; (cases(pt"pos3=pos2+1"))
; (ng #t)
; (assume "2=3+1" "T")
; (simp "2=3+1")
; (use "prog")
; (assume "pos4")
; (simp "SmallerposPlusOne")
; (use "A<2")
; (assume "not3=2+1")
; (use "A<2")
; (auto)
; ; Proof finished.
; )

; (save "posuposCVind")
; (display-theorems "posuposCVind")





; (set-goal
;  (pf "A^ One -> (all pos.(all pos1.pos1<pos -> A^pos1) -> A^pos) -> all pos A^pos"))
; (begin
; (assume "A1" "prog" "pos")
; (use (pf "all pos1,pos2.(pos1<pos2)=False -> A^ pos2") (pt"pos"))
; (assume "pos1")
; (cut(pf"all pos.(all pos2.(pos<pos2)=False -> A^pos2) -> all pos2.(pos+1<pos2)=False -> A^pos2"))
; (cut(pf"all pos2.(1<pos2)=False -> A^pos2"))
; (use-with "posInd" (make-cterm (pv "pos1") (pf "all pos2.(pos1<pos2)=False -> A^pos2")) (pt "pos1"))

; (cases)
; (auto)
; (assume "pos3")
; (prop)
; (assume "pos3")
; (prop)

; (assume "pos2" "A<2" "pos3")
; (simp "LargerposPlusOne")
; (cases(pt"pos3=pos2+1"))
; (ng #t)
; (assume "2=3+1" "T")
; (simp "2=3+1")
; (use "prog")
; (assume "pos4")
; (simp "SmallerposPlusOne")
; (use "A<2")
; (assume "not3=2+1")
; (use "A<2")
; (auto)
; ; Proof finished.
; )

; (save "posCVind")
; (display-theorems "posCVind")




(begin

(add-program-constant
 "PosMult"
 (mk-arrow (py "pos") (py "pos") (py "pos"))
 1 'const 2
)

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

(add-display
 (py "pos")
 (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=? "PosMult"
                        (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))))

(acrs "pos*1"                "pos")
(acrs "pos1 * (SZero pos2)"  "SZero (pos1 * pos2)")
(acrs "pos1 * (SOne pos2)"   "(pos1 * (SZero pos2)) + pos1")

(set! OLD-COMMENT-FLAG COMMENT-FLAG)
(set! COMMENT-FLAG #t)
(display-program-constants "PosMult")

(display"

Test of PosMult:

")

(display "PosMult     3     1         ")
(pp(nt(pt"PosMult     3     1")))
(display "PosMult    42    42      ")
(pp(nt(pt"PosMult    42    42")))
(display "PosMult  1024  1023   ")
(pp(nt(pt"PosMult  1024  1023")))
(set! COMMENT-FLAG OLD-COMMENT-FLAG)

)



(begin

(display "

uposposTwoexp  ₂: upos -> pos

")

(add-program-constant
 "uposposTwoexp"
 (mk-arrow (py "upos") (py "pos"))
 1 'const 1
)

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

(add-display
 (py "pos")
 (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=? "uposposTwoexp"
                        (const-to-name (term-in-const-form-to-const op)))
              (= 1 (length args)))
         (list 'prefix-op "₂" (term-to-token-tree (car args)))
         #f))))

(acrs "₂Unum"         "2")
(acrs "₂(SUCC upos)"  "SZero(₂upos)")

(display-program-constants "uposposTwoexp")

(display"

Test of ₂ :
")

(display "₂Unum             ")
(pp(nt(pt"₂Unum")))

)


(display "

Some RW-rules involving uposposTwoexp  ₂

")

(begin

(sg "1< ₂upos")
(cases)
(auto)
; Proof finished.
(trw "1< ₂upos")


(sg "(SOne pos< ₂upos) = (SZero pos< ₂upos)")
(assume "pos")
(ind)
(auto)
; Proof finished.
(arw "SOne pos< ₂upos" "SZero pos< ₂upos")
)





;;; F O R M U L A E


; neg-form? tests wether a formula
; is a negation of some other

(define(neg-form? formula)
  (and (imp-form? formula)
       (formula=? (imp-form-to-conclusion formula) (make-atomic-formula (pt "F")))))





; Equivalence ⇔

(add-token
 "⇔"
 'and-jct
 (lambda (x y)
   (make-and (make-imp x y) (make-imp y x))))


(define(equiv-form? formula)
  (and (and-form? formula)
       (imp-form? (and-form-to-left  formula))
       (imp-form? (and-form-to-right formula))
       (formula=? (imp-form-to-premise    (and-form-to-left  formula))
		  (imp-form-to-conclusion (and-form-to-right formula)))
       (formula=? (imp-form-to-premise    (and-form-to-right formula))
		  (imp-form-to-conclusion (and-form-to-left formula)))))



; Disjunction |

(av "p" "q" (py "boole"))

(add-token
 "|"
 'or-jct
 (lambda (x y) (make-ex (pv "q") (mk-and (mk-imp (pf "¬q") x) (mk-imp (pf "q") y)))))



(define(or-form? formula)
  (and (ex-form? formula)
       (string=? "boole" (type-to-string(cadr (ex-form? (pf "ex q.q")))))
       (and-form? (ex-form-to-kernel formula))
       (imp-form? (and-form-to-left (ex-form-to-kernel formula)))
       (imp-form? (and-form-to-right (ex-form-to-kernel formula)))
       (formula=? (imp-form-to-premise (and-form-to-left (ex-form-to-kernel formula)))
		  (make-atomic-formula (negboole (make-term-in-var-form(ex-form-to-var formula)))))
       (formula=? (imp-form-to-premise (and-form-to-right (ex-form-to-kernel formula)))
		  (make-atomic-formula (make-term-in-var-form(ex-form-to-var formula))))))




; F O R M U L A - T O - S T R I N G

(define (formula-to-string formula)
  (case (tag formula)
	((atom)
     (let* ((kernel (atom-form-to-kernel formula))
	    (string (term-to-string kernel)))
       (cond ((string=? "True" string) "T")
	     ((string=? "False" string) "F")
	     (else string))))
    ((predicate)
     (predicate-form-to-string formula))
    ((imp)
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula))
	    (string1 (formula-to-string prem))
	    (string2 (formula-to-string concl)))
       (string-append
	(if (or (quant-prime-form? prem) (and-form? prem))
	    string1
	    (string-append "(" string1 ")"))
	" -> " string2)))
    ((and)
     (if (equiv-form? formula)
	 (let*
	     ((lf   (and-form-to-left      formula))
	      (larg (imp-form-to-premise    lf))
	      (rarg (imp-form-to-conclusion lf)))
	   (string-append  "(" (formula-to-string larg) " ⇔ " (formula-to-string rarg) ")" ))
	 (let* ((left (and-form-to-left formula))
		(right (and-form-to-right formula))
		(string1 (formula-to-string left))
		(string2 (formula-to-string right)))
	   (string-append
	    (if (or (quant-prime-form? left) (and-form? left))
		string1
		(string-append "(" string1 ")"))
	    " & "
	    (if (quant-prime-form? right)
		string2
		(string-append "(" string2 ")"))))))
    ((tensor)
     (let* ((left (tensor-form-to-left formula))
	    (right (tensor-form-to-right formula))
	    (string1 (formula-to-string left))
	    (string2 (formula-to-string right)))
       (string-append
	(if (or (quant-prime-form? left) (and-form? left))
	    string1
	    (string-append "(" string1 ")"))
	" ! "
	(if (quant-prime-form? right)
	    string2
	    (string-append "(" string2 ")")))))
    ((all)
     (let ((var (all-form-to-var formula))
	   (kernel (all-form-to-kernel formula)))
       (if (all-form? kernel)
	   (string-append (symbol->string 'all) " " (var-to-string var)
			  ","
			  (let ((string (formula-to-string kernel)))
			    (substring string
				       (string-length "all ")
				       (string-length string))))
	   (string-append (symbol->string 'all) " " (var-to-string var)
			  (if (or (prime-form? kernel) (quant-form? kernel))
			      " " ".")
			  (formula-to-string kernel)))))
    ((ex)
     (if (or-form? formula)
	 (let* 
	     ((form (ex-form-to-kernel formula))
	      (larg (imp-form-to-conclusion (and-form-to-left form)))
	      (rarg (imp-form-to-conclusion (and-form-to-right form))))
	      (string-append  "(" (formula-to-string larg) " | " (formula-to-string rarg) ")" ))
	 (let ((var (ex-form-to-var formula))
		(kernel (ex-form-to-kernel formula)))
	    (if (ex-form? kernel)
		(string-append (symbol->string 'ex) " " (var-to-string var)
			       ","
			       (let ((string (formula-to-string kernel)))
				 (substring string
					    (string-length "ex ")
					    (string-length string))))
		(string-append (symbol->string 'ex) " " (var-to-string var)
			       (if (or (prime-form? kernel) (quant-form? kernel))
				   " " ".")
			       (formula-to-string kernel))))))
    ((allnc)
     (let ((var (allnc-form-to-var formula))
	   (kernel (allnc-form-to-kernel formula)))
       (if (allnc-form? kernel)
	   (string-append (symbol->string 'allnc) " " (var-to-string var)
			  ","
			  (let ((string (formula-to-string kernel)))
			    (substring string
				       (string-length "allnc ")
				       (string-length string))))
	   (string-append (symbol->string 'allnc) " " (var-to-string var)
			  (if (or (prime-form? kernel) (quant-form? kernel))
			      " " ".")
			  (formula-to-string kernel)))))
    ((exnc)
     (let ((var (exnc-form-to-var formula))
	   (kernel (exnc-form-to-kernel formula)))
       (if (exnc-form? kernel)
	   (string-append (symbol->string 'exnc) " " (var-to-string var)
			  ","
			  (let ((string (formula-to-string kernel)))
			    (substring string
				       (string-length "exnc ")
				       (string-length string))))
	   (string-append (symbol->string 'exnc) " " (var-to-string var)
			  (if (or (prime-form? kernel) (quant-form? kernel))
			      " " ".")
			  (formula-to-string kernel)))))
    ((exca)
     (let* ((vars (exca-form-to-vars formula))
	    (kernel (exca-form-to-kernel formula))
	    (comma-string
	     (do ((l (cdr vars) (cdr l))
		  (res (var-to-string (car vars))
		       (string-append res "," (var-to-string (car l)))))
		 ((null? l) res))))
       (string-append (symbol->string 'exca) " " comma-string
		      (if (or (prime-form? kernel) (quant-form? kernel))
			  " " ".")
		      (formula-to-string kernel))))
    ((excl)
     (let* ((vars (excl-form-to-vars formula))
	    (kernel (excl-form-to-kernel formula))
	    (comma-string
	     (do ((l (cdr vars) (cdr l))
		  (res (var-to-string (car vars))
		       (string-append res "," (var-to-string (car l)))))
		 ((null? l) res))))
       (string-append (symbol->string 'excl) " " comma-string
		      (if (or (prime-form? kernel) (quant-form? kernel))
			  " " ".")
		      (formula-to-string kernel))))
    (else (myerror "formula-to-string: formula expected" formula))))




(display"

End of positive.scm

")