; $Id: list.scm 2327 2009-06-30 07:15:42Z schwicht $
(if (not (assoc "nat" ALGEBRAS))
    (myerror "First execute (libload \"nat.scm\")"))

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

(add-param-alg "list" 'prefix-typeop
	       '("Nil" "list")
	       '("Cons" "alpha1=>list=>list"))

; Notice that listrev.scm and list.scm cannot be loaded together.
; Reason: In :0::1::2::3 the ":" is a prefix-op (for listrev.scm), but
; in 3::2::1::0: the ":" is a postfix-op (for list.scm).

; Infix notation allowed (and type parameters omitted) for binary 
; constructors, as follows.  This would also work for prefix notation.
; Example: :: for Cons.  x::y::z: 
; Here : is postfix for z

(add-token
 "::" 'pair-op ;hence right associative
 (lambda (x xs)
   (let ((type (term-to-type x))
	 (listtype (term-to-type xs)))
     (if (and (alg-form? listtype)
	      (string=? "list" (alg-form-to-name listtype))
	      (equal? type (car (alg-form-to-types listtype))))
	 (mk-term-in-app-form
	  (make-term-in-const-form
	   (let* ((constr (constr-name-to-constr "Cons"))
		  (tvars (const-to-tvars constr))
		  (subst (make-substitution tvars (list type))))
	     (const-substitute constr subst #f)))
	  x xs)
	 (myerror "parse error" "types do not fit for" type "::" listtype)))))

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

(add-token
 ":" 'postfix-op
 (lambda (x)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((constr (constr-name-to-constr "Cons"))
	    (tvars (const-to-tvars constr))
	    (subst (make-substitution tvars (list (term-to-type x)))))
       (const-substitute constr subst #f)))
    x
    (make-term-in-const-form
     (let* ((constr (constr-name-to-constr "Nil"))
	    (tvars (const-to-tvars constr))
	    (subst (make-substitution tvars (list (term-to-type x)))))
       (const-substitute constr subst #f))))))

(add-display
 (py "list alpha")
 (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=? "Cons" (const-to-name
				    (term-in-const-form-to-const op)))
		  (= 2 (length args))
		  (term-in-const-form? (cadr args))
		  (string=? "Nil" (const-to-name
				   (term-in-const-form-to-const (cadr args)))))
	     (list 'postfix-op ":" (term-to-token-tree (car args)))
	     #f))
       #f)))

(add-program-constant
 "ListAppend" (py "list alpha=>list alpha=>list alpha") t-deg-zero 'const 1)

(add-token
 ":+:" 'mul-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "ListAppend"))
	    (tvars (const-to-tvars const))
	    (listtype (term-to-type x))
	    (type (car (alg-form-to-types listtype)))
	    (subst (make-substitution tvars (list type))))
       (const-substitute const subst #f)))
    x y)))

(add-display
 (py "list alpha")
 (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=? "ListAppend"
			    (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))
       #f)))

(add-var-name "x" (py "alpha"))
(add-var-name "xs" (py "list alpha"))

(add-computation-rule
 (pt "(ListAppend alpha)(Nil alpha)")
 (pt "[xs]xs"))

(add-computation-rule
 (pt "(ListAppend alpha)(x::xs1)")
 (pt "[xs2](x::xs1 :+:xs2)"))

; "ListAppendTotal"
(set-goal (pf "Total(ListAppend alpha)"))
(use "Total")
(use-with "All-AllPartial" (py "list alpha")
	  (make-cterm (pv "xs^") (pf "Total((ListAppend alpha)xs^)"))
	  "?")
(ind)
; Base
(ng)
(use "Total")
(assume "xs^" "u1")
(use "u1")
; Step
(assume "x" "xs" "IH")
(ng)
(use "Total")
(use-with "All-AllPartial" (py "list alpha")
	  (make-cterm (pv "xs^1") (pf "Total(([xs2]x::xs:+:xs2)xs^1)"))
	  "?")
(assume "xs1")
(ng)
(use (make-proof-in-aconst-form
      (constr-name-to-constr-total-aconst "Cons")))
(use-with
 "AllPartial-All" (py "alpha") (make-cterm (pv "x^") (pf "Total x^"))
 "?" (pt "x"))
(assume "x^" "u1")
(use "u1")
(use-with "Total" (py "list alpha") (py "list alpha")
	  (pt "(ListAppend alpha)xs") 'left "IH" (pt "xs1") "?")
(use-with
 "AllPartial-All" (py "list alpha") (make-cterm (pv "xs^") (pf "Total xs^"))
 "?" (pt "xs1"))
(assume "xs^" "u1")
(use "u1")
; Proof finished.
(save "ListAppendTotal")


; "ListAppendNil"
(set-goal (pf "all xs Equal(xs:+:(Nil alpha))xs"))
(ind)
(use "Eq-Refl")
(assume "x" "xs" "IH")
(ng)
(simp "IH")
(use "Eq-Refl")
; Proof finished.
(save "ListAppendNil")


; "ListAppendNilPartial"
(set-goal (pf "all xs^(STotal xs^ -> Equal(xs^ :+:(Nil alpha))xs^)"))
(ind)
(use "Eq-Refl")
(assume "x^" "xs^" "[STotal]" "IH")
(ng)
(simp "IH")
(use "Eq-Refl")
; Proof finished.
(save "ListAppendNilPartial")

; This is not added as a rewrite rule, because ListAppend is defined
; by recursion over the first argument and expects rules of arity 1.


; We also provide a variant ListAppd of ListAppend (with display ++),
; which allows rewrite rules with two arguments.

(add-program-constant
 "ListAppd" (py "list alpha=>list alpha=>list alpha") t-deg-zero)

(add-token
 "++" 'mul-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "ListAppd"))
	    (tvars (const-to-tvars const))
	    (listtype (term-to-type x))
	    (type (car (alg-form-to-types listtype)))
	    (subst (make-substitution tvars (list type))))
       (const-substitute const subst #f)))
    x y)))

(add-display
 (py "list alpha")
 (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=? "ListAppd"
			    (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))
       #f)))

; (add-var-name "y" (py "alpha"))
; (add-var-name "ys" "zs" (py "list alpha"))

(add-computation-rule (pt "(Nil alpha)++xs2") (pt "xs2"))
(add-computation-rule (pt "(x1::xs1)++xs2") (pt "x1::xs1++xs2"))

; "ListAppdTotal"
(set-goal (pf "Total(ListAppd alpha)"))
(use "Total")
(use-with "All-AllPartial" (py "list alpha")
	  (make-cterm (pv "xs^") (pf "Total((ListAppd alpha)xs^)"))
	  "?")
(ind)

; Base
(use "Total" 'right)
(ng)
(assume "xs^1" "Hyp1")
(use "Hyp1")

; Step
(use "AllPartial-All")
(assume "x^1" "Total x^1" "xs1" "IH")
(use "Total" 'right)
(ng)
(assume "xs^2" "Total xs^2")
(use (make-proof-in-aconst-form
      (constr-name-to-constr-total-aconst "Cons")))
(use  "Total x^1")
(use-with "Total" (py "list alpha") (py "list alpha")
	  (pt "(ListAppd alpha)xs1") 'left "IH" (pt "xs^2") "Total xs^2")
; Proof finished.
(save "ListAppdTotal")


; "ListAppdNil"
(set-goal (pf "all xs Equal(xs++(Nil alpha))xs"))
(ind)
(use "Eq-Refl")
(assume "x" "xs" "IH")
(ng)
(simp "IH")
(use "Eq-Refl")
; Proof finished.
(add-rewrite-rule (pt "xs++(Nil alpha)") (pt "xs"))


; "ListAppdNilPartial"
(set-goal (pf "all xs^(STotal xs^ -> Equal(xs^ ++(Nil alpha))xs^)"))
(ind)
(use "Eq-Refl")
(assume "x^" "xs^" "[STotal]" "IH")
(ng)
(simp "IH")
(use "Eq-Refl")
; Proof finished.
(save "ListAppdNilPartial")


; "ListAppdAssoc"
(set-goal (pf "all xs1,xs2,xs3 Equal(xs1++(xs2++xs3))(xs1++xs2++xs3)"))
(ind)
(assume "xs2" "xs3")
(use "Eq-Refl")
(assume "x1" "xs1" "IH")
(ng)
(assume "xs2" "xs3")
(simp "IH")
(use "Eq-Refl")
; Proof finished.
(save "ListAppdAssoc")

; We could add associativity as a rewrite rule by executing
; (add-rewrite-rule (pt "xs1++(xs2++xs3)") (pt "xs1++xs2++xs3"))

; However, this will block other rewriting rules in long appends.
; Example: consider (pt "s++(L::t++R:)") and (pt "s++(L::t)++R:").
; Both are normal, since rewriting (pt "(L::t)++R:") into (pt
; "L::t++R:") is blocked by the leading s++ and the fact that ++
; associates to the left.

; x: ++xs converts into x::xs.  However, xs1++x2: ++xs2 does not rewrite,
; because ++ associates to the left.  But we can add the corresponding
; rule:

(set-goal (pf "all xs1,x2,xs2 Equal(xs1++x2: ++xs2)(xs1++(x2::xs2))"))
(ind)
(assume "x2" "xs2")
(use "Eq-Refl")
(assume "x" "xs1" "IHxs1" "x2" "xs2")
(ng)
(simp "IHxs1")
(use "Eq-Refl")
; Proof finished.
(add-rewrite-rule (pt "xs1++x2: ++xs2") (pt "xs1++(x2::xs2)"))

; In the other direction this rule would lead to non-termination, if
; we also had associativity as a rewrite rule.  x2: is x2::(Nil par),
; and this again is a redex for associativity.


(add-program-constant "ListLength" (py "list alpha=>nat") t-deg-zero)

(add-token
 "Lh" 'prefix-op 
 (lambda (x) (make-term-in-app-form
	      (make-term-in-const-form
	       (let* ((const (pconst-name-to-pconst "ListLength"))
		      (tvars (const-to-tvars const))
		      (listtype (term-to-type x))
		      (type (car (alg-form-to-types listtype)))
		      (subst (make-substitution tvars (list type))))
		 (const-substitute const subst #f)))
	      x)))

(add-display
 (py "nat")
 (lambda (x)
   (if (term-in-app-form? x)
       (let ((op (term-in-app-form-to-op x)))
	 (if (and (term-in-const-form? op)
		  (string=? "ListLength"
			    (const-to-name (term-in-const-form-to-const op))))
	     (list 'prefix-op "Lh"
		   (term-to-token-tree (term-in-app-form-to-arg x)))
	     #f))
       #f)))

(add-computation-rule (pt "Lh(Nil alpha)") (pt "Zero"))
(add-computation-rule (pt "Lh(x::xs)") (pt "Succ Lh xs"))


; "ListLengthTotal"
(set-goal (pf "Total(ListLength alpha)"))
(use "Total")
(use-with "All-AllPartial" (py "list alpha")
	  (make-cterm (pv "xs^") (pf "Total((ListLength alpha)xs^)"))
	  "?")
(ind)
; Base
(ng)
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
; Step
(assume "x" "xs" "IH")
(ng)
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(ng)
(use (make-proof-in-aconst-form (finalg-to-total-to-e-aconst (py "nat"))))
(use "IH")
; Proof finished.
(save "ListLengthTotal")


; "LhAppend"
(set-goal (pf "all xs1,xs2 Lh(xs1:+:xs2)=Lh xs1+Lh xs2"))
(ind)
(assume "xs2")
(use "Truth-Axiom")
(assume "x" "xs1" "IH")
(use "IH")
; Proof finished.
(save "LhAppend")

(add-rewrite-rule (pt "Lh(xs1:+:xs2)") (pt "Lh xs1+Lh xs2"))


; Now for projection ListProj.  We use the rule (Nil alpha)__n ->
; (Inhab alpha)

(add-program-constant
 "ListProj" (py "nat=>list alpha=>alpha") t-deg-zero 'const 2)

(add-token
 "__" 'mul-op ;hence left associative
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "ListProj"))
	    (tvars (const-to-tvars const))
	    (listtype (term-to-type x))
	    (type (car (alg-form-to-types listtype)))
	    (subst (make-substitution tvars (list type))))
       (const-substitute const subst #f)))
    y x)))

(add-token
 "thof" 'pair-op ;hence right associative
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "ListProj"))
	    (tvars (const-to-tvars const))
	    (listtype (term-to-type y))
	    (type (car (alg-form-to-types listtype)))
	    (subst (make-substitution tvars (list type))))
       (const-substitute const subst #f)))
    x y)))

; Not used (reason: occurrences of "thof" examples/tait)
; (add-display
;  (py "alpha")
;  (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=? "ListProj"
; 			    (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))
;        #f)))

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

(add-computation-rule (pt "nat thof(Nil alpha)") (pt "(Inhab alpha)"))

(add-computation-rule (pt "0 thof(x::xs1)") (pt "x"))
(add-computation-rule (pt "(Succ nat1)thof(x::xs1)") (pt "nat1 thof xs1"))

; (pp (nt (pt "1 thof(0::1::2::3:)")))
; 1
; (pp (nt (pt "5 thof(0::1::2::3:)")))
; (Inhab nat)
; (pp (nt (pt "(0::1::2::3:)__1")))
; 1
; (pp (nt (pt "(0::1::2::3:)__5")))
; (Inhab nat)


; "ListProjTotal"
(set-goal (pf "Total(ListProj alpha)"))
(use "Total")
(use-with "All-AllPartial" (py "nat")
	  (make-cterm (pv "n^") (pf "Total((ListProj alpha)n^)"))
	  "?")
(ind)
; Base
(use "Total" 'right)
(use-with "All-AllPartial" (py "list alpha")
	  (make-cterm (pv "xs^") (pf "Total(0 thof xs^)"))
	  "?")
(ind)

; Base
(ng)
; ?_10: Total(Inhab alpha)
(use "InhabTotal")

; Step
(assume "x" "xs" "IHxs")
(ng)
(use-with
 "AllPartial-All" (py "alpha") (make-cterm (pv "x^") (pf "Total x^"))
 "?" (pt "x"))
(assume "x^" "H1")
(use "H1")


; Step
(assume "n" "IHn")
(use "Total" 'right)
(use-with "All-AllPartial" (py "list alpha")
	  (make-cterm (pv "xs^") (pf "Total(Succ n thof xs^)"))
	  "?")
(ind)

; Base
(ng)
(use "InhabTotal")

; Step
(assume "x" "xs" "IHxs")
(ng)
(use "Total")
(use "IHn")
(use-with
 "AllPartial-All" (py "list alpha") (make-cterm (pv "xs^") (pf "Total xs^"))
 "?" (pt "xs"))
(assume "xs^" "H1")
(use "H1")
; Proof finished.
(save "ListProjTotal")


(add-program-constant
 "ListMap" (py "(alpha1=>alpha2)=>list alpha1=>list alpha2") t-deg-zero)

(add-token
 "map" 'pair-op ;hence right associative
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "ListMap"))
	    (tvars (const-to-tvars const))
	    (listtype (term-to-type y))
	    (type1 (car (alg-form-to-types listtype)))
	    (type2 (arrow-form-to-val-type (term-to-type x)))
	    (subst (make-substitution tvars (list type1 type2))))
       (const-substitute const subst #f)))
    x y)))

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

(add-var-name "phi" (py "alpha1=>alpha2"))

(add-computation-rule (pt "phi map(Nil alpha1)") (pt "(Nil alpha2)"))

(add-var-name "y" (py "alpha1"))
(add-var-name "ys" (py "list alpha1"))
(add-var-name "z" (py "alpha2"))
(add-var-name "zs" (py "list alpha2"))

(add-computation-rule (pt "phi map y::ys") (pt "phi y::phi map ys"))

; (pp (nt (pt "Pred map 2::3::4:")))
; 1::2::3:


; "ListMapTotal"
(set-goal (pf "Total(ListMap alpha1 alpha2)"))
(use "Total")
(use-with "All-AllPartial" (py "alpha1=>alpha2")
	  (make-cterm (pv "phi^") (pf "Total((ListMap alpha1 alpha2)phi^)"))
	  "?")
(assume "phi")
(use "Total" 'right)
(use-with "All-AllPartial" (py "list alpha1")
	  (make-cterm (pv "ys^") (pf "Total(phi map ys^)"))
	  "?")
(ind)

; Base
(ng)
(use-with (make-proof-in-aconst-form
	   (constr-name-to-constr-total-aconst "Nil"))
	  (py "alpha2"))

; Step
(assume "y" "ys" "IH")
(ng)
(use-with (make-proof-in-aconst-form
	   (constr-name-to-constr-total-aconst "Cons"))
	  (py "alpha2") (pt "phi y") (pt "phi map ys") "?"  "IH")
(use-with
 "AllPartial-All" (py "alpha2") (make-cterm (pv "z^") (pf "Total z^"))
 "?" (pt "phi y"))
(assume "z^" "H1")
(use "H1")
; Proof finished.
(save "ListMapTotal")


; "LhMap"
(set-goal (pf "all phi,ys Lh(phi map ys)=Lh ys"))
(assume "phi")
(ind)
(use "Truth-Axiom")
(assume "y" "ys" "IH")
(use "IH")
; Proof finished.
(save "LhMap")


; "LhMapPartial"
(set-goal (pf "all phi^,ys^(STotal ys^ -> Lh(phi^ map ys^)=Lh ys^)"))
(assume "phi^")
(ind)
(use "Truth-Axiom")
(assume "alpha1^" "ys^" "u1" "IH")
(use "IH")
; Proof finished.
(save "LhMapPartial")


; "MapAppend"
(set-goal (pf "all phi,ys2,ys1 
                Equal(phi map ys1:+:ys2)((phi map ys1):+:(phi map ys2))"))
(assume "phi" "ys2")
(ind)
(ng)
(use "Eq-Refl")
(assume "y" "ys" "IH")
(ng)
(simp "IH")
(use "Eq-Refl")
; Proof finished.
(save "MapAppend")


; "MapAppendPartial"
(set-goal
 (pf "all phi^,ys^2,ys^1(
       STotal ys^1 -> 
       Equal(phi^ map ys^1:+:ys^2)((phi^ map ys^1):+:(phi^ map ys^2)))"))
(assume "phi^" "ys^2")
(ind)
(ng)
(use "Eq-Refl")
(assume "y^" "ys^" "u1" "IH")
(ng)
(simp "IH")
(use "Eq-Refl")
; Proof finished.
(save "MapAppendPartial")


; "ListProjMap"
(set-goal
 (pf "all phi^,ys,n(n<Lh ys -> Equal(n thof phi^ map ys)(phi^(n thof ys)))"))
(assume "phi^")
(ind)
(assume "n" "Absurd")
(use "Efq")
(use "Absurd")
(assume "y" "ys" "IH")
(cases)
(assume "Trivial")
(ng)
(use "Eq-Refl")
(assume "n" "n<Lh ys")
(ng)
(use "IH")
(use "n<Lh ys")
; Proof finished.
(save "ListProjMap")


(add-program-constant
 "Consn" (py "nat=>alpha=>list alpha=>list alpha") t-deg-zero)

(add-computation-rule (pt "(Consn alpha)0 x xs") (pt "x::xs"))
(add-computation-rule (pt "(Consn alpha)(Succ n)x(Nil alpha)")
		      (pt "x::(Consn alpha)n x(Nil alpha)"))
(add-computation-rule (pt "(Consn alpha)(Succ n)x(x1::xs)")
		      (pt "x1::(Consn alpha)n x(xs)"))

; (pp (nt (pt "(Consn nat)7 n(0::1::2:)")))
; => 0::1::2::n::n::n::n::n:


; "ConsnTotal"
(set-goal (pf "Total(Consn alpha)"))
(use "Total")
(use "All-AllPartial")
(assume "n")
(use-with "Total" (py "alpha") (py "list alpha=>list alpha")
	  (pt "(Consn alpha)n") 'right "?")

(use "All-AllPartial")
(assume "x")
(use-with "Total" (py "list alpha") (py "list alpha")
	  (pt "(Consn alpha)n x") 'right "?")
(use-with "All-AllPartial" (py "list alpha")
	  (make-cterm (pv "xs^") (pf "Total((Consn alpha)n x xs^)"))
	  "?")
(ind (pt "n"))
; Base
(assume "xs")
(ng)
(use (make-proof-in-aconst-form
      (constr-name-to-constr-total-aconst "Cons")))
(use-with
 "AllPartial-All" (py "alpha") (make-cterm (pv "x^") (pf "Total x^"))
 "?" (pt "x"))
(assume "x^" "u1")
(use "u1")
(use-with
 "AllPartial-All" (py "list alpha") (make-cterm (pv "xs^") (pf "Total xs^"))
 "?" (pt "xs"))
(assume "xs^" "u1")
(use "u1")
; Step
(assume "n1" "IH")
(cases)
; Case Nil
(ng)
(use (make-proof-in-aconst-form
      (constr-name-to-constr-total-aconst "Cons")))
(use-with
 "AllPartial-All" (py "alpha") (make-cterm (pv "x^") (pf "Total x^"))
 "?" (pt "x"))
(assume "x^" "u1")
(use "u1")
(use "IH")
; Case x1::xs
(ng)
(assume "x1" "xs")
(use (make-proof-in-aconst-form
      (constr-name-to-constr-total-aconst "Cons")))
(use-with
 "AllPartial-All" (py "alpha") (make-cterm (pv "x^") (pf "Total x^"))
 "?" (pt "x1"))
(assume "x^" "u1")
(use "u1")
(use "IH")
; Proof finished.
(save "ConsnTotal")

		      
; "LhE"
(set-goal (pf "all xs^(STotal xs^ -> E(Lh xs^))"))
(ind)
(use "Truth-Axiom")
(assume "x^" "xs^" "u1" "IH")
(use "IH")
; Proof finished.
(save "LhE")


; "All-AllPartial-nat"
(set-goal (pf "all n (Pvar nat)n -> 
               all n^(E n^ -> (Pvar nat)n^)"))
(assume "H1" "n^" "H2")
(use-with "All-AllPartial"
	  (py "nat")
	  (make-cterm (pv "n^") (pf "(Pvar nat)n^"))
	  "H1" (pt "n^") "?")
(use (make-proof-in-aconst-form
      (finalg-to-e-to-total-aconst (py "nat"))))
(use "H2")
; Proof finished.
(save "All-AllPartial-nat")


; "LhConsn"
(set-goal
 (pf "all x^1,xs^(
        STotal xs^ -> 
        all n(
         Lh xs^ <=n -> 
         Lh(xs^ :+:(Consn alpha)(n--Lh xs^)x^1(Nil alpha))=Succ n))"))
(assume "x^1")
(ind)
(ind)
(assume "Trivial")
(ng)
(use "Truth-Axiom")
(assume "n" "IHn" "Trivial")
(use "IHn")
(use "Truth-Axiom")
(assume "x^2" "xs^" "u1" "IHl")
(cases)
(assume "Absurd")
(use "Efq")
(use "Absurd")
(assume "n")
(assume "Lh xs^ <=n")
(ng)
(assert (pf "all n1,n^2(E n^2 -> Pred(Succ n1--n^2)=n1--n^2)"))
 (assume "n1")
 (use-with "All-AllPartial-nat"
 	  (make-cterm (pv "n^2") (pf "Pred(Succ n1--n^2)=n1--n^2"))
 	  "?")
 (assume "n2")
 (use "Truth-Axiom")
(assume "H")
(simp "H")
(use "IHl")
(use "Lh xs^ <=n")
(use "LhE")
(use "u1")
; Proof finished.
(save "LhConsn")


; We add a bounded universal quantifier.  AllBList n P means that for
; all lists of length n of booleans the property P holds.

(add-program-constant
 "AllBList" (py "nat=>(list boole=>boole)=>boole") t-deg-zero)

(add-computation-rule (pt "AllBList 0 list boole=>boole")
		      (pt "(list boole=>boole)(Nil boole)"))
(add-computation-rule
 (pt "AllBList(Succ n)list boole=>boole")
 (pt "(AllBList n([list boole]list boole=>boole(True::list boole)))andb
      (AllBList n([list boole]list boole=>boole(False::list boole)))"))


; "AllBListTotal"
(set-goal (pf "Total AllBList"))
(use "Total")
(use "All-AllPartial")
(ind)
; Base
(use "Total" 'right)
(use "All-AllPartial")
(assume "(list boole=>boole)")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "boole"))))
(use "Truth-Axiom")
; Step
(assume "n" "IH")
(use "Total" 'right)
(assume "(list boole=>boole)^" "Tf")
(ng)
(assert (pf "all boole^1(Total boole^1 -> all boole^2(Total boole^2 -> 
                         Total(boole^1 andb boole^2)))"))
  (assume "boole^1" "T1" "boole^2" "T2")
  (use "Total")
  (use "Total")
  (use "AndConstTotal")
  (use "T1")
  (use "T2")
(assume "TA")
(use "TA")
; Case True
(use "Total")
(use "IH")
(use "Total")
(use "All-AllPartial")
(assume "list boole")
(ng)
(use "Total")
(use "Tf")
(use (make-proof-in-aconst-form
      (finalg-to-e-to-total-aconst (py "list boole"))))
(use "Truth-Axiom")
; Case False
(use "Total")
(use "IH")
(use "Total")
(use "All-AllPartial")
(assume "list boole")
(ng)
(use "Total")
(use "Tf")
(use (make-proof-in-aconst-form
      (finalg-to-e-to-total-aconst (py "list boole"))))
(use "Truth-Axiom")
; Proof finished
(save "AllBListTotal")


; "ListLhZero"
(set-goal (pf "all xs^(STotal xs^ -> Lh xs^ =0 -> Equal xs^(Nil alpha))"))
(cases)
(assume "Trivial")
(use "Eq-Refl")
(assume "x^" "xs^" "u1" "IH")
(use "Efq")
(use "IH")
; Proof finished.
(save "ListLhZero")


; "AllBListIntro"
(set-goal
 (pf "all n,(list boole=>boole)(
        all (list boole)^(
         Lh(list boole)^ =n -> (list boole=>boole)(list boole)^) -> 
        AllBList n(list boole=>boole))"))
(ind)
(assume "list boole=>boole")
(ng)
(strip)
(use 1)
(use "Truth-Axiom")
(assume "n" "IH" "list boole=>boole" "H")
(ng)
(split)
(use "IH")
(ng)
(assume "list boole^" "Lh list boole^ =n")
(use "H")
(use "Lh list boole^ =n")
(use "IH")
(ng)
(assume "list boole^" "Lh list boole^ =n")
(use "H")
(use "Lh list boole^ =n")
; Proof finished.
(save "AllBListIntro")


; "AllBListElim"
(set-goal
 (pf "all n,(list boole=>boole)(
        AllBList n(list boole=>boole) -> 
        all (list boole)(
         Lh(list boole)=n -> (list boole=>boole)(list boole)))"))
(ind)
(assume "list boole=>boole" "H1")
(cases)
(assume "Trivial")
(use "H1")
(assume "boole" "list boole" "Absurd")
(use "Efq")
(use "Absurd")
(assume "n" "IH" "list boole=>boole" "H1")
(cases)
(assume "Absurd")
(use "Efq")
(use "Absurd")
(cases)
(assume "list boole")
(use-with "IH" (pt "[list boole1]list boole=>boole(True::list boole1)")
	  "?" (pt "list boole"))
(ng)
(use "H1")
(assume "list boole")
(use-with "IH" (pt "[list boole1]list boole=>boole(False::list boole1)")
	  "?" (pt "list boole"))
(ng)
(use "H1")
; Proof finished.
(save "AllBListElim")

(remove-var-name "x" "xs" "phi" "y" "ys" "z" "zs")
