; $Id: boole.scm 2346 2009-11-13 11:41:47Z schwicht $
; 7. Formulas and comprehension terms
; ===================================

; First we add some tokens (this can only be done after loading
; minitab.scm, which is done immediately before loading the present file)

(add-token "andd" 'and-jct make-andd)
(add-token "andr" 'and-jct make-andr)
(add-token "andu" 'and-jct make-andu)

(add-token "ord" 'or-jct make-ord)
(add-token "orl" 'or-jct make-orl)
(add-token "orr" 'or-jct make-orr)
(add-token "oru" 'or-jct make-oru)

(add-token "eqd" 'pred-infix make-eqd)
(add-idpredconst-display "EqD" 'pred-infix "eqd")

(add-token "exd" 'quantor (lambda (v k) (apply mk-exd (append v (list k)))))
(add-token "exl" 'quantor (lambda (v k) (apply mk-exl (append v (list k)))))
(add-token "exr" 'quantor (lambda (v k) (apply mk-exr (append v (list k)))))
(add-token "exu" 'quantor (lambda (v k) (apply mk-exu (append v (list k)))))


; 7-8. Booleans
; =============

; We need to initialize some global variables (needed for is-used?),
; before we can call add-alg.

(define THEOREMS '())
(define INITIAL-THEOREMS THEOREMS)

(define GLOBAL-ASSUMPTIONS '())
(define INITIAL-GLOBAL-ASSUMPTIONS GLOBAL-ASSUMPTIONS)

(add-alg "unit" '("Dummy" "unit"))
(define dummy-const (constr-name-to-constr "Dummy"))

(add-alg "boole" '("True" "boole") '("False" "boole"))

(add-new-application
 (lambda (type) (equal? type (make-alg "boole")))
 (lambda (test alt1)
   (let* ((type (term-to-type alt1))
	  (var (type-to-new-var type)))
     (make-term-in-abst-form
      var (make-term-in-if-form
	   test (list alt1 (make-term-in-var-form var)))))))

(add-display
 (py "boole")
 (lambda (term)
   (let ((op (term-in-app-form-to-final-op term))
	 (args (term-in-app-form-to-args term)))
     (if (and (term-in-const-form? op)
	      (string=? "=" (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-display
 (py "boole")
 (lambda (term)
   (let ((op (term-in-app-form-to-final-op term))
	 (args (term-in-app-form-to-args term)))
     (if (and (term-in-const-form? op)
	      (string=? "E" (const-to-name (term-in-const-form-to-const op)))
	      (= 1 (length args)))
	 (list 'prefix-op "E" (term-to-token-tree (car args)))
	 #f))))

(define (trueval? val)
  (and (nbe-constr-value? val)
       (string=? "True"
		 (const-to-name (nbe-constr-value-to-constr val)))))

(define true-const (constr-name-to-constr "True"))
(define trueobj (const-to-object-or-arity true-const))
(define truth (make-atomic-formula (make-term-in-const-form true-const)))
(add-token "T" 'const (make-term-in-const-form true-const))

(define (falseval? val)
  (and (nbe-constr-value? val)
       (string=? "False"
		 (const-to-name (nbe-constr-value-to-constr val)))))

(define false-const (constr-name-to-constr "False"))
(define falseobj (const-to-object-or-arity false-const))
(define falsity (make-atomic-formula (make-term-in-const-form false-const)))
(add-token "F" 'const (make-term-in-const-form false-const))

(define (make-negation formula) (make-imp formula falsity))
(add-token "not" 'prefix-jct make-negation)

(define falsity-log
  (make-predicate-formula
   (make-pvar (make-arity) -1 h-deg-zero n-deg-zero "bot")))

; (define falsity-log
;   (make-predicate-formula
;    (make-pvar (make-arity) -1 h-deg-one n-deg-one "bot")))

(define (make-negation-log formula) (make-imp formula falsity-log))
(add-token "notl" 'prefix-jct make-negation-log)

; 2004-12-31 Moved here from pconst.scm.  Reason: =-at and e-at need
; AndConst, which requires the algebra boole.

(define (finalg-to-=-const finalg)
  (if (not (finalg? finalg))
      (myerror "finalg-to-=-const" "finitary algebra expected" finalg)
      (make-const (=-at finalg)
		  "=" 'fixed-rules
		  (mk-arrow finalg finalg (make-alg "boole")) empty-subst
		  1 'rel-op)))

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

(add-computation-rule (pt "AndConst True boole^") (pt "boole^"))
(add-computation-rule (pt "AndConst boole^ True") (pt "boole^"))
(add-computation-rule (pt "AndConst False boole^") (pt "False"))
(add-computation-rule (pt "AndConst boole^ False") (pt "False"))

; We add infix notation "andb" (also "and") (left associative) for AndConst.
; Coq has "/\"

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

(add-token
 "and" 'and-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "AndConst")) 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=? "AndConst"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'and-op "andb"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))

(define and-const (term-in-const-form-to-const (pt "AndConst")))


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

(add-computation-rule (pt "ImpConst False boole^") (pt "True"))
(add-computation-rule (pt "ImpConst True boole^") (pt "boole^"))
(add-computation-rule (pt "ImpConst boole^ True") (pt "True"))

; We add an infix notation "impb" (left associative) for ImpConst

(add-token
 "impb" 'imp-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "ImpConst")) 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=? "ImpConst"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'imp-op "impb"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))
   
(define imp-const (term-in-const-form-to-const (pt "ImpConst")))


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

(add-computation-rule (pt "OrConst True boole^") (pt "True"))
(add-computation-rule (pt "OrConst boole^ True") (pt "True"))
(add-computation-rule (pt "OrConst False boole^") (pt "boole^"))
(add-computation-rule (pt "OrConst boole^ False") (pt "boole^"))

; We add an infix notation "orb" (left associative) for OrConst
; Coq has "\/"

(add-token
 "orb" 'or-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "OrConst")) 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=? "OrConst"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'or-op "orb"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))

(define or-const (term-in-const-form-to-const (pt "OrConst")))


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

(add-computation-rule (pt "NegConst True") (pt "False"))
(add-computation-rule (pt "NegConst False") (pt "True"))

; We add a prefix notation "negb" for NegConst

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

(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=? "NegConst"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 1 (length args)))
	     (list 'prefix-op "negb"
		   (term-to-token-tree (car args)))
	     #f))
       #f)))

(define neg-const (term-in-const-form-to-const (pt "NegConst")))

; In pproof.scm we have
; and-atom-to-left-proof "boole1 andb boole2 -> boole1"
; atoms-to-and-atom-proof "boole1 -> boole2 -> boole1 andb boole2

; In atr.scm we have
; imp-to-atom-proof "(boole1 -> boole2) -> ImpConst boole1 boole2"
; and-to-atom-proof "boole1 & boole2 -> boole1 and boole2"
; atom-to-imp-proof "ImpConst boole1 boole2 -> boole1 -> boole2
; atom-to-and-proof "boole1 and boole2 -> boole1 & boole2"
; qf-to-atom-imp-qf-proof: atom(r_C) -> C
; qf-to-qf-imp-atom-proof: C -> atom(r_C)


(define (=-at finalg)
  (nbe-make-object
   (mk-arrow finalg finalg (make-alg "boole"))
   (lambda (obj1)
     (nbe-make-object
      (mk-arrow finalg (make-alg "boole"))
      (lambda (obj2)
	(let* ((val1 (nbe-object-to-value obj1))
	       (val2 (nbe-object-to-value obj2))
	       (constr1? (nbe-constr-value? val1))
	       (constr2? (nbe-constr-value? val2))
	       (reprod-obj (nbe-make-object
			    (make-alg "boole")
			    (nbe-make-termfam
			     (make-alg "boole")
			     (lambda (k)
			       (mk-term-in-app-form
				(make-term-in-const-form
				 (finalg-to-=-const finalg))
				(nbe-fam-apply (nbe-reify obj1) k)
				(nbe-fam-apply (nbe-reify obj2) k)))))))
	  (cond
	   ((and constr1? constr2?)
	    (let ((name1 (nbe-constr-value-to-name val1))
		  (name2 (nbe-constr-value-to-name val2)))
	      (if
	       (not (string=? name1 name2))
	       falseobj
	       (let* ((args1 (nbe-constr-value-to-args val1))
		      (args2 (nbe-constr-value-to-args val2))
		      (argtypes1 (map nbe-object-to-type args1))
		      (argtypes2 (map nbe-object-to-type args2))
		      (argtypes
		       (if (equal? argtypes1 argtypes2)
			   argtypes1
			   (myerror "=-at" "equal argtypes expected"
				    (map type-to-string argtypes1)
				    (map type-to-string argtypes2))))
		      (prevs
		       (do ((l1 args1 (cdr l1))
			    (l2 args2 (cdr l2))
			    (ltypes argtypes (cdr ltypes))
			    (res
			     '()
			     (let* ((arg1 (car l1))
				    (arg2 (car l2))
				    (type (car ltypes))
				    (prev
				     (case (tag type)
				       ((alg)
					(nbe-object-app (=-at type)
							arg1 arg2))
				       ((arrow) ;unit -> finalg
					(nbe-object-app
					 (=-at (arrow-form-to-val-type type))
					 (nbe-object-app
					  arg1
					  (const-to-object-or-arity
					   dummy-const))
					 (nbe-object-app
					  arg2
					  (const-to-object-or-arity
					   dummy-const))))
				       (else (myerror "=-at" "type expected"
						      type)))))
			       (let ((prevval (nbe-object-to-value prev)))
				 (cond
				  ((trueval? prevval) res)
				  ((falseval? prevval) (cons 'f res))
				  (else (cons prev res)))))))
			   ((or (memq 'f res) (null? l1)) res))))
		 (cond
		  ((null? prevs)
		   trueobj)
		  ((memq 'f prevs)
		   falseobj)
		  (else
		   (do ((l (cdr prevs) (cdr l))
			(obj
			 (car prevs)
			 (nbe-make-object
			  (make-alg "boole")
			  (nbe-make-termfam
			   (make-alg "boole")
			   (lambda (k)
			     (mk-term-in-app-form
			      (make-term-in-const-form
			       (pconst-name-to-pconst "AndConst"))
			      (nbe-fam-apply (nbe-reify (car l)) k)
			      (nbe-fam-apply (nbe-reify obj) k)))))))
		       ((null? l) obj))))))))
	   ((or constr1? constr2?)
	    (let* ((constr-obj (if constr1? obj1 obj2))
		   (constr-val (if constr1? val1 val2))
		   (obj (if constr1? obj2 obj1)))
	      (do ((l (nbe-constr-value-to-args constr-val) (cdr l)))
		  ((or (null? l)
		       (let* ((arg (car l))
			      (argalg (nbe-object-to-type arg))
			      (prev (nbe-object-app (in-at finalg argalg)
						    obj arg))
			      (prevval (nbe-object-to-value prev)))
			 (trueval? prevval)))
		   (if (null? l)
		       reprod-obj
		       falseobj)))))
	   ((and (nbe-fam-value? val1) (nbe-fam-value? val2))
	    (let ((term1 (nbe-extract val1))
		  (term2 (nbe-extract val2)))
	      (if (and (term=? term1 term2)
		       (synt-total? term1) (synt-total? term2))
		  trueobj
		  reprod-obj)))
	   (else reprod-obj))))))))

(define (in-at finalg1 finalg2)
  (nbe-make-object
   (mk-arrow finalg1 finalg2 (make-alg "boole"))
   (lambda (obj1)
     (nbe-make-object
      (mk-arrow finalg2 (make-alg "boole"))
      (lambda (obj2)
	(let ((val1 (nbe-object-to-value obj1))
	      (val2 (nbe-object-to-value obj2)))
	  (cond
	   ((and (equal? finalg1 finalg2)
		 (trueval? (nbe-object-to-value
			    (nbe-object-app (=-at finalg1) obj1 obj2))))
	    trueobj)
	   ((nbe-constr-value? val2)
	    (do ((l (nbe-constr-value-to-args val2) (cdr l)))
		((or (null? l)
		     (let* ((arg (car l))
			    (argtype (nbe-object-to-type arg))
			    (prev (nbe-object-app (in-at finalg1 argtype)
						  obj1 arg))
			    (prevval (nbe-object-to-value prev)))
		       (trueval? prevval)))
		 (if (null? l)
		     falseobj
		     trueobj))))
	   (else falseobj))))))))

(define (finalg-to-e-const finalg)
  (if (not (finalg? finalg))
      (myerror "finalg-to-e-const" "finitary algebra expected" finalg)
      (make-const (e-at finalg)
		  "E" 'fixed-rules
		  (make-arrow finalg (make-alg "boole")) empty-subst
		  1 'prefix-op)))

(define (e-at finalg)
  (nbe-make-object
   (make-arrow finalg (make-alg "boole"))
   (lambda (obj)
     (let ((val (nbe-object-to-value obj))
	   (reprod-obj (nbe-make-object
			(make-alg "boole")
			(nbe-make-termfam
			 (make-alg "boole")
			 (lambda (k)
			   (mk-term-in-app-form
			    (make-term-in-const-form
			     (finalg-to-e-const finalg))
			    (nbe-fam-apply (nbe-reify obj) k)))))))
       (cond
	((nbe-constr-value? val)
	 (let* ((args (nbe-constr-value-to-args val))
		(argtypes (map nbe-object-to-type args))
		(prevs
		 (do ((l args (cdr l))
		      (ltypes argtypes (cdr ltypes))
		      (res
		       '()
		       (let* ((arg (car l))
			      (type (car ltypes))
			      (prev (nbe-object-app (e-at type) arg)))
			 (if (trueval? (nbe-object-to-value prev))
			     res
			     (cons prev res)))))
		     ((null? l) res))))
	   (if (null? prevs)
	       trueobj
	       (do ((l (cdr prevs) (cdr l))
		    (obj
		     (car prevs)
		     (nbe-make-object
		      (make-alg "boole")
		      (nbe-make-termfam
		       (make-alg "boole")
		       (lambda (k)
			 (mk-term-in-app-form
			  (make-term-in-const-form
			   (pconst-name-to-pconst "AndConst"))
			  (nbe-fam-apply (nbe-reify (car l)) k)
			  (nbe-fam-apply (nbe-reify obj) k)))))))
		   ((null? l) obj)))))
	((and (nbe-fam-value? val) (synt-total? (nbe-extract val)))
	 trueobj)
	(else reprod-obj))))))

(define (sfinalg-to-se-const sfinalg)
  (if (not (sfinalg? sfinalg))
      (myerror "sfinalg-to-se-const"
	       "structure finitary algebra expected"
	       sfinalg)
      (make-const (se-at sfinalg)
		  "SE" 'fixed-rules
		  (make-arrow sfinalg (make-alg "boole")) empty-subst
		  1 'prefix-op)))

(define (se-at sfinalg)
  (nbe-make-object
   (make-arrow sfinalg (make-alg "boole"))
   (lambda (obj)
     (let ((val (nbe-object-to-value obj)))
       (cond
        ((nbe-constr-value? val)
         (let* ((alg-name (alg-form-to-name sfinalg))
                (alg-names (alg-name-to-simalg-names alg-name))
                (args (nbe-constr-value-to-args val))
                (argtypes (map nbe-object-to-type args))
                (prevs
                 (do ((l args (cdr l))
                      (ltypes argtypes (cdr ltypes))
                      (res
                       '()
                       (let* ((arg (car l))
                              (type (car ltypes))
                              (prev
                               (if (and (alg-form? type)
                                        (member (alg-form-to-name type)
                                                alg-names))
                                   (nbe-object-app (se-at type) arg)
                                   '())))
                         (if (or (null? prev)
                                 (trueval? (nbe-object-to-value prev)))
                             res
                             (cons prev res)))))
                     ((null? l) res))))
           (if (null? prevs)
               trueobj
               (do ((l (cdr prevs) (cdr l))
                    (obj
                     (car prevs)
                     (nbe-make-object
                      (make-alg "boole")
                      (nbe-make-termfam
                       (make-alg "boole")
                       (lambda (k)
                         (mk-term-in-app-form
                          (make-term-in-const-form
                           (pconst-name-to-const "AndConst"))
                          (nbe-fam-apply (nbe-reify (car l)) k)
                          (nbe-fam-apply (nbe-reify obj) k)))))))
                   ((null? l) obj)))))
        ((and (nbe-fam-value? val) (synt-total? (nbe-extract val)))
	 trueobj)
        ((nbe-fam-value? val) ;reproduce
         (nbe-make-object
          (make-alg "boole")
          (nbe-make-termfam
           (make-alg "boole")
           (lambda (k)
             (mk-term-in-app-form
              (make-term-in-const-form
               (sfinalg-to-se-const sfinalg))
              (nbe-fam-apply (nbe-reify obj) k))))))
        (else (myerror "se-at" "value expected" val)))))))

; The pconst "Inhab" is a constscheme providing a canonical inhabitant
; of an arbitrary type alpha.  It can be given a concrete value.
; Example: (add-computation-rule (pt "(Inhab boole)") (pt "False"))

; (Inhab alpha) considered as total.  Reason: since every algebra is
; required to have nullary constructors, every (closed) type rho can
; be given a total canonical inhabitant.

(add-program-constant "Inhab" (py "alpha") t-deg-one)


