
; MINLOG: boolean.scm

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

(mload "abbrev.scm")

(display"
Begin of boole.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)

(acr "¬True"  "False")
(acr "¬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"))))))

)





; 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")




; (sg "all boole.[if boole boole1 boole2]=((boole∧boole1)∨(¬boole∧boole2))")
; (assume "boole1" "boole2")
; (cases)
; (auto)
; ; Proof finished.
; (save "ifboole")
; (display-theorems "ifboole")




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


)


(display"
End of boolean.scm

")


; EOF