; Copyright (C) 1995 by Ken Kunen.  All Rights Reserved.

; This script is hereby placed in the public domain, and therefore unlimited
; editing and redistribution is permitted.

; NO WARRANTY

; Ken Kunen PROVIDES ABSOLUTELY NO WARRANTY.  THE EVENT SCRIPT IS PROVIDED "AS
; IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, BUT
; NOT LIMITED TO, ANY IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
; SCRIPT IS WITH YOU.  SHOULD THE SCRIPT PROVE DEFECTIVE, YOU ASSUME THE COST OF
; ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

; IN NO EVENT WILL Ken Kunen BE LIABLE TO YOU FOR ANY DAMAGES, ANY LOST
; PROFITS, LOST MONIES, OR OTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES
; ARISING OUT OF THE USE OR INABILITY TO USE THIS SCRIPT (INCLUDING BUT NOT
; LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED
; BY THIRD PARTIES), EVEN IF YOU HAVE ADVISED US OF THE POSSIBILITY OF SUCH
; DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY.


; This is a proof of the Paris-Harrington Ramsey theorem, 
; and some related results.
; The proof is described in our paper, "A Ramsey Theorem
; in Boyer-Moore Logic".

; The following takes [ 79.1 1561.9 92.8 ]  on a DECstation 5000/125
; it takes [ 11.9 197.5 15.0 ] on a Pentium 133 running linux

(proveall "ramsey" '(


(boot-strap nqthm)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                        BASIC ARITHMETIC                                ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


; (expt m n ) = m^n, as in Lisp
(defn expt (m n) (if (zerop n) 
	1
	(times m (expt m (sub1 n))) ) )

(prove-lemma distributivity (rewrite) (equal
	(plus (times u y) (times a y))
	(times (plus u a) y)))

(prove-lemma associativity-of-times (rewrite) (equal
	(times m u y) (times (times m u) y)))

(prove-lemma addition-of-exponents (rewrite) (equal
	(expt m (plus a b))
	(times (expt m a) (expt m b)))) 

; consider the exponenial b^e -- it's monotonic as a function
; of b and of e separately

; as a function of b
(prove-lemma monoton-of-exp-1 () (implies
	(leq b1 b2) 
	(leq (expt b1 e) (expt b2 e))))

(prove-lemma plus-difference (rewrite) (implies 
	(and (leq e1 e2)  (numberp e1) (numberp e2) )
	(equal
		(plus e1 (difference e2 e1))
		e2 )))
	
; as a function of e:  
(prove-lemma monoton-of-exp-aux1 () (implies
	(and (leq e1 e2)  (numberp e1) (numberp e2) )
	(equal (expt b e2) (times (expt b e1) (expt b (difference e2 e1)))))
( ; hints
(do-not-induct T)
(use (addition-of-exponents (m b) (a e1) (b (difference e2 e1))))
(disable addition-of-exponents)
))

(prove-lemma expt-is-positive (rewrite) (implies
	(not (zerop b))
	(lessp 0 (expt b e)) ))

(prove-lemma monoton-of-exp-aux2 ()  (implies
	(not (zerop b))
	(leq x (times x (expt b e)))))

(prove-lemma monoton-of-exp-2 () (implies
	(and (leq e1 e2)  (numberp e1) (numberp e2) (not (zerop b)))
	(leq (expt b e1) (expt b e2)))  
( ; hints
(do-not-induct T)
(use 
	(monoton-of-exp-aux1 (b b) (e1 e1) (e2 e2))   
	(monoton-of-exp-aux2 (b b) (x (expt b e1)) (e (difference e2 e1)))   ) 
))
; 0 is an exception because 0^0 = 1 but 0^1 = 0

(disable monoton-of-exp-aux1)
(disable monoton-of-exp-aux2)

; (magic s) is the function g(s) which "magically" makes the
; Ramsey proof work out.  Here we just prove some basic arithmetic properties
; of it

(defn magic (s) (times
	(plus (times 3 s) 3)
	(expt (plus s 2) (plus s 2))))

(prove-lemma magic-is-a-number (rewrite)
	(numberp (magic n)))

; now, we have to prove that magic is monotonic

(prove-lemma magic-is-monotonic-aux1 ( ) (implies
	(lessp m n)
	(lessp  (plus (times 3 m) 3)  (plus (times 3 n) 3)  )))

(prove-lemma magic-is-monotonic-aux2 ( ) (implies
	(lessp m n)
	(leq
		(expt (plus m 2) (plus m 2))
		(expt (plus n 2) (plus n 2)))  )
( ; hints
(do-not-induct T)
(use
	(monoton-of-exp-1  (e (plus m 2)) (b1 (plus m 2)) (b2 (plus n 2)))
	(monoton-of-exp-2  (b (plus n 2)) (e1 (plus m 2)) (e2 (plus n 2)))  )
))

(prove-lemma magic-is-monotonic-aux3 (rewrite) 
	(lessp 0 (expt (plus s 2) (plus s 2)))
( ; hints
(do-not-induct T)
(use
	(expt-is-positive (b (plus s 2)) (e (plus s 2)) ))
))

(prove-lemma magic-is-monotonic-aux4 ()  (implies
	(and  (lessp x y) (leq a b) (lessp 0 a) (lessp 0 b))
	(lessp (times x a) (times y b))))

(prove-lemma magic-is-monotonic (rewrite) (implies
	(lessp m n)
	(lessp (magic m) (magic n)))
( ; hints
(do-not-induct T)
(use
	(magic-is-monotonic-aux4
		(x (plus (times 3 m) 3)) (y (plus (times 3 n) 3))
		(a (expt (plus m 2) (plus m 2))) (b (expt (plus n 2) (plus n 2))) )
	(magic-is-monotonic-aux3 (s m))
	(magic-is-monotonic-aux3 (s n))
	(magic-is-monotonic-aux1 (m m) (n n))
	(magic-is-monotonic-aux2 (m m) (n n))  )
(disable times addition-of-exponents magic-is-monotonic-aux3)
))


(disable magic-is-monotonic-aux1)
(disable magic-is-monotonic-aux2)
(disable magic-is-monotonic-aux3)
(disable magic-is-monotonic-aux4)

(disable magic)
; we need that (magic n) >= n ; this should follow just by monotonicity

(prove-lemma magic-is-bigger-aux1 (rewrite) 
        (IMPLIES (AND (NOT (EQUAL N 0))
                      (EQUAL (MAGIC N) 0))
                 (NOT (NUMBERP N)))
( ; hints
(use (magic-is-monotonic (m 0) (n n)))
))

(prove-lemma magic-is-bigger-aux2 (rewrite)
(IMPLIES 
	(AND 
		(NUMBERP N)
		(NOT (LESSP (MAGIC (SUB1 N)) (SUB1 N)))  )
	(NOT (LESSP (MAGIC N) N)))
( ; hints
(use (magic-is-monotonic (m (sub1 n)) (n n)))
))

(prove-lemma magic-is-bigger (rewrite) (implies
	(numberp n)
	(not (lessp (magic n) n)))  )

(disable magic-is-bigger-aux1)
(disable magic-is-bigger-aux2)

; the above is sufficient for all the basic theory of {alpha}(n)
; and alpha-large sets.
; BUT, we need some further arithmetic properties of magic which
; get used in the Ramsey theorem

; first, let's prove that * is monotonic; + will be handled
; by built-in linear arithmetic

(prove-lemma times-is-monotonic ()  (implies
	(and  (leq x y) (leq a b))
	(leq (times x a) (times y b))))

(prove-lemma times-right-ident (rewrite) (implies
	(numberp x) (equal (times x 1) x)))
(prove-lemma times-left-ident (rewrite) (implies
	(numberp x) (equal (times 1 x) x)))

; now, just a chain of uninteresting inequalities culminating
; in exactly what we need about magic(s)
; call these magic-1, magic-2, ...
; they won't be rewrite rules, so we don't need to disable them later

(enable magic)  ; we need its defn for some other properties

(prove-lemma magic-1 () (leq
	(plus (times 2 s) 3)
	(magic s) )
( ; hints
(do-not-induct T)
(use 
	(expt-is-positive (b (plus s 2)) (e (plus s 2)))
	(times-is-monotonic 
		(x (plus (times 2 s) 3)) (a 1)
		(y (plus (times 3 s) 3)) (b (expt (plus s 2) (plus s 2))) ) )
(disable addition-of-exponents times)
))

(prove-lemma magic-2 () (implies
	(numberp s)
	(leq     (expt s s)     (expt (plus s 2) (plus s 2))) )
( ; hints
(do-not-induct T)
(use 
	(monoton-of-exp-1 (e s) (b1 s) (b2 (plus s 2)))
	(monoton-of-exp-2 (e1 s) (e2 (plus s 2)) (b (plus s 2))) )
))

(prove-lemma magic-3 () (implies
	(numberp r)
	(leq  
		(times (times 3 r) (expt r r))
		(magic r)) )
( ; hints
(do-not-induct T)
(use
	(magic-2 (s r))
	(times-is-monotonic 
		(x (times 3 r)) (a (expt r r))
		(y (plus (times 3 r) 3) )  (b (expt (plus r 2) (plus r 2)) )) )
(disable addition-of-exponents times)
))

(prove-lemma magic-4 () (implies
	(numberp s)
	(leq     (expt 2 s)     (expt (plus s 2) (plus s 2))) )
( ; hints
(do-not-induct T)
(use 
	(monoton-of-exp-1 (e s) (b1 2) (b2 (plus s 2)))
	(monoton-of-exp-2 (e1 s) (e2 (plus s 2)) (b (plus s 2))) )
))

(prove-lemma magic-5 () (implies
	(numberp s)
	(leq  
		(expt 2 s)
		(magic s)) )
( ; hints
(do-not-induct T)
(use
	(magic-4 (s s))
	(times-is-monotonic 
		(x 1) (a (expt 2 s))
		(y (plus (times 3 s) 3) )  (b (expt (plus s 2) (plus s 2)) )) )
(disable addition-of-exponents times)
))

(prove-lemma magic-6 () (implies
	(numberp s)
	(leq  
		(expt s (expt 2 s))
		(expt (magic s) (magic s)) ) )
( ; hints
(do-not-induct T)
(use
	(magic-5 (s s))
	(magic-is-bigger (n n))
	(monoton-of-exp-1 (b1 s) (b2 (magic s)) (e (expt 2 s)))
	(monoton-of-exp-2 (b (magic s)) (e1 (expt 2 s)) (e2 (magic s))) )
(disable magic addition-of-exponents times)
(hands-off magic)
))

(prove-lemma magic-7 () (implies
	(numberp s)
	(leq  
		(times (times 3 (magic s)) (expt s (expt 2 s)) )
		(times (times 3 (magic s)) (expt (magic s) (magic s)) ) ) )
( ; hints
(do-not-induct T)
(use
	(magic-6 (s s))
	(times-is-monotonic
		(x (times 3 (magic s))) (a (expt s (expt 2 s)) )
		(y (times 3 (magic s))) (b (expt (magic s) (magic s)))) )
(disable magic addition-of-exponents times)
(hands-off magic)
))

(prove-lemma magic-8 () (implies
	(numberp s)
	(leq  
		(times (times 3 (magic s)) (expt s (expt 2 s)) )
		(magic (magic s))) )
( ; hints
(do-not-induct T)
(use
	(magic-7 (s s))
	(magic-3 (r (magic s))))
(disable magic addition-of-exponents times)
(hands-off magic)
))

(prove-lemma magic-9 () 
	(leq  
		(plus (times 2 s) 3 (times 2 (magic s)))
		(times 3 (magic s)) )
( ; hints
(do-not-induct T)
(use (magic-1 (s s)))
(disable magic addition-of-exponents times)
(hands-off magic)
))

(prove-lemma magic-10 () 
	(implies
		(numberp s)
		(leq  
			(times  
				(plus (times 2 s) 3 (times 2 (magic s)))
				(expt s (expt 2 s)) )
			(magic (magic s))) ) 
( ; hints
(do-not-induct T)
(use 
	(times-is-monotonic
		(x (plus (times 2 s) 3 (times 2 (magic s)))) (y (times 3 (magic s)))
		(a (expt s (expt 2 s))) (b (expt s (expt 2 s)))  )
	(magic-8 (s s))
	(magic-9 (s s)))
(disable magic addition-of-exponents times)
(hands-off magic)
))

; now, let's throw in some more parameters.  We have
; a = the norm of some ordinal;
; d = a + c ; s = z + d, q >= magic(z + d), c > 0
; we want to conclude
;(leq 
;	(times 
;		(plus (times 2 a) (times 2 (magic z)) 3 c)
;		(expt c (expt 2 z)) )
;	(magic q) )
; 1. show (leq   (plus (times 2 a) (times 2 (magic z)) 3 c)
;                (plus (times 2 s) 3 (times 2 (magic s))))
; 2. show (leq (expt c (expt 2 z)) (expt s (expt 2 s)))
; then apply magic-10

; step 1

(prove-lemma magic-11 () (implies
	(and (equal d (plus a c)) (equal s (plus z d)) (not (zerop c)) )
	(leq
		(plus (times 2 a) (times 2 (magic z)) 3 c)
		(plus (times 2 s) 3 (times 2 (magic s))))  )
( ; hints
(do-not-induct T)
(use (magic-is-monotonic (m z) (n (plus z a c))))
(disable magic magic-is-monotonic)
))

; step 2

(prove-lemma magic-12 () (implies
	(and (equal d (plus a c)) (equal s (plus z d)) )
	(leq  (expt 2 z) (expt 2 s)))
( ; hints
(do-not-induct T)
(use
	(monoton-of-exp-2 (b 2) (e1 z) (e2 s)) )
(disable addition-of-exponents associativity-of-times)
))

(prove-lemma magic-13 () (implies
	(and (equal d (plus a c)) (equal s (plus z d)) )
	(leq  (expt c (expt 2 z)) (expt s (expt 2 s))))
( ; hints
(do-not-induct T)
(use
	(magic-12 (d d) (a a) (c c) (s s) (z z))
	(monoton-of-exp-1 (b1 c) (b2 s) (e (expt 2 z)))
	(monoton-of-exp-2 (b s) (e1 (expt 2 z)) (e2 (expt 2 s)))  )
(disable addition-of-exponents associativity-of-times)
))

; putting the two steps together:
(prove-lemma magic-14 () (implies
	(and (equal d (plus a c)) (equal s (plus z d)) (not (zerop c)) )
	(leq
		(times
			(plus (times 2 a) (times 2 (magic z)) 3 c)
			(expt c (expt 2 z)))
		(times
			(plus (times 2 s) 3 (times 2 (magic s)))
			(expt s (expt 2 s))   ) ) )
( ; hints
(do-not-induct T)
(use
	(magic-11 (d d) (a a) (c c) (s s) (z z))
	(magic-13 (d d) (a a) (c c) (s s) (z z))
	(times-is-monotonic
		(x (plus (times 2 a) (times 2 (magic z)) 3 c))
		(y (plus (times 2 s) 3 (times 2 (magic s))))
		(a (expt c (expt 2 z)))
		(b (expt s (expt 2 s))) )  )
(disable addition-of-exponents associativity-of-times magic times)
))

; now, adding magic-10
(prove-lemma magic-15 () (implies
	(and (equal d (plus a c)) (equal s (plus z d)) (not (zerop c)) )
	(leq
		(times
			(plus (times 2 a) (times 2 (magic z)) 3 c)
			(expt c (expt 2 z)))
		(magic (magic s)))  )
( ; hints
(do-not-induct T)
(use
	(magic-14 (d d) (a a) (c c) (s s) (z z))
	(magic-10 (s s)) )
(disable addition-of-exponents associativity-of-times magic times)
))

; now, the final result doesn't mention s at all -- rather,
; it's in terms of q >= magic(z + d)  (where s is z+d)

; first, isolate the monotnicity of magic
(prove-lemma magic-16-aux1 (rewrite) (implies
	(not (numberp v))
	(equal (times w v) 0)))

(prove-lemma magic-16 () (implies
	(not (numberp v))
	(equal (magic v) 12)))
(disable magic-16-aux1)

(prove-lemma magic-17 () (implies
	(leq v w)
	(leq (magic v) (magic w)))
( ;  hints
(do-not-induct T)
(use
	(magic-is-monotonic (m v) (n w) )
	(magic-16 (v w))
	(magic-16 (v v)))
(disable magic)
))

(prove-lemma magic-18 () (implies
	(and (equal d (plus a c)) (leq (magic (plus z d)) q) (not (zerop c)) )
	(leq
		(times
			(plus (times 2 a) (times 2 (magic z)) 3 c)
			(expt c (expt 2 z)))
		(magic q))  )
( ; hints
(do-not-induct T)
(use
	(magic-17 (v (magic (plus z d))) (w q))
	(magic-15 (d d) (a a) (c c) (s (plus z d)) (z z))  )
(disable addition-of-exponents associativity-of-times magic times)
))

; this concludes all the arithmetic facts about magic that we need

(disable magic)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                      PROPERTIES OF LISTS                               ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


; append is build-in, but the following simple lemmas aren't

(prove-lemma append-works-left (rewrite) (implies
	(member x lst1)
	(member x (append lst1 lst2))))

(prove-lemma append-works-right (rewrite) (implies
	(member y lst2)
	(member y (append lst1 lst2))))

(defn length (set) (if (listp set)
	(add1 (length (cdr set)))
	0 ))

(prove-lemma length-of-append (rewrite) (equal
	(length (append lst1 lst2))
	(plus (length lst1) (length lst2)) ))


;;;;;;;;;;  product of two lists

(defn cons-all (item lst) (if (listp lst)
	(cons (cons item (car lst)) (cons-all item (cdr lst)))
	nil ))

(defn product (lst1 lst2) (if (nlistp lst1)
	nil
	(append (cons-all (car lst1) lst2) (product (cdr lst1) lst2) ) ))
; (product '(1 2) '(3 4 5) ) -->
; ((1 . 3) (1 . 4) (1 . 5) (2 . 3) (2 . 4) (2 . 5))

; we need to prove this contains all pairs
; first, for cons-all

(prove-lemma all-pairs-in-cons-all (rewrite) (implies
	(member y lst)
	(member (cons item y) (cons-all item lst)) ))

(prove-lemma all-pairs (rewrite) (implies
	(and (member x lst1) (member y lst2))
	(member (cons x y) (product lst1 lst2))))

; We never need the other direction -- that the product
; contains only such pairs

(disable product)


; there are two notions of "sublist" for lists
; 1: (subsetp s1 s2) means that every member of s1 is a member of s2
; 2: (sublistp lst1 lst2) means that lst1 is a consecutive 
;     sublist of lst2 -- so, a list of length n always
;     has exactly 2^n sublists.
; For our intended representation of sets as increasing
; lists of natural numbers, (1) and (2) are equivalent.
; In general, (2) implies (1).
; in both cases, for non-nil-terminated lists -- e.g.
; (A1 A2 A3 . B), we ignore the B

(defn subsetp (s1 s2) 
	(if (listp s1)
		(and
			(member (car s1) s2)
			(subsetp (cdr s1) s2))
		T )) 

; there are two fundamental properties of subsetp 
; 1. If (subsetp s1 s2) and (member x s1) then (member x s2)
; 2. If (not (subsetp s1 s2)), then there is an x such
;    that (member x s1) and (not (member x s2))
;    Call this object (memb-of-dif s1 s2)

(prove-lemma subsetp-works-1 (rewrite) (implies
	(and (subsetp s1 s2) and (member x s1))
	(member x s2)))

(defn memb-of-dif (s1 s2)
	(if (listp s1)
		(if (member (car s1) s2)
			(memb-of-dif (cdr s1) s2)
			(car s1))
		NIL ))

(prove-lemma subsetp-works-2 (rewrite) (implies
	(not (subsetp s1 s2))
	(and
		(member (memb-of-dif s1 s2) s1) 
		(not (member (memb-of-dif s1 s2) s2)) ) ))

(disable memb-of-dif)
; It's really just a Skolem function for (not (subsetp s1 s2))
; We should never need its definition

; the following facts may also be useful:

(prove-lemma subset-of-empty-set (rewrite) (implies
	(listp s) (not (subsetp s nil))))

(prove-lemma transitivity-of-subset (rewrite) (implies
	(and (subsetp s1 s2) (subsetp s2 s3))
	(subsetp s1 s3)))

(prove-lemma cdr-is-subset-aux1 (rewrite)  (implies
	(member x (cdr s))
	(member x s)))

(prove-lemma cdr-is-subset (rewrite) 
	(subsetp (cdr s) s)  
; hints
( (use (subsetp-works-2 (s1 (cdr s)) (s2 s)))  ))

(disable cdr-is-subset-aux1)

(prove-lemma cdr-of-subset (rewrite) (implies
	(and (subsetp s1 s2) (listp s1))
	(subsetp (cdr s1) s2)))

(prove-lemma nil-is-subset (rewrite)
	(subsetp nil s))

; the following might useful in proving consequences
; of (subsetp s1 s2) by induction -- reducing to
; (subsetp s1 (cdr s2))
(prove-lemma subset-of-cdr (rewrite) (implies
	(and (subsetp s1 s2) (not (member (car s2) s1)))
	(subsetp s1 (cdr s2))))

(prove-lemma non-empty-subset (rewrite) (implies
	(and (subsetp lst1 lst2) (listp lst1))
	(listp lst2)))

(prove-lemma car-of-subset (rewrite) (implies
	(and (subsetp lst1 lst2) (listp lst1))
	(member (car lst1) lst2)))

; now, consider sub-lists

(defn sublistp (lst1 lst2) (if (listp lst2) 
	(or
		(sublistp lst1 (cdr lst2))
		(and 
			(listp lst1)
			(equal (car lst1) (car lst2))
			(sublistp (cdr lst1) (cdr lst2)) ) )
	(not (listp lst1)) ))

(prove-lemma sublist-implies-subset () (implies
	(sublistp lst1 lst2)
	(subsetp lst1 lst2) )
( ;  hints
(induct (sublistp lst1 lst2))
))

(prove-lemma transitivity-of-sublist (rewrite) (implies
	(and (sublistp s1 s2) (sublistp s2 s3))
	(sublistp s1 s3)))

; (power-set S) will actually be the set of all 
; (nil-terminated)
; sublists of S -- but this will be all subsets
; in our intended "standard" representation of sets

(defn power-set (set)  (if (listp set)
	(append 
		(cons-all (car set) (power-set (cdr set)))
		(power-set (cdr set)))  
	(list nil) ))

; this has 2^(length elements)

(prove-lemma size-of-cons-all (rewrite) (equal
	(length (cons-all item lst))
	(length lst) ))

(prove-lemma size-of-power-set (rewrite) (equal
	(length (power-set set))
	(expt 2 (length set)) ))

; now, we prove that the power-set contains all sublists,
; and only sublists -- of course, the power set is only
; collecting proper lists

(defn properp (lst) (if (listp lst)
	(properp (cdr lst))
	(equal lst nil)))

(prove-lemma cons-preserves-proper (rewrite) (implies
	(properp lst)
	(properp (cons item lst))))
	
(defn members-all-properp (biglst) (if (listp biglst)
	(and (properp (car biglst)) (members-all-properp (cdr biglst)))
	T ))

(prove-lemma append-preserves-members-all-properp (rewrite) (implies
	(and 
		(members-all-properp biglst1) 
		(members-all-properp biglst2)  )
	(members-all-properp (append biglst1 biglst2) ) ) )

(prove-lemma cons-all-preserves-members-all-properp (rewrite) (implies
	(members-all-properp biglst)  
	(members-all-properp (cons-all item biglst)) ))

; of coure, we chould check the defining property:
(prove-lemma members-all-properp-works (rewrite) (implies
	(and
		(member lst biglst)
		(members-all-properp biglst) )
	(properp lst)))

(prove-lemma only-proper-aux1 (rewrite) 
	(members-all-properp (power-set lst)))

(prove-lemma only-proper () (implies
	(member lst (power-set set))
	(properp lst)))

(disable only-proper-aux1)

(defn members-all-sublistp (biglst set) (if (listp biglst)
	(and (sublistp (car biglst) set) (members-all-sublistp (cdr biglst) set))
	T ))

(prove-lemma append-preserves-members-all-sublistp (rewrite) (implies
	(and 
		(members-all-sublistp biglst1 set) 
		(members-all-sublistp biglst2 set)  )
	(members-all-sublistp (append biglst1 biglst2) set ) ) )

(prove-lemma cons-all-preserves-members-all-sublistp (rewrite) (implies
	(members-all-sublistp biglst set)  
	(members-all-sublistp (cons-all item biglst) (cons item set) ) ))

; of coure, we chould check the defining property:
(prove-lemma members-all-sublistp-works (rewrite) (implies
	(and
		(member lst biglst)
		(members-all-sublistp biglst set) )
	(sublistp lst set)))

(prove-lemma only-sublists-aux1 (rewrite) 
	(members-all-sublistp (power-set set) set) )

(prove-lemma only-sublists (rewrite) (implies
	(member lst (power-set set))
	(sublistp lst set)))

; also, we get all sublists

(prove-lemma all-sublists (rewrite) (implies
	(and (sublistp lst set) (properp lst))
	(member lst (power-set set))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                           STANDARD SETS                                ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; These standard lists of numbers in strictly increasing order.

(defn setp (s) (if (listp s)
	; if it's a list (i.e., a cons) :
	(and 
		(numberp (car s))
		(setp (cdr s))
		(or
			(equal (cdr s) nil)
			(lessp (car s) (cadr s)) ))  ; increasing order
	; if it's not a cons, it must be the empty list, not some other atom
	(equal s nil)  ))


;;;;; large, in Paris-Harrington sense:
(defn largep (set) (and
	(setp set) (listp set)
	(not (lessp (length set) (car set)))))

(prove-lemma empty-is-nil (rewrite) (implies
	(and (setp s) (not (listp s)))
	(equal (equal s nil) T)))
	; so it can be a rewrite rule -- can't rewrite a var

(prove-lemma increasing (rewrite) (implies
	(and (setp s) (member x (cdr s)))
	(lessp (car s) x)))

; Since the order is increasing, the members don't occur twice
(prove-lemma not-again (rewrite) (implies 
	(setp s)
	(not (member (car s) (cdr s)))))

; the min of a set is its first element
(prove-lemma min-is-first (rewrite) (implies
	(and (setp s) (lessp x (car s)))
	(not (member x s))))
	
; the max of a set is its last element

(defn last (set) (if (listp set)
	(if (listp (cdr set)) 
		(last (cdr set))
		(car set) )
	0 ; really, undefined in this case, but the max of emptyset is 0
))

; the tail of a set is a set
(prove-lemma tail-of-a-set (rewrite) (implies
	(and (setp s) (listp s))
	(setp (cdr s))))
; this is useful in inductive proofs about sets


(prove-lemma first-before-last (rewrite) (implies
	(and (setp s) (listp (cdr s)))
	(lessp (car s) (last s))))


(prove-lemma max-is-last (rewrite) (implies
	(and (setp s) (lessp (last s) x ))
	(not (member x s)))
( ; hints
(disable min-is-first)
))

; sets are proper lists:
(prove-lemma sets-are-proper (rewrite)
	(implies (setp s) (properp s)))

;; now, a few lemmas about the first elements of subsets

(prove-lemma compare-first-elts (rewrite) (implies
	(and (setp s1) (setp s2) (listp s1) (subsetp s1 s2))
	(not (lessp (car s1) (car s2))) )   
( ; hints -- reason -- (car s1) is a member of s2
(do-not-induct T)
(use 
	(car-of-subset (s1 s1) (s2 s2))
	(min-is-first (x (car s1)) (s s2) ) )
(disable car-of-subset min-is-first setp)
))

; now, if (subsetp s1 s2) -- there are two cases
; the cars are the same, or (car s2) is smaller

(prove-lemma smaller-cars-in-subset (rewrite) (implies
	(and (setp s1) (setp s2) (listp s1) (subsetp s1 s2)
		(lessp (car s2) (car s1)) )
	(subsetp s1 (cdr s2)))
( ; hints -- reason -- (car s2) is not a member of s1
(do-not-induct T)
(use
	(subset-of-cdr (s1 s1) (s2 s2)) )
(disable subset-of-cdr)
))

(prove-lemma same-cars-in-subset-aux1 (rewrite) (implies
	(and (setp s1)  (listp s1) (listp (cdr s1)))
	(lessp (car s1) (cadr s1)) ))

(prove-lemma same-cars-in-subset-aux2 (rewrite) (implies
	(and (setp s1) (setp s2) (listp s1) (subsetp s1 s2)
		(listp (cdr s1))
		(equal (car s2) (car s1)) )
	(subsetp (cdr s1) (cdr s2))  )   
(; hints -- reason -- apply previous lemma to (cdr s1) s2
(use 
	(smaller-cars-in-subset (s1 (cdr s1)) (s2 s2))
	(same-cars-in-subset-aux1 (s1 s1)))
(do-not-induct T)
(disable smaller-cars-in-subset same-cars-in-subset-aux1 min-is-first
	not-again)
))

(prove-lemma same-cars-in-subset (rewrite) (implies
	(and (setp s1) (setp s2) (listp s1) (subsetp s1 s2)
		(equal (car s2) (car s1)) )
	(subsetp (cdr s1) (cdr s2))) 
(; hints -- reason -- apply previous lemma to (cdr s1) s2
(do-not-induct T)
(use (same-cars-in-subset-aux2 (s1 s1) (s2 s2)))
(disable same-cars-in-subset-aux2 not-again)
))

(disable same-cars-in-subset-aux1)
(disable same-cars-in-subset-aux2)

; now, we want to prove that subset implies sublist for sets

(defn bad-for-subset-implies-sublist (set1 set2) (and
	(subsetp set1 set2)
	(setp set1) (setp set2)
	(not (sublistp set1 set2)) )) 

(prove-lemma subset-implies-sublist-aux1 (rewrite) (implies
	(not (listp set1))
	(not (bad-for-subset-implies-sublist set1 set2)) ))

(prove-lemma subset-implies-sublist-aux2 (rewrite) (implies
	(not (listp set2))
	(not (bad-for-subset-implies-sublist set1 set2)) ))

; now, we do induction-- if (subsetp set1 set2) and the cars are the
; same, and the cdrs are subsets

(prove-lemma subset-implies-sublist-aux3 (rewrite) (implies
	(and
		(listp set1) (listp set2)
		(equal (car set2) (car set1))
		(sublistp (cdr set1) (cdr set2)))
	(sublistp set1 set2)  ))

(prove-lemma subset-implies-sublist-aux4 (rewrite) (implies
	(and
		(listp set1) (listp set2)
		(equal (car set2) (car set1))
		(bad-for-subset-implies-sublist set1 set2)  )
	(bad-for-subset-implies-sublist (cdr set1) (cdr set2))  )  
( ; hints
(do-not-induct T)
(disable subset-implies-sublist-aux1  subset-implies-sublist-aux2
	sublistp  empty-is-nil nil-is-subset power-set non-empty-subset )
))

(prove-lemma subset-implies-sublist-aux5 (rewrite) (implies
	(and
		(listp set1) (listp set2)
		(lessp (car set2) (car set1))
		(bad-for-subset-implies-sublist set1 set2)  )
	(bad-for-subset-implies-sublist  set1 (cdr set2))  ))

; Now, use the fact that (car set2) <= (car set1)
(prove-lemma subset-implies-sublist-aux6 (rewrite) (implies
	(and
		(listp set1) (listp set2)
		(bad-for-subset-implies-sublist set1 set2)  )
	(or
		(lessp (car set2) (car set1))
		(equal (car set2) (car set1)) ) ))

(prove-lemma subset-implies-sublist-aux7 (rewrite) (implies
	(and
		(listp set1) (listp set2)
		(bad-for-subset-implies-sublist set1 set2)  )
	(or
		(bad-for-subset-implies-sublist  set1 (cdr set2))
		(bad-for-subset-implies-sublist  (cdr set1) (cdr set2))  )  )
( ; hints
(do-not-induct T)
(use (subset-implies-sublist-aux6 (set1 set1) (set2 set2) ))
(disable subset-implies-sublist-aux6 bad-for-subset-implies-sublist)
))

; so there are no bad pairs, by induction -- we have to force the
; correct induction

(defn subset-implies-sublist-kludge (set1 set2) (if (listp set1)
	(if (listp set2)
		(plus
			(subset-implies-sublist-kludge (cdr set1) (cdr set2))
			(subset-implies-sublist-kludge  set1 (cdr set2)) )
		0 )
	0 ))

(prove-lemma subset-implies-sublist-aux8 (rewrite) 
	(not (bad-for-subset-implies-sublist set1 set2)  )  
( ; hints
(induct (subset-implies-sublist-kludge set1 set2))
(use (subset-implies-sublist-aux7 (set1 set1) (set2 set2)))
(disable bad-for-subset-implies-sublist subset-implies-sublist-aux7)
))

(disable subset-implies-sublist-kludge)
(disable subset-implies-sublist-aux1)
(disable subset-implies-sublist-aux2)
(disable subset-implies-sublist-aux3)
(disable subset-implies-sublist-aux4)
(disable subset-implies-sublist-aux5)
(disable subset-implies-sublist-aux6)
(disable subset-implies-sublist-aux7)

(prove-lemma subset-implies-sublist () (implies
	(and
		(subsetp set1 set2)
		(setp set1) (setp set2) )
	(sublistp set1 set2)  )
( ; hints
(use (subset-implies-sublist-aux8 (set1 set1) (set2 set2)))
(disable subset-implies-sublist-aux8 )
)) 

(disable subset-implies-sublist-aux8)
(disable bad-for-subset-implies-sublist)

;;;;;;;;;;
; now,, we prove that every subset of set is in the power-set

(prove-lemma all-subsets (rewrite) (implies
	(and (setp set) (setp x) (subsetp x set))
	(member x (power-set set)) )
(; hints
(do-not-induct T)
(use 
	(subset-implies-sublist (set1 x) (set2 set))
	(all-sublists (lst x) (set set) ) )
(disable subset-implies-sublist all-sublists transitivity-of-subset)
))


;;;;;;;;;;;;;;;;;;;  extensionality
; Two standard sets, s1, s2, are equal if they have the same members:
;  (implies
;      (and (setp s1) (setp s2) (subsetp s1 s2) (subsetp s2 s1))
;      (equal s1 s2) )
;  The proof is "by induction", but it requires a bunch of auxilliaries,
;  which we intruduce, and then disable after the proof

(defn bad-for-ext (s1 s2) (and
	(setp s1) (setp s2) (subsetp s1 s2) (subsetp s2 s1) (not (equal s1 s2))))

; so, we want to show, by induction, that this can't happen.

(prove-lemma extensionality-aux1 (rewrite) (implies
	(not (listp s1)) (not (bad-for-ext s1 s2))))

(prove-lemma extensionality-aux2 (rewrite) (implies
	(not (listp s2)) (not (bad-for-ext s1 s2))))


; now, (bad-for-ext s1 s2) implies that s1, s2 aren't empty, and we can
; look at their first element.  By (subsetp s1 s2) (subsetp s2 s1)
; the first elements are the same.

(prove-lemma extensionality-aux3 (rewrite) (implies
	(and 
		(setp s1) (setp s2) (listp s1) (listp s2)
		(subsetp s1 s2) (subsetp s2 s1))
	(equal (car s1) (car s2) ) ) 
( ; hints
(do-not-induct T)
(use 
	( compare-first-elts (s1 s1) (s2 s2) )
	( compare-first-elts (s1 s2) (s2 s1) ) )
(disable compare-first-elts)
))

(prove-lemma extensionality-aux4 (rewrite) (implies
	(and 
		(listp s1) (listp s2) (bad-for-ext s1 s2))
	(equal (car s1) (car s2) ) ) 
( ; hints
(do-not-induct T)
(use 
	(extensionality-aux3 (s1 s1) (s2 s2) ) )
(disable extensionality-aux3)
))

(disable extensionality-aux3)

; now, we should get that the cdrs are bad

(prove-lemma extensionality-aux5 (rewrite) (implies
	(and 
		(listp s1) (listp s2) (bad-for-ext s1 s2))
	(bad-for-ext (cdr s1) (cdr s2))   ) 
( ; hints
(use 
	(extensionality-aux4 (s1 s1) (s2 s2))
	(same-cars-in-subset (s1 s1) (s2 s2))
	(same-cars-in-subset (s1 s2) (s2 s1)) )
(disable 
	extensionality-aux4 same-cars-in-subset transitivity-of-subset
	setp not-again min-is-first max-is-last member subsetp )
))

(disable extensionality-aux4)

(defn extensionality-kludge (s1 s2) (if (not (listp s1))
	0 
	(if (not (listp s2)) 
		0
		(extensionality-kludge (cdr s1) (cdr s2)))))

(prove-lemma extensionality-aux6 (rewrite) 
	(not (bad-for-ext s1 s2))
; hints
(
	(induct (extensionality-kludge s1 s2))
	(disable bad-for-ext)
))

(disable extensionality-aux1)
(disable extensionality-aux2)
(disable extensionality-aux5)
(disable extensionality-aux6)

(prove-lemma extensionality () (implies
	(and (setp s1) (setp s2) (subsetp s1 s2) (subsetp s2 s1))
	(equal s1 s2) )   
; hints
(
	(do-not-induct T)
	(use (extensionality-aux6 (s1 s1) (s2 s2)))
))

(disable extensionality-kludge)


;;;;;;;;;;  segments

; (segment 3 6) is (3 4 5 6)
; These are special kinds of sets.  More on them will appear
; below; here we just put the defn and a few basic facts.

(defn segment (m n) (if 
	(and (leq m n) (numberp m) (numberp n))
		(cons m (segment (add1 m) n))
		nil  )
( ; hints
(lessp (difference  (add1 n) m))
))

(prove-lemma size-of-segment (rewrite) (implies
	(and (leq m n) (numberp m) (numberp n))
	(equal (length (segment m n)) (difference (add1 n) m)) ))

(prove-lemma members-of-segment (rewrite) (implies
	(and (leq m n) (numberp m) (numberp n)) 
	(equal
		(member x (segment m n))
		(and (numberp x) (leq x n) (leq m x))) )
( ; hints
(induct (segment m n))  ; about twice as fast this way
))

(disable segment)   ; for now


; some lemmas about length:

(prove-lemma length-of-sublist (rewrite) (implies
	(sublistp lst1 lst2)
	(not (lessp (length lst2) (length lst1))))
( ; hints
(disable subsetp setp)
))

(prove-lemma length-of-subset (rewrite) (implies
	(and
		(setp X) (setp Y) (subsetp X Y))
	(not (lessp (length Y) (length X))))
( ; hints
(do-not-induct T)
(use 
	(length-of-sublist (lst1 X) (lst2 Y))
	(subset-implies-sublist (set1 X) (set2 Y)))
))


; a few more set facts

(prove-lemma empty-subset(rewrite) (implies
	(not (listp s1))
	(subsetp s1 s2)) )

(prove-lemma car-before-cadr (rewrite) (implies
	(and (listp (cdr s)) (setp s))
	(lessp (car s) (cadr s))))

; now, we prove that (and (setp s1) (setp s2) (listp s1) (subsetp s1 s2))
; implies (subsetp (cdr s1) (cdr s2))
; this is by examination of cases:

(prove-lemma cdr-cdr-subset-aux1 () (implies
	(and (setp s1) (setp s2) (listp s1) (subsetp s1 s2))
	(or (equal (car s2) (car s1))  (lessp (car s2) (car s1)) )   )
( ; hints
(do-not-induct T)
(use (compare-first-elts (s1 s1) (s2 s2)))
))

(prove-lemma cdr-cdr-subset (rewrite) (implies
	(and (setp s1) (setp s2) (listp s1) (subsetp s1 s2))
	(subsetp (cdr s1) (cdr s2)))
( ; hints
(do-not-induct T)
(use (cdr-cdr-subset-aux1 (s1 s1) (s2 s2)))
(disable subsetp setp)
))

(disable cdr-cdr-subset-aux1)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                              ORDINALS                                  ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


; ordinalp (the property of representing an ordinal < epsilon_0)
; and ord-lessp (the < on the ordinals) are built-in
; we define all the basic function so that they do the right thing
; on legal notations for ordinals; we don't care what they do on non-ordinals

; Ordinals are represented as:
; The natural number n represents itself.
; (alpha beta gamma . n) represents omega^alpha + omega^beta + omega^gamma + n
; For this to be legal, alpha >= beta >= gamma -- this ensures
;  that each ordinal has a unique representation


; temporarily disable some set stuff
(disable subsetp)
(disable setp)
(disable max-is-last)
(disable tail-of-a-set)
(disable increasing)
(disable compare-first-elts)


;;;;;;;  some basic properties of order on the ordinals

(prove-lemma irreflex (rewrite) (not (ord-lessp x x)))

(prove-lemma nocycle (rewrite) (not
	(and (ord-lessp x y) (ord-lessp y x))))

(prove-lemma no-cycle-alt (rewrite) (implies
	(ord-lessp y x)
	(not (ord-lessp x y))))

(prove-lemma trichotomy (rewrite) (implies 
	(and (ordinalp sigma) (ordinalp tau))
	(or
		(equal sigma tau)
		(ord-lessp sigma tau)
		(ord-lessp tau sigma) )  ))

(prove-lemma transitivity (rewrite) (implies
	(and 
		(ord-lessp alpha beta)
		(ord-lessp beta gamma))
	(ord-lessp alpha gamma) ))

(prove-lemma transitivity-alt (rewrite) (implies
	(and 
		(ordinalp alpha) (ordinalp beta) (ordinalp gamma)
		(not (ord-lessp beta alpha))  ; alpha <= beta
		(ord-lessp beta gamma))
	(ord-lessp alpha gamma) )
( ; hints
(do-not-induct T)
(use 
	(trichotomy (sigma  alpha) (tau beta)))
(disable trichotomy)
))

(prove-lemma ords-below-2 () (implies
	(and
		(ordinalp alpha)
		(not (ord-lessp 1 alpha)) )
	(or 
		(equal alpha 0) 
		(equal alpha 1)  )) )

(prove-lemma postive-ord-lessp (rewrite) (implies
	(and (ordinalp gamma) (ordinalp delta) (ord-lessp gamma delta))
	(ord-lessp 0 delta)))


;;;;;;;  successors and limit ordinals

(defn successorp (alpha) (if (listp alpha)
	(successorp (cdr alpha))
	(lessp 0 alpha) ))

(defn limitp (alpha) (and 
	(listp alpha) 
	(not (successorp alpha)) ))

(prove-lemma successors-are-positive (rewrite) (implies
	(and (ordinalp alpha) (successorp alpha))
	(ord-lessp 0 alpha)))

(prove-lemma three-kinds (rewrite) (implies
	(ordinalp alpha)
	(or
		(limitp alpha)
		(successorp alpha)
		(equal alpha 0))))

(defn successor (alpha) (if (listp alpha)
	(cons (car alpha) (successor (cdr alpha)))
	(add1 alpha) ))
; the successor of 8 is 9
; the successor of (alpha beta . 8) is (alpha beta . 9)

(prove-lemma successor-is-an-ordinal (rewrite) (implies
	(ordinalp alpha)
	(ordinalp (successor alpha))  ))

(prove-lemma successor-is-a-successor (rewrite) 
	(successorp (successor alpha)))

(prove-lemma successor-is-bigger (rewrite) 
	(ord-lessp alpha (successor alpha)))

(prove-lemma succ-preserves-order (rewrite) (implies
	(ord-lessp alpha beta)
	(ord-lessp (successor alpha) (successor beta)) ))

(prove-lemma nothing-between (rewrite) (not (and
	(ord-lessp alpha beta)
	(ord-lessp beta (successor alpha)) )))

(defn predecessor (alpha) (if (listp alpha)
	(cons (car alpha) (predecessor (cdr alpha)))
	(sub1 alpha) ))

; these are inverses of each other

(prove-lemma predecessor-suc (rewrite) (implies
	(ordinalp alpha)
	(equal (predecessor (successor alpha)) alpha)  ))

(prove-lemma suc-predecessor (rewrite) (implies
	(and (ordinalp alpha) (successorp alpha))
	(equal (successor (predecessor alpha)) alpha)  ))

(prove-lemma predecessor-is-an-ordinal (rewrite) (implies
	(ordinalp alpha) 
	(ordinalp (predecessor alpha))  ))

(prove-lemma predecessor-is-smaller (rewrite) (implies
	(and (ordinalp alpha) (successorp alpha))
	(ord-lessp (predecessor alpha) alpha)  ))

(prove-lemma predecessor-of-0 (rewrite) (equal 
	(predecessor 0) 0))

(prove-lemma predecessor-of-limit (rewrite) (implies
	(and (ordinalp alpha) (limitp alpha))
	(equal (predecessor alpha) alpha)  ))


;;;;;;;;;;  ord-leq :  a <= on ordinals

(defn ord-leq (alpha beta) (not (ord-lessp beta alpha)))

(prove-lemma leq-as-an-or (rewrite) (implies 
	(and (ordinalp rho) (ordinalp sigma) (ord-leq rho sigma))
	(or (ord-lessp rho sigma) (equal rho sigma)))
; hints
(
(do-not-induct T)
(use (trichotomy (sigma rho) (tau sigma)))
(disable ord-lessp)
))

(prove-lemma leq-0 (rewrite) (implies 
	(and (ordinalp delta) (ord-leq delta 0))
	(equal (equal delta 0) T)))

(prove-lemma cars-go-down (rewrite) (implies
	(ordinalp beta)
	(ord-leq (cadr beta) (car beta))))

(prove-lemma ord-leq-is-transitive (rewrite) (implies
	(and 
		(ordinalp alpha) (ordinalp beta) (ordinalp gamma)
		(ord-leq alpha beta) (ord-leq beta gamma))
	(ord-leq alpha gamma)))

(prove-lemma ord-leq-zero (rewrite) (implies
	(and (ordinalp delta) (ord-leq delta 0))
	(equal (equal delta 0) T) ) )

(prove-lemma cars-are-ordinals (rewrite) (implies
	(ordinalp alpha) 
	(ordinalp (car alpha) )))

(prove-lemma cdrs-are-ordinals (rewrite) (implies
	(ordinalp alpha) 
	(ordinalp (cdr alpha) )))


; Now, we want to prove that (cdr alpha) < alpha
; this should be trivial but seems to require help

(defn bad-for-cdrs-are-smaller (alpha) (and
	(ordinalp alpha) (listp alpha)
	(not (ord-lessp (cdr alpha) alpha))))

(prove-lemma cdrs-are-smaller-aux1 (rewrite) (implies
	(nlistp alpha)
	(not (bad-for-cdrs-are-smaller alpha))))

(prove-lemma cdrs-are-smaller-aux2 (rewrite) (implies
	(nlistp (cdr alpha))
	(not (bad-for-cdrs-are-smaller alpha))))

(prove-lemma cdrs-are-smaller-aux3 (rewrite) (implies
	(and (ordinalp alpha) (listp (cdr alpha)) 
		(equal (car alpha) (cadr alpha)) 
		(ord-lessp (cddr alpha) (cdr alpha)))
	(ord-lessp (cdr alpha) alpha)))

(prove-lemma cdrs-are-smaller-aux4 (rewrite) (implies
	(and (ordinalp alpha) (listp (cdr alpha)) 
		(ord-lessp (car alpha) (cadr alpha))  )
	(ord-lessp (cdr alpha) alpha)))

(prove-lemma cdrs-are-smaller-aux5 (rewrite) (implies
	(and (ordinalp alpha) (listp (cdr alpha)) )
	(or
		(equal (car alpha) (cadr alpha)) 
		(ord-lessp (cadr alpha) (car alpha)))  )  
( ; hints
(do-not-induct T)
(use (trichotomy (sigma (car alpha)) (tau (cadr alpha)))  )
))

(disable cdrs-are-smaller-aux3)
(disable cdrs-are-smaller-aux4)
(disable cdrs-are-smaller-aux5)

(prove-lemma cdrs-are-smaller-aux6 (rewrite) (implies
	(and (ordinalp alpha) (listp (cdr alpha)) 
		(ord-lessp (cddr alpha) (cdr alpha)))
	(ord-lessp (cdr alpha) alpha))

( ; hints
(do-not-induct T)
(use 
	(cdrs-are-smaller-aux3 (alpha alpha)) 
	(cdrs-are-smaller-aux4 (alpha alpha)) 
	(cdrs-are-smaller-aux5 (alpha alpha)) )
(disable ordinalp listp )
))

(prove-lemma cdrs-are-smaller-aux7 (rewrite) (implies
	(and (listp (cdr alpha)) (bad-for-cdrs-are-smaller alpha))
	(bad-for-cdrs-are-smaller (cdr alpha))))

(disable cdrs-are-smaller-aux2)

(prove-lemma cdrs-are-smaller-aux8 (rewrite) (implies
	(bad-for-cdrs-are-smaller alpha)
	(bad-for-cdrs-are-smaller (cdr alpha)))
( ; hints
(do-not-induct T)
(use 
	(cdrs-are-smaller-aux7 (alpha alpha))
	(cdrs-are-smaller-aux2 (alpha alpha))  )
(disable bad-for-cdrs-are-smaller)
))

(prove-lemma cdrs-are-smaller-aux9 (rewrite) (not
	(bad-for-cdrs-are-smaller  alpha ))
( ; hints
; (induct (cdrs-are-smaller-kludge 	alpha))
(induct (successor alpha))
(disable bad-for-cdrs-are-smaller)
))

(disable cdrs-are-smaller-aux1)
(disable cdrs-are-smaller-aux6)
(disable cdrs-are-smaller-aux7)
(disable cdrs-are-smaller-aux8)
(disable cdrs-are-smaller-aux9)

(prove-lemma cdrs-are-smaller (rewrite) (implies
	(and (ordinalp alpha) (listp alpha))
	(ord-lessp (cdr alpha) alpha))  
( ;hints
(use (cdrs-are-smaller-aux9 (alpha alpha)))
))

(disable bad-for-cdrs-are-smaller)


(prove-lemma cars-of-smaller-ordinals (rewrite) (implies
	(and (ordinalp alpha) (ordinalp beta) (ord-lessp alpha beta))
	(or (ord-lessp (car alpha) (car beta) ) (equal (car alpha) (car beta)))))

(prove-lemma limit-not-succ (rewrite) (implies
	(and
		(ordinalp alpha) (ordinalp delta)
		(limitp alpha))
	(not (equal (successor delta) alpha) )  ))

(prove-lemma succ-below-limit (rewrite) (implies
	(and
		(ordinalp alpha) (ordinalp delta)
		(ord-lessp delta alpha)
		(limitp alpha))
	(ord-lessp (successor delta) alpha) )   
( ; hints
(do-not-induct T)
(use 
	(nothing-between (alpha delta) (beta alpha))
	(trichotomy (sigma alpha) (tau (successor delta)))  )
))


(prove-lemma irreflex-of-ord-leq (rewrite) (implies
	(and (ordinalp sigma) (ordinalp tau)
		(ord-leq sigma tau) (ord-leq tau sigma))
	(equal (equal sigma tau) T))
( ; hints
(do-not-induct T)
(use (trichotomy (sigma sigma) (tau tau)))
(disable transitivity-alt no-cycle-alt ord-leq-zero)
))

(prove-lemma transitivity-alt2 () (implies
	(and
		(ordinalp alpha) (ordinalp beta) (ordinalp gamma)
		(ord-lessp alpha beta) (ord-leq beta gamma))
	(ord-lessp alpha gamma) )
( ; hints
(do-not-induct T)
(use (trichotomy (sigma beta) (tau gamma)))
(disable irreflex-of-ord-leq transitivity-alt no-cycle-alt ord-leq-zero)
))


;;;;;;;;;;;;;;;;;;;;  multiplicities
; (mult delta alpha) is the coefficient of omega^delta in the
; Cantor normal form of alpha.  We want to define this, and
; prove that alpha is determined by its multiplicities
; This is slightly messy, since delta = 0 is a special case
; in the Boyer-Moore notation -- let's do that separately
; (mult 0 alpha) will be (number-part alpha)

(defn number-part (alpha) (if (nlistp alpha)
	alpha
	(number-part (cdr alpha))))

(prove-lemma number-part-is-a-number (rewrite) (implies
	(ordinalp alpha)
	(numberp (number-part alpha))  ))

; for delta > 0, (mult delta alpha) = (pos-mult delta alpha)

(defn pos-mult (delta alpha) (if (nlistp alpha)
	0
	(if (equal delta (car alpha))
		(add1 (pos-mult delta (cdr alpha)))
		(pos-mult delta (cdr alpha))  )  ))

(prove-lemma pos-mult-is-a-number (rewrite) 
	(numberp (pos-mult delta alpha)))

(defn mult (delta alpha) (if (equal delta 0)
	(number-part alpha) 
	(pos-mult delta alpha)))

(prove-lemma mult-is-a-number (rewrite) (implies
	(ordinalp alpha)
	(numberp (mult delta alpha))  ))

(prove-lemma mult-in-a-number (rewrite) (implies
	(and (numberp alpha) (not (equal delta 0)))
	(equal (mult delta alpha) 0)))

; now, we prove if delta > (car alpha), (mult delta alpha) = 0
; this is true for numbers alpha because the car of a non-list = 0
; Prover needs help to find the correct induction

(defn bad-for-bound-on-mult (delta alpha) (and
	(ordinalp alpha) (ordinalp delta) (ord-lessp (car alpha) delta)
	(not (equal (mult delta alpha) 0)) ))

; we want to show this can't happen

(prove-lemma bound-on-mult-aux1 (rewrite) (implies
	(nlistp alpha)
	(not (bad-for-bound-on-mult delta alpha)))  )

(prove-lemma bound-on-mult-aux2 (rewrite) (implies
	(and (listp alpha) (ordinalp alpha))
	(not (ord-lessp (car alpha) (cadr alpha))) ))

(prove-lemma bound-on-mult-aux3 (rewrite) (implies
	(ordinalp alpha) (ordinalp (car alpha))))

(prove-lemma bound-on-mult-aux4 (rewrite) (implies
	(ordinalp alpha) (ordinalp (cadr alpha))))

(prove-lemma bound-on-mult-aux5 (rewrite) (implies
	(and (listp alpha) (ordinalp alpha) (ordinalp delta)
		(ord-lessp (car alpha) delta))
	(ord-lessp (cadr alpha) delta)) 
( ; hints
(do-not-induct T)
(use (transitivity-alt (alpha (cadr alpha)) (beta (car alpha)) (gamma delta)))
(disable transitivity-alt ordinalp ord-lessp)
))

(prove-lemma bound-on-mult-aux6 (rewrite) (implies
	(and (listp alpha) (bad-for-bound-on-mult delta alpha))
	(bad-for-bound-on-mult delta (cdr alpha)) ) 
( ; hints
(disable ord-leq transitivity-alt no-cycle-alt)
))

(defn bound-on-mult-kludge (alpha) ; force correct induction
	(if (nlistp alpha) 0 (bound-on-mult-kludge (cdr alpha))))

(prove-lemma bound-on-mult-aux7 () (not
	(bad-for-bound-on-mult delta alpha))
( ; hints
(disable bad-for-bound-on-mult)
(induct (bound-on-mult-kludge alpha))
))

(prove-lemma bound-on-mult (rewrite) (implies
	(and (ordinalp alpha) (ordinalp delta) (ord-lessp (car alpha) delta))
	(equal (mult delta alpha) 0) )
( ;  hint
(use (bound-on-mult-aux7 (delta delta) (alpha alpha)))
(disable ord-leq transitivity-alt)
))

(disable bound-on-mult-aux1)
(disable bound-on-mult-aux2)
(disable bound-on-mult-aux3)
(disable bound-on-mult-aux4)
(disable bound-on-mult-aux5)
(disable bound-on-mult-aux6)
(disable bound-on-mult-aux7)
(disable bad-for-bound-on-mult)
(disable bound-on-mult-kludge)

; now, (different-mult alpha beta) returns a delta
; such that (mult delta alpha) != (mult delta beta)

(defn different-mult (alpha beta) (if (equal (car alpha) (car beta))
	; if the cars are the same, consider two cases:
	; note that for ordinals, alpha is compound iff beta is
	(if (listp alpha)
		(different-mult (cdr alpha) (cdr beta))
		0 )   ; for numbers, return 0
	; if the cars are different, return the larger one
	(if (ord-lessp (car alpha) (car beta))
		(car beta)
		(car alpha) )  ) )

; summarize the features of the definition

(prove-lemma different-mult-is-ord (rewrite) (implies
	(and (ordinalp alpha) (ordinalp beta))
	(ordinalp (different-mult alpha beta)))
( ; hints
(induct (different-mult alpha beta))
(disable ordinalp ord-lessp)
))

(prove-lemma different-mult-for-numbers (rewrite) (implies
	(and (numberp alpha) (numberp beta))
	(equal (different-mult alpha beta) 0)))

;;;;;;;;;;  The following is causing us a lot of trouble:
(disable transitivity-alt)
(disable irreflex-of-ord-leq)

(prove-lemma different-mult-number-list (rewrite) (implies
	(and (numberp alpha) (ordinalp beta) (listp beta))
	(equal (different-mult alpha beta) (car beta))))

(prove-lemma different-mult-list-number (rewrite) (implies
	(and (numberp beta) (ordinalp alpha) (listp alpha))
	(equal (different-mult alpha beta) (car alpha))))

(prove-lemma different-mult-for-lists-same-car (rewrite) (implies
	(and (ordinalp alpha) (ordinalp beta) 
		(listp alpha) (listp beta)
		(equal (car alpha) (car beta)))
	(equal 
		(different-mult alpha beta)
		(different-mult (cdr alpha) (cdr beta))) )
( ; hints
(disable ord-leq no-cycle-alt)
))

(prove-lemma different-mult-for-smaller-car (rewrite) (implies
	(ord-lessp (car alpha) (car beta))
	(equal 
		(different-mult alpha beta)
		(car beta)) ))

(prove-lemma different-mult-for-larger-car (rewrite) (implies
	(ord-lessp (car beta) (car alpha))
	(equal 
		(different-mult alpha beta)
		(car alpha)) ))

(disable different-mult)

; now, we have to prove that it works
; this needs some help

(defn bad-for-different-mult-works (alpha beta) (and
	(ordinalp alpha) (ordinalp beta) (not (equal alpha beta))
	(equal
		(mult (different-mult alpha beta) alpha)
		(mult (different-mult alpha beta) beta) ) ))

; if they have different cars, this should follow
; by "bound-on-mult"

(prove-lemma different-mult-works-aux1 (rewrite) (implies
	(and (ordinalp sigma)  (not (equal (car sigma) 0)))
	(not (equal (mult (car sigma) sigma) 0) ) ))

; the following is causing us a lot of trouble
(disable no-cycle-alt)
(disable ord-leq-is-transitive)


(prove-lemma different-mult-works-aux2 (rewrite) (implies
	(ord-lessp (car alpha) (car beta))
	(not (bad-for-different-mult-works alpha beta)))
( ; hints
(do-not-induct T)
(use 
	(different-mult-works-aux1 (sigma beta))
	(bound-on-mult (alpha alpha) (delta (car beta))))
(disable ord-leq different-mult-works-aux1 bound-on-mult)
))

(prove-lemma different-mult-works-aux3 (rewrite) (implies
	(ord-lessp (car beta) (car alpha))
	(not (bad-for-different-mult-works alpha beta)))
( ; hints
(do-not-induct T)
(use 
	(different-mult-works-aux1 (sigma alpha))
	(bound-on-mult (alpha beta) (delta (car alpha))))
(disable different-mult-works-aux1 bound-on-mult)
))

(prove-lemma different-mult-works-aux4 (rewrite) (implies
	(and (numberp alpha) (numberp beta))
	(not (bad-for-different-mult-works alpha beta)) ))

(prove-lemma different-mult-works-aux5 (rewrite) (implies
	(and (numberp alpha) (ordinalp beta) (listp beta))
	(ord-lessp (car alpha) (car beta))))

(prove-lemma different-mult-works-aux6 (rewrite) (implies
	(and (nlistp alpha)  (listp beta))
	(not (bad-for-different-mult-works alpha beta)) ))

(prove-lemma different-mult-works-aux7 (rewrite) (implies
	(and (listp alpha)  (nlistp beta))
	(not (bad-for-different-mult-works alpha beta)) ))

(prove-lemma different-mult-works-aux8 (rewrite) (implies
	(and (nlistp alpha)  (nlistp beta))
	(not (bad-for-different-mult-works alpha beta)) ))

(disable different-mult-works-aux4 )
(disable different-mult-works-aux5 )
(disable different-mult-works-aux6 )
(disable different-mult-works-aux7 )
(disable different-mult-works-aux8 )

(prove-lemma different-mult-works-aux9 (rewrite) (implies
	(or (nlistp alpha)  (nlistp beta))
	(not (bad-for-different-mult-works alpha beta)) )
( ; hints
(disable bad-for-different-mult-works)
(use
	(different-mult-works-aux6 (alpha alpha) (beta beta))
	(different-mult-works-aux7 (alpha alpha) (beta beta))
	(different-mult-works-aux8 (alpha alpha) (beta beta)) )
))

; so, they are both compound

(disable different-mult-works-aux1 )
(disable different-mult-works-aux2 )
(disable different-mult-works-aux3 )

(prove-lemma different-mult-works-aux10 (rewrite) (implies
	(not (equal (car beta) (car alpha)))
	(not (bad-for-different-mult-works alpha beta)))
( ; hints
(use 
	(trichotomy (sigma (car alpha)) (tau (car beta)))
	(different-mult-works-aux2 (alpha alpha) (beta beta))
	(different-mult-works-aux3 (alpha alpha) (beta beta)) )
(disable  different-mult-works-aux9)
))


; so, if they are bad,  they are both compound and their cars
; are the same

(prove-lemma same-mult-for-cdr (rewrite) (implies
	(and 
		(listp alpha) (listp beta) (equal (car alpha) (car beta))
		(equal (mult delta alpha) (mult delta beta)) )
	(equal (mult delta (cdr alpha)) (mult delta (cdr beta)) )  ))

(prove-lemma different-mult-works-aux11 (rewrite) (implies
	(and 
		(listp alpha) (listp beta) (equal (car alpha) (car beta))
		(bad-for-different-mult-works alpha beta) )
	(bad-for-different-mult-works (cdr alpha) (cdr beta)) )
( ;  hints
(use 
	(same-mult-for-cdr (alpha alpha) (beta beta) (delta
			(different-mult alpha beta))) )
(disable mult ordinalp ord-lessp same-mult-for-cdr)
))

(disable different-mult-works-aux10)

(prove-lemma different-mult-works-aux12 (rewrite) (implies
	(and 
		(listp alpha) (listp beta) 
		(bad-for-different-mult-works alpha beta) )
	(bad-for-different-mult-works (cdr alpha) (cdr beta)) ) 
( ; hints
(do-not-induct T)
(disable bad-for-different-mult-works)
(use (different-mult-works-aux10 (alpha alpha) (beta beta)))
))

(defn different-mult-works-kludge (alpha beta) (if
	(and (listp alpha) (listp beta))
	(different-mult-works-kludge (cdr alpha) (cdr beta))
	0 ))

(prove-lemma different-mult-works-aux13 (rewrite) 
	(not (bad-for-different-mult-works alpha beta))
( ; hints
(induct (different-mult-works-kludge alpha beta))
(disable bad-for-different-mult-works)
))

(disable different-mult-works-kludge)
(disable different-mult-works-aux9)
(disable different-mult-works-aux11)
(disable different-mult-works-aux12)
(disable different-mult-works-aux13)

(prove-lemma different-mult-works (rewrite) (implies
	(and (ordinalp alpha) (ordinalp beta) (not (equal alpha beta)))
	(not (equal
		(mult (different-mult alpha beta) alpha)
		(mult (different-mult alpha beta) beta) )) )
( ; hints
(use (different-mult-works-aux13 (alpha alpha) (beta beta)))
(disable mult)
))

(disable bad-for-different-mult-works)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                          NATURAL SUM                                   ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;  alpha # lambda
; this is defined by merging the Cantor Normal Forms
; as with the above, there are two cases because
; of the special treatment of numbers

; we must verify 5 things:
; 0. this is an ordinal
; 1. bound-below:  alpha # lambda > lambda  if alpha != 0
; 2. bound above:  car(alpha # lambda) is the larger of the two cars
; 3. monotonic:  alpha < beta --> alpha # lambda < beta # lambda
; 4. mult-is-additive:  mult(delta, alpha # lambda) = 
;     mult(delta, alpha) + mult(delta, lambda)
;   this will easily imply that # is assoc and commutative

; we do this for lambda in omega and lambda = (sigma . 0) 
;  and then put them together

; first alpha # n when n is a number

(defn num-sharp (alpha n)  (if (nlistp alpha)
	(plus alpha n)
	(cons (car alpha) (num-sharp (cdr alpha) n))))

(prove-lemma num-sharp-is-an-ordinal (rewrite) (implies
	(and (ordinalp alpha) (numberp n))
	(ordinalp (num-sharp alpha n))))

(prove-lemma num-sharp-and-zero (rewrite) (implies
	(ordinalp alpha)
	(equal (num-sharp alpha 0) alpha)))

(prove-lemma num-sharp-and-successor (rewrite)
	(equal (num-sharp alpha 1) (successor alpha)))

(prove-lemma num-sharp-gets-bigger (rewrite) (implies
	(and (ordinalp alpha) (numberp n) (not (equal n 0)))
	(ord-lessp alpha (num-sharp alpha n))))

(prove-lemma car-of-num-sharp (rewrite) (implies
	(numberp n)
	(equal (car (num-sharp alpha n)) (car alpha))))

(prove-lemma num-sharp-is-monotonic (rewrite) (implies
	(and (ordinalp alpha) (ordinalp beta) (numberp n)
		(ord-lessp alpha beta))
	(ord-lessp (num-sharp alpha n) (num-sharp beta n))))


; check out multiplicities

(prove-lemma number-part-of-num-sharp (rewrite) (equal
	(number-part (num-sharp alpha n))
	(plus (number-part alpha) n )))

(prove-lemma pos-mult-of-num-sharp (rewrite)
	(equal
		(pos-mult delta (num-sharp alpha n))
		(pos-mult delta alpha) )) 

(prove-lemma mult-of-num-sharp (rewrite) (implies
	(and (numberp n) (ordinalp delta) (ordinalp alpha))
	(equal
		(mult delta (num-sharp alpha n))
		(plus
			(mult delta alpha)
			(mult delta n)))))

; now, alpha # omega^delta where delta > 0
; this is (insert delta alpha) -- we insert delta in the CNF of alpha

(defn insert (delta alpha) (if (nlistp alpha)
	(cons delta alpha) 
	(if (ord-lessp delta (car alpha))
		(cons (car alpha) (insert delta (cdr alpha)))
		(cons delta alpha))))

; the car is the larger of the two cars

(prove-lemma car-of-insert-A (rewrite) (implies
	(and (ord-lessp delta (car alpha)) (ordinalp alpha))
	(equal (car (insert delta alpha)) (car alpha))))

(prove-lemma car-of-insert-B (rewrite) (implies
	(not (ord-lessp delta (car alpha))) 
	(equal (car (insert delta alpha)) delta)))


(prove-lemma insert-is-an-ordinal (rewrite) (implies
	(and (ordinalp alpha) (ordinalp delta) (not (equal delta 0)))
	(ordinalp (insert delta alpha)))
(  ; hints
(induct (insert delta alpha))
(enable no-cycle-alt)
(disable ord-leq-zero leq-0 ord-leq transitivity 
	car-of-insert-A car-of-insert-B)
))


; now, we want to show that alpha < (insert delta alpha)
; this need some help

(prove-lemma insert-is-cons (rewrite) (implies
	(and (ordinalp alpha) (ordinalp delta)  (not (equal delta 0))
		(not (ord-lessp delta (car alpha))))
	(equal
		(insert delta alpha)
		(cons delta alpha))))

(prove-lemma insert-is-bigger-aux1 (rewrite) (implies
	(and (ordinalp alpha) (ordinalp delta) (not (equal delta 0))
		(listp alpha) (not (ord-lessp delta (car alpha))))
	(ord-lessp alpha (insert delta alpha)) )
( ;  hints
(use (trichotomy (sigma delta) (tau (car alpha))))
(disable trichotomy)
))

(defn bad-for-insert-is-bigger (alpha delta) (and
	(ordinalp alpha) (ordinalp delta) (not (equal delta 0))
	(not (ord-lessp alpha (insert delta alpha)))))

(prove-lemma insert-is-bigger-aux2 (rewrite) (implies
	(nlistp alpha)
	(not (bad-for-insert-is-bigger alpha delta)) ))

(prove-lemma insert-is-bigger-aux3 (rewrite) (implies
	(and (listp alpha) (not (ord-lessp delta (car alpha))))
	(not (bad-for-insert-is-bigger alpha delta)) )
( ;  hints
(use (insert-is-bigger-aux1  (alpha alpha) (delta delta)))
(disable insert-is-bigger-aux1 )
(do-not-induct T)
) )

(prove-lemma insert-small-ordinal (rewrite) (implies
	(and (ordinalp alpha)  (listp alpha) 
		(ord-lessp delta (car alpha)))
	(equal
		(insert delta alpha)
		(cons (car alpha) (insert delta (cdr alpha))))))

(prove-lemma insert-is-bigger-aux4 (rewrite) (implies
	(and (ordinalp alpha)  (listp alpha) 
		(ord-lessp delta (car alpha))
		(ord-lessp (cdr alpha) (insert delta (cdr alpha))) )
	(ord-lessp alpha (insert delta alpha)))
(; hints
(use (insert-small-ordinal (alpha alpha) (delta delta)))
(disable ordinalp insert insert-small-ordinal)
))

(prove-lemma insert-is-bigger-aux5 (rewrite) (implies
	(and (listp alpha)  (ord-lessp delta (car alpha))
		(bad-for-insert-is-bigger alpha delta)  ) 
	(bad-for-insert-is-bigger (cdr alpha)  delta)) 
( ;  hints
(do-not-induct T)
(use (insert-is-bigger-aux4 (alpha alpha) (delta delta)))
(disable ordinalp ord-lessp insert-is-bigger-aux4 insert-small-ordinal insert)
))

(prove-lemma insert-is-bigger-aux6 (rewrite) (implies
	(and (listp alpha)  
		(bad-for-insert-is-bigger alpha delta)  ) 
	(bad-for-insert-is-bigger (cdr alpha)  delta)) 
( ;  hints
(do-not-induct T)
(use (insert-is-bigger-aux5 (alpha alpha) (delta delta)))
(disable bad-for-insert-is-bigger
ordinalp ord-lessp insert-is-bigger-aux5 insert-small-ordinal insert)
))

(prove-lemma insert-is-bigger-aux7 (rewrite) 
	(not (bad-for-insert-is-bigger alpha delta))
( ; hints
(induct (successor alpha))
(disable bad-for-insert-is-bigger)
))

(prove-lemma insert-is-bigger (rewrite) (implies
	(and (ordinalp alpha) (ordinalp delta) (not (equal delta 0)))
	(ord-lessp alpha (insert delta alpha)))
( ; hints
(do-not-induct T)
(use (insert-is-bigger-aux7 (alpha alpha) (delta delta)))
(disable insert-is-bigger-aux7)
))

(disable insert-is-bigger-aux1)
(disable insert-is-bigger-aux2)
(disable insert-is-bigger-aux3)
(disable insert-is-bigger-aux4)
(disable insert-is-bigger-aux5)
(disable insert-is-bigger-aux6)
(disable insert-is-bigger-aux7)


;;;; now --  check out multiplicities

(prove-lemma number-part-of-insert (rewrite) (equal
	(number-part (insert delta alpha))
	(number-part alpha)))

(prove-lemma pos-mult-same (rewrite) (equal
	(pos-mult delta (insert delta alpha))
	(add1 (pos-mult delta alpha))))

(prove-lemma pos-mult-different (rewrite)  (implies
	(not (equal x delta))
	(equal
		(pos-mult x (insert delta alpha))
		(pos-mult x alpha))))

(prove-lemma mult-of-insert-A (rewrite) (implies 
	(and (ordinalp alpha) (not (equal sigma delta)))
	(equal
		(mult sigma (insert delta alpha))
		(mult sigma alpha))))

(prove-lemma mult-of-insert-B (rewrite) (implies 
	(and (ordinalp alpha) (not (equal delta 0)))
	(equal
		(mult delta (insert delta alpha))
		(add1 (mult delta alpha)))))

; we still have to check monotonicity --
; but first, define #  and prove it's assoc and commut
; just to make sure we've got it right.

(defn sharp (alpha beta) (if (nlistp beta)
	(num-sharp alpha beta)
	(insert (car beta) (sharp alpha (cdr beta)))))

(prove-lemma sharp-is-an-ordinal (rewrite) (implies
	(and (ordinalp alpha) (ordinalp beta))
	(ordinalp (sharp alpha beta))))

(prove-lemma sharp-with-0 (rewrite) (implies
	(ordinalp alpha)
	(equal (sharp alpha 0) alpha)))

(prove-lemma sharp-gets-bigger (rewrite) (implies
	(and (ordinalp alpha) (ordinalp beta) (not (equal beta 0)))
	(ord-lessp alpha (sharp alpha beta)))
( ; hints
(induct (successor beta)) ; i.e., go down cdrs, not cars
(disable num-sharp insert)
))


; now we prove that (car (sharp alpha beta)) =  (car alpha)
; in the case that (car alpha) >= (car beta) -- the other way
; around will follow once we prove # is commutative

(prove-lemma car-of-insert-aux1 (rewrite) (implies
	(and (equal delta (car alpha)) (ordinalp alpha) (ordinalp delta))
	(equal (car (insert delta alpha)) (car alpha))))

(prove-lemma car-of-insert-C (rewrite) (implies
	(and (ord-leq delta (car alpha)) (ordinalp alpha) (ordinalp delta))
	(equal (car (insert delta alpha)) (car alpha)))
( ; hints
(do-not-induct T)
(use (leq-as-an-or (rho delta) (sigma (car alpha))))
(disable ord-leq ordinalp leq-as-an-or)
))

(prove-lemma car-of-sharp-aux1 (rewrite) (implies
	(and (not (listp beta))
		(ordinalp alpha) (ordinalp beta))
	(equal (car (sharp alpha beta)) (car alpha)))
(; hints
(induct (successor beta))
(disable ordinalp ord-leq)
))

(prove-lemma car-of-sharp-aux2 (rewrite) (implies
	(and (ord-leq (car beta) (car alpha)) 
		(ordinalp alpha) (ordinalp beta))
	(ord-leq (cadr beta) (car alpha)) )
(; hints
(do-not-induct T)
(use
	(ord-leq-is-transitive 
		(alpha (cadr beta)) (beta (car beta)) (gamma (car alpha)))
	(cars-go-down (beta beta)))
(disable ordinalp ord-leq cars-go-down ord-leq-is-transitive)
))

(prove-lemma car-of-sharp-A (rewrite) (implies
	(and (ord-leq (car beta) (car alpha)) 
		(ordinalp alpha) (ordinalp beta))
	(equal (car (sharp alpha beta)) (car alpha)))
(; hints
(induct (successor beta))
(disable ordinalp ord-leq)
))

(disable car-of-sharp-aux1)
(disable car-of-sharp-aux2)

; now, check out that multiplicities are additive

(defn bad-for-mult-of-sharp (sigma alpha beta) (and
	(ordinalp sigma) (ordinalp alpha) (ordinalp beta)
	(not (equal
		(mult sigma (sharp alpha beta))
		(plus (mult sigma alpha) (mult sigma beta)))) ))

(prove-lemma mult-of-sharp-aux1 (rewrite) (implies
	(nlistp beta)
	(not (bad-for-mult-of-sharp sigma alpha beta))))

(prove-lemma mult-of-sharp-aux2 (rewrite) (implies
	(and (listp beta) (ordinalp beta))
	(not (equal (car beta) 0))))

(prove-lemma mult-of-sharp-aux3 (rewrite) (implies
	(and (listp beta) (not (equal sigma (car beta)))
		(ordinalp sigma) (ordinalp alpha) (ordinalp beta))
	(equal 
		(mult sigma (sharp alpha (cdr beta)))
		(mult sigma (sharp alpha beta)) ))
( ;  hints
(do-not-induct T)
(use
	(mult-of-insert-A (sigma sigma) (alpha (sharp alpha (cdr beta))) 
		(delta (car beta))) )
(disable  same-mult-for-cdr  mult-of-insert-A mult-of-insert-B
	ordinalp ord-leq mult insert)
))

(prove-lemma mult-of-sharp-aux4 (rewrite) (implies
	(and (listp beta) (not (equal sigma (car beta))))
	(equal 
		(mult sigma (cdr beta))
		(mult sigma beta)))
( ; hints
(disable bound-on-mult same-mult-for-cdr)
))

(prove-lemma mult-of-sharp-aux5 (rewrite) (implies
	(and (listp beta) (bad-for-mult-of-sharp sigma alpha beta)
		(not (equal sigma (car beta))))
	(bad-for-mult-of-sharp sigma alpha (cdr beta))  ) 
( ; hints
(do-not-induct T)
(disable ordinalp sharp car-of-sharp-A)
))

(prove-lemma mult-of-sharp-aux6 (rewrite) (implies
	(and (listp beta) (ordinalp beta))
	(equal 
		(mult (car beta)  beta)
		(add1 (mult (car beta) (cdr beta)))))
( ; hints
(disable ordinalp bound-on-mult same-mult-for-cdr)
))

(prove-lemma mult-of-sharp-aux7 (rewrite) (implies
	(and (listp beta) (bad-for-mult-of-sharp (car beta) alpha beta))
	(bad-for-mult-of-sharp (car beta) alpha (cdr beta))  ) 
( ; hints
(do-not-induct T)
(disable same-mult-for-cdr mult-of-sharp-aux5 bound-on-mult
	ordinalp car-of-sharp-A)
))

(prove-lemma mult-of-sharp-aux8 (rewrite) (implies
	(and (listp beta) (bad-for-mult-of-sharp sigma alpha beta))
	(bad-for-mult-of-sharp sigma alpha (cdr beta))  ) 
( ; hints
(do-not-induct T)
(use
	(mult-of-sharp-aux7 (alpha alpha) (beta beta) )
	(mult-of-sharp-aux5 (alpha alpha) (beta beta) (sigma sigma)) )
(disable  bad-for-mult-of-sharp mult-of-sharp-aux5 mult-of-sharp-aux7)
))

(prove-lemma mult-of-sharp-aux9 (rewrite) 
	(not (bad-for-mult-of-sharp sigma alpha beta))
( ; hints
(disable bad-for-mult-of-sharp)
(induct (sharp alpha beta))))

(prove-lemma mult-of-sharp (rewrite) (implies
	(and
		(ordinalp sigma) (ordinalp alpha) (ordinalp beta))
	(equal
		(mult sigma (sharp alpha beta))
		(plus (mult sigma alpha) (mult sigma beta))))
( ; hints
(do-not-induct T)
(use ( mult-of-sharp-aux9 (alpha alpha) (beta beta) (sigma sigma)) )
(disable mult ord-leq ordinalp
	mult-of-sharp-aux2 mult-of-sharp-aux9)
))

(disable bad-for-mult-of-sharp)
(disable mult-of-sharp-aux1)
(disable mult-of-sharp-aux2)
(disable mult-of-sharp-aux3)
(disable mult-of-sharp-aux4)
(disable mult-of-sharp-aux5)
(disable mult-of-sharp-aux6)
(disable mult-of-sharp-aux7)
(disable mult-of-sharp-aux8)
(disable mult-of-sharp-aux9)


; now, we should show that sharp is commutative and associative

(prove-lemma commut-of-sharp (rewrite) (implies
	(and (ordinalp alpha) (ordinalp beta))
	(equal (sharp alpha beta) (sharp beta alpha))  )
( ; hints
(do-not-induct T)
(use 
	(different-mult-works 
		(alpha (sharp alpha beta)) (beta (sharp beta alpha)))  )
(disable ord-leq insert sharp ordinalp ord-lessp different-mult-works)
))

(prove-lemma assoc-of-sharp (rewrite) (implies
	(and (ordinalp alpha) (ordinalp beta) (ordinalp gamma))
	(equal 
		(sharp (sharp alpha beta) gamma)
		(sharp alpha (sharp beta gamma)) ) ) 
( ; hints
(do-not-induct T)
(use 
	(different-mult-works 
		(alpha (sharp (sharp alpha beta) gamma) ) 
		(beta (sharp alpha (sharp beta gamma))))  )
(disable ord-leq insert sharp ordinalp ord-lessp different-mult-works)
))

;;; now, we can finish the discussion of the car of a #

(prove-lemma car-of-sharp-B (rewrite) (implies
	(and (ord-leq (car alpha) (car beta)) 
		(ordinalp alpha) (ordinalp beta))
	(equal (car (sharp alpha beta)) (car beta)))
(; hints
(do-not-induct T)
(use 
	(car-of-sharp-A (alpha beta) (beta alpha))
	(commut-of-sharp (alpha alpha) (beta beta)))
(disable sharp ord-leq ordinalp)
))


; now, turn to monotonicity:  alpha < beta --> alpha # lambda < beta # lambda
; this should follow by induction if we can do monotonicty of insert

; first, do it in the case that delta >= (car beta)

(disable car-of-insert-aux1)

(prove-lemma monotonicity-of-insert-aux1 (rewrite) (implies
	(and 
		(ordinalp alpha) (ordinalp beta) (ordinalp delta)
		(not (ord-lessp delta (car beta)))
		(not (equal delta 0))
		(ord-lessp alpha beta) )
	(ord-lessp (insert delta alpha) (insert delta beta)))
( ; hints
(do-not-induct T)
(use 
	(insert-is-cons (alpha alpha) (delta delta))
	(insert-is-cons (alpha beta) (delta delta)) )
(disable  car-of-insert-A car-of-insert-B car-of-insert-C
	leq-0 insert ord-leq insert-is-cons)
))

; now, consider case that delta < (car beta)

; first, suppose also (car alpha) < (car beta)
; Then (car (insert delta alpha)) < (car beta)
; so (insert delta alpha) < beta < (insert delta beta)

(prove-lemma monotonicity-of-insert-aux2 (rewrite) (implies
	(and 
		(ordinalp alpha) (ordinalp sigma) (ordinalp delta)
		(ord-lessp delta sigma)
		(ord-lessp (car alpha) sigma )  )
	(ord-lessp (car (insert delta alpha)) sigma))
( ; hints
(do-not-induct T)
(use
	(car-of-insert-B (delta delta) (alpha alpha))
	(car-of-insert-C (delta delta) (alpha alpha)) )
(disable  
	leq-0 ordinalp car-of-insert-B car-of-insert-C)
))

(prove-lemma monotonicity-of-insert-aux3 (rewrite) (implies
	(and 
		(ordinalp alpha) (ordinalp beta) (ordinalp delta)
		(ord-lessp delta (car beta))
		(not (equal delta 0))
		(ord-lessp (car alpha) (car beta) ) )
	(ord-lessp (insert delta alpha) beta ))  
( ; hints
(do-not-induct T)
(disable ord-leq leq-0)
))

(prove-lemma monotonicity-of-insert-aux4 (rewrite) (implies
	(and 
		(ordinalp alpha) (ordinalp beta) (ordinalp delta)
		(ord-lessp delta (car beta))
		(not (equal delta 0))
		(ord-lessp (car alpha) (car beta) )  )
	(ord-lessp (insert delta alpha) (insert delta beta))) 
( ; hints
(do-not-induct T)
(disable ord-leq leq-0)
))

; this concludes the case that delta < (car beta) and (car alpha) < (car beta)
; the remaining case is that delta < (car beta) and (car alpha) = (car beta)
; this should proceed by induction

(defn bad-for-monotonicity-of-insert (alpha beta delta) (and
		(ordinalp alpha) (ordinalp beta) (ordinalp delta)
		(not (equal delta 0))
		(ord-lessp alpha beta) 
		(not (ord-lessp (insert delta alpha) (insert delta beta)))))

(prove-lemma monotonicity-of-insert-aux5 (rewrite) (implies
	(bad-for-monotonicity-of-insert alpha beta delta) 
	(ord-lessp delta (car beta)))
( ; hints
(do-not-induct T)
(disable  insert-is-cons insert
	ordinalp ord-lessp ord-leq leq-0)
))

(prove-lemma monotonicity-of-insert-aux6 (rewrite) (implies
	(bad-for-monotonicity-of-insert alpha beta delta) 
	(not (ord-lessp (car alpha) (car beta) )  ) )
( ; hints
(do-not-induct T)
(use
	(monotonicity-of-insert-aux5 (alpha alpha) (beta beta) (delta delta)))
(disable  insert-is-cons insert monotonicity-of-insert-aux5
	ordinalp ord-lessp ord-leq leq-0)
))

(prove-lemma monotonicity-of-insert-aux7 (rewrite) (implies
	(bad-for-monotonicity-of-insert alpha beta delta) 
	(equal (car alpha) (car beta)   ) )
( ; hints
(do-not-induct T)
(use
	(cars-of-smaller-ordinals (alpha alpha) (beta beta))
	(monotonicity-of-insert-aux6 (alpha alpha) (beta beta) (delta delta)))
(disable  ord-lessp
	insert-is-cons insert monotonicity-of-insert-aux6
	ordinalp ord-leq leq-0)
))

; now we know that any counter-example satisfies
; delta  car alpha = car beta
; so, the insert's start off with delta, and we can use induction

; check that alpha and beta are not numbers

(prove-lemma monotonicity-of-insert-aux8 (rewrite) (implies
	(bad-for-monotonicity-of-insert alpha beta delta) 
	(and (listp alpha) (listp beta)))
( ; hints
(do-not-induct T)
(use
	(monotonicity-of-insert-aux5 (alpha alpha) (beta beta) (delta delta))
	(monotonicity-of-insert-aux7 (alpha alpha) (beta beta) (delta delta)))
(disable  
	insert-is-cons insert monotonicity-of-insert-aux7 
	bad-for-monotonicity-of-insert
	monotonicity-of-insert-aux5
	ordinalp ord-leq leq-0)
))

(prove-lemma monotonicity-of-insert-aux9 (rewrite) (implies
	(bad-for-monotonicity-of-insert alpha beta delta) 
	(bad-for-monotonicity-of-insert (cdr alpha) (cdr beta) delta) )
( ; hints
(do-not-induct T)
(use
	(insert-is-an-ordinal (delta delta) (alpha (cdr alpha)))
	(insert-is-an-ordinal (delta delta) (alpha (cdr beta)))
	(monotonicity-of-insert-aux5 (alpha alpha) (beta beta) (delta delta))
	(monotonicity-of-insert-aux7 (alpha alpha) (beta beta) (delta delta)))
(disable ordinalp insert  monotonicity-of-insert-aux3 
	monotonicity-of-insert-aux4 car-of-insert-A 
	car-of-insert-C car-of-insert-B
	insert-is-cons monotonicity-of-insert-aux7 monotonicity-of-insert-aux5
	ordinalp ord-leq leq-0)
))

(defn monotonicity-of-insert-kludge (alpha beta) (if
	(and (listp alpha) (listp beta))
	(monotonicity-of-insert-kludge (cdr alpha) (cdr beta))
	0 ))

(prove-lemma monotonicity-of-insert-aux10 (rewrite) (not
	(bad-for-monotonicity-of-insert alpha beta delta))
( ; hints
(disable bad-for-monotonicity-of-insert)
(induct (monotonicity-of-insert-kludge alpha beta)) 
))

(prove-lemma monotonicity-of-insert (rewrite) (implies
	(and 
		(ordinalp alpha) (ordinalp beta) (ordinalp delta)
		(not (equal delta 0))
		(ord-lessp alpha beta) )
	(ord-lessp (insert delta alpha) (insert delta beta)))
( ; hints
(do-not-induct T)
(use (monotonicity-of-insert-aux10 (alpha alpha) (beta beta) (delta delta)))
(disable ordinalp ord-lessp monotonicity-of-insert-aux10)
))

(disable monotonicity-of-insert-aux1)
(disable monotonicity-of-insert-aux2)
(disable monotonicity-of-insert-aux3)
(disable monotonicity-of-insert-aux4)
(disable monotonicity-of-insert-aux5)
(disable monotonicity-of-insert-aux6)
(disable monotonicity-of-insert-aux7)
(disable monotonicity-of-insert-aux8)
(disable monotonicity-of-insert-aux9)
(disable monotonicity-of-insert-aux10)
(disable monotonicity-of-insert-kludge)
(disable bad-for-monotonicity-of-insert)

; now, we can prove monotonicity of sharp

(prove-lemma monotonicity-of-sharp (rewrite) (implies
	(and 
		(ordinalp alpha) (ordinalp beta) (ordinalp lambda)
		(ord-lessp alpha beta) )
	(ord-lessp (sharp alpha lambda) (sharp beta lambda))) 
( ; hints
(induct (sharp alpha lambda))
(disable ord-leq
	insert-is-cons insert-small-ordinal
	leq-0 insert ord-leq)
))


;;;;;;;  disable a bunch of stuff --  these are causing
;;;; a lot of trouble by firing when we don't want them to:
(disable ord-lessp)
(disable ord-leq)
(disable leq-0)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                          NORMS AND PRED                                ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;   norms = count ; 
(defn norm (x) (count x))
; This defn is just so that we can disable norm without disabling count

(prove-lemma norm-is-a-number (rewrite) (numberp (norm x)))

(prove-lemma norm-of-a-number (rewrite) (implies
	(numberp n)
	(equal (norm n) n)))

(prove-lemma norm-of-successor (rewrite) (implies 
	(ordinalp alpha)
	(equal (norm (successor alpha))  (add1 (norm alpha))) ))

(prove-lemma norm-of-predecessor (rewrite) (implies
	(and (ordinalp alpha) (successorp alpha))
	(equal (norm (predecessor alpha)) (sub1 (norm alpha))) )  
( ;  hints
(do-not-induct T)
(use 
	(norm-of-successor (alpha (predecessor alpha))) )
))

(prove-lemma norm-of-cons (rewrite) (implies
	(listp alpha)
	(equal (norm alpha) (add1 (plus 
		(norm (car alpha)) (norm (cdr alpha))  )))))

(prove-lemma norm-non-zero (rewrite) (implies
	(listp alpha)
	(not (equal (norm alpha) 0)))
( ; hints
(use
	(norm-of-cons (alpha alpha))
	(norm-is-a-number (x (car alpha)))
	(norm-is-a-number (x (cdr alpha))) )
(disable norm-of-cons norm-is-a-number )
))

(disable norm)

; now, (norm-up-to n) will contain all ordinals with
; norm n or below, plus a lot of other stuff

(defn norm-up-to (n) (if (zerop n)
	(list 0)
	(append 
		(segment 0 n)
		(product (norm-up-to (sub1 n)) (norm-up-to (sub1 n)) ) )))

(prove-lemma norm-up-to-big-enuf-aux1 (rewrite) (implies
	(and (ordinalp alpha) (leq (norm alpha) n) (nlistp alpha))
	(member alpha (norm-up-to n))))

; now, we just consider (listp alpha)

(prove-lemma norm-up-to-big-enuf-aux2 (rewrite) (implies
	(and (listp alpha) (leq (norm alpha) n))
	(not (zerop n))) )

(prove-lemma norm-up-to-big-enuf-aux3 (rewrite) (implies
	(and (ordinalp alpha) (leq (norm alpha) n) (zerop n))
	(member alpha (norm-up-to n)))
( ; hints
(do-not-induct T)
(use (norm-non-zero (alpha alpha)))
(disable norm-up-to norm-non-zero)
))

(prove-lemma norm-up-to-big-enuf-aux4 (rewrite) (implies
	(and (member x (norm-up-to n)) (member y (norm-up-to n)))
	(member (cons x y) (norm-up-to (add1 n)))))

(disable norm-up-to)

(disable norm-of-cons)   ; needed for next defn to work
(defn norm-up-to-big-enuf-kludge (alpha n) (if
	(and (listp alpha) (not (zerop n)))
	(plus
		(norm-up-to-big-enuf-kludge (car alpha) (sub1 n))
		(norm-up-to-big-enuf-kludge (cdr alpha) (sub1 n)) )
	0 ) )
(enable norm-of-cons)

(defn bad-for-norm-up-to-big-enuf (alpha n) (and
	(ordinalp alpha) (leq (norm alpha) n)
	(not (member alpha (norm-up-to n)))))

(prove-lemma norm-up-to-big-enuf-aux5 (rewrite) (implies
	(bad-for-norm-up-to-big-enuf alpha n) 
	(and (listp alpha) (not (zerop n)))) )

(prove-lemma norm-up-to-big-enuf-aux6 (rewrite) (implies
	(and
		(listp alpha) (not (zerop n))
		(not (bad-for-norm-up-to-big-enuf (car alpha)  (sub1 n)))
		(not (bad-for-norm-up-to-big-enuf (cdr alpha)  (sub1 n))) )
	(not (bad-for-norm-up-to-big-enuf alpha  n))) 
( ; hints
(do-not-induct T)
(use (norm-up-to-big-enuf-aux4 (x (car alpha)) (y (cdr alpha)) (n  (sub1 n))))
(disable norm-up-to-big-enuf-aux4 ordinalp)
))

(prove-lemma norm-up-to-big-enuf-aux7 (rewrite) (not
	(bad-for-norm-up-to-big-enuf alpha n))
( ; hints
(disable bad-for-norm-up-to-big-enuf)
(induct (norm-up-to-big-enuf-kludge alpha n))
))

(prove-lemma norm-up-to-big-enuf (rewrite) (implies
	(and (ordinalp alpha) (leq (norm alpha) n))
	(member alpha (norm-up-to n)))
( ; hints
(use (norm-up-to-big-enuf-aux7 (alpha alpha) (n n)))
(disable  norm-up-to-big-enuf-aux7)
))

(disable norm-up-to-big-enuf-aux1)
(disable norm-up-to-big-enuf-aux2)
(disable norm-up-to-big-enuf-aux3)
(disable norm-up-to-big-enuf-aux4)
(disable norm-up-to-big-enuf-aux5)
(disable norm-up-to-big-enuf-aux6)
(disable norm-up-to-big-enuf-aux7)
(disable norm-up-to-big-enuf-kludge)
(disable bad-for-norm-up-to-big-enuf)

;;;; norm of sharp
; prove that the norm of alpha # beta is the sum of the norms

(prove-lemma norm-of-num-sharp (rewrite) (implies
	(and (ordinalp alpha) (numberp n))
	(equal (norm (num-sharp alpha n)) (plus (norm alpha) (norm n)))))


(prove-lemma norm-of-insert (rewrite) (implies
	(ordinalp alpha)
	(equal 
		(norm (insert delta alpha))
		(add1 (plus (norm delta) (norm alpha))))))

(prove-lemma norm-of-sharp (rewrite) (implies
	(and (ordinalp alpha) (ordinalp beta))
	(equal (norm (sharp alpha beta)) (plus (norm alpha) (norm beta)))))

;;;;;;;;;;;;;;;;;;  (pred alpha n)  = {alpha}(n)
; this is 0 if alpha = 0   ; otherwise, it's the largest ordinal
;   beta < alpha such that (norm beta) <= (norm alpha) + magic(n)

; first, define (max-below alpha lst) to be the largest ordinal in lst
; of norm <= n
; which is less than alpha.  Define it to be 0 in the default cases.

(defn max-below (alpha lst n) (if (listp lst)
	(if 
		(and 
			(ordinalp (car lst))
			(leq (norm (car lst)) n)
			(ord-lessp (max-below alpha (cdr lst) n) (car lst))
			(ord-lessp (car lst) alpha) )
		(car lst)
		(max-below alpha (cdr lst) n)     )
	0 ))

; let's prove the basic properties of this and then disable it

(prove-lemma max-below-is-an-ordinal (rewrite) 
	(ordinalp (max-below alpha lst n)))

(prove-lemma max-below-is-below (rewrite) (implies
	(ord-lessp 0 alpha)
	(ord-lessp (max-below alpha lst n) alpha) )  )

(prove-lemma max-below-is-max (rewrite) (implies
	(and
		(ordinalp beta)
		(leq (norm beta) n)
		(member beta lst)
		(ord-lessp beta alpha))
	(not (ord-lessp (max-below alpha lst n) beta))  ))

(prove-lemma norm-of-max-below () (leq
	(norm (max-below alpha lst n)) n))

(enable ord-lessp)
(prove-lemma max-below-of-0 (rewrite) (equal
	(max-below 0 lst n) 0))
(disable ord-lessp)

(disable max-below)  ; we just need its properties

; now, we want to define {alpha}(n) = the largest
; ordinal < alpha with norm <= norm(alpha) + magic(n)
; The basic properties of magic have been derived in the 
; beginning arithmetic section

(defn pred (alpha n) (max-below 
	alpha 
	(norm-up-to (plus (norm alpha) (magic  n)))
	(plus (norm alpha) (magic  n)) ))

; let's prove the basic properties of this and then disable it
; that is -- (pred 0 n) = 0
; if alpha > 0, then (pred alpha n) < alpha and is the largest
; ordinal < alpha whose norm <= (norm alpha) + magic(n)

(prove-lemma pred-of-0 (rewrite) (equal (pred 0 n) 0))

(prove-lemma pred-is-below (rewrite) (implies
	(ord-lessp 0 alpha)
	(ord-lessp (pred alpha n) alpha) ) )

(prove-lemma pred-is-an-ordinal (rewrite) 
	(ordinalp (pred alpha n)))

(prove-lemma upper-bound-on-norm-of-pred () 
	(leq
		(norm (pred alpha n))
		(plus (norm alpha) (magic n))  ) 
( ; hints
(do-not-induct T)
(use 
	(norm-of-max-below (alpha alpha) (n (plus (norm alpha) (magic n))) 
		(lst (norm-up-to (plus (norm alpha) (magic  n))) )) )
))

(prove-lemma pred-is-largest (rewrite) (implies
	(and 
		(ordinalp alpha) 
		(ordinalp beta)
		(leq (norm beta) (plus (norm alpha) (magic n)))
		(ord-lessp beta alpha)  )
	(ord-leq beta (pred alpha n)))
( ; hints
(do-not-induct T)
(use 
	(max-below-is-max (alpha alpha) (beta beta) 
		(n (plus (norm alpha) (magic  n)))
		(lst (norm-up-to (plus (norm alpha) (magic  n)))) )
	(norm-up-to-big-enuf (alpha beta) (n (plus (norm alpha) (magic  n)))) )
(disable norm-up-to-big-enuf max-below-is-max)
(enable ord-leq)
))

(disable pred)

; let's compute the norm of (pred alpha n) when alpha is a limit.

(enable ord-lessp)
(prove-lemma pred-below-limit (rewrite) (implies
	(and (ordinalp alpha) (limitp alpha))
	(ord-lessp (pred alpha n) alpha)))
(disable ord-lessp)

(prove-lemma norm-of-pred-of-limit-aux1 (rewrite) (implies
	(and (ordinalp alpha) (limitp alpha))
	(ord-lessp (successor (pred alpha n)) alpha)))

(prove-lemma norm-of-pred-of-limit-aux2 (rewrite) (implies
	(and (ordinalp alpha) (limitp alpha))
	(lessp 
		(plus (norm alpha) (magic  n))
		(norm (successor (pred alpha n))) ) )  
( ; hints
(do-not-induct T)
(use
	(pred-is-largest (alpha alpha) (beta (successor (pred alpha n)))) )
(disable pred-is-largest norm-of-cons)
(enable ord-leq)
))

(prove-lemma norm-of-pred-of-limit-aux3 (rewrite) (implies
	(and (ordinalp alpha) (limitp alpha))
	(lessp 
		(plus (norm alpha) (magic  n))
		(add1 (norm (pred alpha n))) ) )
( ; hints
(do-not-induct T)
(use
	(norm-of-pred-of-limit-aux2 (alpha alpha) (n n))
	(norm-of-successor (alpha (pred alpha n)))      )
(disable  ordinalp norm-of-successor limitp norm-of-cons)
))

(prove-lemma norm-of-pred-of-limit (rewrite) (implies
	(and (ordinalp alpha) (limitp alpha))
	(equal
		(norm (pred alpha n))
		(plus (norm alpha) (magic  n))  ))    
( ; hints
(do-not-induct T)
(use 
	(upper-bound-on-norm-of-pred (alpha alpha) (n n))
	(norm-of-pred-of-limit-aux3 (alpha alpha) (n n)) )
(disable norm-of-pred-of-limit-aux3  ordinalp limitp norm-of-cons)
))

(disable norm-of-pred-of-limit-aux1)
(disable norm-of-pred-of-limit-aux2)
(disable norm-of-pred-of-limit-aux3)

; now, consider (pred alpha n) for successor alpha

(prove-lemma pred-of-succ-aux1 (rewrite) (implies
	(and (ordinalp alpha) (successorp alpha))
	(ord-lessp (pred alpha n) alpha))  )

(prove-lemma pred-of-succ-aux2 (rewrite) (implies
	(and (ordinalp alpha) (successorp alpha))
	(ord-leq (pred alpha n) (predecessor alpha)) )  
( ; hints
(do-not-induct T)
(use
	(nothing-between (alpha (predecessor alpha)) (beta (pred alpha n)))
	(pred-of-succ-aux1 (alpha alpha) (n n)) )
(disable pred-of-succ-aux1)
(enable ord-leq)
))

(prove-lemma pred-of-succ-aux3 () (implies
	(and (ordinalp alpha) (successorp alpha))
	(leq 
		(norm (predecessor alpha)) 
		(plus (norm alpha) (magic n)) )))

(prove-lemma pred-of-succ-aux4 () (implies
	(and (ordinalp alpha) (successorp alpha))
	(ord-leq (predecessor alpha) (pred alpha n)))
( ;hints
(use (pred-of-succ-aux3 (alpha alpha) (n n)))
))

(prove-lemma pred-of-succ (rewrite) (implies
	(and (ordinalp alpha) (successorp alpha))
	(equal (pred alpha n) (predecessor alpha)))  
( ;  hints
(do-not-induct T)
(use 
	(pred-of-succ-aux2 (n n) (alpha alpha))
	(pred-of-succ-aux4 (n n) (alpha alpha)) )
(disable  predecessor-is-smaller norm-of-predecessor
	pred-of-succ-aux4 pred-of-succ-aux2 ordinalp)
(enable irreflex-of-ord-leq)
))

(disable  pred-of-succ-aux1)
(disable  pred-of-succ-aux2)
(disable  pred-of-succ-aux3)
(disable  pred-of-succ-aux4)

(prove-lemma norm-of-pred-of-succ (rewrite) (implies
	(and (ordinalp alpha) (successorp alpha))
	(equal (norm (pred alpha n)) (sub1 (norm alpha)))  ))

; now, by cases {alpha}(n) has norm at least ||alpha||-1 for all alpha

(prove-lemma lower-bound-on-norm-of-pred (rewrite) (implies 
	(ordinalp alpha)
	(not (lessp 
		(norm (pred alpha n)) 
		(sub1 (norm alpha)))) )
(; hints
(do-not-induct T)
(use 
	(three-kinds (alpha alpha)) )
(disable ordinalp limitp)
))


;;;;;;;;; pred of a sharp

; if beta > 0,
; we show:  alpha # {beta}(n) <= {alpha # beta}(n)
; the proof is
; 1.  alpha # {beta}(n) < alpha # beta by monotonicity of #
; 2.  norm(alpha # {beta}(n)) <= norm(alpha # beta) + magic(n)
; 3. Result follows by lemma "pred-is-largest"

; step 1

(prove-lemma pred-sharp-below (rewrite) (implies
	(and 
		(ordinalp alpha) (ordinalp beta)
		(ord-lessp 0 beta))
	(ord-lessp 
		(sharp alpha (pred beta n))
		(sharp alpha beta) ))
( ; hints
(do-not-induct T)
(use
	(monotonicity-of-sharp 
		(alpha (pred beta n)) (beta beta) (lambda alpha))
	(pred-is-below (alpha beta) (n n))   )
(disable ordinalp pred-is-below monotonicity-of-sharp)
))

; step 2

(prove-lemma norm-of-pred-sharp () (implies
	(and 
		(ordinalp alpha) (ordinalp beta) (numberp n ) )
	(leq
		(norm (sharp alpha (pred beta n)))
		(plus (norm (sharp alpha beta)) (magic n)))  )
( ; hints
(do-not-induct T)
(use 
	(upper-bound-on-norm-of-pred (alpha beta) (n n)))
))

; step 3

(prove-lemma pred-sharp () (implies
	(and 
		(ordinalp alpha) (ordinalp beta) (numberp n ) (ord-lessp 0 beta) )
	(ord-leq
		(sharp alpha (pred beta n))
		(pred (sharp alpha beta) n) )  )
( ; hints
(do-not-induct T)
(use 
	(norm-of-pred-sharp (alpha alpha) (beta beta) (n n)))
))


;;;;;;;;  monotonicity of pred

; {alpha}(n) is a monotonic function of n

; first, a trivial fact about ord-leq

(enable ord-leq)
(prove-lemma ord-leq-is-idempotent (rewrite) 
	(ord-leq x x))
(disable ord-leq)

(prove-lemma monot-of-pred-aux1 (rewrite) (implies 
	(and 
		(ord-lessp 0 alpha)
		(ordinalp alpha) (numberp m) (numberp n) (leq m n))
	(ord-leq (pred alpha m) (pred alpha n)))
( ; hints
(do-not-induct T)
(use
	(magic-is-monotonic (m m) (n n))
	(upper-bound-on-norm-of-pred (alpha alpha) (n m))
	(pred-is-largest (n n) (alpha alpha) (beta (pred alpha m)) )  )
(disable magic-is-monotonic
	pred-is-largest upper-bound-on-norm-of-pred ordinalp)
))
		
(prove-lemma monot-of-pred-aux2 (rewrite) (implies 
	(and 
		(not (ord-lessp 0 alpha))
		(ordinalp alpha) (numberp m) (numberp n) (leq m n))
	(ord-leq (pred alpha m) (pred alpha n)))
( ; hints
(use
	(pred-of-0 (alpha alpha) (n n))
	(pred-of-0 (alpha alpha) (n m)) )
(disable pred-of-0)
(enable ord-lessp)
(do-not-induct T)
))

(prove-lemma monot-of-pred (rewrite) (implies 
	(and 
		(ordinalp alpha) (numberp m) (numberp n) (leq m n))
	(ord-leq (pred alpha m) (pred alpha n))) 
( ; hints
(do-not-induct T)
(use
	(monot-of-pred-aux1 (alpha alpha) (m m) (n n))
	(monot-of-pred-aux2 (alpha alpha) (m m) (n n)) )
(disable monot-of-pred-aux1 monot-of-pred-aux2 ordinalp )
))

(disable monot-of-pred-aux1)
(disable monot-of-pred-aux2)

; the norm of pred is also monotonic
; we can prove this by cases -- successor, limit, 0

(prove-lemma monot-of-norm-of-pred-aux1 (rewrite) (implies 
	(and 
		(equal alpha 0)
		(ordinalp alpha) (numberp m) (numberp n) (leq m n))
	(not (lessp (norm (pred alpha n)) (norm (pred alpha m)))) ))

(prove-lemma monot-of-norm-of-pred-aux2 (rewrite) (implies 
	(and 
		(limitp alpha)
		(ordinalp alpha) (numberp m) (numberp n) (leq m n))
	(not (lessp (norm (pred alpha n)) (norm (pred alpha m)))) )
( ; hints
(do-not-induct T)
(use (magic-is-monotonic (m m) (n n)))
(disable limitp magic-is-monotonic)
))

(prove-lemma monot-of-norm-of-pred-aux3 (rewrite) (implies 
	(and 
		(successorp alpha)
		(ordinalp alpha) (numberp m) (numberp n) (leq m n))
	(not (lessp (norm (pred alpha n)) (norm (pred alpha m)))) ))

(prove-lemma monot-of-norm-of-pred (rewrite) (implies 
	(and 
		(ordinalp alpha) (numberp m) (numberp n) (leq m n))
	(not (lessp (norm (pred alpha n)) (norm (pred alpha m)))) )
( ; hints
(do-not-induct T)
(use (three-kinds (alpha alpha)))
(disable norm-of-pred-of-succ limitp
	norm-of-pred-of-limit
	ordinalp three-kinds pred-of-0 pred-of-succ )
))

(disable monot-of-norm-of-pred-aux1)
(disable monot-of-norm-of-pred-aux2)
(disable monot-of-norm-of-pred-aux3)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                           O-LARGE SETS                                 ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; We define the notion :  X is alpha-large
; It is intended that X is a set in standard form, so the car is the min
; Largep was the Paris-Harrington defn of large; 
; o-largep is ordinal version

(defn o-largep (set alpha) (if (equal alpha 0)
	T
	(if (nlistp set)
		F
		(o-largep (cdr set) (pred alpha (car set))))))

; prove the basic properties and then disable the defn

; base cases

(prove-lemma all-zero-large (rewrite) 
	(o-largep set 0))

(prove-lemma empty-not-large (rewrite) (implies
	(and (not (equal alpha 0)) (nlistp set))
	(not (o-largep set alpha))))

(prove-lemma recursive-case-for-large (rewrite) (implies
	(and (listp set) (not (equal alpha 0)))
	(equal
		(o-largep set alpha)
		(o-largep (cdr set) (pred alpha (car set))))))

(prove-lemma positive-large (rewrite) (implies
	(and (ordinalp alpha) (not (o-largep set alpha)))
	(ord-lessp 0 alpha))
( ;  hints
(enable ord-lessp)
))

(disable o-largep)


; lookat alpha-large when alpha is a successor ordinal

(prove-lemma successor-large-non-empty (rewrite) (implies
	(and (ordinalp alpha) (successorp alpha) (not (listp set)))
	(not (o-largep set alpha))))

(prove-lemma successor-large (rewrite) (implies
	(and (ordinalp alpha) (successorp alpha))
	(equal
		(o-largep set alpha)
		(and
			(listp set)
			(o-largep (cdr set) (predecessor alpha)))))
( ; hints
(do-not-induct T)
(use
	(recursive-case-for-large (set set) (alpha alpha)) )
(disable recursive-case-for-large)
))

; lookat n-large for numbers n

(prove-lemma number-large (rewrite) (implies
	(numberp n)
	(equal
		(o-largep set n)
		(leq n (length set) ))) 
( ; hints
(induct (o-largep set n))
))

;;;;;;;;;;;;  omega
; more on omega = '(1 . 0)
; we want to discuss  omega-large -- but first
; we need to discuss {omega}(n) = magic(n) + 2

(prove-lemma omega-is-a-limit (rewrite) 
	(limitp '(1 . 0)))

(enable ord-lessp)
(prove-lemma numbers-below-omega (rewrite)  (implies
	(and (ordinalp alpha) (ord-lessp alpha '(1 . 0)))
	(numberp alpha)))
(disable ord-lessp)

(prove-lemma pred-of-omega-aux1 (rewrite)
	(numberp (pred '(1 . 0) n)))

(prove-lemma pred-of-omega-aux2 (rewrite) (implies
	(numberp n)
	(equal (norm (pred '(1 . 0) n))  (plus (magic n) 2))))

(prove-lemma pred-of-omega (rewrite) (implies
	(numberp n)
	(equal (pred '(1 . 0) n)  (plus (magic n) 2)))
( ; hints
(do-not-induct T)
(use 
	(pred-of-omega-aux2 (n n))
	(norm-of-pred-of-limit (alpha '(1 . 0)) (n n))
	(norm-of-a-number (n (pred '(1 . 0) n)))   )
(disable  limitp ordinalp
	pred-of-omega-aux2 norm-of-a-number norm-of-pred-of-limit)
))

(disable pred-of-omega-aux1)
(disable pred-of-omega-aux2)

; now, consider omega-large -- here
; we use (setp set) -- so we know that (car set) is a number

(enable setp)
(prove-lemma car-of-a-set (rewrite) (implies
	(setp (cons x tail))
	(numberp x)))
(disable setp)

(prove-lemma omega-large ()  (implies
	(and (setp set) (o-largep set '(1 . 0)) )
	(and
		(listp set)
		(leq (plus (magic (car set)) 3) (length set)))) ) 

; in particular, omega-large implies large in the Paris-Harrington sense:
(prove-lemma omega-large-implies-large () (implies
	(and (setp set) (o-largep set '(1 . 0)))
	(largep set) ))


;;;;;;;;; let's see what it means for a singleton to be alpha-large
; this can only happen for alpha = 0 or 1
; First, note that {alpha}(n) = 0 implies alpha is 0 or 1

(prove-lemma norm-above-1-aux1 (rewrite) (implies
	(and (numberp alpha) (ord-lessp 1 alpha) (ordinalp alpha))
	(lessp 1 (norm alpha)) ))

(enable norm)
(enable ord-lessp)
(prove-lemma norm-above-1-aux2 (rewrite) (implies
	(and (not (numberp alpha)) (ord-lessp 1 alpha) (ordinalp alpha))
	(lessp 1 (norm alpha)) ))
(disable norm)
(disable ord-lessp)

(prove-lemma norm-above-1 (rewrite) (implies
	(and  (ord-lessp 1 alpha) (ordinalp alpha))
	(lessp 1 (norm alpha)) )
( ; hints
(do-not-induct T)
(use 
	(norm-above-1-aux1 (alpha alpha))
	(norm-above-1-aux2 (alpha alpha)) )
))

(disable norm-above-1-aux1)
(disable norm-above-1-aux2)

(prove-lemma pred-not-0 (rewrite) (implies
	(and (ord-lessp 1 alpha) (ordinalp alpha))
	(ord-leq 1 (pred alpha n)))
( ; hints
(do-not-induct T)
(use (pred-is-largest (n n) (beta 1) (alpha alpha)))
(disable pred-is-largest ordinalp)
))

(prove-lemma singletons-not-large (rewrite) (implies
	(and 
		(o-largep set alpha)
		(ordinalp alpha)
		(ord-lessp 1 alpha) )
	(listp (cdr set))  )  ; set isn't a singleton
( ; hints
(do-not-induct T)
(use (pred-not-0 (alpha alpha) (n (car set))))
(disable  pred-is-largest norm-above-1
	pred-not-0  recursive-case-for-large empty-not-large)
(enable o-largep)
))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                      O-LARGE AND SUBSETS                               ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; The main fact here is:  Let x = min(X) = car(X).
; If X is beta-large, alpha <= beta, X is a subset of Y
; and norm(alpha) <= norm(beta) + magic(x),
; then Y is alpha-large.
; This is true even if X is empty, since then beta = alpha = 0
; (and x = car(nil) = 0)

(defn bad-for-large-superset-ord (alpha beta X Y) (and
		(ordinalp alpha) (ordinalp beta) 
		(setp X) (setp Y) (subsetp X Y)
		(o-largep X beta)
		(ord-leq alpha beta) 
		(leq (norm alpha) (plus (norm beta) (magic (car X))) )
		(not (o-largep Y alpha))) )

; we want to show this can't happen.  
; first, some base cases

(prove-lemma large-superset-ord-aux1 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(ord-lessp 0 alpha))
( ; hints
(enable ord-lessp)
))

(prove-lemma large-superset-ord-aux2 () (implies
	(and  (ordinalp alpha) (ordinalp beta)
		(ord-lessp 0 alpha) (ord-leq alpha beta))
	(ord-lessp 0 beta))
( ; hints
(do-not-induct T)
(enable ord-leq)
(use 
	(trichotomy (sigma alpha) (tau beta)))
))

(prove-lemma large-superset-ord-aux3 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(ord-lessp 0 beta)) 
( ; hints
(do-not-induct T)
(use 
	(large-superset-ord-aux1 (alpha alpha) (X X) (Y Y) (beta beta))
	(large-superset-ord-aux2 (alpha alpha) (beta beta)) ) 
(disable large-superset-ord-aux1)
))

; so, alpha and beta are larger than 0
; next, check that can't have alpha = beta = 1

(prove-lemma large-superset-ord-aux4 (rewrite) (not
	(bad-for-large-superset-ord 1 1 X Y) ))

; now,  show X can't be a singleton, and alpha > 1

(prove-lemma large-superset-ord-aux5 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(and (ordinalp alpha) (ordinalp beta))))
	
(prove-lemma large-superset-ord-aux6 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(or (ord-lessp 1 alpha) (ord-lessp 1 beta)))
( ; hints
(do-not-induct T)
(use  
	(large-superset-ord-aux1 (alpha alpha) (beta beta) (X X) (Y Y))
	(large-superset-ord-aux3 (alpha alpha) (beta beta) (X X) (Y Y))
	(ords-below-2 (alpha alpha))
	(ords-below-2 (alpha beta)) )
(disable transitivity large-superset-ord-aux1 large-superset-ord-aux3 
	bad-for-large-superset-ord ord-lessp)
))

(prove-lemma large-superset-ord-aux7 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(ord-leq alpha beta)))

(prove-lemma large-superset-ord-aux8 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(ord-lessp 1 beta) )
( ; hints
(do-not-induct T)
(use 
	(large-superset-ord-aux6 (alpha alpha) (beta beta) (X X) (Y Y))
	(transitivity-alt2 (alpha 1) (beta alpha) (gamma beta)))
(disable large-superset-ord-aux6 bad-for-large-superset-ord)
))

(prove-lemma large-superset-ord-aux9 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(listp (cdr X)))
( ; hints
(do-not-induct T)
(use
	(large-superset-ord-aux8  (alpha alpha) (beta beta) (X X) (Y Y)))
(disable large-superset-ord-aux8)
))

; now, we want to show that
; (bad-for-large-superset-ord alpha beta X Y) is always false
; we know it implies alpha > 0, beta > 1, and X, Y are lists (i.e., not empty)
; the induction splits into two cases:

; Case 1:  alpha = beta
; we show (bad-for-large-superset-ord
;        (pred alpha (car Y)) (pred alpha (car X)) (cdr X)  (cdr Y) )
; Case 2: alpha < beta
; we show (bad-for-large-superset-ord
;        alpha (pred beta (car X)) (cdr X)   Y )

; BEGIN Case 1  alpha = beta
; we check the various clauses in bad for
;        (pred alpha (car Y))  (pred alpha (car X)) (cdr X)  (cdr Y) 
; as much as possible, we keep alpha, beta separate
; so the work can be used in Case 2

(prove-lemma large-superset-ord-aux10 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(and  (ordinalp (pred alpha (car Y))) (ordinalp (pred beta (car X))))))

(prove-lemma large-superset-ord-aux11 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(and (listp X) (listp Y)))
( ; hints
(do-not-induct T)
(use (large-superset-ord-aux9 (X X) (Y Y) (alpha alpha) (beta beta)))
))

(prove-lemma large-superset-ord-aux12 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(and (setp (cdr X)) (setp (cdr Y)) ))
( ; hints
(do-not-induct T)
(use
	(large-superset-ord-aux11 (X X) (Y Y) (alpha alpha) (beta beta))
	(tail-of-a-set (s X))
	(tail-of-a-set (s Y))  )
(disable  car-nlistp cdr-nlistp large-superset-ord-aux11
	transitivity-of-subset  large-superset-ord-aux10
	ord-leq-is-idempotent cdr-cdr-subset tail-of-a-set)
))

(prove-lemma large-superset-ord-aux13 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(subsetp (cdr X) (cdr Y)) )
( ; hints
(do-not-induct T)
(use
	(large-superset-ord-aux11 (alpha alpha) (beta beta) (X X) (Y Y) )
	(cdr-cdr-subset (s1 X) (s2 Y))
	(tail-of-a-set (s X))
	(tail-of-a-set (s Y))  )
(disable   IRREFLEX-OF-ORD-LEQ ORD-LEQ-IS-TRANSITIVE
	MIN-IS-FIRST ORD-LEQ CARS-ARE-ORDINALS NUMBERS-BELOW-OMEGA
	transitivity-of-subset  large-superset-ord-aux11
	ord-leq-is-idempotent cdr-cdr-subset tail-of-a-set)
))

(prove-lemma large-superset-ord-aux14 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(o-largep (cdr X) (pred beta (car X))  ))
( ; hints
(do-not-induct T)
(use
	(recursive-case-for-large (set X) (alpha beta))
	(large-superset-ord-aux11 (alpha alpha) (beta beta) (X X) (Y Y) ) )
(disable recursive-case-for-large  large-superset-ord-aux11)
))

(prove-lemma large-superset-ord-aux15 (rewrite) (implies
	(bad-for-large-superset-ord alpha alpha X Y) 
	(ord-leq (pred alpha (car Y)) (pred alpha (car X)))  )
( ; hints
(do-not-induct T)
(use
	(compare-first-elts (s1 X) (s2 Y))
	(large-superset-ord-aux11 (alpha alpha) (beta alpha) (X X) (Y Y) ) )
(disable large-superset-ord-aux11 compare-first-elts)
))

(prove-lemma large-superset-ord-aux16 () (implies
	(bad-for-large-superset-ord alpha alpha X Y) 
	(leq
		(norm (pred alpha (car Y)))
		(plus (norm (pred alpha (car X)))
			(magic (car (cdr X))))))
					; actually, don't need the magic ... here
					; since (car Y) <= (car X)
( ; hints
(do-not-induct T)
(use
	(monot-of-norm-of-pred (alpha alpha) (m (car Y)) (n (car X)))
	(compare-first-elts (s1 X) (s2 Y))
	(large-superset-ord-aux11 (alpha alpha) (beta alpha) (X X) (Y Y) ) )
(disable large-superset-ord-aux11 compare-first-elts)
))

(prove-lemma large-superset-ord-aux17 () (implies
	(bad-for-large-superset-ord alpha alpha X Y) 
	(not (o-largep (cdr Y) (pred alpha (car Y))))  )
( ; hints
(do-not-induct T)
(use
	(recursive-case-for-large (set Y) (alpha alpha))
	(large-superset-ord-aux11 (alpha alpha) (beta alpha) (X X) (Y Y) ) ) 
(disable large-superset-ord-aux11 recursive-case-for-large) 
))

(prove-lemma large-superset-ord-aux18 (rewrite) (implies
	(bad-for-large-superset-ord alpha alpha X Y) 
	(bad-for-large-superset-ord 
		(pred alpha (car Y))
		(pred alpha (car X))
		(cdr X)  (cdr Y) ))
( ; hints
(do-not-induct T)
(use
	(large-superset-ord-aux10 (alpha alpha) (beta alpha) (X X) (Y Y) )  
	(large-superset-ord-aux11 (alpha alpha) (beta alpha) (X X) (Y Y) )  
	(large-superset-ord-aux12 (alpha alpha) (beta alpha) (X X) (Y Y) )  
	(large-superset-ord-aux13 (alpha alpha) (beta alpha) (X X) (Y Y) )  
	(large-superset-ord-aux14 (alpha alpha) (beta alpha) (X X) (Y Y) )  
	(large-superset-ord-aux15 (alpha alpha) (beta alpha) (X X) (Y Y) )  
	(large-superset-ord-aux16 (alpha alpha) (beta alpha) (X X) (Y Y) )  
	(large-superset-ord-aux17 (alpha alpha) (beta alpha) (X X) (Y Y) )  )
(disable  subsetp ord-leq cdr-of-subset subset-of-cdr
	numbers-below-omega pred-is-largest norm cars-are-ordinals
	large-superset-ord-aux10 
	large-superset-ord-aux11 
	large-superset-ord-aux12 
	large-superset-ord-aux13 
	large-superset-ord-aux14 
	large-superset-ord-aux15 
	large-superset-ord-aux16 
	large-superset-ord-aux17 )
))

; END Case 1

; BEGIN  Case 2: alpha < beta
; we check the various requrements for
;  (bad-for-large-superset-ord alpha (pred beta (car X)) (cdr X)   Y)
; alpha and (pred beta (car X)) are ordinals by  the defn of bad and aux10
; (cdr X) and Y are sets by the defn of bad and aux12
; (o-largep (cdr X) (pred beta (car X)))  by aux14
; (not (o-largep Y alpha))  by defn of bad
; next 

(prove-lemma large-superset-ord-aux19 (rewrite) (implies
	(and
		(bad-for-large-superset-ord alpha beta X Y) 
		(ord-lessp alpha beta))
	(ord-leq alpha (pred beta (car X)))))


; finally, we have to use (car X) < (cadr X) with the
; following simple ordinal fact:

(prove-lemma large-superset-ord-aux20 () (implies
	(and
		(ordinalp beta) (numberp v) (numberp z) (lessp v z))
	(leq
		(plus (norm beta) (magic v))
		(plus (norm (pred beta z)) (magic z)))  ))
; we use this with v = (car X) and z = (cadr X)

(prove-lemma large-superset-ord-aux21 () (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(lessp (car X) (cadr X)))
( ; hints
(do-not-induct T)
(use
	(large-superset-ord-aux9 (alpha alpha) (beta beta) (X X) (Y Y)))
))

(prove-lemma large-superset-ord-aux22 () (implies
	(and
		(bad-for-large-superset-ord alpha beta X Y) 
		(ord-lessp alpha beta))
	(leq 
		(norm alpha)
		(plus (norm (pred beta (car X))) (magic (car (cdr X))))) )
( ; hints
(do-not-induct T)
(use
	(large-superset-ord-aux21 (alpha alpha) (beta beta) (X X) (Y Y))
	(large-superset-ord-aux20 (beta beta) (v (car X)) (z (cadr X)))   )
))

(prove-lemma large-superset-ord-aux23 () (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(subsetp (cdr X) Y) )
( ; hints
(do-not-induct T)
(use (cdr-is-subset (s X)))
(disable cdr-is-subset)
))

(prove-lemma large-superset-ord-aux24 () (implies
	(and
		(bad-for-large-superset-ord alpha beta X Y) 
		(ord-lessp alpha beta))
	(bad-for-large-superset-ord 
		alpha (pred beta (car X))
		(cdr X)   Y) )
( ; hints
(do-not-induct T)
(use
	(large-superset-ord-aux23 (alpha alpha) (beta beta) (X X) (Y Y)) 
	(large-superset-ord-aux10 (alpha alpha) (beta beta) (X X) (Y Y)) 
	(large-superset-ord-aux12 (alpha alpha) (beta beta) (X X) (Y Y)) 
	(large-superset-ord-aux14 (alpha alpha) (beta beta) (X X) (Y Y)) 
	(large-superset-ord-aux19 (alpha alpha) (beta beta) (X X) (Y Y)) 
	(large-superset-ord-aux22 (alpha alpha) (beta beta) (X X) (Y Y)) )
(disable 
	large-superset-ord-aux23
	large-superset-ord-aux10 
	large-superset-ord-aux11 
	large-superset-ord-aux12 
	large-superset-ord-aux14 
	large-superset-ord-aux19 
	large-superset-ord-aux22 )
))

; END Case 2

; now, we should show that case 1 or case 2 holds

(prove-lemma large-superset-ord-aux25 () (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(or
		(ord-lessp alpha beta)
		(equal alpha beta)))
( ; hints
(do-not-induct T)
(use (trichotomy (sigma alpha) (tau beta)))
(enable ord-leq)
))

(disable large-superset-ord-aux1)
(disable large-superset-ord-aux2)
(disable large-superset-ord-aux3)
(disable large-superset-ord-aux4)
(disable large-superset-ord-aux5)
(disable large-superset-ord-aux6)
(disable large-superset-ord-aux7)
(disable large-superset-ord-aux8)
(disable large-superset-ord-aux9)
(disable large-superset-ord-aux10)
(disable large-superset-ord-aux11)
(disable large-superset-ord-aux12)
(disable large-superset-ord-aux13)
(disable large-superset-ord-aux14)
(disable large-superset-ord-aux15)
(disable large-superset-ord-aux16)
(disable large-superset-ord-aux17)
(disable large-superset-ord-aux18)
(disable large-superset-ord-aux19)
(disable large-superset-ord-aux21)
(disable large-superset-ord-aux22)
(disable large-superset-ord-aux23)
(disable large-superset-ord-aux24)
(disable large-superset-ord-aux25)

; summarizing

(prove-lemma large-superset-ord-aux26 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(or
		(bad-for-large-superset-ord 
			alpha (pred beta (car X))
			(cdr X)   Y) 
		(bad-for-large-superset-ord 
			(pred alpha (car Y))
			(pred alpha (car X))
			(cdr X)  (cdr Y) )    )  )
( ; hints
(do-not-induct T)
(use
	(large-superset-ord-aux24 (alpha alpha) (beta beta) (X X) (Y Y))
	(large-superset-ord-aux25 (alpha alpha) (beta beta) (X X) (Y Y))
	(large-superset-ord-aux18 (alpha alpha)  (X X) (Y Y)) )
(disable bad-for-large-superset-ord)  
))

(prove-lemma large-superset-ord-aux27 (rewrite) (implies
	(bad-for-large-superset-ord alpha beta X Y) 
	(listp X) )
( ; hints
(do-not-induct T)
(use
	(large-superset-ord-aux9 (alpha alpha) (beta beta) (X X) (Y Y)) )
(disable bad-for-large-superset-ord)  
))

(defn large-superset-ord-kludge (alpha beta X Y) (if (nlistp X)
	0
	(plus
		(large-superset-ord-kludge 
			alpha (pred beta (car X))
            (cdr X)   Y)
		(large-superset-ord-kludge 
			(pred alpha (car Y))
			(pred alpha (car X))
			(cdr X)  (cdr Y) )    )  ) )

(prove-lemma large-superset-ord-aux28 (rewrite) (implies
	(and
		(not (bad-for-large-superset-ord 
			alpha (pred beta (car X))
			(cdr X)   Y)  )
		(not (bad-for-large-superset-ord 
			(pred alpha (car Y))
			(pred alpha (car X))
			(cdr X)  (cdr Y) )    )  )
	(not (bad-for-large-superset-ord alpha beta X Y)  )  )
( ; hints
(do-not-induct T)
(use (large-superset-ord-aux26 (alpha alpha) (beta beta) (X X) (Y Y)))
(disable bad-for-large-superset-ord large-superset-ord-aux26)  
))

(prove-lemma large-superset-ord-aux29 (rewrite) 
	(not (bad-for-large-superset-ord alpha beta X Y) ) 
( ; hints
(induct (large-superset-ord-kludge alpha beta X Y))
(disable bad-for-large-superset-ord)  
))

(prove-lemma large-superset-ord (rewrite) (implies
	(and
		(ordinalp alpha) (ordinalp beta) 
		(setp X) (setp Y) (subsetp X Y)
		(o-largep X beta)
		(ord-leq alpha beta) 
		(leq (norm alpha) (plus (norm beta) (magic (car X))) ) )
	(o-largep Y alpha))
( ; hints
(do-not-induct T)
(use (large-superset-ord-aux29 (alpha alpha) (beta beta) (X X) (Y Y)))
(disable large-superset-ord-aux29)
))

(disable large-superset-ord-aux26)
(disable large-superset-ord-aux27)
(disable large-superset-ord-aux28)
(disable large-superset-ord-aux29)
(disable large-superset-ord-kludge)


;;;;;;;; two important special cases

; Special case 1 -- alpha = beta

(prove-lemma large-goes-up (rewrite) (implies
	(and
		(ordinalp alpha) 
		(setp X) (setp Y) (subsetp X Y)
		(o-largep X alpha) )
	(o-largep Y alpha)) 
( ; hints
(do-not-induct T)
(use (large-superset-ord (alpha alpha) (beta alpha) (X X) (Y Y)))
))

; Special case 2 -- X = Y

(prove-lemma subsetp-is-idempotent (rewrite) (subsetp s s)
( ; hints
(use (subsetp-works-2 (s1 s) (s2 s)))
(disable subsetp-works-2)
))

(prove-lemma large-with-smaller-ord (rewrite) (implies
	(and
		(ordinalp alpha) (ordinalp beta) 
		(setp X) 
		(o-largep X beta)
		(ord-leq alpha beta) 
		(leq (norm alpha) (plus (norm beta) (magic (car X))) ) )
	(o-largep X alpha))  
( ; hints
(do-not-induct T)
(use (large-superset-ord (alpha alpha) (beta beta) (X X) (Y X)) )
))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                              PIGEON-2                                  ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; this is the two-set pigeon-hole principle:
; if X is a subset of A union B, and X is alpha # beta-large
; then A is alpha-large or B is beta-large

;;;;;; covers
; Rather than define union, we just define what it means
; for A union B to cover X

(defn covers (A B X) (if (nlistp X) T
	(and 
		(covers A B (cdr X))
		(or
			(member (car X) A)
			(member (car X) B)  ))))

; some basic lemmas expressing the recursion

(prove-lemma covers-empty (rewrite) (implies
	(nlistp X)
	(covers A B X)))

(prove-lemma covers-negative (rewrite) (implies
	(and 
		(listp X)
		(not (member (car X) A))
		(not (member (car X) B)) )
	(not (covers A B X))))

(prove-lemma covers-positive-A (rewrite) (implies
	(and
		(listp X)
		(covers A B (cdr X))
		(member (car X) A))
	(covers A B X)))

(prove-lemma covers-positive-B (rewrite) (implies
	(and
		(listp X)
		(covers A B (cdr X))
		(member (car X) B))
	(covers A B X)))

(prove-lemma member-of-covered-set (rewrite) (implies
	(and
		(member u X)
		(covers A B X))
	(or
		(member u A)
		(member u B))))

; if A,B don't cover X, we can compute an element of X which is not covered

(defn uncovered (A B X) (if (nlistp X)
	nil
	(if (covers A B (cdr X))
		(car X)
		(uncovered A B (cdr X)))))

(prove-lemma uncovered-isnt-covered (rewrite) (implies
	(not (covers A B X))
	(and
		(member (uncovered A B X) X)
		(not (member (uncovered A B X) A))
		(not (member (uncovered A B X) B))  )))

(prove-lemma cdr-is-covered (rewrite) (implies
	(covers A B X)
	(covers A B (cdr X))))

; we probably don't need the defn of covers any more

(disable covers)

(prove-lemma covers-is-symmetric ( ) (implies
	(covers A B X)
	(covers B A X))
( ; hints
(do-not-induct T)
(use
	(member-of-covered-set (A A) (B B) (X X) (u (uncovered B A X) ))
	(uncovered-isnt-covered (A B) (B A) (X X)))
(disable uncovered-isnt-covered member-of-covered-set)
))

(prove-lemma discard-the-car-A (rewrite) (implies
	(and
		(covers A B X)
		(listp A)
		(not (member (car A) X)) )
	(covers (cdr A) B X) )
( ; hints
(do-not-induct T)
(use
	(member-of-covered-set (A A) (B B) (X X) (u (uncovered (cdr A) B X) ))
	(uncovered-isnt-covered (A (cdr A)) (B B) (X X)))
(disable uncovered-isnt-covered member-of-covered-set)
))

(prove-lemma discard-the-car-B (rewrite) (implies
	(and
		(covers A B X)
		(listp B)
		(not (member (car B) X)) )
	(covers  A (cdr B) X) )
( ; hints
(do-not-induct T)
(use
	(member-of-covered-set (A A) (B B) (X X) (u (uncovered A (cdr B) X) ))
	(uncovered-isnt-covered (A A) (B (cdr B)) (X X)))
(disable uncovered-isnt-covered member-of-covered-set)
))

;;;;  for sets
; special facts, for standard sets, using min-is-first

(prove-lemma discard-the-car-set-A (rewrite) (implies
	(and
		(setp A) (listp A) (setp X) (covers A B X) 
		(lessp (car A) (car X)) )
	(covers (cdr A) B X) ))

(prove-lemma discard-the-car-set-B (rewrite) (implies
	(and
		(setp B) (listp B) (setp X) (covers A B X) 
		(lessp (car B) (car X)) )
	(covers A (cdr B) X) ))

; now if X is non-empty and covered by A union B --
; there are two cases
; 1.  A is non-empty and its min is <= min X
; 2.  B is non-empty and its min is <= min X
; in case 1, (cdr X) is covered by (cdr A) union B
; likewise in case 2

; the two cases
(prove-lemma smaller-car-when-covered (rewrite) (implies
	(and
		(setp A) (setp B) (setp X) (listp X) (covers A B X)  )
	(or
		(and (listp A) (leq (car A) (car X)))
		(and (listp B) (leq (car B) (car X))) )  ))

; now, consider case 1
; as auxiliaries, we consider sub-cases depending on whether
; (cdr X) is empty or not

; first, if (cdr X) is non-empty
(prove-lemma cdr-is-covered-set-A-aux1 (rewrite) (implies
	(and
		(listp (cdr X))
		(setp A) (setp B) (setp X) (listp X) (covers A B X) 
		(listp A) (leq (car A) (car X)))
	(lessp (car A) (cadr X)))   )

(prove-lemma cdr-is-covered-set-A-aux2 (rewrite) (implies
	(and
		(listp (cdr X))
		(setp A) (setp B) (setp X) (listp X) (covers A B X) 
		(listp A) (leq (car A) (car X)))
	(covers (cdr A) B (cdr X)) )  
( ; hints
(use 
	(tail-of-a-set (s X))
	(cdr-is-covered-set-A-aux1 (A A) (B B) (X X))
	(discard-the-car-set-A (A A) (B B) (X (cdr X)))  )
(disable discard-the-car-set-A tail-of-a-set)
))

; now, if cdr X is empty, it's trivial, so

(prove-lemma  cdr-is-covered-set-A (rewrite) (implies
	(and
		(setp A) (setp B) (setp X) (listp X) (covers A B X) 
		(listp A) (leq (car A) (car X)))
	(covers (cdr A) B (cdr X)) )  
( ; hints
(do-not-induct T)
(use 
	(cdr-is-covered-set-A-aux2 (A A) (B B) (X X)) )
(disable cdr-is-covered-set-A-aux2)
))

(disable cdr-is-covered-set-A-aux1)
(disable cdr-is-covered-set-A-aux2)

; now, by symmetry:

(prove-lemma cdr-is-covered-set-B (rewrite) (implies
	(and
		(setp A) (setp B) (setp X) (listp X) (covers A B X) 
		(listp B) (leq (car B) (car X)))
	(covers  A (cdr B) (cdr X)) ) 
( ; hints
(do-not-induct T)
(use 
	(cdr-is-covered-set-A (A B) (B A) (X X))
	(covers-is-symmetric (A A) (B B) (X X))
	(covers-is-symmetric (A (cdr B)) (B A) (X (cdr X))) )
(disable covers-negative min-is-first cars-are-ordinals car-of-a-set
	 cdr-is-covered-set-A covers-is-symmetric cdr-is-covered)
))


;;;;;;;;;; sharp-and-cdr
; before going to pigeon-hole, we need a lemma that
; if X is alpha # beta - large, beta > 0, and m <= (car X) then
; (cdr X) is alpha # {beta}(m) -- large
; Also, by symmetry, the same holds for alpha/beta reversed
; X must be non-empty, since (cdr nil) = 0 -- not a set

; first observe that (cdr X) is {alpha # beta}(x) -- large

(enable o-largep)
(prove-lemma sharp-and-cdr-aux1 (rewrite) (implies
	(and
		(ordinalp alpha) (ordinalp beta) (listp X)
		(o-largep X (sharp alpha beta))  )
	(o-largep (cdr X) (pred (sharp alpha beta) (car X))  )))

; now note that if (cdr X) is empty, {alpha # beta}(x) = 0
; this should be the "trivial" case

(prove-lemma sharp-and-cdr-aux2 (rewrite) (implies
	(and
		(nlistp (cdr X))
		(ordinalp alpha) (ordinalp beta) (listp X)
		(o-largep X (sharp alpha beta))  )
	(equal (pred (sharp alpha beta) (car X)) 0 ) ))

(disable o-largep)

; now, if m <= (car X) then alpha # {beta}(m) <= {alpha # beta}(car X)
; proof:  alpha # {beta}(m) <= {alpha # beta}(m) <= {alpha # beta}(car X)
; the first <= is by pred-sharp, the second by monoton of pred

(prove-lemma sharp-and-cdr-aux3 (rewrite) (implies
	(and
		(ordinalp alpha) (ordinalp beta) (ord-lessp 0 beta)
        (numberp m) (numberp n) (leq m n)  )
	(ord-leq 
		(sharp alpha (pred beta m)) 
		(pred (sharp alpha beta) n) ) )
( ; hints
(do-not-induct T)
(use
	(ord-leq-is-transitive 
		(alpha (sharp alpha (pred beta m)))
		(beta (pred (sharp alpha beta) m))
		(gamma (pred (sharp alpha beta) n)) )
	(pred-sharp (alpha alpha) (beta beta) (n m))
	(monot-of-pred (m m) (n n) (alpha (sharp alpha beta))) )
(disable ordinalp pred-sharp monot-of-pred ord-leq-is-transitive)
))

(prove-lemma sharp-and-cdr-aux4 (rewrite) (implies
	(and
		(ordinalp alpha) (ordinalp beta) (ord-lessp 0 beta)
		(setp X) (numberp m) (leq m (car X)))
	(ord-leq 
		(sharp alpha (pred beta m)) 
		(pred (sharp alpha beta) (car X)) ) )
( ; hints
(do-not-induct T)
(use
	(sharp-and-cdr-aux3 (alpha alpha) (beta beta) (m m) (n (car X))))
(disable cars-are-ordinals cdrs-are-ordinals ordinalp sharp-and-cdr-aux3)
))

; now, if (cdr X) is empty, alpha # {beta}(m) = 0

(prove-lemma sharp-and-cdr-aux5 (rewrite) (implies
	(and
		(listp X) (not (listp (cdr X)))
		(o-largep X (sharp alpha beta)) 
		(ordinalp alpha) (ordinalp beta) (ord-lessp 0 beta)
		(setp X) (numberp m) (leq m (car X)))
	(equal (sharp alpha (pred beta m))  0 ))
( ; hints
(do-not-induct T)
(use
	(sharp-and-cdr-aux2 (X X) (alpha alpha) (beta beta))
	(sharp-and-cdr-aux4 (X X) (m m) (alpha alpha) (beta beta)))
(disable   subsetp-is-idempotent large-goes-up
	ord-leq pred-is-largest
	ordinalp sharp-and-cdr-aux2
	sharp-and-cdr-aux3 sharp-and-cdr-aux4)
))

; in particular, our result is trivial if (cdr X) is empty

(prove-lemma sharp-and-cdr-aux6 (rewrite) (implies
	(and
		(not (listp (cdr X)))
		(ordinalp alpha) (ordinalp beta) (ord-lessp 0 beta)
		(setp X) (listp X) (numberp m) (leq m (car X))
		(o-largep X (sharp alpha beta))  )
	(o-largep (cdr X) (sharp alpha (pred beta m)))  ))

; now, consider the case where (cdr X) is non-empty

(prove-lemma sharp-and-cdr-aux7 (rewrite) (implies
	(and
		(setp X) (listp (cdr X)) (numberp m) (leq m (car X)) )
	(lessp m (cadr X)) ))

; we have, from the above:
; aux1 : (o-largep (cdr X) (pred (sharp alpha beta) (car X))  )
; aux4
; (ord-leq (sharp alpha (pred beta m)) (pred (sharp alpha beta) (car X)) )
; aux7 :  m < (cadr X)
; we want to apply large-with-smaller-ordinal to (cdr X)
; so we need that
;  (norm (sharp alpha (pred beta m))) <= 
;    (plus (norm (pred (sharp alpha beta) (car X))) (magic (cadr X)))
; prove this separately, as a lemma:

(prove-lemma sharp-and-cdr-aux8 () (implies
	(and
		(ordinalp alpha) (ordinalp beta) (ord-lessp 0 beta)
		(numberp m) (numberp x0) (lessp m x1)  )
	(leq
		(norm (sharp alpha (pred beta m)))
		(plus (norm (pred (sharp alpha beta) x0)) (magic x1)) ) )
( ; hints
(do-not-induct T)
(use
	(upper-bound-on-norm-of-pred (alpha beta) (n m))
	(magic-is-monotonic (m m) (n x1))
	(lower-bound-on-norm-of-pred  (alpha (sharp alpha beta)) (n x0)) )
))
; intended :  x0 is (car X) ; x1 is (cadr x)

(prove-lemma sharp-and-cdr-aux9 () (implies
	(and
		(listp (cdr X))
		(ordinalp alpha) (ordinalp beta) (ord-lessp 0 beta)
		(setp X) (listp X) (numberp m) (leq m (car X)) )
	(leq
		(norm (sharp alpha (pred beta m)))
		(plus (norm (pred (sharp alpha beta) (car X))) (magic (cadr X))) ) )
( ; hints
(use (sharp-and-cdr-aux8 (alpha alpha) (beta beta)
		(x0 (car X)) (x1 (cadr X))))
(disable  norm lower-bound-on-norm-of-pred pred sharp
	ord-leq-zero numbers-below-omega ord-leq)
))

(prove-lemma sharp-and-cdr-aux10 (rewrite) (implies
	(and
		(listp (cdr X))
		(ordinalp alpha) (ordinalp beta) (ord-lessp 0 beta)
		(setp X) (listp X) (numberp m) (leq m (car X))
		(o-largep X (sharp alpha beta))  )
	(o-largep (cdr X) (sharp alpha (pred beta m)))  ) 
( ; hints
(do-not-induct T)
(use 
	(large-with-smaller-ord 
		(alpha (sharp alpha (pred beta m)))
		(beta (pred (sharp alpha beta) (car X)))
		(X (cdr X)) )
	(tail-of-a-set (s X))
	(sharp-and-cdr-aux1 (alpha alpha) (beta beta) (X X))
	(sharp-and-cdr-aux4 (alpha alpha) (beta beta) (m m) (X X))
	(sharp-and-cdr-aux9 (alpha alpha) (beta beta) (m m) (X X))     )
(disable  large-with-smaller-ord tail-of-a-set
	first-before-last large-superset-ord norm-of-pred-of-succ 
	subsetp subsetp-is-idempotent large-goes-up
	norm-of-a-number sharp-and-cdr-aux3
	singletons-not-large norm-of-pred-of-limit
	pred-of-succ successorp transitivity 
	sharp norm pred-is-largest insert-is-cons
	norm-of-sharp sharp-and-cdr-aux9 sharp-and-cdr-aux1
	sharp-and-cdr-aux4 ord-leq insert 
	ord-leq-zero numbers-below-omega)
))

(prove-lemma sharp-and-cdr-B (rewrite) (implies
	(and
		(ordinalp alpha) (ordinalp beta) (ord-lessp 0 beta)
		(setp X) (listp X) (numberp m) (leq m (car X))
		(o-largep X (sharp alpha beta))  )
	(o-largep (cdr X) (sharp alpha (pred beta m)))  )
( ; hints
(do-not-induct T)
(use 
	(sharp-and-cdr-aux10 (alpha alpha) (beta beta) (m m) (X X)))
(disable sharp-and-cdr-aux10)
))

(disable sharp-and-cdr-aux1)
(disable sharp-and-cdr-aux2)
(disable sharp-and-cdr-aux3)
(disable sharp-and-cdr-aux4)
(disable sharp-and-cdr-aux5)
(disable sharp-and-cdr-aux6)
(disable sharp-and-cdr-aux7)
(disable sharp-and-cdr-aux8)
(disable sharp-and-cdr-aux9)
(disable sharp-and-cdr-aux10)

; the same thing with alpha replacing beta follows automatically by symmetry

(prove-lemma sharp-and-cdr-A (rewrite) (implies
	(and
		(ordinalp alpha) (ordinalp beta) (ord-lessp 0 alpha)
		(setp X) (listp X) (numberp m) (leq m (car X))
		(o-largep X (sharp alpha beta))  )
	(o-largep (cdr X) (sharp (pred alpha m)  beta )))  )


;;;;;;;;;;;  Proof of pigeon-2
; This is the version with 2 holes:
; if (covers A B X) and X is alpha # beta -- large
; then A is alpha -- large     or      B is beta -- large

; we prove this by induction, showing the following can't happen

(defn bad-for-pigeon-2 (A B X alpha beta) (and
		(ordinalp alpha) (ordinalp beta)
		(setp A) (setp B) (setp X) (covers A B X)
		(o-largep X (sharp alpha beta))  
		(not (o-largep A alpha))
		(not (o-largep B beta))  ) )

; first, kill off some base cases:

; alpha and beta are > 0

(prove-lemma pigeon-2-aux1 (rewrite) (implies
	(bad-for-pigeon-2 A B X alpha beta)
	(ord-lessp 0 alpha) ) )

(prove-lemma pigeon-2-aux2 (rewrite) (implies
	(bad-for-pigeon-2 A B X alpha beta)
	(ord-lessp 0 beta) ) )

(prove-lemma pigeon-2-aux3 (rewrite) (implies
	(bad-for-pigeon-2 A B X alpha beta)
	(and (ordinalp alpha) (ordinalp beta))))

(prove-lemma pigeon-2-aux4 (rewrite) (implies
	(bad-for-pigeon-2 A B X alpha beta)
	(ord-lessp 0 (sharp alpha beta)) ) 
( ;  hints
(do-not-induct T)
(use 
	(postive-ord-lessp (gamma alpha) (delta (sharp alpha beta)))
	(sharp-gets-bigger (alpha alpha) (beta beta))
	(pigeon-2-aux2 (A A) (B B) (X X) (alpha alpha) (beta beta)) )
(disable ordinalp postive-ord-lessp
	bad-for-pigeon-2 pigeon-2-aux2)
))

(prove-lemma pigeon-2-aux5 (rewrite) (implies
	(bad-for-pigeon-2 A B X alpha beta)
	(listp X))
( ; hints
(do-not-induct T)
(use 
	(pigeon-2-aux4 (A A) (B B) (X X) (alpha alpha) (beta beta))
	(empty-not-large (set X) (alpha (sharp alpha beta))))
(disable pigeon-2-aux4  insert sharp o-largep numbers-below-omega 
	 ORD-LEQ ORD-LEQ-IS-TRANSITIVE empty-not-large subsetp-is-idempotent  )
))

(prove-lemma pigeon-2-aux6 (rewrite) (implies
	(bad-for-pigeon-2 A B X alpha beta)
	(and
		(setp A) (setp B) (setp X) (listp X) (covers A B X)  ) )
( ; hints
(do-not-induct T)
(use 
	(pigeon-2-aux5 (A A) (B B) (X X) (alpha alpha) (beta beta)) )
(hands-off ordinalp setp o-largep)
(disable pigeon-2-aux5 LARGE-GOES-UP SHARP-IS-AN-ORDINAL)
))

(prove-lemma pigeon-2-aux7 (rewrite) (implies
	(bad-for-pigeon-2 A B X alpha beta)
	(or
		(and (listp A) (leq (car A) (car X)))
		(and (listp B) (leq (car B) (car X))) )  )
( ; hints
(do-not-induct T)
(use
	(pigeon-2-aux6 (A A) (B B) (X X) (alpha alpha) (beta beta) )
	(smaller-car-when-covered (A A) (B B) (X X)))
(disable smaller-car-when-covered covers-empty  pigeon-2-aux6 o-largep
	bad-for-pigeon-2 cars-are-ordinals)
(hands-off ordinalp)
))

; now, consider the first case:
; we have (and (listp A) (leq (car A) (car X)))
; we want to show that 
; (bad-for-pigeon-2 (cdr A) B (cdr X)  (pred alpha (car A)) beta)

; we check the five lines  in the definition

; line1
(prove-lemma pigeon-2-aux8 (rewrite) (implies
	(bad-for-pigeon-2 A B X alpha beta)
	(and (ordinalp (pred alpha (car A))) (ordinalp beta)  )))

; line2
(prove-lemma pigeon-2-aux9 (rewrite) (implies
	(and
		(bad-for-pigeon-2 A B X alpha beta)
		(listp A) (leq (car A) (car X))  ) 
	(and
		(setp (cdr A)) (setp B) (setp (cdr X)) (covers (cdr A) B (cdr X))  )  )
( ;  hints
(do-not-induct T)
(use
	(tail-of-a-set (s A))
	(tail-of-a-set (s X))
	(cdr-is-covered-set-A (A A) (B B) (X X))
	(pigeon-2-aux6 (A A) (B B) (X X) (alpha alpha) (beta beta) ) )
(disable CARS-ARE-ORDINALS  IRREFLEX-OF-ORD-LEQ ORD-LEQ-ZERO       
	NUMBERS-BELOW-OMEGA
 	bad-for-pigeon-2 pigeon-2-aux6  cdr-is-covered-set-A)
(hands-off covers ord-leq )
))

; line3
(prove-lemma pigeon-2-aux10 (rewrite) (implies
	(and
		(bad-for-pigeon-2 A B X alpha beta)
		(leq (car A) (car X))  ) 
	(o-largep (cdr X) (sharp (pred alpha (car A)) beta))  ) 
( ; hints
(do-not-induct T)
(use 
	(pigeon-2-aux5 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(sharp-and-cdr-A  (X X) (alpha alpha) (beta beta) (m (car A))))
(disable 
	CARS-ARE-ORDINALS  O-LARGEP  NUMBERS-BELOW-OMEGA IRREFLEX-OF-ORD-LEQ  
	ORD-LEQ-ZERO        pigeon-2-aux5
	o-largep sharp sharp-and-cdr-A)
(hands-off o-largep )
))

; line4
(prove-lemma pigeon-2-aux11 (rewrite) (implies
	(and
		(bad-for-pigeon-2 A B X alpha beta)
		(listp A) )
	(not (o-largep (cdr A) (pred alpha (car A))))  )
( ; hints
(do-not-induct T)
(use 
	(recursive-case-for-large (set A) (alpha alpha)) )
(disable recursive-case-for-large)
))

; line5
(prove-lemma pigeon-2-aux12 (rewrite) (implies
	(bad-for-pigeon-2 A B X alpha beta)
	(not (o-largep B beta))  ) )

; summarize what we need for
; (bad-for-pigeon-2 (cdr A) B (cdr X) (pred alpha (car A)) beta)

(prove-lemma pigeon-2-aux13 (rewrite) (implies
	(and
		(ordinalp (pred alpha (car A))) (ordinalp beta)
		(setp (cdr A)) (setp B) (setp (cdr X)) (covers (cdr A) B (cdr X))
		(o-largep (cdr X) (sharp (pred alpha (car A)) beta))  
		(not (o-largep (cdr A) (pred alpha (car A))))
		(not (o-largep B beta))   )
	(bad-for-pigeon-2 (cdr A) B (cdr X) (pred alpha (car A)) beta) ) )

; putting them together in the first case
(prove-lemma pigeon-2-aux14 (rewrite) (implies
	(and
		(bad-for-pigeon-2 A B X alpha beta)
		(listp A) (leq (car A) (car X))  ) 
	(bad-for-pigeon-2 (cdr A) B (cdr X) (pred alpha (car A)) beta) ) 
( ; hints
(do-not-induct T)
(use 
	(pigeon-2-aux8 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(pigeon-2-aux9 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(pigeon-2-aux10 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(pigeon-2-aux11 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(pigeon-2-aux12 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(pigeon-2-aux13 (A A) (B B) (X X) (alpha alpha) (beta beta)  ) )
(hands-off ordinalp setp o-largep sharp insert)
(disable pigeon-2-aux8 pigeon-2-aux9 pigeon-2-aux10 pigeon-2-aux11
	pigeon-2-aux12 bad-for-pigeon-2 setp)
))

; this ends the first case
; now, consider the second case
; we have (and (listp B) (leq (car B) (car X)))
; we want to show that 
; (bad-for-pigeon-2  A (cdr B) (cdr X)  alpha (pred beta (car B)))

; again we check the five lines  in the definition

; line1
(prove-lemma pigeon-2-aux15 (rewrite) (implies
	(bad-for-pigeon-2 A B X alpha beta)
	(and (ordinalp alpha) (ordinalp (pred beta (car B)))   )))

; line2
(prove-lemma pigeon-2-aux16 (rewrite) (implies
	(and
		(bad-for-pigeon-2 A B X alpha beta)
		(listp B) (leq (car B) (car X))  ) 
	(and
		(setp  A) (setp (cdr B)) (setp (cdr X)) (covers A (cdr B)(cdr X))  )  )
( ;  hints
(do-not-induct T)
(use
	(tail-of-a-set (s B))
	(tail-of-a-set (s X))
	(cdr-is-covered-set-B (A A) (B B) (X X))
	(pigeon-2-aux6 (A A) (B B) (X X) (alpha alpha) (beta beta) ) )
(disable CARS-ARE-ORDINALS  IRREFLEX-OF-ORD-LEQ ORD-LEQ-ZERO       
	NUMBERS-BELOW-OMEGA
 	bad-for-pigeon-2 pigeon-2-aux6  cdr-is-covered-set-A)
(hands-off covers ord-leq )
))

; line3
(prove-lemma pigeon-2-aux17 (rewrite) (implies
	(and
		(bad-for-pigeon-2 A B X alpha beta)
		(leq (car B) (car X))  ) 
	(o-largep (cdr X) (sharp alpha (pred beta (car B))))  ) 
( ; hints
(do-not-induct T)
(use 
	(pigeon-2-aux5 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(sharp-and-cdr-B  (X X) (alpha alpha) (beta beta) (m (car B))))
(disable 
	CARS-ARE-ORDINALS  O-LARGEP  NUMBERS-BELOW-OMEGA IRREFLEX-OF-ORD-LEQ  
	ORD-LEQ-ZERO        pigeon-2-aux5
	o-largep sharp sharp-and-cdr-B)
(hands-off o-largep )
))

; line5
(prove-lemma pigeon-2-aux18 (rewrite) (implies
	(and
		(bad-for-pigeon-2 A B X alpha beta)
		(listp B) )
	(not (o-largep (cdr B) (pred beta (car B))))  )
( ; hints
(do-not-induct T)
(use 
	(recursive-case-for-large (set B) (alpha beta)) )
(disable recursive-case-for-large)
))

; line4
(prove-lemma pigeon-2-aux19 (rewrite) (implies
	(bad-for-pigeon-2 A B X alpha beta)
	(not (o-largep A alpha))  ) )

; summarize what we need for
; (bad-for-pigeon-2  (cdr B) (cdr X) alpha (pred beta (car B)))  

(prove-lemma pigeon-2-aux20 (rewrite) (implies
	(and
		(ordinalp alpha) (ordinalp (pred beta (car B))) 
		(setp A) (setp (cdr B)) (setp (cdr X)) (covers A (cdr B) (cdr X))
		(o-largep (cdr X) (sharp alpha (pred beta (car B)) ))  
		(not (o-largep A alpha))  
		(not (o-largep (cdr B) (pred beta (car B)))) )
	(bad-for-pigeon-2 A (cdr B) (cdr X) alpha (pred beta (car B)) ) ) )

; putting them together in the second case
(prove-lemma pigeon-2-aux21 (rewrite) (implies
	(and
		(bad-for-pigeon-2 A B X alpha beta)
		(listp B) (leq (car B) (car X))  ) 
	(bad-for-pigeon-2  A (cdr B) (cdr X) alpha (pred beta (car B)) ) )
( ; hints
(do-not-induct T)
(use 
	(pigeon-2-aux15 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(pigeon-2-aux16 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(pigeon-2-aux17 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(pigeon-2-aux18 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(pigeon-2-aux19 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(pigeon-2-aux20 (A A) (B B) (X X) (alpha alpha) (beta beta)  ) )
(hands-off ordinalp setp o-largep sharp insert)
(disable pigeon-2-aux15 pigeon-2-aux16 pigeon-2-aux17 pigeon-2-aux18
	pigeon-2-aux19 bad-for-pigeon-2 setp)
))

; now the point is:  if (bad-for-pigeon-2 A B X alpha beta)
; then (listp X) ( by aux5 ) and (cdr X) messes
; up with something -- so we can induct on X

(prove-lemma pigeon-2-aux22 (rewrite) (implies
	(bad-for-pigeon-2 A B X alpha beta)
	(or
		(bad-for-pigeon-2 (cdr A) B (cdr X) (pred alpha (car A)) beta)  
		(bad-for-pigeon-2  A (cdr B) (cdr X) alpha (pred beta (car B)) ) ) )
( ; hints
(do-not-induct T)
(use 
	(pigeon-2-aux7 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(pigeon-2-aux14 (A A) (B B) (X X) (alpha alpha) (beta beta)  )
	(pigeon-2-aux21 (A A) (B B) (X X) (alpha alpha) (beta beta)  ) )
(disable bad-for-pigeon-2 
	CARS-ARE-ORDINALS IRREFLEX-OF-ORD-LEQ ORD-LEQ-ZERO 
	NUMBERS-BELOW-OMEGA ORD-LEQ   )
(hands-off ord-leq)
))

(defn pigeon-2-kludge (A B X alpha beta) (if (nlistp X) 
	0
	(plus
		(pigeon-2-kludge (cdr A) B (cdr X) (pred alpha (car A)) beta)  
		(pigeon-2-kludge A (cdr B) (cdr X) alpha (pred beta (car B)) ) ) ))

(prove-lemma pigeon-2-aux23 (rewrite) (not
	(bad-for-pigeon-2 A B X alpha beta) )
( ; hints
(disable bad-for-pigeon-2 )
(induct (pigeon-2-kludge A B X alpha beta))
(use 
	(pigeon-2-aux22 (A A) (B B) (X X) (alpha alpha) (beta beta)  ) )
))

; finally, the GOAL:
(prove-lemma pigeon-2 (rewrite) (implies
	(and 
		(ordinalp alpha) (ordinalp beta)
		(setp A) (setp B) (setp X) (covers A B X)
		(o-largep X (sharp alpha beta))  )
	(or
		(o-largep A alpha)
		(o-largep B beta)  )  )
( ; hints
(do-not-induct T)
(use (pigeon-2-aux23  (A A) (B B) (X X) (alpha alpha) (beta beta)  ) )
(disable pigeon-2-aux23 )
))

(disable bad-for-pigeon-2)     (disable pigeon-2-kludge)
(disable pigeon-2-aux1) (disable pigeon-2-aux2)
(disable pigeon-2-aux3) (disable pigeon-2-aux4)
(disable pigeon-2-aux5) (disable pigeon-2-aux6)
(disable pigeon-2-aux7) (disable pigeon-2-aux8)
(disable pigeon-2-aux9) (disable pigeon-2-aux10)
(disable pigeon-2-aux11) (disable pigeon-2-aux12)
(disable pigeon-2-aux13) (disable pigeon-2-aux14)
(disable pigeon-2-aux15) (disable pigeon-2-aux16)
(disable pigeon-2-aux17) (disable pigeon-2-aux18)
(disable pigeon-2-aux19) (disable pigeon-2-aux20)
(disable pigeon-2-aux21) (disable pigeon-2-aux22)
(disable pigeon-2-aux23)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                 FUNCTIONS AND HOMOGENEOUS SETS                         ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; view every S-expression as an association list, and hence a function

(defn funcall (g x) (cadr (assoc x g)))

; since (cadr nil) = 0, we always have 0 in the range:

(defn range (g) (if (nlistp g)
	(list 0)
	(cons (cadar g) (range (cdr g)))  ))

(prove-lemma range-is-big-enuf (rewrite) (member (funcall g x) (range g)))

(disable range)
; we don't care exactly what it is

(disable funcall)
; for now -- later, we'll need its definition to show that we
; can build up functions with prescribed definitions

(defn mapsto (g set1 set2) (if (nlistp set1)
	T
	(and
		(mapsto g (cdr set1) set2)
		(member (funcall g (car set1)) set2) ) ))

(prove-lemma mapsto-works (rewrite) (implies
	(and (mapsto g set1 set2) (member x set1))
	(member (funcall g x) set2) ))

(disable mapsto)

;;;;;;;;;;;;;;;;;;;;;;;;
; let's disable some ordinal stuff which seems to slow down the set proofs
(disable numbers-below-omega)
(disable cdrs-are-ordinals)
(disable ord-leq-zero)
(disable ord-leq-is-transitive)


;;;;;;;;;;;;  notion of homogeneous

; (homp set g n) means that  set is homogeneous for g as a partition
; of n-tuples:  that is,
; whenever s1, s2 are subsets of set of size <= n, and 
; |s1| =|s2| and g(s1) = g(s2) < c, then g(s1) = g(s2)

; we first define what a counter-example would be
; search through the list of all possible counter-examples

(defn hom-bad-pairp (x y set g n) (and
	(sublistp x set) (sublistp y set)
	(setp x) (setp y)
	(equal (length x) n) (equal (length y) n)
	(not (equal (funcall g x) (funcall g y))) ))
; use sublistp rather than subsetp because power-set was defined
; to work with sublistp.  These are equivalent anyway when
; (setp set), which is what we're interested in.

; pairs is a list of pairs which are possible counter-examples
; counter-hom looks for a pair (x y) which refutes homogeneous
; if it fails, it returns 0

; disable bad-pair temporarily 
(disable hom-bad-pairp)

(defn counter-hom (set g n pairs) (if (nlistp pairs)
	0
	(if (listp (counter-hom set g n (cdr pairs)))
		; have we found one in the cdr?
		(counter-hom set g n (cdr pairs))
			; if yes, take it -- if not, see if the car is a counter-ex
		(if (hom-bad-pairp (caar pairs) (cdar pairs) set g n)
			(cons (caar pairs) (cdar pairs))
			0 )  )  ) )

(prove-lemma bad-pair-is-bad (rewrite) (implies
	(listp (counter-hom set g n pairs))
	(hom-bad-pairp
		(car (counter-hom set g n pairs))
		(cdr (counter-hom set g n pairs)) 
		set g n) ))

(prove-lemma counter-hom-finds-one (rewrite) (implies
	(and
		(member (cons x y) pairs)
		(hom-bad-pairp x y set g n) )
	(listp (counter-hom set g n pairs) )  ))

(disable counter-hom)

; now -- homp means we search thru all pairs from the
; power-set and don't find one

(defn homp (set g n) (nlistp (counter-hom     set g n 
	(product (power-set set) (power-set set))  )))


; now, we prove that homp is necessary and sufficient
; this needs the defn of hom-bad-pairp
(enable hom-bad-pairp)

(prove-lemma homp-is-sufficient-A (rewrite) (implies
	(and 
		(homp set g n)
		(sublistp x set) (sublistp y set)
		(setp x) (setp y)
		(equal (length x) n) (equal (length y) n) )
	(equal (funcall g x) (funcall g y))    )
( ;hints
(do-not-induct T)
(use 
	(all-pairs (x x) (y y) (lst1 (power-set set)) (lst2 (power-set set)) ) )
(disable all-pairs)
))

;;; in our paper, it would be less confusing to have a version
; to quote which uses subsetp instead of sublistp

(prove-lemma homp-is-sufficient (rewrite) (implies
	(and 
		(homp set g n)
		(subsetp x set) (subsetp y set)
		(setp set) (setp x) (setp y)
		(equal (length x) n) (equal (length y) n) )
	(equal (funcall g x) (funcall g y))    )
( ;hints
(do-not-induct T)
(use 
	(homp-is-sufficient-A))
(disable homp-is-sufficient-A)
))


; to prove necessary, it would be nice to have an abbreviation for
; the x and y coordinate of the counter-example

(defn counter-hom-x (set g n) (car (counter-hom     set g n
    (product (power-set set) (power-set set))  )))
(defn counter-hom-y (set g n) (cdr (counter-hom     set g n
    (product (power-set set) (power-set set))  )))

(prove-lemma homp-is-necessary (rewrite) (implies
	(not (homp set g n))
	(and
		(sublistp (counter-hom-x set g n) set) 
		(sublistp (counter-hom-y set g n) set)
		(setp (counter-hom-x set g n)) 
		(setp (counter-hom-y set g n))
		(equal (length (counter-hom-x set g n)) n) 
		(equal (length (counter-hom-y set g n)) n) 
		(not (equal 
			(funcall g (counter-hom-x set g n)) 
			(funcall g (counter-hom-y set g n)))    )   )   )
( ; hints
(use (bad-pair-is-bad
	(g g) (n n) (set set) (pairs (product (power-set set) (power-set set))  )))
(do-not-induct T)
(disable bad-pair-is-bad length length-of-subset length-of-sublist)
(hands-off length sublistp power-set subsetp)
))

(disable homp)
(disable hom-bad-pairp)
(disable counter-hom-x)
(disable counter-hom-y)


;;;;;;;;;;;;;;;  add-on-end
; before discussing pre-homogeneous sets, we have to talk
; about adding one element at the end of a set -- maybe
; it's simpler to define this outright, rather than using "append"

(defn add-on-end (item set) (if (nlistp set)
	(list item) 
	(cons (car set) (add-on-end item (cdr set)))))
; for sets, this is set Union {item}

(prove-lemma add-in-end-is-last (rewrite) (equal
	(last (add-on-end item set))
	item ))

(prove-lemma add-in-end-and-length (rewrite) (equal
	(length (add-on-end item set))
	(add1 (length set))))

; we should probably define all-but-last  -- everything
; except the last element

(prove-lemma all-but-last-aux1 (rewrite) (implies
	(listp (cdr lst))
	(listp lst) ))
; needed for the recursion

(defn all-but-last (lst) (if (nlistp (cdr lst) )
	nil
	(cons (car lst) (all-but-last (cdr lst)))))

(disable all-but-last-aux1)

(prove-lemma all-but-last-and-length (rewrite) (implies
	(listp (cdr lst))
	(equal 
		(length (all-but-last lst))
		(sub1 (length lst)))))

(prove-lemma all-but-last-of-add-on-end (rewrite) (implies
	(properp lst)
	(equal (all-but-last (add-on-end item lst))     lst)))

(enable setp)
(prove-lemma add-on-end-makes-sets (rewrite) (implies
	(and (setp set) (numberp n) (lessp (last set) n) )
	(setp (add-on-end n set))))
(disable setp)

(prove-lemma all-but-last-is-sublist (rewrite) 
	(sublistp (all-but-last lst) lst))

(prove-lemma all-but-last-is-sublist-A (rewrite) (implies
	(sublistp s1 set) 
	(sublistp (all-but-last s1) set))
( ; hints
(do-not-induct T)
(use 
	(all-but-last-is-sublist (lst s1)))
(disable all-but-last-is-sublist)
))

(prove-lemma all-but-last-is-non-empty (rewrite)  (implies
	(leq 2 (length lst))
	(listp (all-but-last lst))))
(enable setp)
(prove-lemma all-but-last-is-a-set (rewrite) (implies
	(setp set)
	(setp (all-but-last set))))
(disable setp)

(prove-lemma re-assemble-at-end (rewrite) (implies
	(and (properp lst) (listp lst))
	(equal (add-on-end (last lst) (all-but-last lst))  lst )))

(prove-lemma length-of-all-but-last (rewrite) (implies
	(listp x)
	(equal (length (all-but-last x)) (sub1 (length x)))))


;;;;;;;;;;;;  notion of pre-homogeneous

; (pre-homp set g) means that  set is pre-homogeneous for g as a partition
; that is:  whenever s1 is a non-empty subset of set, y,z are members of
; set and are larger than max(s1) :
; g(s1 U {y}) = g(s1 U {z})

; we use the same "bad" method

(defn pre-hom-bad-triplep (y z s1 set g) (and
	(sublistp s1 set)  (listp s1) (setp s1)
	(member y set) (member z set)
	(lessp (last s1) y) (lessp (last s1) z)
	(not (equal 
		(funcall g (add-on-end y s1)) 
		(funcall g (add-on-end z s1)) ))  ))

; disable bad-triple temporarily 
(disable pre-hom-bad-triplep)

; triples will be just ( (a .  b) .  c) -- so we get a,b,c as the
; caar, cdar, cdr
; then all triples are getten as (product (product set set) (power-set set))

(defn counter-pre-hom (set g triples) (if (nlistp triples)
	0
	(if (listp (counter-pre-hom set g (cdr triples)))
		; have we found one in the cdr?
		(counter-pre-hom set g (cdr triples))
			; if yes, take it -- if not, see if the car is a counter-ex
		(if (pre-hom-bad-triplep 
				(caaar triples) (cdaar triples) (cdar triples) set g)
			(cons (cons (caaar triples) (cdaar triples)) (cdar triples)) 
			0 )  )  ) )

(prove-lemma bad-triple-is-bad (rewrite) (implies
	(listp (counter-pre-hom set g triples))
	(pre-hom-bad-triplep
		(caar (counter-pre-hom set g triples))
		(cdar (counter-pre-hom set g triples))
		(cdr (counter-pre-hom set g triples)) 
		set g) ))

(prove-lemma counter-pre-hom-finds-one (rewrite) (implies
	(and
		(member (cons (cons y z) s1) triples)
		(pre-hom-bad-triplep y z s1 set g) )
	(listp (counter-pre-hom set g triples) )  ))

(disable counter-pre-hom)

(defn pre-homp (set g) (nlistp (counter-pre-hom    set g 
	(product (product set set) (power-set set))  )))

; now, we prove that pre-homp is necessary and sufficient
; this needs the defn of pre-hom-bad-triplep
(enable pre-hom-bad-triplep)

(prove-lemma pre-homp-is-sufficient (rewrite) (implies
	(and 
		(pre-homp set g)
		(sublistp s1 set) (listp s1) (setp s1)
		(member y set) (member z set)
		(lessp (last s1) y) (lessp (last s1) z) )
	(equal 
		(funcall g (add-on-end y s1)) 
		(funcall g (add-on-end z s1)) )  )
( ;hints
(do-not-induct T)
(use 
	(all-pairs (x y) (y z) (lst1 set) (lst2 set) )
	(all-pairs (x (cons y z)) (y s1) 
			(lst1 (product set set)) (lst2 (power-set set)) ))
(disable all-pairs)
))

;  to prove necessary, we use an abbreviation for 
; the y,z, s1 of the counter-example

(defn counter-pre-hom-y (set g) (caar (counter-pre-hom     set g
	(product (product set set) (power-set set))  )))
(defn counter-pre-hom-z (set g) (cdar (counter-pre-hom     set g
	(product (product set set) (power-set set))  )))
(defn counter-pre-hom-s1 (set g) (cdr (counter-pre-hom     set g
	(product (product set set) (power-set set))  )))

(prove-lemma pre-homp-is-necessary (rewrite) (implies
	(not (pre-homp set g))
	(and
		(sublistp (counter-pre-hom-s1 set g) set)
		(listp (counter-pre-hom-s1 set g) )
		(setp (counter-pre-hom-s1 set g) )
		(member (counter-pre-hom-y set g) set) 
		(member (counter-pre-hom-z set g) set) 
		(lessp (last (counter-pre-hom-s1 set g)) (counter-pre-hom-y set g)) 
		(lessp (last (counter-pre-hom-s1 set g)) (counter-pre-hom-z set g))
		(not (equal 
			(funcall g (add-on-end (counter-pre-hom-y set g) 
				(counter-pre-hom-s1 set g))) 
			(funcall g (add-on-end (counter-pre-hom-z set g) 
				(counter-pre-hom-s1 set g))) )  )  ) )
( ; hints
(do-not-induct T)
(use (bad-triple-is-bad
	(g g)  (set set) (triples  (product (product set set) (power-set set)))) )
(disable bad-triple-is-bad length length-of-subset length-of-sublist)
(hands-off length sublistp power-set subsetp)
))

(disable pre-homp)
(disable pre-hom-bad-triplep)
(disable counter-pre-hom-y)
(disable counter-pre-hom-z)
(disable counter-pre-hom-s1)


;;;;;;;;;;;;;;;;;;;;   derived partitions
; This is used in the induction step in Ramsey's Theorem --
;  passing from n-1 - tuples to n - tuples
; Think of g as a partition of n-tuples (n >= 2)
; If set is pre-hom for g, there is a derived partition h, on n-1 - tuples
; such that whenever hset is homogeneous for h, hset is homogeneous for g

; to compute (h s1) :  apply g to s1 U {x}, where x =
; (find-larger-element s1 set) -- this returns an element x of set
; which is a number and larger than (last s1)
; it returns nil if there is no such number
; so -- by testing for numberp, we know if we have found one.

(defn find-larger-element (s1 set) (if (nlistp set) 
	nil
	(if  (and (numberp (car set)) (lessp (last s1) (car set)) )
		(car set)
		(find-larger-element s1 (cdr set)))))

(prove-lemma find-larger-element-works-A (rewrite) (implies
	(numberp (find-larger-element s1 set))
	(and
		(member (find-larger-element s1 set) set)
		(numberp (find-larger-element s1 set) )
		(lessp (last s1) (find-larger-element s1 set) )  )  ))

(prove-lemma find-larger-element-works-B (rewrite) (implies
	(and
		(member x set)
		(numberp x )
		(lessp (last s1) x )  )  
	(numberp (find-larger-element s1 set))  ))

(disable find-larger-element) 
; we don't care which one we found

; if s1 is a subset of set and s1 has length at least 2,
; then (find-larger-element (all-but-last) set )  really
; finds one -- since (last s1) is a candidate.

; first, we have to show it really is a candidate
; the following is probably needed also for properties
; of pre-homogeneous sets

(prove-lemma last-is-a-member (rewrite) (implies
	(listp lst)
	(member (last lst) lst)))

(prove-lemma last-is-a-candidate-1 (rewrite) (implies
	(and
		(sublistp s1 set)
		(leq 2 (length s1)) )
	(member (last s1) set))
( ; hints
(do-not-induct T)
(use (last-is-a-member (lst s1))
	(sublist-implies-subset (lst1 s1) (lst2 set))  )
(disable last-is-a-member sublist-implies-subset)
))

(enable setp)
(prove-lemma members-are-numbers (rewrite) (implies
	(and (setp set) (member x set))
	(numberp x)))
(disable setp)

(prove-lemma last-is-a-candidate-2 (rewrite) (implies
	(and
		(setp s1)
		(leq 2 (length s1)) )
	(numberp (last s1))))

(enable setp)
(prove-lemma last-is-a-candidate-3 (rewrite) (implies
	(and
		(setp s1)
		(leq 2 (length s1)) )
	(lessp (last (all-but-last s1)) (last s1) )  ) )
(disable setp)

(prove-lemma larger-elt-is-found (rewrite) (implies
	(and
		(setp s1) (sublistp s1 set)
		(leq 2 (length s1)) )
	(numberp (find-larger-element (all-but-last s1) set)))  
( ; hints
(do-not-induct T)
(use
	(find-larger-element-works-B 
		(x (last s1)) (s1 (all-but-last s1)) (set set)))
(disable find-larger-element-works-B)
))

; it follows that if g is pre-homogeneous on set, then (g s1) =
; (g  (add-on-end 
;         (find-larger-element (all-but-last s1) set)
;         (all-but-last s1) ) )
; that is, (g s1) is determined as the derived partition
;  applied to (all-but-last s1)

(prove-lemma pre-hom-and-all-but-last (rewrite) (implies
	(and
		(pre-homp set g)
		(setp s1) (sublistp s1 set)
		(leq 2 (length s1)) )
	(equal
		(funcall g s1)
		(funcall g
			(add-on-end
				(find-larger-element (all-but-last s1) set)
				(all-but-last s1) )))  )
( ; hints
(do-not-induct T)
(use 
	(re-assemble-at-end (lst s1))
	(pre-homp-is-sufficient (set set) (g g)
		(s1 (all-but-last s1)) 
		(y (last s1))
		(z (find-larger-element (all-but-last s1) set) ) ) )
(disable pre-homp-is-sufficient re-assemble-at-end)
))

; now we simply define the derived partition h = (derived g set)  so that 
;(h s) = 
;(funcall g
;    (add-on-end
;        (find-larger-element s set)
;        s ))  
; but to define a function h like this, we have to run down
; a list of subsets -- i.e., (power-set set)
; and construct h as a list of pairs
    
(defn derived-aux (g set lst) (if (nlistp lst)
	; lst "should be" a list of subsets of set
	nil
	(cons
		(list
			(car lst)   ; the arg
			(funcall g 
				(add-on-end (find-larger-element (car lst) set) (car lst)))  )
				; the value
		(derived-aux g set (cdr lst))  )  ))

(prove-lemma derived-aux1 (rewrite) (implies
	(member s lst)
	(equal 
		(assoc s (derived-aux g set lst))
		(list 
			s 
			(funcall g (add-on-end (find-larger-element s set) s)) )))
( ; hints
(disable add-on-end)
(hands-off add-on-end)
))

(enable funcall)
(prove-lemma derived-aux2 (rewrite) (implies
	(member s lst)
	(equal 
		(funcall (derived-aux g set lst) s)
		(funcall g (add-on-end (find-larger-element s set) s)) ) )
( ; hints
(disable add-on-end)
(hands-off add-on-end)
))

(disable funcall)
(disable derived-aux)
(disable derived-aux1)

(defn derived (g set) 
	(derived-aux g set (power-set set)))

(prove-lemma derived-works (rewrite) (implies
	(and (sublistp s set) (setp s))   
		; actually, (properp s) would be enough, but
		; we only care about sets here
	(equal 
		(funcall (derived g set) s)
		(funcall g (add-on-end (find-larger-element s set) s)) ) ) )

(disable derived)
(disable derived-aux2)

; now, if g is pre-homogeneous, then 
; (g s1) is computed from ((derived g set) s), where
; s = (all-but-last s1)

(prove-lemma derived-and-prehom (rewrite) (implies
	(and
		(pre-homp set g)
		(setp s1) (sublistp s1 set)
		(leq 2 (length s1)) )
	(equal
		(funcall g s1)
		(funcall (derived g set) (all-but-last s1))))
( ; hints
(do-not-induct T)
(use 
	(all-but-last-is-sublist-A (s1 s1) (set set))
	(derived-works (s (all-but-last s1)) (g g) (set set) ) )
(disable derived-works all-but-last-is-sublist-A)
))


; now suppose n>=2 and  g is prehom on set
; then say we find small-set is a subset of set which
; is homogeneous for (derivde g set) on the n-1 -- tuples
; then small-set is homogeneous for g on the n -- tuples

; to prove this, we consider any two subsets x, y of small-set
; of size n and prove that g(x) = h(all-but-last x) = h(all-but-last y)
; = g(y) , where h is the derived partition

(prove-lemma derived-partition-lemma-aux1 (rewrite) (implies
	(not (lessp (length x) 2))
	(equal (length (all-but-last x)) (sub1 (length x)))))

(prove-lemma derived-partition-lemma-aux2 (rewrite) (implies
	(and 
		(leq 2 n) (pre-homp  set g)
		(sublistp small-set set)
		(homp small-set (derived g set) (sub1 n)) 
		(sublistp x small-set) (sublistp y small-set)
		(setp x) (setp y)
		(equal (length x) n) (equal (length y) n) )
	(equal (funcall g x) (funcall g y) )  )
( ;  hints
(do-not-induct T)
(use 
	(homp-is-sufficient-A 
		(x (all-but-last x)) (y (all-but-last y)) 
		(g (derived g set)) (set small-set) (n (sub1 n)) ))
(disable homp-is-sufficient-A)
))

; now, if (homp small-set g n) fails, lookat a counter-example

(prove-lemma derived-partition-lemma (rewrite) (implies
	(and 
		(leq 2 n) (pre-homp set g)
		(sublistp small-set set)
		(homp small-set (derived g set) (sub1 n)) )
	(homp small-set g n) )
( ; hints 
(do-not-induct T) 
(use 
	(derived-partition-lemma-aux2
		(n n) (g g) (set set) (small-set small-set) 
		(x (counter-hom-x small-set g n))
		(y (counter-hom-y small-set g n)) )  
	(homp-is-necessary (g g) (n n) (set small-set))) 
(disable homp-is-necessary sublistp only-sublists derived-partition-lemma-aux2) 
(hands-off funcall)))

(disable derived-partition-lemma-aux1)
(disable derived-partition-lemma-aux2)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                           THE TAIL LEMMA                               ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Suppose ZZ is a set which is omega^alpha + omega + k  -- large.
; let z = min ZZ.
; If we take cdr's magic(z+d) times, we get a set QQ such that
; 1. QQ is a set and omega^alpha -- large
; 2. QQ is a subset of ZZ
; 3. min(QQ) >= min(ZZ) + magic(z+k).

; To prove this, we analyze ordinals delta of the forms:
;   type A: delta = omega^alpha + omega + k (k > 0)   (alpha 1 . k) k > 0
;   type B: delta = omega^alpha +  k        (k > 0)   (alpha . k)  k > 0
;   type C: delta = omega^alpha + omega               (alpha 1 . 0)

; As a first step, consider the {delta}(n) for these ordinals.

; type A  : (cons alpha (cons 1 k)) : k > 0

(enable ord-lessp)
(prove-lemma type-A-is-ordinal (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (lessp 0 k) )  
	(ordinalp (cons alpha (cons 1 k)) )))
(disable ord-lessp)

(prove-lemma type-A-is-a-successor (rewrite) (implies
	(lessp 0 k)
	(successorp (cons alpha (cons 1 k)) )))

(prove-lemma predecessor-of-type-A (rewrite)  (implies
	(lessp 0 k)
	(equal
		(predecessor (cons alpha (cons 1 k)) )  
		(cons alpha (cons 1 (sub1 k) )) )) )

(prove-lemma pred-type-A (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (lessp 0 k) )
	(equal
		(pred (cons alpha (cons 1 k)) n)
		(cons alpha (cons 1 (sub1 k))) ))   )

; type B  : (cons alpha k) : k > 0

(enable ord-lessp)
(prove-lemma type-B-is-ordinal (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (lessp 0 k) )  
	(ordinalp (cons alpha k) )))
(disable ord-lessp)

(prove-lemma type-B-is-a-successor (rewrite) (implies
	(lessp 0 k)
	(successorp (cons alpha k) )))

(prove-lemma predecessor-of-type-B (rewrite)  (implies
	(lessp 0 k)
	(equal
		(predecessor (cons alpha k) )  
		(cons alpha (sub1 k) )  ) )  )

(prove-lemma pred-type-B (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (lessp 0 k) )
	(equal
		(pred (cons alpha k) n)
		(cons alpha (sub1 k)) ))   )

; type C  : (cons alpha (cons 1 0)) 
(enable ord-lessp)
(prove-lemma type-C-is-ordinal (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha)  )  
	(ordinalp (cons alpha (cons 1 0)) )))
(disable ord-lessp)

(prove-lemma type-C-is-a-limit (rewrite) 
	(limitp (cons alpha (cons 1 0)) ))

; Now we want:
; (equal 
;   (pred (cons alpha (cons 1 0)) n)
;   (cons alpha (plus (magic n) 2)) )  

; first, compute the norms

(prove-lemma norm-of-type-C (rewrite) (equal
	(norm (cons alpha (cons 1 0)) )
	(plus (norm alpha) 3) ))

(prove-lemma norm-of-pred-of-type-C (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (numberp n)  )  
	(equal
		(norm (pred (cons alpha (cons 1 0)) n) )
		(plus (norm alpha) 3 (magic n)) )) )

(prove-lemma norm-of-right-answer-C (rewrite) (implies
	(numberp n)
	(equal
		(norm (cons alpha (plus (magic n) 2)) ) 
		(plus (norm alpha) 3 (magic n)) ) ) )

; now, we prove that the right answer,  omega^alpha + (magic n) + 2
; is less than omega^alpha + omega  -- then we need
; only show that anything strictly betwwen 
; omega^alpha + (magic n) + 2 and omega^alpha + omega  has larger norm


(prove-lemma pred-type-C-aux1 (rewrite) 
	(ord-lessp
		(cons alpha (plus (magic n) 2))      ; the right answer
		(cons alpha (cons 1 0))  )       ; the type-C ord
( ; hints 
(enable ord-lessp)))

(prove-lemma pred-type-C-aux2 (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (numberp n)  )  
	(ord-leq
		(cons alpha (plus (magic n) 2))    ; the right answer
		(pred (cons alpha (cons 1 0)) n) )))

; so, the only remaining possibility is that 
; (pred (cons alpha (cons 1 0)) n)   is strictly between
; (cons alpha (plus (magic n) 2))   and (cons alpha (cons 1 0))
; but then its norm would be too large

; any ordinal strictly between must be of the form
;  (cons alpha j)  where j > (plus (magic n) 2)

(prove-lemma pred-type-C-aux3 (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (ordinalp sigma)
		(numberp r)
		(ord-lessp (cons alpha r) sigma)
			; omega^alpha + r < sigma
		(ord-lessp sigma (cons alpha (cons 1 0)))     )
			; sigma < omega^alpha + omega
	(and  ; sigma = (cons alpha j) =  omega^alpha + j where r < j
		(equal (car sigma) alpha)
		(numberp (cdr sigma))
		(lessp r (cdr sigma)) )  )
( ; hints 
(do-not-induct T)
(enable ord-lessp)
(use (nocycle (x alpha) (y (car sigma))))
(disable nocycle)
))

(prove-lemma pred-type-C-aux4 (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (ordinalp sigma) (numberp n)
		(ord-lessp (cons alpha (plus (magic n) 2)) sigma)
			; the right answer < sigma
		(ord-lessp sigma (cons alpha (cons 1 0)))     )
			; sigma < omega^alpha + omega
	(lessp (plus (norm alpha) 3 (magic n)) (norm sigma) ) )   ; norm too big
( ; hints 
(do-not-induct T)
(use (pred-type-C-aux3  (alpha alpha) (sigma sigma) 
	(r (plus (magic n) 2)) ) )
(disable pred-type-C-aux3)
))

(prove-lemma pred-type-C-aux5 (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (numberp n) )
	(not (ord-lessp
		(cons alpha (plus (magic n) 2))  ; the right answer
		(pred (cons alpha (cons 1 0)) n) ))  )
( ; hints 
(do-not-induct T)
(use (pred-type-C-aux4  (alpha alpha) (n n)
	(sigma (pred (cons alpha (cons 1 0)) n))))
(disable pred-type-C-aux4)
))

(prove-lemma pred-type-C (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (numberp n)  )  
	(equal 
		(pred (cons alpha (cons 1 0)) n)
		(cons alpha (plus (magic n) 2)) )  )
( ; hints 
(do-not-induct T)
(use 
	(pred-type-C-aux5  (alpha alpha) (n n))
	(pred-type-C-aux2  (alpha alpha) (n n))  )
(disable pred-type-C-aux1 pred-type-C-aux5 pred-type-C-aux2)
(enable ord-leq irreflex-of-ord-leq )
))

(disable pred-type-C-aux1)
(disable pred-type-C-aux2)
(disable pred-type-C-aux3)
(disable pred-type-C-aux4)
(disable pred-type-C-aux5)

;; OK -- that finishes the {delta}(n) discussion

;;;;;;;; nthcdr
; this is like the common lisp function

(defn nthcdr (n lst) (if (zerop n)
	lst
	(cdr (nthcdr (sub1 n) lst))))

; some trivail properties:

(prove-lemma nthcdr-0 (rewrite) (implies
	(zerop n)
	(equal (nthcdr n lst) lst)))

(prove-lemma nthcdr-1 (rewrite) 
	(equal (nthcdr 1 lst) (cdr lst)))

(prove-lemma nthcdr-add (rewrite) (equal
	(nthcdr m (nthcdr n lst))
	(nthcdr (plus m n) lst)))

; since the cdr of a non-list is 0:
(prove-lemma length-of-nthcdr (rewrite) (implies
	(not (equal (nthcdr n lst) 0))
	(equal 
		(length (nthcdr n lst)) 
		(difference (length lst) n))))

; since non-lists are subsets of everying

(enable subsetp)
(prove-lemma nthcdr-is-subset (rewrite)
	(subsetp (nthcdr n lst) lst))
(disable subsetp)


; now, special facts about sets -- 
; we want to know that (nthcdr n set) is a subset of set
; whose car is at least  (car set) + n
; (assuming  the nthdr isn't empty)

(prove-lemma cdr-is-a-set (rewrite) (implies
	(and
		(setp set)
		(not (equal (cdr  set) 0)) )
	(setp (cdr set))) 
( ; hints
(use (tail-of-a-set (s set)))
))

(prove-lemma nthcdr-is-a-set (rewrite) (implies
	(and
		(setp set)
		(not (equal (nthcdr n set) 0)) )
	(setp (nthcdr n set))))


(prove-lemma cdr-is-above (rewrite) (implies
	(and 
		(setp set)
		(listp (cdr set) ))
	(lessp (car set) (car (cdr  set))))) 

(prove-lemma cdr-is-above-by-1 (rewrite) (implies
	(and 
		(setp set)
		(listp (cdr set) ))
	(not (lessp (car (cdr  set)) (add1 (car set)))) ) )

(defn bad-for-nthcdr-is-above-by-n (n set)
	(and
		(setp set)
		(listp (nthcdr n set) )
		(lessp (car (nthcdr n set)) (plus n (car set))))  )

(prove-lemma nthcdr-is-above-by-n-aux1 (rewrite) (implies
	(zerop n)
	(not (bad-for-nthcdr-is-above-by-n n set))))

(prove-lemma nthcdr-is-above-by-n-aux2 (rewrite) (implies
	(and
		(setp set)
		(not (setp (nthcdr n set))) )
	(not (listp (cdr (nthcdr n set)))))
( ; hints
(do-not-induct T)
(use (nthcdr-is-a-set (set set) (n n)))
))

(prove-lemma nthcdr-is-above-by-n-aux3 (rewrite) (implies
	(bad-for-nthcdr-is-above-by-n (add1 n) set)
	(bad-for-nthcdr-is-above-by-n n set) )
( ; hints
(do-not-induct T)
(use (cdr-is-above-by-1 (set (nthcdr n set))))
))

(prove-lemma nthcdr-is-above-by-n-aux4 (rewrite) 
	(not (bad-for-nthcdr-is-above-by-n n set))
( ; hints
(induct (nthcdr n set))
(disable bad-for-nthcdr-is-above-by-n)
))


(prove-lemma nthcdr-is-above-by-n (rewrite) (implies
	(and 
		(setp set)
		(listp (nthcdr n set) ))
	(not (lessp (car (nthcdr n set)) (plus n (car set))))   )
( ; hints
(do-not-induct T)
(use (nthcdr-is-above-by-n-aux4 (n n) (set set)))
(disable nthcdr-is-above-by-n-aux4)
)) 

;;;;;;;;;;;
; now, suppose Z is omega^alpha + omega + d large (say, alpha > 0),
; and z = min(Z).   Let Q = (nthcdr (magic(z +d )  Z))
; then Q is omega^alpha large (in particular, non-empty) , and
; then, by the above, Q is a subset of Z and min(Q)  >= magic(z + d)

; we consider the three types of ordinals in sequence.

; one more simple fact -- needed in the following inductive proofs
(prove-lemma nthcdr-of-cdr (rewrite) (implies
	(not (zerop k))
	(equal
		(nthcdr (sub1 k) (cdr set))
		(nthcdr k set))))

; type A  : (cons alpha (cons 1 k)) : k > 0  : omega^alpha + omega + k
; we iterate k times to get to Z' which is omega^alpha + omega -- large

(prove-lemma cdr-large-A (rewrite) (implies
	(and 
		(setp set)
		(ordinalp alpha) (ord-leq 1 alpha) (lessp 0 k)   
		(o-largep set (cons alpha (cons 1 k))))
	(o-largep (cdr set) (cons alpha (cons 1 (sub1 k))))) )

(defn bad-for-nthcdr-large-A (set alpha k)  (and
	(setp set)
	(ordinalp alpha) (ord-leq 1 alpha) (numberp k) 
	(o-largep set (cons alpha (cons 1 k)) )  
	(or
		(not (setp (nthcdr k set)))
		(not (o-largep (nthcdr k set) (cons alpha (cons 1 0)))))))

(prove-lemma nthcdr-large-A-aux1 (rewrite) (implies
	(zerop k)
	(not  (bad-for-nthcdr-large-A set alpha k))))

(prove-lemma nthcdr-large-A-aux2 (rewrite) (implies
	(setp (cons z x))
	(setp x) )
( ; hints
(use (tail-of-a-set (s (cons z x))))
))

(prove-lemma nthcdr-large-A-aux3 (rewrite) (implies
	(o-largep v (cons alpha (cons 1 k)))
	(listp v) ))

(prove-lemma nthcdr-large-A-aux4 (rewrite) (implies
	(and
		(not (zerop k))
		(bad-for-nthcdr-large-A set alpha k))
	(bad-for-nthcdr-large-A (cdr set) alpha (sub1 k)))
( ; hints
(do-not-induct T)
(use 
	(cdr-large-A (set set) (alpha alpha) (k k)))
(disable cdr-large-A 
	SUBSETP-IS-IDEMPOTENT TYPE-A-IS-ORDINAL LARGE-GOES-UP TYPE-A-IS-A-SUCCESSOR
	PREDECESSOR-OF-TYPE-A SUCCESSOR-LARGE)
))

; force correct induction
(defn nthcdr-large-A-kludge (set alpha k) (if
	(lessp 0 k)
	(nthcdr-large-A-kludge (cdr set) alpha (sub1 k))
	0 ))


(prove-lemma nthcdr-large-A-aux5 (rewrite) 
	(not (bad-for-nthcdr-large-A set alpha k))
( ; hints
(induct (nthcdr-large-A-kludge set alpha k)) 
(disable bad-for-nthcdr-large-A)
))

(prove-lemma nthcdr-large-A (rewrite) (implies
	(and 
		(setp set)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp k) 
		(o-largep set (cons alpha (cons 1 k)) )  )
	(and
		(setp (nthcdr k set))
		(o-largep (nthcdr k set) (cons alpha (cons 1 0))))) 
( ; hints
(do-not-induct T)
(use (nthcdr-large-A-aux5 (set set) (alpha alpha) (k k)))
(disable nthcdr-large-A-aux5
RECURSIVE-CASE-FOR-LARGE NTHCDR-LARGE-A-AUX3 MEMBERS-ARE-NUMBERS
NTHCDR-IS-SUBSET CAR-OF-SUBSET PRED-TYPE-C TYPE-B-IS-A-SUCCESSOR
TYPE-B-IS-ORDINAL PREDECESSOR-OF-TYPE-B SUCCESSOR-LARGE )
))

(disable nthcdr-large-A-aux1)
(disable nthcdr-large-A-aux2)
(disable nthcdr-large-A-aux3)
(disable nthcdr-large-A-aux4)
(disable nthcdr-large-A-aux5)
(disable bad-for-nthcdr-large-A)
(disable nthcdr-large-A-kludge)

; repeat for
; type B  : (cons alpha  k) : k > 0  : omega^alpha +  k
; start with Z whih is omega^alpha +  k -- large
; we iterate k times to get to Z' which is omega^alpha  -- large

(prove-lemma cdr-large-B (rewrite) (implies
	(and 
		(setp set)
		(ordinalp alpha) (ord-leq 1 alpha) (lessp 0 k)   
		(o-largep set (cons alpha  k)))
	(o-largep (cdr set) (cons alpha  (sub1 k)))) )

(defn bad-for-nthcdr-large-B (set alpha k)  (and
	(setp set)
	(ordinalp alpha) (ord-leq 1 alpha) (numberp k) 
	(o-largep set (cons alpha  k) )  
	(or
		(not (setp (nthcdr k set)))
		(not (o-largep (nthcdr k set) (cons alpha  0))))))

(prove-lemma nthcdr-large-B-aux1 (rewrite) (implies
	(zerop k)
	(not  (bad-for-nthcdr-large-B set alpha k))))

(prove-lemma nthcdr-large-B-aux2 (rewrite) (implies
	(setp (cons z x))
	(setp x) )
( ; hints
(use (tail-of-a-set (s (cons z x))))
))

(prove-lemma nthcdr-large-B-aux4 (rewrite) (implies
	(and
		(not (zerop k))
		(bad-for-nthcdr-large-B set alpha k))
	(bad-for-nthcdr-large-B (cdr set) alpha (sub1 k)))
( ; hints
(do-not-induct T)
(use 
	(cdr-large-B (set set) (alpha alpha) (k k)))
(disable cdr-large-B 
	SUBSETP-IS-IDEMPOTENT TYPE-B-IS-ORDINAL LARGE-GOES-UP TYPE-B-IS-A-SUCCESSOR
	PREDECESSOR-OF-TYPE-B SUCCESSOR-LARGE)
))

; force correct induction
(defn nthcdr-large-B-kludge (set alpha k) (if
	(lessp 0 k)
	(nthcdr-large-B-kludge (cdr set) alpha (sub1 k))
	0 ))

(prove-lemma nthcdr-large-B-aux5 (rewrite) 
	(not (bad-for-nthcdr-large-B set alpha k))
( ; hints
(induct (nthcdr-large-B-kludge set alpha k)) 
(disable bad-for-nthcdr-large-B)
))

(prove-lemma nthcdr-large-B (rewrite) (implies
	(and 
		(setp set)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp k) 
		(o-largep set (cons alpha k ) )  )
	(and
		(setp (nthcdr k set))
		(o-largep (nthcdr k set) (cons alpha  0)))) 
( ; hints
(do-not-induct T)
(use (nthcdr-large-B-aux5 (set set) (alpha alpha) (k k)))
(disable nthcdr-large-B-aux5
RECURSIVE-CASE-FOR-LARGE MEMBERS-ARE-NUMBERS
NTHCDR-IS-SUBSET CAR-OF-SUBSET PRED-TYPE-C TYPE-B-IS-A-SUCCESSOR
TYPE-B-IS-ORDINAL PREDECESSOR-OF-TYPE-B SUCCESSOR-LARGE )
))

(disable nthcdr-large-B-aux1)
(disable nthcdr-large-B-aux2)
(disable nthcdr-large-B-aux4)
(disable nthcdr-large-B-aux5)
(disable bad-for-nthcdr-large-B)
(disable nthcdr-large-B-kludge)

; type C  : (cons alpha (cons 1 0))  : omega^alpha + omega
; start with Z which is omega^alpha + omega -- large
; then its cdr is a set and is omega^alpha + (magic z) + 2 -- large

(prove-lemma nthcdr-C-1 (rewrite) (implies
	(and 
		(setp set)
		(ordinalp alpha) (ord-leq 1 alpha) 
		(o-largep set (cons alpha  (cons 1 0)) )  )
	(setp  (cdr set)))   
( ; hints
(do-not-induct T)
(enable  nthcdr-large-B-aux2)
))

(prove-lemma nthcdr-C-2 (rewrite) (implies
	(and 
		(setp set)
		(ordinalp alpha) (ord-leq 1 alpha) 
		(o-largep set (cons alpha  (cons 1 0)) )  )
	(o-largep (cdr set)  (cons alpha (plus (magic (car set)) 2))) )
( ; hints
(do-not-induct T)
(use (pred-type-C (alpha alpha) (n (car set))))
(disable pred-type-C 
	TYPE-B-IS-A-SUCCESSOR TYPE-B-IS-ORDINAL PREDECESSOR-OF-TYPE-B)
(enable o-largep)
))

; now; return to the tail lemma:
; Suppose ZZ is a set which is omega^alpha + omega + d  -- large.
; let z = min ZZ.
; If we take cdr's magic(z+d) times, we get a set QQ such that
; 1. QQ is a set and omega^alpha -- large
; 2. QQ is a subset of ZZ
; 3. min(QQ) >= min(ZZ) + magic(z+d).
; call these parts tail-lemma-1, tail-lemma-2, tail-lemma-3


; First, apply the reductions for types A, C, B in sequence,
; to get an omega^alpha -- large set

(prove-lemma tail-lemma-1-aux1 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )  
		(equal Z1 (nthcdr d ZZ))
		(equal Z2 (cdr Z1))
		(equal Z3 (nthcdr (plus (magic (car Z1)) 2) Z2))  )
	(and
		(setp Z3)
		(o-largep Z3 (cons alpha  0))) )
( ; hints
(use
	(nthcdr-large-A (set ZZ) (k d) (alpha alpha))
	(nthcdr-C-1 (set Z1) (alpha alpha))
	(nthcdr-C-2 (set Z1) (alpha alpha))
	(nthcdr-large-B (set Z2) (k (plus (magic (car Z1)) 2)) (alpha alpha)) )
(disable  o-largep successor-large nthcdr large-with-smaller-ord
	nthcdr-large-A nthcdr-C-1 nthcdr-C-2 nthcdr-large-B )
(do-not-induct T)
))

(prove-lemma tail-lemma-1-aux2 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )  
		(equal Z1 (nthcdr d ZZ))
		(equal Z2 (cdr Z1))
		(equal Z3 (nthcdr 
			(plus (magic (car (nthcdr d ZZ))) 2) 
			(cdr (nthcdr d ZZ))))  )
	(and
		(setp Z3)
		(o-largep Z3 (cons alpha  0))) )  )

(prove-lemma tail-lemma-1-aux3 (rewrite) (equal
	(nthcdr i (cdr set))
	(nthcdr (add1 i) set)))

(prove-lemma tail-lemma-1-aux4 (rewrite) (equal
	(nthcdr 
		(plus j 2) 
		(cdr (nthcdr d ZZ)))
	(nthcdr 
		(add1 (plus j 2))
		(nthcdr d ZZ))))

(prove-lemma tail-lemma-1-aux5 (rewrite) (equal
	(nthcdr 
		(plus j 2) 
		(cdr (nthcdr d ZZ)))
	(nthcdr 
		(plus j 3 d)  
		ZZ)  )   )

(prove-lemma tail-lemma-1-aux6 (rewrite) (equal
	(nthcdr 
		(plus (magic (car (nthcdr d ZZ))) 2) 
		(cdr (nthcdr d ZZ)))
	(nthcdr 
		(plus (magic (car (nthcdr d ZZ))) 3 d) 
		ZZ)  )  )

(prove-lemma tail-lemma-1-aux7 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )  
		(equal Z3 (nthcdr 
			(plus (magic (car (nthcdr d ZZ))) 3 d) 
			ZZ)  )  )
	(and
		(setp Z3)
		(o-largep Z3 (cons alpha  0))) )  )

; now, what we want is not Z3, but
; QQ = (nthcdr (magic (plus (car ZZ) d))  ZZ)
; so, we need that QQ is a subset of Z3, which involves
; showing that 
;  (magic (plus (car ZZ) d)) <= (plus (magic (car (nthcdr d ZZ))) 3 d)
; magic is monotonic, so we need only: 
; (plus (car ZZ) d) <=  (car (nthcdr d ZZ))

(prove-lemma tail-lemma-1-aux8 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )   )
	(listp (nthcdr d ZZ) ))
( ; hints
(do-not-induct T)
(use (nthcdr-large-A (alpha alpha) (set ZZ) (k d)))
(disable nthcdr-large-A)
))

(prove-lemma tail-lemma-1-aux9 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )   )
	(not (lessp
		(car (nthcdr d ZZ)) 
		(plus (car ZZ) d)  ))  )
( ;  hints
(do-not-induct T)
(use (nthcdr-is-above-by-n (set ZZ) (n d)))
(disable  recursive-case-for-large car-of-subset subsetp min-is-first
	o-largep first-before-last nthcdr-is-above-by-n nthcdr setp)
))

(prove-lemma tail-lemma-1-aux10 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )   )
	(not (lessp
		(magic (car (nthcdr d ZZ))) 
		(magic (plus (car ZZ) d)) ))  )
( ;  hints
(do-not-induct T)
(use (magic-17 (v (plus (car ZZ) d)) (w (car (nthcdr d ZZ)))))
))

(prove-lemma tail-lemma-1-aux11 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )   )
	(lessp
		(magic (plus (car ZZ) d))
		(plus (magic (car (nthcdr d ZZ))) 3 d) ) ))

(prove-lemma tail-lemma-1-aux12 (rewrite) (implies
	(lessp i j)
	(equal  (plus  (difference j i) i) j)))

(prove-lemma tail-lemma-1-aux13 (rewrite) (implies
	(lessp i j)
	(subsetp (nthcdr j ZZ) (nthcdr i ZZ)))
( ; hints
(do-not-induct T)
(use 
	(nthcdr-add (m (difference j i)) (n i) (lst ZZ) ) 
	(nthcdr-is-subset (n (difference j i)) (lst (nthcdr i ZZ))) )
(disable nthcdr-is-subset nthcdr-add)
))

(prove-lemma tail-lemma-1-aux14 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )  
		(equal QQ (nthcdr
			(magic (plus (car ZZ) d))
			ZZ ))
		(equal Z3 (nthcdr 
			(plus (magic (car (nthcdr d ZZ))) 3 d) 
			ZZ)  )  )
	(subsetp Z3 QQ) )  )

; now, QQ will be a set if it's not 0

(prove-lemma tail-lemma-1-aux15 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )  
		(equal Z3 (nthcdr 
			(plus (magic (car (nthcdr d ZZ))) 3 d) 
			ZZ)  )  )
	(listp Z3) )
( ; hints
(do-not-induct T)
(use (tail-lemma-1-aux7 (ZZ ZZ) (alpha alpha) (d d) (Z3 Z3)))
(disable successor-large nthcdr tail-lemma-1-aux8 
	tail-lemma-1-aux2 tail-lemma-1-aux7 tail-lemma-1-aux1 tail-lemma-1-aux6)
))

; all these aux lemmas are getting in our way now -- let's 
; just disable them and just quote the ones we need

(disable  tail-lemma-1-aux1)
(disable  tail-lemma-1-aux2)
(disable  tail-lemma-1-aux3)
(disable  tail-lemma-1-aux4)
(disable  tail-lemma-1-aux5)
(disable  tail-lemma-1-aux6)
(disable  tail-lemma-1-aux7)
(disable  tail-lemma-1-aux8)
(disable  tail-lemma-1-aux9)
(disable  tail-lemma-1-aux10)
(disable  tail-lemma-1-aux11)
(disable  tail-lemma-1-aux12)
(disable  tail-lemma-1-aux13)
(disable  tail-lemma-1-aux14)
(disable  tail-lemma-1-aux15)

(prove-lemma tail-lemma-1-aux16 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )  
		(equal QQ (nthcdr
			(magic (plus (car ZZ) d))
			ZZ ))
		(equal Z3 (nthcdr 
			(plus (magic (car (nthcdr d ZZ))) 3 d) 
			ZZ)  )  )
	(listp QQ) )
( ; hints
(do-not-induct T)
(use 
	(tail-lemma-1-aux15 (ZZ ZZ) (alpha alpha) (d d) (Z3 Z3))
	(tail-lemma-1-aux14 (ZZ ZZ) (alpha alpha) (d d) (Z3 Z3)) )
))

(disable  tail-lemma-1-aux16)

(prove-lemma tail-lemma-1-aux17 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )  
		(equal QQ (nthcdr
			(magic (plus (car ZZ) d))
			ZZ ))
		(equal Z3 (nthcdr 
			(plus (magic (car (nthcdr d ZZ))) 3 d) 
			ZZ)  )  )
	(and
		(setp QQ)
		(o-largep QQ (cons alpha  0))) )  
( ; hints
(do-not-induct T)
(use 
	(large-goes-up (alpha (cons alpha  0)) (X Z3) (Y QQ))
	(tail-lemma-1-aux7 (alpha alpha) (ZZ ZZ) (d d) (Z3 Z3))
	(tail-lemma-1-aux14 (alpha alpha) (ZZ ZZ) (d d) (QQ QQ) (Z3 Z3))   
	(tail-lemma-1-aux16 (alpha alpha) (ZZ ZZ) (d d) (QQ QQ) (Z3 Z3))   )
(disable successor-large-non-empty members-are-numbers
	large-goes-up large-superset-ord
	o-largep setp nthcdr nthcdr-large-a large-with-smaller-ord
	recursive-case-for-large successor-large nthcdr-C-1)
))

(prove-lemma tail-lemma-1 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )  
		(equal QQ (nthcdr
			(magic (plus (car ZZ) d))
			ZZ )) )
	(and
		(setp QQ)
		(o-largep QQ (cons alpha  0))) )  )

(disable  tail-lemma-1-aux17)

; now return to parts 2 and 3 of the tail-lemma:
; Suppose ZZ is a set which is omega^alpha + omega + d  -- large.
; let z = min ZZ.
; If we take cdr's magic(z+d) times, we get a set QQ such that
; 1. QQ is a set and omega^alpha -- large
; 2. QQ is a subset of ZZ
; 3. min(QQ) >= min(ZZ) + magic(z+d).
; call these parts tail-lemma-1, tail-lemma-2, tail-lemma-3


(prove-lemma tail-lemma-2 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )  
		(equal QQ (nthcdr
			(magic (plus (car ZZ) d))
			ZZ )) )
	(subsetp QQ ZZ)))

(prove-lemma tail-lemma-aux1 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )  
		(equal QQ (nthcdr
			(magic (plus (car ZZ) d))
			ZZ )) )
	(listp QQ) )
( ; hints
(do-not-induct T)
(use 
	(tail-lemma-1 (ZZ ZZ) (QQ QQ) (d d) (alpha alpha)))
(disable recursive-case-for-large nthcdr members-are-numbers
	tail-lemma-2 tail-lemma-1 nthcdr-large-B type-B-is-ordinal)
))

(prove-lemma tail-lemma-3 (rewrite) (implies
	(and 
		(setp ZZ)
		(ordinalp alpha) (ord-leq 1 alpha) (numberp d) 
		(o-largep ZZ (cons alpha (cons 1 d)) )  
		(equal QQ (nthcdr
			(magic (plus (car ZZ) d))
			ZZ )) )
	(not (lessp 
		(car QQ) 
		(plus (car ZZ) (magic (plus (car ZZ) d)))  ) ) )
( ; hints
(do-not-induct T)
(use 
	(nthcdr-is-above-by-n (n (magic (plus (car ZZ) d))) (set ZZ)))
(disable recursive-case-for-large nthcdr members-are-numbers
	tail-lemma-2)
))

(disable tail-lemma-aux1)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                    PROPERTIES OF PHI AND STAR                          ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; phi(alpha, c) = omega^alpha + omega + norm(alpha) + c

(defn phi (alpha c) (if 
	(and (ordinalp alpha) (ord-leq 1 alpha) (numberp c)) ; intended domain
	(cons alpha (cons 1 (plus (norm alpha) c)))
	(plus (norm alpha) (norm alpha) c 3) ))

(prove-lemma phi-is-an-ord (rewrite) (ordinalp (phi alpha c))
( ; hints
(enable ord-leq)
))

(prove-lemma norm-of-phi (rewrite) (implies
	(numberp c)
	(equal 
		(norm (phi alpha c))
		(plus (norm alpha) (norm alpha) c 3) )))

(defn star (alpha n) (if (zerop n) 
	0
	(sharp alpha (star alpha (sub1 n)))))

(prove-lemma star-is-an-ord (rewrite) (implies
	(ordinalp alpha)
	(ordinalp (star alpha n))))

(prove-lemma star-with-0 (rewrite) (implies
	(zerop n)
	(equal (star alpha n) 0)))

(prove-lemma star-with-1 (rewrite)  (implies
	(ordinalp alpha)
	(equal (star alpha 1) alpha)))

(prove-lemma norm-of-star (rewrite) (implies
	(and (ordinalp alpha) (numberp n))
	(equal 
		(norm (star alpha n))
		(times n (norm alpha) )) ))

(prove-lemma sharp-with-0-reversed (rewrite) (implies
	(ordinalp alpha)
	(equal (sharp alpha 0) alpha)))


(prove-lemma car-of-star (rewrite) (implies
	(and (ordinalp alpha) (lessp 0 n))
	(equal (car (star alpha n)) (car alpha)))
( ; hints
(induct (star alpha n))
))

;; now we show: "bound-on-phi":
; if alpha < beta , then phi(alpha,c) * n < omega^beta  (for any n)

(prove-lemma bound-on-phi-aux1 () (implies
	(ordinalp alpha)
	(equal
		(not (ord-leq 1 alpha))
		(equal alpha 0) ) )
( ; hints
(enable ord-leq ord-lessp)
))

(prove-lemma bound-on-phi-aux2 (rewrite) (implies
	(ord-lessp (car sigma) (car tau))
	(ord-lessp sigma tau) )
( ; hints
(enable ord-lessp)
))

; now, we just need to look at the cars:

(prove-lemma car-of-phi (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (numberp c) )
	(equal
		(car (phi alpha c))
		alpha) ))

(prove-lemma bound-on-phi-aux3 (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (numberp c) (not (zerop n)) )
	(equal (car (star (phi alpha c) n))  alpha) )
( ; hints
(do-not-induct T)
(use
	(car-of-phi (alpha alpha) (c c) )
	(car-of-star (n n) (alpha (phi alpha c))))
(disable car-of-star car-of-phi phi)
(hands-off ord-leq)
))

(prove-lemma bound-on-phi-aux4 (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (numberp c) (zerop n) )
	(equal (car (star (phi alpha c) n))  0) ) )

(prove-lemma bound-on-phi-aux5 (rewrite) (implies
	(and
		(ordinalp alpha) (not (ord-leq 1 alpha)) )
	(equal (car (star (phi alpha c) n))  0) ) 
( ; hints
(do-not-induct T)
(use
	(car-of-star (n n) (alpha (phi alpha c))))
(disable car-of-star)
))

(prove-lemma bound-on-phi (rewrite) (implies
	(and
		(ordinalp alpha) (ordinalp beta) (ord-lessp alpha beta)
		(numberp c) )
	(ord-lessp
		(star (phi alpha c) n)
		(cons beta 0)))  
( ; hints
(do-not-induct T)
(use
	(bound-on-phi-aux2 (sigma (star (phi alpha c) n )) (tau (cons beta 0)))
	(bound-on-phi-aux3 (alpha alpha) (c c) (n n))
	(bound-on-phi-aux5 (alpha alpha) (c c) (n n))
	; (bound-on-phi-aux6 (alpha alpha) (beta beta) (c c) (n n))
	(bound-on-phi-aux4 (alpha alpha) (c c) (n n)) )
(disable phi star bound-on-phi-aux5  car-of-phi ; bound-on-phi-aux6  
	bound-on-phi-aux3 bound-on-phi-aux4 bound-on-phi-aux2)
(enable ord-lessp)
))

(disable bound-on-phi-aux1)
(disable bound-on-phi-aux2)
(disable bound-on-phi-aux3)
(disable bound-on-phi-aux4)
(disable bound-on-phi-aux5)


;;; we plan to apply norm-star-phi with n = c^{2^z}

(prove-lemma norm-star-phi-aux1 (rewrite) (implies
	(and 
		(ordinalp alpha) (numberp n) (numberp c) )
	(equal 
		(norm (star (phi alpha c) n ))
		(times n (plus (norm alpha) (norm alpha) c 3) )))
( ; hints
(do-not-induct T)
(use 
	(norm-of-phi) )
(disable star  norm-of-phi phi)
))


; revise the format to be consistent with lemma magic-18 in Basic arithmetic
; We need some trivial arithmetic to do this.
(prove-lemma times-with-zero-1 (rewrite) (implies
	(zerop x)
	(equal (times x y) 0)))
(prove-lemma times-with-zero-2  (rewrite)(implies
	(zerop y)
	(equal (times x y) 0)))


(prove-lemma commut-of-times-aux1 (rewrite) (implies
	(numberp z)
	(equal
		(times y (add1 z))
		(plus y (times z y)) )  )
( ; hints
(induct (times y v))
))

(prove-lemma commut-of-times () (equal   ; maybe this is a bad rewrite rule
	(times x y) (times y x)) )

(prove-lemma norm-star-phi-aux2 (rewrite) (implies
	(and 
		(numberp x)  (numberp c) )
	(equal
		(plus (plus x x) (add1 (plus 2 c)))
		(plus x x c 3) )))

(prove-lemma norm-star-phi-aux3 (rewrite) (implies
	(and 
		(numberp x) (numberp n) (numberp c) )
	(equal
		(times n (plus x x c 3))
		(times (plus (times 2 x) 3 c) n)))
( ; hints
(use
	(commut-of-times (x n) (y (plus x x c 3)) ))
))

(prove-lemma norm-star-phi (rewrite) (implies
	(and 
		(ordinalp alpha) (numberp n) (numberp c) )
	(equal 
		(norm (star (phi alpha c) n ))
		(times  
			(plus (times 2 (norm alpha) ) 3 c) 
			n)))
( ; hints
(do-not-induct T)
(use
	(norm-star-phi-aux1) )
(disable star phi norm-star-phi-aux1)
))

(disable norm-star-phi-aux1)
(disable norm-star-phi-aux2)
(disable norm-star-phi-aux3)

(disable phi) ; probably we don't need its defn again


;;;;; lemma "norm-star-exp-phi"
;; One more arithmetic fact about phi -- to be used
; in the "cdr-lemma" below.

; suppose  alpha-hat = {alpha}(z),  c > 0
; d = norm(alpha) + c, and q >= magic(z+d).
; Then:    norm(phi(alpha-hat, c) * c^(2^z)) <= magic(q).
; reason   norm(alpha-hat) <= norm(alpha) + magic(z)
; so norm(phi(alpha-hat, c) * c^(2^z)) <= 
;     2 norm (alpha) + 2 magic(z) + 3 + c  <=
;     magic(q)    (by lemma magic-18)

; first, all we use about alpha-hat is its norm

(prove-lemma norm-star-exp-phi-aux1 () (implies
	(equal alpha-hat (pred alpha z))
	(leq
		(norm alpha-hat) 
		(plus (norm alpha) (magic z)) ))
( ; hints
(use (upper-bound-on-norm-of-pred (n z)))
))

; second, plug alpha-hat into norm-star-phi

(prove-lemma norm-star-exp-phi-aux2 (rewrite) (implies
	(and
		(ordinalp alpha) (numberp n) (numberp c) 
		(equal alpha-hat (pred alpha z)))
	(equal 
		(norm (star (phi alpha-hat c) n ))
		(times  
			(plus (times 2 (norm alpha-hat) ) 3 c) 
			n)))   )

; now, we apply aux1 to get an inequality
; since this involves a product with n, we need some preliminary
; arithmetic.  Think of
; a = norm(alpha)
; a-hat = norm(alpha-hat)
; nsp = (norm (star (phi alpha-hat c) n ))
; mz = (magic z)

(prove-lemma norm-star-exp-phi-aux3 () (implies
	(leq a-hat (plus a mz) )
	(leq
		(plus (times 2 a-hat) 3 c)
		(plus (times 2 a) (times 2 mz) 3 c) ) ))

(prove-lemma norm-star-exp-phi-aux4 () (implies
	(leq a-hat (plus a mz) )
	(leq
		(times (plus (times 2 a-hat) 3 c) n)
		(times (plus (times 2 a) (times 2 mz) 3 c) n) ) )
( ; hints
(do-not-induct T)
(use
	(times-is-monotonic (a n) (b n)
		(x (plus (times 2 a-hat) 3 c))
		(y (plus (times 2 a) (times 2 mz) 3 c)) )
	(norm-star-exp-phi-aux3) )
))

(prove-lemma norm-star-exp-phi-aux5 () (implies
	(and
		(equal nsp (times (plus (times 2 a-hat) 3 c) n))
		(leq a-hat (plus a mz)) )
	(leq nsp (times (plus (times 2 a) (times 2 mz) 3 c) n) )  )
( ; hints
(do-not-induct T)
(use (norm-star-exp-phi-aux4))
))

(prove-lemma norm-star-exp-phi-aux6 () (implies
	(and
		(ordinalp alpha) (numberp n) (numberp c) 
		(equal alpha-hat (pred alpha z)))
	(leq 
		(norm (star (phi alpha-hat c) n ))
		(times  
			(plus (times 2 (norm alpha)) (times 2 (magic z)) 3 c) 
			n)))   
( ; hints
(do-not-induct T)
(use 
	(norm-star-exp-phi-aux5
		(nsp (norm (star (phi alpha-hat c) n )))
		(mz (magic z))
		(a-hat (norm alpha-hat))   (a (norm alpha))
		(c c) (n n)  )
	(norm-star-exp-phi-aux1)
	(norm-star-exp-phi-aux2)      )
(disable norm-star-phi norm-star-exp-phi-aux2
	norm star sharp ord-leq
	PHI-IS-AN-ORD NORM-OF-PHI NORM-OF-STAR TIMES-LEFT-IDENT)
))

(prove-lemma norm-star-exp-phi () (implies
	(and 
		(ordinalp alpha) (equal alpha-hat (pred alpha z))
		(not (zerop c))
		(equal d (plus (norm alpha) c))
		(leq (magic (plus z d)) q) )
	(leq
		(norm (star (phi alpha-hat c)  (expt c (expt 2 z)) ))
		(magic q)  ))
( ; hints
(do-not-induct T)
(use
	(norm-star-exp-phi-aux6 (n (expt c (expt 2 z))))
	(magic-18
		(d d) (z z) (q q) (c c) (a (norm alpha)) ) )
(disable  times-left-ident norm-star-phi)
(hands-off norm ord-leq sharp)
))

(disable norm-star-exp-phi-aux1)
(disable norm-star-exp-phi-aux2)
(disable norm-star-exp-phi-aux3)
(disable norm-star-exp-phi-aux4)
(disable norm-star-exp-phi-aux5)
(disable norm-star-exp-phi-aux6)

(disable norm-star-phi)  ; this is firing when we don't want it to



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                             THE CDR LEMMA                              ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Suppose ZZ is a set which is phi(alpha,c) -- large ; alpha >= 1 ; c >= 1
; let z = min ZZ, and alpha-hat = {alpha}(z)
; then
; 1. (cdr ZZ) is a set
; 2. (cdr ZZ) is phi(alpha-hat,c) * c^(2^z)  --  large
; call these cdr-lemma-1 and cdr-lemma-2

; cdr-lemma-1 should be a triviality -- it just says that ZZ is non-empty

(prove-lemma cdr-lemma-1 (rewrite) (implies
	(and
		(setp ZZ)
		(o-largep ZZ (phi alpha c)) )
	(setp (cdr ZZ)))
( ; hints
(enable phi)
(use (tail-of-a-set (s ZZ)))
(disable tail-of-a-set)
))

; for cdr-lemma-2, let 
;        d = norm(alpha) + c
;        QQ = (nthcdr (magic (plus (car ZZ) d)) ZZ )
;         q = (car QQ)
; by defn of phi, ZZ is omega^alpha + omega + d -- large
; then 
; QQ is a set and is omega^alpha -- large (by tail-lemma-1)
; q >= z + magic(z+d)  (by tail-lemma 3)
; phi(alpha-hat,c)* c^(2^z) < omega^alpha (by bound-on-phi)
; norm( phi(alpha-hat,c)* c^(2^z)) <= magic(q) (by norm-star-exp-phi)
; QQ is phi(alpha-hat,c) * c^(2^z)  --  large  (by large-with-smaller-ord)
; QQ is a subset of (cdr Z)  (since (magic (plus (car ZZ) d)) >= 1)
; (cdr ZZ) is phi(alpha-hat,c) * c^(2^z)  --  large  (by large-goes-up)

; unwind defn of phi
(prove-lemma cdr-lemma-aux1 (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (numberp c)
		(setp ZZ)
		(o-largep ZZ (phi alpha c)) 
		(equal d (plus (norm alpha) c))  )
	(o-largep ZZ (cons alpha (cons 1 d)) ) )
( ; hints
(enable phi)
))

(prove-lemma cdr-lemma-aux2 (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (numberp c)
		(setp ZZ)
		(o-largep ZZ (phi alpha c)) 
		(equal d (plus (norm alpha) c))  
		(equal QQ (nthcdr (magic (plus (car ZZ) d)) ZZ )) )
	(and
		(setp QQ)
		(o-largep QQ (cons alpha  0))) )  
( ; hints
(do-not-induct T)
(use
	(tail-lemma-1)
	(cdr-lemma-aux1) )
(hands-off o-largep subsetp)
( disable tail-lemma-1 tail-lemma-2 cdr-lemma-aux1)
))

(prove-lemma cdr-lemma-aux3 () (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (numberp c)
		(setp ZZ)
		(o-largep ZZ (phi alpha c)) 
		(equal d (plus (norm alpha) c))  
		(equal QQ (nthcdr (magic (plus (car ZZ) d)) ZZ )) )
	(leq
		(plus (car ZZ) (magic (plus (car ZZ) d)))
		(car QQ) ) ) 
( ; hints
(do-not-induct T)
(hands-off o-largep subsetp)
(use
	(tail-lemma-3 )
	(cdr-lemma-aux1) )
(disable members-are-numbers tail-lemma-3 cdr-lemma-aux1)
))

(prove-lemma cdr-lemma-aux4 (rewrite) (implies
	(and (ordinalp alpha) (ord-leq 1 alpha) )
	(ord-lessp 0 alpha) )
( ;  hints
(do-not-induct T)
(enable ord-leq ord-lessp)
))

(prove-lemma cdr-lemma-aux5 (rewrite) (implies
	(and (ordinalp alpha) (ord-leq 1 alpha) )
	(ord-lessp (pred alpha z) alpha) ) 
( ; hints
(do-not-induct T)
(use (pred-is-below (n z)) )
(disable pred-is-below)
))

(prove-lemma cdr-lemma-aux6 (rewrite) (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (numberp c)
		(equal alpha-hat (pred alpha z))  )
	(ord-lessp
		(star (phi alpha-hat c) n)
		(cons alpha 0))   )
( ; hints
(do-not-induct T)
(use 
	(bound-on-phi (alpha alpha-hat) (beta alpha) ) )
(disable bound-on-phi)
(hands-off ord-leq insert star sharp)
))

(prove-lemma cdr-lemma-aux7 () (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (not (zerop c))
		(setp ZZ)
		(equal alpha-hat (pred alpha (car ZZ)))  
		(o-largep ZZ (phi alpha c)) 
		(equal d (plus (norm alpha) c))  
		(equal QQ (nthcdr (magic (plus (car ZZ) d)) ZZ )) )
	(leq
		(norm (star (phi alpha-hat c)  (expt c (expt 2 (car ZZ))) ))
		(magic (car QQ)) )   ) 
( ; hints
(do-not-induct T)
(use 
	(cdr-lemma-aux3)
	(norm-star-exp-phi (q (car QQ)) (z (car ZZ)))  )
(disable members-are-numbers cdr-lemma-aux2
phi-is-an-ord norm-of-phi norm-of-star )
(hands-off o-largep setp star sharp insert)
))

; the form of large-with-smaller-ord we need:
(prove-lemma cdr-lemma-aux8 (rewrite) (implies
    (and
        (ordinalp sigma) (ordinalp tau)
        (setp QQ)
        (o-largep QQ tau)
        (ord-lessp sigma tau)
        (leq (norm sigma) (magic (car QQ)) ) )
    (o-largep QQ sigma)) 
( ; hints
(do-not-induct T)
(use 
	(nocycle (x sigma) (y tau))
	(large-with-smaller-ord (alpha sigma) (beta tau) (X QQ) ) )
(disable large-with-smaller-ord nocycle)
(enable ord-leq)
))

(prove-lemma cdr-lemma-aux9 () (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (not (zerop c))
		(equal alpha-hat (pred alpha (car ZZ)))  
		(setp ZZ)
		(o-largep ZZ (phi alpha c)) 
		(equal d (plus (norm alpha) c))  
		(equal QQ (nthcdr (magic (plus (car ZZ) d)) ZZ )) )
	(o-largep QQ  (star (phi alpha-hat c)  (expt c (expt 2 (car ZZ))) )) ) 
( ; hints
(do-not-induct T)
(use
	(cdr-lemma-aux2)  
		; QQ is omega^alpha large
	(cdr-lemma-aux6 (n (expt c (expt 2 (car ZZ)))) (z (car ZZ)) )
		; (star ...) < omega^alpha
	(cdr-lemma-aux7)  
		;  bound on norm of (star ...)  
	(cdr-lemma-aux8 
		(sigma  (star (phi alpha-hat c)  (expt c (expt 2 (car ZZ))) ))
		(tau (cons alpha 0))    )  )
		; these bounds are sufficient
(disable  successor-large
	cdr-lemma-aux2 cdr-lemma-aux6 cdr-lemma-aux8)
(hands-off o-largep star nthcdr sharp norm expt magic)
))

; we know that (cdr ZZ) is a set (cdr-lemma-1) and 
; that QQ is a set (aux2)
; now we just need that QQ is a subset of (cdr ZZ)
(prove-lemma cdr-lemma-aux10 (rewrite) (implies
	(and
		(setp ZZ)
		(o-largep ZZ (phi alpha c)) )
	(listp ZZ) )
( ; hints
(enable phi)
(disable successor-large number-large)
))

(prove-lemma cdr-lemma-aux11 (rewrite) 
	(lessp 2 (magic s))
( ; hints
(do-not-induct T)
(use (magic-1))
))

(prove-lemma cdr-lemma-aux12 (rewrite) (implies
	(not (zerop x)) 
	(equal (nthcdr x ZZ) (nthcdr (sub1 x) (cdr ZZ)))) )

(prove-lemma cdr-lemma-aux13 (rewrite) (implies
	(not (zerop x)) 
	(subsetp (nthcdr x ZZ) (cdr ZZ) ))
( ; hints
(hands-off nthcdr)
(do-not-induct T)
(use 
	(cdr-lemma-aux12)
	(nthcdr-is-subset (lst (cdr ZZ)) (n (sub1 x))))
(disable nthcdr-is-subset cdr-lemma-aux12)
))

(prove-lemma cdr-lemma-aux14 (rewrite) (implies
	(and
		(setp ZZ)
		(equal QQ (nthcdr (magic u) ZZ)) )
	(subsetp QQ (cdr ZZ)))
( ; hints
(hands-off nthcdr)
(disable setp cdr-lemma-aux12 nthcdr-of-cdr)
))

(prove-lemma cdr-lemma-aux15 (rewrite) (implies
    (and
        (ordinalp alpha) (ord-leq 1 alpha) (numberp c)
        (setp ZZ)
        (o-largep ZZ (phi alpha c)) )
	(setp (nthcdr 
			(magic (plus (car ZZ) (plus (norm alpha) c))) 
			ZZ )) ) 
( ; hints
(use
	(cdr-lemma-aux2 
		(d (plus (norm alpha) c))
		(QQ (nthcdr (magic (plus (car ZZ) (plus (norm alpha) c))) ZZ )) )   )
(hands-off o-largep nthcdr)
(disable large-goes-up cdr-lemma-aux2 cdr-lemma-aux12)
))

; disable all the aux's now -- the prover doesn't get them right
(disable cdr-lemma-aux1)
(disable cdr-lemma-aux2)
(disable cdr-lemma-aux3)
(disable cdr-lemma-aux4)
(disable cdr-lemma-aux5)
(disable cdr-lemma-aux6)
(disable cdr-lemma-aux7)
(disable cdr-lemma-aux8)
(disable cdr-lemma-aux9)
(disable cdr-lemma-aux10)
(disable cdr-lemma-aux11)
(disable cdr-lemma-aux12)
(disable cdr-lemma-aux13)
(disable cdr-lemma-aux14)
(disable cdr-lemma-aux15)

(prove-lemma cdr-lemma-2 () (implies
	(and
		(ordinalp alpha) (ord-leq 1 alpha) (not (zerop c))
		(equal alpha-hat (pred alpha (car ZZ)))  
		(setp ZZ)
		(o-largep ZZ (phi alpha c))  )
	(o-largep 
		(cdr ZZ)  
		(star (phi alpha-hat c)  (expt c (expt 2 (car ZZ))) )) )   
( ; hints
(do-not-induct T)
(use
	(cdr-lemma-1)   ; (cdr ZZ) is a set
	(cdr-lemma-aux15)  ; QQ is a set
	(cdr-lemma-aux14  ; QQ is a subset of (cdr ZZ)
		(QQ (nthcdr (magic (plus (car ZZ) (plus (norm alpha) c))) ZZ ))
		(u (plus (car ZZ) (plus (norm alpha) c)) ) )
	(cdr-lemma-aux9  ; QQ is (star ... large)
		(QQ (nthcdr (magic (plus (car ZZ) (plus (norm alpha) c))) ZZ ))
		(d (plus (norm alpha) c)) )
	(large-goes-up
		(alpha (star (phi alpha-hat c)  (expt c (expt 2 (car ZZ)))))
		(X (nthcdr (magic (plus (car ZZ) (plus (norm alpha) c))) ZZ  ))
		(Y (cdr ZZ)) ) )
(disable cdr-lemma-1 successor-large large-goes-up)
(hands-off nthcdr o-largep setp norm star sharp insert)
))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                      THE PIGEON-HOLE PRINCIPLE                         ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; We need a pigeon lemma which says:  If c>0,
;  (mapsto g XX lst),   XX is alpha * c -- large, and c >= |lst|
; then there is a  set YY such that YY is a subset of XX,
; YY is alpha -- large and  g is constant on YY.
; YY will be computed as: (extract-pigeon g XX lst alpha c)
; then the lemma has 4 parts:
; "pigeon-A" says that YY is a subset of XX
; "pigeon-B" says that YY is a set
; "pigeon-C" says that g is constant on YY
; "pigeon-D" says that YY is alpha-large


;;;; first, some facts about mapsto and constant

; define "g is constant on lst"

(defn constantp (g lst) (if (nlistp lst)
	T
	(if (nlistp (cdr lst))
		T
		(and
			(equal (funcall g (car lst)) (funcall g (cadr lst)) )
			(constantp g (cdr lst)))  ) ) )

(prove-lemma constant-same-value (rewrite) (implies
	(and 
		(constantp g lst)
		(member x lst) (member y lst))
	(equal (funcall g x) (funcall g y))))

; constantp is trivially true for lists of length 0 and 1

(prove-lemma constant-0 (rewrite) (implies
	(nlistp lst)
	(constantp g lst)))
(prove-lemma constant-1 (rewrite) (implies
	(nlistp (cdr lst))
	(constantp g lst)))

; if not (constantp g lst),  there is a pair of members
; dif1(g,lst) and dif2(g,lst) such that 
; g(dif1(g,lst)) != g(dif2(g,lst))

(defn dif-pair (g lst) (if (nlistp lst)
	NIL
	(if (nlistp (cdr lst))
		NIL
		(if (not (equal (funcall g (car lst)) (funcall g (cadr lst)) ))
			(cons (car lst) (cadr lst))
			(dif-pair g (cdr lst))))))

(defn dif1 (g lst) (car (dif-pair g lst)))
(defn dif2 (g lst) (cdr (dif-pair g lst)))

(prove-lemma non-constant-different-values (rewrite) (implies
	(not (constantp g lst))
	(and
		(member (dif1 g lst) lst)
		(member (dif2 g lst) lst)
		(not (equal (funcall g (dif1 g lst)) (funcall g (dif2 g lst))) ))))

(disable constantp)
(disable dif-pair)
(disable dif1)
(disable dif2)

; if (mapgst g XX lst) and (length lst) <= 1 then g is constant on XX:

(prove-lemma constant-range-1-aux1 () (implies
	(and 
		(leq (length lst) 1) (member u lst) (member v lst))
	(equal u v) ))

(prove-lemma constant-range-1 (rewrite) (implies
	(and
		(mapsto g XX lst) (leq (length lst) 1))
	(constantp g XX))
( ; hints
(do-not-induct T)
(use
	(mapsto-works
		(g g) (set1 XX) (set2 lst)
		(x (dif1 g XX)) )
	(mapsto-works
		(g g) (set1 XX) (set2 lst)
		(x (dif2 g XX)) )
	(constant-range-1-aux1 
		(u (funcall g (dif1 g XX)))
		(v (funcall g (dif2 g XX))) )
	(non-constant-different-values (g g) (lst XX)))
(disable mapsto-works non-constant-different-values constant-range-1-aux1)
))

(disable constant-range-1-aux1)


;;;;; we prove the pigeon-hole principle as follows:

; Suppose (mapsto g XX lst) , and (listp lst)
; there are two subsets of XX:
; AA = (first-part g XX lst) = set of elements of XX which
;   map to the element (car lst)
; BB = (rest-part g XX lst) = set of elements of XX which 
;   map into (cdr lst)
; then (covers AA BB XX), g is constant on AA, and maps BB to (cdr lst)
; (star alpha n) is (sharp alpha (star alpha (sub1 n)))
; so we will have that if XX is (star alpha n) -- large
; then either AA is alpha-large or BB is 
;       (sharp alpha (star alpha (sub1 n))) -- large

;  AA:
(defn first-part (g XX lst) (if (nlistp XX)
	NIL
	(if (equal (funcall g (car XX)) (car lst))
		(cons (car XX) (first-part g (cdr XX) lst))
		(first-part g (cdr XX) lst)) ))
	
(prove-lemma value-on-first-part (rewrite) (implies
	(member x (first-part g XX lst))
	(equal (funcall g x) (car lst))))

(prove-lemma constantp-on-first-part (rewrite)
	(constantp g (first-part g XX lst) )
( ; hints
(do-not-induct T)
(use (non-constant-different-values (lst (first-part g XX lst)) ))
(disable non-constant-different-values)
))

; BB:
(defn rest-part (g XX lst) (if (nlistp XX)
	NIL
	(if (member (funcall g (car XX)) (cdr lst))
		(cons (car XX) (rest-part g (cdr XX) lst))
		(rest-part g (cdr XX) lst)) ))

(prove-lemma values-on-rest-part (rewrite) (implies
	(member x (rest-part g XX lst))
	(member (funcall g x) (cdr lst)))  )
	
(prove-lemma mapsto-rest-part (rewrite) 
	(mapsto g (rest-part g XX lst) (cdr lst))
( ; hints
(enable mapsto)
))

;; covering properties
(prove-lemma members-of-first-part (rewrite) (implies
	(and 
		(mapsto g XX lst)
		(equal (funcall g x) (car lst))
		(member x XX))
	(member x (first-part g XX lst)))  
( ; hints
(enable mapsto)
))

(prove-lemma members-of-rest-part (rewrite) (implies
	(and 
		(mapsto g XX lst)
		(member (funcall g x) (cdr lst))
		(member x XX))
	(member x (rest-part g XX lst)))  
( ; hints
(enable mapsto)
))

(prove-lemma first-rest-member (rewrite)  (implies
	(and 
		(mapsto g XX lst)
		(member x XX))
	(or
		(member x (first-part g XX lst) )
		(member x (rest-part g XX lst) )  ))  
( ; hints
(enable mapsto)
))

(prove-lemma first-rest-cover (rewrite)  (implies
	(mapsto g XX lst)
	(covers
		(first-part g XX lst)
		(rest-part g XX lst)
		XX ) )  
( ; hints
(do-not-induct T)
(use
	(uncovered-isnt-covered
		(A (first-part g XX lst))
		(B (rest-part g XX lst))
		(X XX))
	(first-rest-member 
		(x  (uncovered (first-part g XX lst) (rest-part g XX lst) XX) )))
(disable uncovered-isnt-covered first-rest-member)
))

; we also need that the first-part and the rest-part are subsets

(prove-lemma first-part-is-sublist (rewrite) 
	(sublistp (first-part g XX lst) XX) )
(prove-lemma rest-part-is-sublist (rewrite) 
	(sublistp (rest-part g XX lst) XX) )

(prove-lemma first-part-is-subset (rewrite) 
	(subsetp (first-part g XX lst) XX)   
( ; hints
(do-not-induct T)
(use 
	(sublist-implies-subset (lst1 (first-part g XX lst)) (lst2 XX))
	(first-part-is-sublist))
(disable first-part-is-sublist)
))
(prove-lemma rest-part-is-subset (rewrite) 
	(subsetp (rest-part g XX lst) XX)   
( ; hints
(do-not-induct T)
(use 
	(sublist-implies-subset (lst1 (rest-part g XX lst)) (lst2 XX))
	(rest-part-is-sublist))
(disable rest-part-is-sublist)
))

; now, prove they are sets
; this is a little inelegant -- we just repeat the same
; argument for first-part and for rest-part

; first-part
(prove-lemma first-part-is-set-aux1 (rewrite) (implies
	(member u (first-part g  XX lst))
	(member u XX)))
(prove-lemma first-part-is-set-aux2 (rewrite) (implies
	(member u (first-part g  (cdr XX) lst))
	(member u (cdr XX))))

(prove-lemma first-part-is-set-aux3 (rewrite) (implies
	(and (setp XX) (member u (first-part g (cdr XX) lst)))
	(lessp (car XX) u))
( ; hints
(do-not-induct T)
(use
	(increasing  (s XX) (x u))
	(first-part-is-set-aux2))
(disable first-part-is-set-aux2 increasing)
))

(prove-lemma first-part-is-set-aux4 (rewrite) (implies
	(and (setp XX) (listp (first-part g (cdr XX) lst)))
	(lessp (car XX) (car (first-part g (cdr XX) lst))) ) 
( ; hints
(do-not-induct T)
(use
	(first-part-is-set-aux3 (u (car (first-part g (cdr XX) lst))) ) )
(disable first-part-is-set-aux2)
))

; we need the following trivial set fact:
(enable setp)
(prove-lemma set-builder (rewrite) (implies
	(and (setp s) (numberp x) (lessp x (car s)))
	(setp (cons x s))) )
(disable setp)

(prove-lemma first-part-is-set-aux5 (rewrite) (implies
	(and 
		(setp XX) 
		(listp (first-part g (cdr XX) lst))
		(setp  (first-part g (cdr XX) lst)) )
	(setp (first-part g XX lst)) )
( ; hints
(do-not-induct T)
(use
	(set-builder (s (first-part g (cdr XX) lst)) (x (car XX))) )
(disable set-builder)
))

(prove-lemma first-part-is-set-aux6 (rewrite) (implies
	(nlistp (first-part g XX lst) )
	(equal (first-part g  XX lst) nil)))

(prove-lemma first-part-is-set-aux7 (rewrite) (implies
	(and 
		(setp XX) 
		(nlistp (first-part g (cdr XX) lst)) )
	(setp (first-part g XX lst)) ) 
( ; hints
(do-not-induct T)
(enable setp)
))

(prove-lemma first-part-is-set-aux8 (rewrite) (implies
	(not (listp XX))
	(setp (first-part g XX lst) )))

(prove-lemma first-part-is-set-aux9 (rewrite) (implies
	(and 
		(setp XX) 
		(setp  (first-part g (cdr XX) lst)) )
	(setp (first-part g XX lst)) )  
( ; hints
(do-not-induct T)
(use
	(first-part-is-set-aux6) 
	(first-part-is-set-aux7) )
(disable first-part listp first-part-is-set-aux7 first-part-is-set-aux6)
))

(prove-lemma first-part-is-set (rewrite) (implies
	(setp XX)
	(setp (first-part g XX lst) ) )  
( ; hints
(use (tail-of-a-set (s XX)))
(disable first-part setp tail-of-a-set)
(hands-off funcall)
(induct (first-part g XX lst))
))

(disable first-part-is-set-aux1)
(disable first-part-is-set-aux2)
(disable first-part-is-set-aux3)
(disable first-part-is-set-aux4)
(disable first-part-is-set-aux5)
(disable first-part-is-set-aux6)
(disable first-part-is-set-aux7)
(disable first-part-is-set-aux8)
(disable first-part-is-set-aux9)


;;; rest-part
(prove-lemma rest-part-is-set-aux1 (rewrite) (implies
	(member u (rest-part g  XX lst))
	(member u XX)))
(prove-lemma rest-part-is-set-aux2 (rewrite) (implies
	(member u (rest-part g  (cdr XX) lst))
	(member u (cdr XX))))

(prove-lemma rest-part-is-set-aux3 (rewrite) (implies
	(and (setp XX) (member u (rest-part g (cdr XX) lst)))
	(lessp (car XX) u))
( ; hints
(do-not-induct T)
(use
	(increasing  (s XX) (x u))
	(rest-part-is-set-aux2))
(disable rest-part-is-set-aux2 increasing)
))

(prove-lemma rest-part-is-set-aux4 (rewrite) (implies
	(and (setp XX) (listp (rest-part g (cdr XX) lst)))
	(lessp (car XX) (car (rest-part g (cdr XX) lst))) ) 
( ; hints
(do-not-induct T)
(use
	(rest-part-is-set-aux3 (u (car (rest-part g (cdr XX) lst))) ) )
(disable rest-part-is-set-aux2)
))

(prove-lemma rest-part-is-set-aux5 (rewrite) (implies
	(and 
		(setp XX) 
		(listp (rest-part g (cdr XX) lst))
		(setp  (rest-part g (cdr XX) lst)) )
	(setp (rest-part g XX lst)) )
( ; hints
(do-not-induct T)
(use
	(set-builder (s (rest-part g (cdr XX) lst)) (x (car XX))) )
(disable set-builder)
))

(prove-lemma rest-part-is-set-aux6 (rewrite) (implies
	(nlistp (rest-part g XX lst) )
	(equal (rest-part g  XX lst) nil)))

; a trivial set fact:
(prove-lemma singleton-set (rewrite) (implies
	(numberp m)
	(setp (list m)))
( ; hints
(enable setp)
))

(prove-lemma rest-part-is-set-aux7 (rewrite) (implies
	(and 
		(setp XX) 
		(nlistp (rest-part g (cdr XX) lst)) )
	(setp (rest-part g XX lst)) ) 
( ; hints
(do-not-induct T)
(disable setp)
))

(prove-lemma rest-part-is-set-aux8 (rewrite) (implies
	(not (listp XX))
	(setp (rest-part g XX lst) )))

(prove-lemma rest-part-is-set-aux9 (rewrite) (implies
	(and 
		(setp XX) 
		(setp  (rest-part g (cdr XX) lst)) )
	(setp (rest-part g XX lst)) )  
( ; hints
(do-not-induct T)
(use
	(rest-part-is-set-aux6) 
	(rest-part-is-set-aux7) )
(disable rest-part listp rest-part-is-set-aux7 rest-part-is-set-aux6)
))

(prove-lemma rest-part-is-set (rewrite) (implies
	(setp XX)
	(setp (rest-part g XX lst) ) )  
( ; hints
(use (tail-of-a-set (s XX)))
(disable rest-part setp tail-of-a-set)
(hands-off funcall)
(induct (rest-part g XX lst))
))

(disable rest-part-is-set-aux1)
(disable rest-part-is-set-aux2)
(disable rest-part-is-set-aux3)
(disable rest-part-is-set-aux4)
(disable rest-part-is-set-aux5)
(disable rest-part-is-set-aux6)
(disable rest-part-is-set-aux7)
(disable rest-part-is-set-aux8)
(disable rest-part-is-set-aux9)


;;;;;; now, back to the pigeon-hole principle:
; if (mapsto g XX lst) and XX is alpha * c -- large, and c >= |lst|
; and c > 0,
; then there is a YY subset XX such that YY is alpha -- large
; and g is constant on YY.

; YY will be (extract-pigeon g XX lst alpha c)

(defn extract-pigeon (g XX lst alpha c) (if (leq c 1) 
	XX
	(if
		(o-largep (first-part g XX lst) alpha)
		(first-part g XX lst)
		(extract-pigeon g (rest-part g XX lst) (cdr lst) alpha (sub1 c)))))

; "pigeon-A" says that YY is a subset of XX
; "pigeon-B" says that YY is a set
; "pigeon-C" says that g is constant on YY
; "pigeon-D" says that YY is alpha-large

(prove-lemma pigeon-A (rewrite) (subsetp
	(extract-pigeon g XX lst alpha c)
	XX ))

(prove-lemma pigeon-B (rewrite) (implies
	(setp XX)
	(setp (extract-pigeon g XX lst alpha c))))

(prove-lemma pigeon-C-aux1 (rewrite)  (implies
	(and (mapsto g XX lst) (leq (length lst) c) (leq c 1))
	(constantp
		g
		(extract-pigeon g XX lst alpha c) )) 
( ; hints
(do-not-induct T)
(use (constant-range-1))
(disable constant-range-1) 
))

(prove-lemma pigeon-C-aux2 (rewrite)  (implies
	(and
		(lessp 1 c)
		(not (o-largep (first-part g XX lst) alpha)) )
	(equal
		(extract-pigeon g XX lst alpha c)
		(extract-pigeon g (rest-part g XX lst) (cdr lst) alpha (sub1 c)) )  ))
		
(prove-lemma pigeon-C (rewrite)  (implies
	(and (mapsto g XX lst) (leq (length lst) c))
	(constantp
		g
		(extract-pigeon g XX lst alpha c) ))   
( ; hints
(induct (extract-pigeon g XX lst alpha c))
))

(disable pigeon-C-aux1)
(disable pigeon-C-aux2)

; now, for D, we have to induct on c

(defn bad-for-pigeon-D (g XX lst alpha c) (and
	(ordinalp alpha) (setp XX) (o-largep XX (star alpha c))
	(mapsto g XX lst) (leq (length lst) c) (not (zerop c))
	(not (o-largep (extract-pigeon g XX lst alpha c) alpha))))

; basis:
(prove-lemma pigeon-D-aux1 (rewrite)  (implies
	(zerop c)
	(not (bad-for-pigeon-D g XX lst alpha c))))

(prove-lemma pigeon-D-aux2 (rewrite)  
	(not (bad-for-pigeon-D g XX lst alpha 1)))

; now we have to work on the induction step, where c > 1:

(prove-lemma pigeon-D-aux3 (rewrite)  (implies
	(and
		(lessp 1 c)
		(bad-for-pigeon-D g XX lst alpha c) )
	(not (o-largep (first-part g XX lst) alpha) ) ))

(prove-lemma pigeon-D-aux4 (rewrite)  (implies
	(and
		(lessp 1 c)
		(bad-for-pigeon-D g XX lst alpha c) )
	(equal
		(extract-pigeon g XX lst alpha c)
		(extract-pigeon g (rest-part g XX lst) (cdr lst) alpha (sub1 c))))
( ; hints
(do-not-induct T)
(use
	(pigeon-D-aux3) )
(disable pigeon-D-aux3)
(hands-off star length o-largep setp rest-part)
))
		
(prove-lemma pigeon-D-aux5 (rewrite)  (implies
	(and
		(ordinalp alpha) (lessp 1 c)
		(setp A) (setp B) (setp X) (covers A B X)
		(o-largep X (star alpha c))
		(not (o-largep A alpha)) )
	(o-largep B (star alpha (sub1 c))))
( ; hints
(do-not-induct T)
(use
	(pigeon-2 
		(alpha alpha) (beta (star alpha (sub1 c)))
		(A A) (B B) (X X)) )
(disable pigeon-2)
(hands-off sharp insert o-largep)
))

(prove-lemma pigeon-D-aux6 (rewrite)  (implies
	(and
		(ordinalp alpha) (mapsto g XX lst)
		(lessp 1 c) (setp XX) (o-largep XX (star alpha c))
		(not (o-largep (first-part g XX lst) alpha) )  )
	(o-largep (rest-part g XX lst) (star alpha (sub1 c))) )
( ; hints
(do-not-induct T)
(use
	(pigeon-D-aux5 (X XX) (A (first-part g XX lst)) (B (rest-part g XX lst))))
(disable pigeon-D-aux5)
(hands-off sharp o-largep)
))

; induction step:  
(prove-lemma pigeon-D-aux7 (rewrite)  (implies
	(and
		(lessp 1 c)
		(listp lst) ; we'll get rid of this later
		(bad-for-pigeon-D g XX lst alpha c) )
	(bad-for-pigeon-D g  (rest-part g XX lst) (cdr lst) alpha (sub1 c)) )
( ; hints
(do-not-induct T)
(use (pigeon-D-aux6))
(hands-off sharp insert o-largep)
(disable setp o-largep rest-part pigeon-D-aux6)
))

; now, what if lst is empty
(prove-lemma pigeon-D-aux8 (rewrite)  (implies
	(and
		(mapsto g XX lst)
		(not (listp lst)) )
	(not (listp XX))) 
( ; hints
(enable mapsto)
))

(prove-lemma pigeon-D-aux9 (rewrite)  (implies
	(and
		(ordinalp alpha)
		(not (equal alpha 0))
		(not (zerop c)))
	(not (equal (star alpha c) 0))))


(prove-lemma pigeon-D-aux10 ()  (implies
	(and
		(ordinalp alpha) (not (zerop c))
		(o-largep XX (star alpha c))
		(nlistp XX))
	(equal alpha 0)))

(prove-lemma pigeon-D-aux11 (rewrite)  (implies
	(and
		(not (zerop c))
		(nlistp lst) )
	(not (bad-for-pigeon-D g XX lst alpha c)))
( ; hints
(do-not-induct T)
(hands-off insert star sharp)
(use
	(pigeon-D-aux10))
))

; revised induction step:  
(prove-lemma pigeon-D-aux12 (rewrite)  (implies
	(and
		(lessp 1 c)
		(bad-for-pigeon-D g XX lst alpha c) )
	(bad-for-pigeon-D g  (rest-part g XX lst) (cdr lst) alpha (sub1 c)) ) 
( ; hints
(do-not-induct T)
(use (pigeon-D-aux7) (pigeon-D-aux11))
(hands-off sharp star ord-leq insert o-largep)
(disable bad-for-pigeon-D setp o-largep rest-part
	pigeon-D-aux7  pigeon-D-aux11)
))

; rephrase the  basis
(prove-lemma pigeon-D-aux13 (rewrite)   (implies
	(not (lessp 1 c))
	(not (bad-for-pigeon-D g XX lst alpha c))))

(prove-lemma pigeon-D-aux14 (rewrite)  
	(not (bad-for-pigeon-D g XX lst alpha c) ) 
( ; hints
(disable bad-for-pigeon-D pigeon-D-aux1 pigeon-D-aux2)
(induct (extract-pigeon g XX lst alpha c))
))

(prove-lemma pigeon-D (rewrite) (implies
	(and 
		(ordinalp alpha) (setp XX) (o-largep XX (star alpha c))
		(mapsto g XX lst) (leq (length lst) c) (not (zerop c)))
	(o-largep (extract-pigeon g XX lst alpha c) alpha))
( ; hints
(do-not-induct T)
(use (pigeon-D-aux14))
(disable pigeon-D-aux14 LARGE-GOES-UP STAR-IS-AN-ORD SUBSETP-IS-IDEMPOTENT)
(hands-off star o-largep sharp insert)
))

(disable bad-for-pigeon-D)
(disable pigeon-D-aux1)
(disable pigeon-D-aux2)
(disable pigeon-D-aux3)
(disable pigeon-D-aux4)
(disable pigeon-D-aux5)
(disable pigeon-D-aux6)
(disable pigeon-D-aux7)
(disable pigeon-D-aux8)
(disable pigeon-D-aux9)
(disable pigeon-D-aux10)
(disable pigeon-D-aux11)
(disable pigeon-D-aux12)
(disable pigeon-D-aux13)
(disable pigeon-D-aux14)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                 RANGES                                 ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; We follow the usual set-theoretic convention that a partition into
; c pieces is just a map into c = {0 ... c-1}.
; when we work with partitions g on tuples from a set XX -- 
; it will be simpler to just assume that g of anything is < c
; Since our definition has (funcall g x) = 0 whenever x is
; outside the natural range of g, this will not cause any problem

; first, let's define the intended domain of g

(defn domain (g) (if (nlistp g)
	nil
	(if (listp (car g))
		(cons (caar g) (domain (cdr g)))
		(domain (cdr g)))))

; even for 0, if 0 is not in (domain g), then (assoc 0 g) is an 
; atom, so its cdr is 0

(prove-lemma assoc-outside-domain (rewrite) (implies
	(not (member x (domain g)))
	(equal (cdr (assoc x g)) 0)))

(enable funcall)
(prove-lemma funcall-outside-domain (rewrite) (implies
	(not (member x (domain g)))
	(equal (funcall g x) 0)))
(disable funcall)

(defn rangep (g c) (if (nlistp g)
	(lessp 0 c)
	(and 
		(rangep (cdr g) c) 
		(numberp (cadar g))
		(lessp (cadar g) c))))

(prove-lemma rangep-is-positive (rewrite) (implies
	(rangep g c)
	(equal (lessp 0 c) T)))

(prove-lemma rangep-bounds (rewrite) (implies
	(rangep g c)
	(lessp (funcall g x) c))
( ; hints
(enable funcall)
))

(prove-lemma rangep-numbers (rewrite) (implies
	(rangep g c)
	(numberp (funcall g x) ))
( ; hints
(enable funcall)
))

(disable rangep)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                             SEGMENTS                                  ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; we need some more on segments now, since (segment 0 c) will
;; be used as the range of a function

(enable segment)

(prove-lemma segments-non-empty (rewrite) (implies
    (and (leq m n) (numberp m) (numberp n))
	(listp (segment m n))))

(prove-lemma car-of-segment (rewrite) (implies
	(listp (segment m n))
	(equal (car (segment m n)) m)))

(prove-lemma cdr-of-segment (rewrite) (implies
	(listp (segment m n))
	(equal (cdr (segment m n)) (segment (add1 m) n))))

(prove-lemma empty-segment (rewrite) (implies
	(or 
		(not (numberp m))
		(not (numberp n))
		(lessp n m))
	(equal (segment m n) nil) ))

(prove-lemma non-list-segment (rewrite) (implies
	(not (listp (segment m n)))
	(equal (segment m n) nil)))

(prove-lemma recursive-case-for-segment (rewrite) (implies
    (and (leq m n) (numberp m) (numberp n))
	(equal (segment m n) (cons m (segment (add1 m) n)) ) ))

(disable segment)

(prove-lemma singleton-segment (rewrite) (implies
	(numberp m)
	(equal (segment m m) (list m)))
( ; hints
(do-not-induct T)
(use 
	(recursive-case-for-segment (m m) (n m))
	(empty-segment (m (add1 m)) (n m))  )
(hands-off segment)
(disable irreflex-of-ord-leq segments-non-empty)
))

(prove-lemma cadr-of-segment (rewrite) (implies
	(listp (cdr (segment m n)))
	(equal (cadr (segment m n)) (add1 m) ))
( ; hints
(use
	(car-of-segment (m (add1 m)) (n n))
	(cdr-of-segment (m m) (n n)))
(disable recursive-case-for-segment
	empty-segment cdr-of-segment car-of-segment segments-non-empty)
(hands-off segment)
))

; let's prove segments are sets -- this is a bit of a pain

(defn bad-for-segments-are-sets (m n) (not (setp (segment m n))))

(prove-lemma segments-are-sets-aux1 ()  (implies
	(bad-for-segments-are-sets m n)
	(and
		(numberp m)
		(numberp n)
		(leq m n))))

(prove-lemma segments-are-sets-aux2 (rewrite)  (implies
	(numberp m)
	(not (bad-for-segments-are-sets m m))) )

(prove-lemma segments-are-sets-aux3 (rewrite)  (implies
	(not (and
		(numberp m)
		(numberp n)
		(lessp m n)) )
	(not (bad-for-segments-are-sets m n)) )
( ; hints
(do-not-induct T)
(use (segments-are-sets-aux1 (m m) (n n)))
(disable recursive-case-for-segment)
))

(prove-lemma segments-are-sets (rewrite)
    (setp (segment m n))
( ; hints
(induct (segment m n))
(use
    (segments-are-sets-aux3 (m m) (n n) )  )
(disable irreflex-of-ord-leq ord-leq-zero segments-are-sets-aux3)
))

(disable segments-are-sets-aux1)
(disable segments-are-sets-aux2)
(disable segments-are-sets-aux3)
(disable bad-for-segments-are-sets)

; another trivial segment fact:

(prove-lemma first-of-segment (rewrite) (implies
	(and (numberp m) (numberp n) (leq m n)) 
	(equal (car (segment m n)) m))
( ; hints
(use (recursive-case-for-segment (m m) (n n)))
(disable recursive-case-for-segment)
))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                      BASIS OF RAMSEY THEOREM                           ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; This will be "ramsey-basis" -- the Ramsey theorem for 1-tuples.
; Suppose (rangep g c) (so c > 0), XX is a set which is alpha * c -- large.
; Then there is a  set YY such that YY is a subset of XX,
; YY is alpha -- large,  g is constant on the singletons of YY --
; that is:  (homp YY g 1)
; the proof is to define an auxilliary function h -- so that
; (funcall h x) = (funcall g (list x)), 
; and then apply the pigeon-hole principle

; call this h "(sing-fn g)"
; this will be (sing-fn-aux g (domain g))
; if h = (sing-fn-aux g lst)  and (list x) is in lst, then
; (funcall h x) = (funcall g (list x))

; then YY will be (extract-ramsey-basis g XX alpha c) = 
; (extract-pigeon (sing-fn g) XX (segment 0 c) alpha c)

(defn sing-fn-aux (g lst) (if (nlistp lst)
	nil
	(if (equal (car lst) (list (caar lst)))  ; (car list is of form (list x))
		(cons 
			(list (caar lst) (funcall g (car lst)))
			(sing-fn-aux g (cdr lst)) )
		(sing-fn-aux g (cdr lst))  )  )  )

(prove-lemma sing-fn-aux-1 (rewrite) (implies
	(member (list x) lst)
	(equal
		(assoc x (sing-fn-aux g lst))
		(list x (funcall g (list x))))))

(prove-lemma sing-fn-aux-2 (rewrite) (implies
	(not (member (list x) lst))
	(not (listp (assoc x (sing-fn-aux g lst))))))

(enable funcall)

(prove-lemma sing-fn-aux-3 (rewrite) (implies
	(member (list x) lst)
	(equal
		(funcall (sing-fn-aux g lst) x)
		(funcall g (list x)))))

(prove-lemma sing-fn-aux-4 (rewrite) (implies
	(not (member (list x) lst))
	(equal
		(funcall (sing-fn-aux g lst) x)
		0)))

(disable funcall)

(defn sing-fn (g) (sing-fn-aux g (domain g)))

(prove-lemma sing-fn-on-sings (rewrite) (equal
	(funcall (sing-fn g) x)
	(funcall g (list x)))  
( ; hints
(do-not-induct T)
(use
	(sing-fn-aux-3 (lst (domain g)))
	(sing-fn-aux-4 (lst (domain g))) )
(disable sing-fn-aux-3 sing-fn-aux-4)
))

(disable sing-fn-aux)
(disable sing-fn-aux-1)
(disable sing-fn-aux-2)
(disable sing-fn-aux-3)
(disable sing-fn-aux-4)

(disable sing-fn)  ; all we need is its properties

; now, if (rangep g c) (so c > 0) , then
; g takes anything to (segment 0 (sub1 c)) = {0 ... c-1} = c
; this is a list of length c, so the pigeon hole principle
; should apply.

; as preliminaries

(prove-lemma size-of-initial-segment (rewrite) (implies
	(lessp 0 c)
	(equal (length (segment 0 (sub1 c)))  c))
( ; hints
(do-not-induct T)
(use (size-of-segment (m 0) (n (sub1 c))))
(disable size-of-segment)
))

(prove-lemma members-of-initial-segment (rewrite) (implies
	(lessp 0 c)
    (equal
        (member x (segment 0 (sub1 c)))
        (and (numberp x) (lessp x c))))  
( ; hints
(do-not-induct T)
(use (members-of-segment (m 0) (n (sub1 c))))
(disable members-of-segment recursive-case-for-segment)
))

(prove-lemma bound-values-of-sing-fn (rewrite) (implies
	(rangep g c)
	(lessp (funcall (sing-fn g) x) c)  ))

(prove-lemma number-values-of-sing-fn (rewrite) (implies
	(rangep g c)
	(numberp (funcall (sing-fn g) x) )  )
( ; hints
(do-not-induct T)
(use 
	(sing-fn-on-sings)
	(rangep-numbers (g g) (c c) (x (list x)))) 
(disable sing-fn-on-sings)
))

(prove-lemma sing-fn-mapsto-aux1 (rewrite) (implies
	(rangep g c)
	(member (funcall (sing-fn g) x)    (segment 0 (sub1 c))))
( ; hints
(do-not-induct T)
(use 
	(members-of-initial-segment (x (funcall (sing-fn g) x))) )
(disable  recursive-case-for-segment
	sing-fn-on-sings members-of-initial-segment)
(hands-off rangep)
))

(prove-lemma sing-fn-mapsto (rewrite) (implies
	(rangep g c)
	(mapsto (sing-fn g) XX (segment 0 (sub1 c))))
( ; hints
(enable mapsto)
(disable segment recursive-case-for-segment sing-fn-on-sings)
(hands-off segment sing-fn)
))

(disable sing-fn-mapsto-aux1)

;; now, we are set up for a proof of the basis of Ramsey's theorem

; the YY that works is given by

(defn extract-ramsey-basis (g XX alpha c)
	(extract-pigeon (sing-fn g) XX (segment 0 (sub1 c)) alpha c))

; We're assuming 
; (rangep g c) (so c > 0), XX is a set which is alpha * c -- large.

; "ramsey-basis-A" says that YY is a subset of XX
; "ramsey-basis-B" says that YY is a set
; "ramsey-basis-C" says that (homp YY g 1)
; "ramsey-basis-D" says that YY is alpha-large

(prove-lemma ramsey-basis-A (rewrite) (subsetp
	(extract-ramsey-basis g XX alpha c)
	XX ))

(prove-lemma ramsey-basis-B (rewrite) (implies
	(setp XX)
	(setp (extract-ramsey-basis g XX alpha c))))

; now to prove (homp YY g 1) -- 
; we need to prove that 
; (constantp (sing-fn g) YY) implies (homp YY g 1)
; this is true because we've proved if (not ((homp YY g n)))
; we have an explicit counter-example
; first, let's recast this counter-example in the case n = 1

(prove-lemma ramsey-basis-C-aux1 (rewrite)  (implies
	(sublistp (list x) set)
	(member x set)))

(defn counter-hom-aux-x (set g) (car (counter-hom-x set g 1)))
(defn counter-hom-aux-y (set g) (car (counter-hom-y set g 1)))

(prove-lemma ramsey-basis-C-aux2 (rewrite)  (implies
	(and 
		(setp lst)
		(equal (length lst) 1) )
	(equal (list (car lst)) lst))
( ; hints
(enable setp)
(disable sublistp members-are-numbers ramsey-basis-C-aux1)
))

(prove-lemma ramsey-basis-C-aux3 (rewrite)  (implies
	(not (homp set g 1))
	(equal (counter-hom-x set g 1) (list (counter-hom-aux-x set g)) )) 
( ; hints
(do-not-induct T)
(use 
	(homp-is-necessary (n 1)))
(disable homp-is-necessary)
))

(prove-lemma ramsey-basis-C-aux4 (rewrite)  (implies
	(not (homp set g 1))
	(equal (counter-hom-y set g 1) (list (counter-hom-aux-y set g)) )) 
( ; hints
(do-not-induct T)
(use 
	(homp-is-necessary (n 1)))
(disable homp-is-necessary)
))

(prove-lemma ramsey-basis-C-aux5 (rewrite)  (implies
	(not (homp set g 1))
	(and
		(member (counter-hom-aux-x set g) set)
		(member (counter-hom-aux-y set g) set)
		(not (equal
			(funcall (sing-fn g) (counter-hom-aux-x set g))
			(funcall (sing-fn g) (counter-hom-aux-y set g))) )))
( ; hints
(do-not-induct T)
(use
	(homp-is-necessary (n 1)))
(disable homp-is-necessary)
))

(prove-lemma ramsey-basis-C-aux6 (rewrite)  (implies
	(constantp (sing-fn g) set)
	(homp set g 1))
( ; hints
(do-not-induct T)
(use
	(constant-same-value
		(lst set)
		(g (sing-fn g))
		(x (counter-hom-aux-x set g))
		(y (counter-hom-aux-y set g)) ))
(hands-off counter-hom-aux-x  counter-hom-aux-y)
(disable sing-fn-on-sings 
	counter-hom-aux-x  counter-hom-aux-y constant-same-value)
))

(prove-lemma ramsey-basis-C (rewrite)  (implies
    (rangep g c)
    (homp  (extract-ramsey-basis g XX alpha c)  g 1))
( ; hints
(do-not-induct T)
(use
	(ramsey-basis-C-aux6  (set (extract-ramsey-basis g XX alpha c)))
	(rangep-is-positive)
	(pigeon-C (g (sing-fn g)) (lst (segment 0 (sub1 c)))))
(disable  rangep-is-positive recursive-case-for-segment
	pigeon-C setp sublistp rest-part homp extract-pigeon o-largep)
))

(disable counter-hom-aux-x)
(disable counter-hom-aux-y)
(disable ramsey-basis-C-aux1)
(disable ramsey-basis-C-aux2)
(disable ramsey-basis-C-aux3)
(disable ramsey-basis-C-aux4)
(disable ramsey-basis-C-aux5)
(disable ramsey-basis-C-aux6)

(prove-lemma ramsey-basis-D (rewrite)  (implies
	(and
		(ordinalp alpha) (setp XX) (o-largep XX (star alpha c))
		(rangep g c))
	(o-largep (extract-ramsey-basis g XX alpha c) alpha) )  
( ; hints
(do-not-induct T)
(use
	(rangep-is-positive)
	(pigeon-D (g (sing-fn g)) (lst (segment 0 (sub1 c)))))
(disable o-largep star sharp insert extract-pigeon members-are-numbers
	recursive-case-for-segment pigeon-D rangep-is-positive)
(hands-off o-largep)
))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                     MISCELLANEOUS CONSTRUCTIONS                        ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;  vn

; first, to make our notation more compact:
; Look a number z as a von Neumann ordinal -- 
; the set of all smaller numbers.  
; to make this a standard set, we list them in increasing order

(defn vn (z) (if (zerop z) 
	nil
	(add-on-end (sub1 z) (vn (sub1 z)))))

(prove-lemma size-of-vn (rewrite) (implies
	(numberp z)
	(equal (length (vn z)) z)) )

(prove-lemma last-of-vn (rewrite) (implies
	(not (zerop z))
	(equal (last (vn z)) (sub1 z))))

(prove-lemma vn-is-a-set-aux1 (rewrite) (implies
	(and (lessp 1 z) (setp (vn (sub1 z))) )
	(setp (vn z)))
( ; hints
(do-not-induct T)
(use (add-on-end-makes-sets (set (vn (sub1 z))) (n (sub1 z))))
(disable add-on-end-makes-sets)
))

(prove-lemma vn-is-a-set-aux2 (rewrite) (implies
	(zerop z) (setp (vn z))))

(prove-lemma vn-is-a-set-aux3 (rewrite) (setp (vn 1)))

(prove-lemma vn-is-a-set (rewrite)
	(setp (vn z))
( ; hints
(induct (vn z))
(use
	(vn-is-a-set-aux1))
(disable vn vn-is-a-set-aux1)
))

(disable vn-is-a-set-aux1)
(disable vn-is-a-set-aux2)
(disable vn-is-a-set-aux3)

; to prove that the members of (vn z) are the numbers below z
; we have to say what the members of add-on-end are

(prove-lemma members-of-add-on-end (rewrite) (equal
	(member x (add-on-end item lst))
	(or
		(member x lst)
		(equal x item))))

(prove-lemma members-of-vn-aux1 (rewrite)  (implies
	(zerop z)
	(not (member x (vn z)))))

(prove-lemma members-of-vn-aux2 (rewrite)  (implies
	(not (zerop z))
    (equal
        (member x (vn z))
		(or
			(member x (vn (sub1 z)))
			(equal x (sub1 z))))))

(disable vn)   ; probably, we will never need its defn

(prove-lemma members-of-vn (rewrite) 
    (equal
        (member x (vn z))
        (and (numberp x) (lessp x z)))
( ; hints
(induct (vn z))
))

(disable members-of-vn-aux1)
(disable members-of-vn-aux2)


;;;;;;;;;;;;;;   all-maps
;;; let c>0

; (standard-fn g lst c) says that g is a function in standard
;  form from lst into c.   If lst = (x_1 ... x_n . foo), then
; g should be ( (x_1 v_1) ... (x_n v_n))
; we will build these in the induction step for Ramsey's theorem.
; now, we just want to prove that there are c^(length lst) of these

; we define (all-maps lst c), show that it contains all standard
; functions, and show that its size is c^(length lst)

(defn standard-function (g lst c) (if (nlistp lst)
	(equal g nil)
	(and
		(standard-function (cdr g) (cdr lst) c)
		(listp (car g))
		(equal (car g) (list (car lst) (cadar g)))
		(and (numberp (cadar g)) (lessp (cadar g) c)))))

; in an r-loop
; *(standard-function '((a 3) (b 1)) '(a b) 4 )
;  T
; *(standard-function '((a 3) (b 1)) '(a b) 3 )
;  F
; *(standard-function '((a 3) (b 1)) '(a b c) 5 )
;  F

(prove-lemma tail-of-standard-function (rewrite) (implies
	(standard-function g (cons x lst) c)
	(standard-function (cdr g)  lst c) ))

; to build up (all-maps lst c):
; suppose g is a standard fn from (cons x lst) to c
; and (cdr g) is a member of a family FF
; then g is of the form (cons (list x i) h) for some i < c
; there are exactly c possibilites for (cons x i)

; we define (extend-family FF x c) to be all such g -- 
; then this will have length = c * |FF|

(defn list-all (x c) (if (zerop c)
	nil
	(cons (list x (sub1 c)) (list-all x (sub1 c)))))

(prove-lemma list-all-gets-all (rewrite) (implies
	(and (numberp i) (lessp i c))
	(member (list x i) (list-all x c)))
( ; hints
(induct (list-all x c))
))
; the list of all (list x i) ; with i < c

(prove-lemma size-of-list-all (rewrite)  (implies
	(numberp c)
	(equal (length (list-all x c)) c) )  )

(defn all-maps (lst c) (if (nlistp lst)
	'(NIL)
	(product
		(list-all (car lst) c)
		(all-maps (cdr lst) c) ) ))

(prove-lemma all-maps-gets-all (rewrite) (implies
	(standard-function g lst c)
	(member g (all-maps lst c))))

; now, to compute the size of (all-maps lst c)
; we first need to compute the size of the product of two lists

(enable product)
(prove-lemma size-of-product (rewrite) (equal
	(length (product lst1 lst2))
	(times (length lst1) (length lst2))))
(disable product)

(prove-lemma size-of-all-maps (rewrite) (implies
	(numberp c)
	(equal
		(length (all-maps lst c))
		(expt c (length lst)))))


;;;;;;;  constructing standard functions
; If OP is any defined function, we may construct a standard fn from
; lst to c by running down lst and applying OP
; Since we can't quantify over all defined functions without using
; something like $eval, we just do this for the one OP needed
; in the proof of Ramsey's theorem.

; Suppose (rangep g c) ; think of g as a partition of tuples
; we are trying to get a homogeneous set for.
; In an attempt to construct a pre-homogeneous set, we fix
; a z in omega and let lst be the power set of z  (so |lst| = 2^z)
; for a y > z, we consider g to define a map lst --> c 
; which takes a set S to g(S union {z,y})
; we can call this new function (power-map g z y), and
; later try to get a large set of y's for which (power-map g z y) is the same.

; (power-map g z y)  will be (augmented-map g z y (power-set (vn z)))

; first, let's define (augmented-map g z y lst)

(defn end-end (x g z y) 
	(funcall g (add-on-end y (add-on-end z x))) )
; i.e., we're expecting x subset z < y, so we apply the partition
; g to x union {z,y}

; for now, we only care that this defines a function of x,
; with g,z,y as parameters, and that the values are < c 
; if g has range c

(prove-lemma end-end-yields-numbers (rewrite) (implies
	(rangep g c)
	(numberp (end-end x g z y))))

(prove-lemma bound-on-end-end (rewrite) (implies
	(rangep g c)
	(lessp (end-end x g z y) c)))

(disable end-end)

(defn augmented-map (g z y lst)  (if (nlistp lst)
	nil
	(cons
		(list (car lst) (end-end (car lst) g z y))
		(augmented-map g z y (cdr lst)))))

(prove-lemma augmented-map-is-standard (rewrite) (implies
	(rangep g c)
	(standard-function (augmented-map g z y lst) lst c)))

(prove-lemma values-of-augmented-map (rewrite) (implies
	(member x lst)
	(equal
		(funcall (augmented-map g z y lst) x)
		(end-end x g z y)))
( ; hints
(enable funcall)
))


;;;;;;;  power-map
; now, let's develop the properties of (power-map g z y)

(defn power-map (g z y) (augmented-map g z y (power-set (vn z))))

; intent :  z is in omega, and y > z
; then (power-map g z y) is a function which takes the
; sub-set S of z to  g(S U {z,y})

; first, let's consider the kind of object (power-map g z y) is,
; and show that there are  only c^(2^z) of these.

(defn all-fns-on-power (z c) (all-maps (power-set (vn z)) c))

(prove-lemma size-of-all-fns-on-power (rewrite) (implies
	(and (numberp c)  (numberp z))
	(equal 
		(length (all-fns-on-power z c))
		(expt c (expt 2 z)))))

(prove-lemma power-map-in-all-fns (rewrite)  (implies
	(rangep g c)
	(member
		(power-map g z y)
		(all-fns-on-power z c))))

; now, show that power-map takes sub-sets of z where they should go:

(prove-lemma value-of-power-map (rewrite) (implies
	(and (setp S) (subsetp S (vn z)))
	(equal
		(funcall (power-map g z y) S)
		(end-end S g z y)))
( ; hints
(do-not-induct T)
))

; the main point of this is:  if we have a set YY such that
; (power-map g z y) is the same for all y in YY, then
; g(S U {z,y}) is independent of y in YY:

(prove-lemma same-power-maps (rewrite) (implies
	(and 
		(setp S) (subsetp S (vn z))
		(equal
			(power-map g z y1)
			(power-map g z y2)) )
	(equal
		(funcall g (add-on-end y1 (add-on-end z S)))
		(funcall g (add-on-end y2 (add-on-end z S)))  )  )   
( ; hints
(do-not-induct T)
(enable end-end)
(use
	(value-of-power-map (y y1))
	(value-of-power-map (y y2)))
(disable value-of-power-map power-map)
))

; now, in order to get such a YY, we consider (power-map g z y)
; as a function on YY, and then apply the pigeon-hole principle

; first, repeat the procedure to get a function on YY

(defn power-power (g z YY) (if (nlistp YY)
	nil
	(cons
		(list (car YY) (power-map g z (car YY)))
		(power-power g z (cdr YY)))))

; this maps YY into (all-fns-on-power z c) -- i.e., the
; set of functions from power-set of z into c

(prove-lemma value-of-power-power (rewrite) (implies
	(member y YY)
	(equal
		(funcall (power-power g z YY) y)
		(power-map g z y) ))
( ; hints
(enable funcall)
(disable all-fns-on-power power-map subsetp-is-idempotent car-of-subset)
))

(prove-lemma member-values-of-power-power (rewrite) (implies
	(and (rangep g c) (member y YY))
	(member 
		(funcall (power-power g z YY) y)
		(all-fns-on-power z c) )  )
( ; hints
(enable funcall)
(disable all-fns-on-power power-map subsetp-is-idempotent car-of-subset)
))

(prove-lemma range-of-power-power-aux1 (rewrite) (implies
	(and (rangep g c) (subsetp K YY))
	(mapsto (power-power g z YY) K  (all-fns-on-power z c)))   
( ; hints
(enable mapsto)
(disable power-power all-fns-on-power value-of-power-power)
(hands-off power-power all-fns-on-power)
))

; the following was a little tricky to prove, since
; we need to induct on the second YY -- with the first one fixed
; the "natural" induction will replace YY with (cdr YY) in both occurences
(prove-lemma range-of-power-power (rewrite) (implies
	(rangep g c)
	(mapsto (power-power g z YY) YY  (all-fns-on-power z c)))    
( ; hints
(do-not-induct T)
(disable power-power all-fns-on-power)
(hands-off power-power all-fns-on-power)
))

(disable range-of-power-power-aux1)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                           THE NICE SET LEMMA                           ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; assume z is a number and XX is a set
;      (we plan to have z < min XX)
; we want (nice g z XX)  to say that whenever x1,x2 are in X
; and S is a subset of z, g(S U {z,x1}) = g(S U {z,x2})

; since we will get this situation by applying the pigeon-hole
; principle, which uses constantp, we make that the official defn
; and then derive the main property

(defn nice (g z XX) (constantp (power-power g z XX) XX))

(prove-lemma nice-implies-constant (rewrite) (implies
	(and
		(nice g z XX)
		(member x1 XX) (member x2 XX) )
	(equal
		(funcall (power-power g z XX) x1)
		(funcall (power-power g z XX) x2)  )  )
( ; hints
(do-not-induct T)
(hands-off funcall)
(use
	(constant-same-value 
		(g (power-power g z XX) ) 
		(lst XX)  (x x1) (y x2)))
(disable constant-same-value power-power value-of-power-power)
))

(prove-lemma nice-implies-same-values (rewrite) (implies
	(and
		(nice g z XX)
		(member x1 XX) (member x2 XX)
		(setp S) (subsetp S (vn z)) )
	(equal
		(funcall g (add-on-end x1 (add-on-end z S)))
		(funcall g (add-on-end x2 (add-on-end z S))) ))  
( ; hints
(do-not-induct T)
(use
	(same-power-maps (y1 x1) (y2 x2)  )
	(nice-implies-constant)  )
(disable 
	same-power-maps add-on-end setp nice-implies-constant nice power-map)
))


;;;;;;;  lemma "nice-going-down"

; now, we plan to start with a big XX and apply the pigeon-hole
; principle to the map (power-power g z XX) to get a subset YY
; of XX such that (constantp (power-power g z XX) YY)

; we will need that this implies (constantp (power-power g z YY) YY) --
; i.e., (nice g z YY) :  lemma "nice-going-down"

; this is true because if y is in YY, a subset of XX
; then (funcall (power-power g z YY) y)  = (funcall (power-power g z XX) y)

; this is because both are equal to (power-map g z y)

(prove-lemma nice-goes-down-aux1 (rewrite) (implies
	(and 
		(member y YY)
		(subsetp YY XX))
	(equal
		(funcall (power-power g z YY) y)
		(funcall (power-power g z XX) y) )  ))

(prove-lemma nice-goes-down-aux2 (rewrite) (implies
	(and 
		(constantp (power-power g z XX) YY)
		(member y1 YY) (member y2 YY)
		(subsetp YY XX))
	(equal
		(funcall (power-power g z YY) y1)
		(funcall (power-power g z YY) y2)  ))
( ; hints
(do-not-induct T)
(use
	(constant-same-value (g (power-power g z XX)) (lst YY) (x y1) (y y2)))
(disable constant-same-value
	power-map value-of-power-power funcall-outside-domain)
(hands-off setp)
))

(disable nice-goes-down-aux1)
(disable nice-goes-down-aux2)

(prove-lemma nice-goes-down-aux3 (rewrite) (implies
	(and 
		(constantp (power-power g z XX) YY)
		(listp VV) (listp (cdr VV))
		(subsetp YY XX) (subsetp VV YY))
	(equal
		(funcall (power-power g z YY) (car VV))
		(funcall (power-power g z YY) (cadr VV))  )) 
( ; hints
(do-not-induct T)
(use (nice-goes-down-aux2 (y1 (car VV)) (y2 (cadr VV))))
(disable power-power value-of-power-power)
))

(prove-lemma nice-goes-down-aux4 (rewrite) (implies
	(and (subsetp VV YY) (listp VV))
	(subsetp (cdr VV) YY)))

(prove-lemma nice-goes-down-aux5 (rewrite) (implies
	(and 
		(constantp (power-power g z XX) YY)
		(subsetp YY XX) (subsetp VV YY))
	(constantp (power-power g z YY) VV))
( ; hints
(disable subsetp-is-idempotent 
	power-power value-of-power-power cdr-of-subset)
(enable constantp)
; (hands-off funcall setp)
(induct (constantp u VV))
))

; we had the following problem in proving this:
; we want to prove  (constantp (power-power g z YY) YY) --
; but we have to induct on the second YY -- not the first --
; so we added a set VV:  assume VV subset YY subset XX
; and prove (constantp (power-power g z YY) VV) -- then set VV = YY  :
(prove-lemma nice-goes-down (rewrite) (implies
	(and 
		(constantp (power-power g z XX) YY)
		(subsetp YY XX))
	(nice g z YY))  )

(disable nice-goes-down-aux3)
(disable nice-goes-down-aux4)
(disable nice-goes-down-aux5)


;;;;;;;;  now, back to the nice set lemma
; Suppose ZZ is a set which is phi(alpha,c) -- large ; alpha >= 1 ; c >= 1
; let z = min ZZ, and alpha-hat = {alpha}(z)
; then, by cdr-lemma-1 and cdr-lemma2
; 1. (cdr ZZ) is a set
; 2. (cdr ZZ) is phi(alpha-hat,c) * c^(2^z)  --  large

; now, suppose also that g maps into c.
; then, we can apply the pigeon-hole principle to the
; function (power-power g z (cdr ZZ)) to get a subset
; YY of (cdr ZZ) such that YY is phi(alpha-hat,c)  -- large
; and (power-power g z (cdr ZZ)) is constant on YY --
; so (nice g z YY)

; we obtain YY as (extract-nice g ZZ alpha c)
; we define extract-nice so that it will return NIL if the
; hypotheses to the nice set lemma aren't met

(defn extract-nice (g ZZ alpha c) (if
	(and
		(ordinalp alpha) (not (zerop c)) (ord-leq 1 alpha)
		(rangep g c)
		(setp ZZ) (o-largep ZZ (phi alpha c)))
	(extract-pigeon 
		(power-power g (car ZZ) (cdr ZZ))   ; the function
		(cdr ZZ)   ; we're getting this fn constant on this set
		(all-fns-on-power (car ZZ) c)  ; the range -- of size c^(2^z)
		(phi (pred alpha (car ZZ)) c)  ; how large we want it
		(expt c (expt 2 (car ZZ))))
	NIL ))


; if ZZ is a set and YY = (extract-nice g ZZ alpha c)
; "nice-set-A" says that YY is a set
; "nice-set-B" says that if ZZ is also phi(alpha,c) -- large
;           YY is a sub-set of (cdr ZZ)
; "nice-set-C" says that (nice g z YY)
; "nice-set-D" says that YY is phi(alpha-hat,c) -- large
;           whenever alpha is an ord >= 1, c > 0, and
;           ZZ is phi(alpha,c) -- large and (rangep g c)


; Here's a trivial property of phi:
(prove-lemma phi-non-zero (rewrite) 
	(not (equal (phi alpha c) 0))
( ; hints
(enable phi)
))

(prove-lemma nice-set-A-aux1 (rewrite) (implies
	(and (setp ZZ) (o-largep ZZ (phi alpha c)))
	(listp ZZ)))

(prove-lemma nice-set-A-aux2 (rewrite) (implies
	(and (setp ZZ) (o-largep ZZ (phi alpha c)))
	(setp (cdr ZZ))))

(prove-lemma nice-set-A-aux3 (rewrite) (setp nil))

(prove-lemma nice-set-A (rewrite) (implies
	(setp ZZ)
	(setp (extract-nice g ZZ alpha c))) 
( ; hints
(do-not-induct T)
(use 
	(pigeon-B 
		(g (power-power g (car ZZ) (cdr ZZ)) )
		(XX (cdr ZZ))
		(lst (all-fns-on-power (car ZZ) c))
		(alpha (phi (pred alpha (car ZZ)) c))
		(c (expt c (expt 2 (car ZZ)))))
	(nice-set-A-aux2))
(disable  times-with-zero-1
	pigeon-B  all-fns-on-power nice-set-A-aux2 o-largep setp large-goes-up)
(hands-off o-largep setp funcall power-map augmented-map)
))

(disable nice-set-A-aux1)
(disable nice-set-A-aux2)
(disable nice-set-A-aux3)

(prove-lemma nice-set-B (rewrite) (implies
	(and (setp ZZ) (o-largep ZZ (phi alpha c)))
	(subsetp (extract-nice g ZZ alpha c) (cdr ZZ))) 
( ; hints
(do-not-induct T)
(use 
	(nice-set-A-aux2)  ); so, (cdr ZZ) is a set
(disable o-largep)
(hands-off o-largep)
))

; for nice-set-C -- we need (contantp ...) which involves establishing
; "mapsto" hypothesis
; we have to show that the function, (power-power g (car ZZ) (cdr ZZ))
; which is mapping on (cdr ZZ), mapsto
; (all-fns-on-power (car ZZ) c)
; 

(prove-lemma nice-set-C-aux1 (rewrite) (implies 
	(rangep g c)
	(mapsto
		(power-power g (car ZZ) (cdr ZZ))
		(cdr ZZ)
		(all-fns-on-power (car ZZ) c) ))
( ; hints
(do-not-induct T)
(use
	(range-of-power-power (z (car ZZ)) (YY (cdr ZZ))))
(disable range-of-power-power)
))

; we also need that the size of the range >= c^(2^z)
; which follows since c and z are numbers

(enable nice-set-A-aux1)
; ZZ is non-empty, assuming (setp ZZ) and (o-largep ZZ (phi alpha c))

(prove-lemma nice-set-C-aux2 (rewrite) (implies 
	(and
		(not (zerop c))
		(setp ZZ) (o-largep ZZ (phi alpha c)))
	(equal
		(length (all-fns-on-power (car ZZ) c))
		(expt c (expt 2 (car ZZ))))))

; putting this together with pigeon-C, we get (constantp ...)

(prove-lemma nice-set-C-aux3 (rewrite) (implies 
	(and
		(ordinalp alpha) (not (zerop c)) (ord-leq 1 alpha)
		(rangep g c)
		(setp ZZ) (o-largep ZZ (phi alpha c)))
	(constantp
		(power-power g (car ZZ) (cdr ZZ)) 
		(extract-nice g ZZ alpha c) ))
( ; hints
(do-not-induct T)
(use
	(nice-set-C-aux1)
	(nice-set-C-aux2)
	(pigeon-C
		(g (power-power g (car ZZ) (cdr ZZ)))
		(XX (cdr ZZ))
		(lst (all-fns-on-power (car ZZ) c))
		(c (expt c (expt 2 (car ZZ))))
		(alpha (phi (pred alpha (car ZZ)) c)) ) )
(disable   nice-set-C-aux1 nice-set-C-aux2 range-of-power-power
	pigeon-C all-fns-on-power subsetp-is-idempotent car-of-subset
	recursive-case-for-large o-largep successor-large setp constantp)
(hands-off o-largep setp constantp expt power-power)
))

; actually, if the above hypotheses fail, then
; extract-nice returns nil, so we still have constantp

(prove-lemma nice-set-C-aux4 (rewrite) (implies 
	(not (and
		(ordinalp alpha) (not (zerop c)) (ord-leq 1 alpha)
		(rangep g c)
		(setp ZZ) (o-largep ZZ (phi alpha c))))
	(constantp
		(power-power g (car ZZ) (cdr ZZ)) 
		(extract-nice g ZZ alpha c) )) 
( ;hints
(do-not-induct T)
(use 
	(constant-0
		(lst (extract-nice g ZZ alpha c))
		(g (power-power g (car ZZ) (cdr ZZ)))))
(hands-off o-largep)
(disable nice-set-C-aux3 constant-0
	constantp large-goes-up)
))

(prove-lemma nice-set-C-aux5 (rewrite) 
	(constantp
		(power-power g (car ZZ) (cdr ZZ)) 
		(extract-nice g ZZ alpha c) )
( ;hints
(do-not-induct T)
(use 
	(nice-set-C-aux4)
	(nice-set-C-aux3) )
(hands-off o-largep)
(disable nice-set-C-aux3 nice-set-C-aux4
	constantp large-goes-up extract-nice)
))

; now, we apply nice-goes-down, since (extract-nice g ZZ alpha c)
; is a subset of (cdr ZZ) (by nice-set-B --
; assuming (and (setp ZZ) (o-largep ZZ (phi alpha c)))   )

(disable nice-set-A-aux1)
(disable nice-set-C-aux1)
(disable nice-set-C-aux2)
(disable nice-set-C-aux3)
(disable nice-set-C-aux4)
(disable nice-set-C-aux5)

(prove-lemma nice-set-C (rewrite) (implies
	(and (setp ZZ) (o-largep ZZ (phi alpha c)))
	(nice g (car ZZ) (extract-nice g ZZ alpha c) ) ) 
( ; hints
(do-not-induct T)
(use
	(nice-set-B)
	(nice-set-C-aux5))
(disable o-largep extract-nice nice-set-B)
(hands-off o-largep)
))

; finally, nice-set-D assumes the full hypotheses of extract-nice
; and concludes that (extract-nice g ZZ alpha c)
; is phi(alpha-hat,c) -- large, where alpha-hat is
; (pred alpha (car ZZ))

; this uses the fact that the set we're mapping from, (cdr ZZ)
; is (phi (pred alpha (car ZZ)) c) * (expt c (expt 2 (car ZZ))) -- large
; -- this is by the cdr-lemma

; then, we have to apply pigeon-D to get a large set

(prove-lemma nice-set-D (rewrite) (implies 
	(and
		(ordinalp alpha) (not (zerop c)) (ord-leq 1 alpha)
		(rangep g c)
		(setp ZZ) (o-largep ZZ (phi alpha c)))
	(o-largep
		(extract-nice g ZZ alpha c)
		(phi (pred alpha (car ZZ)) c)))
( ; hints
(do-not-induct T)
(use
	(cdr-lemma-1 (alpha-hat (pred alpha (car ZZ))))
	(cdr-lemma-2 (alpha-hat (pred alpha (car ZZ)))) )
(disable members-are-numbers star sharp insert large-with-smaller-ord
	subsetp tail-lemma-2 min-is-first tail-lemma-1
	all-fns-on-power
	recursive-case-for-large large-goes-up subsetp-is-idempotent
	cdr-lemma-1 cdr-lemma-2 o-largep successor-large)
(hands-off ord-leq all-fns-on-power)
))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                 THE PRE-HOMOGENEOUS SET LEMMA                          ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; we iterate extract-nice to obtain a prehomogeneous set

;;;;;;;;;  Preliminaries

;;;;  nice-and-last :    a more useful version of nice
; we want this in terms of (last S)

; probably, we don't need the defn of nice any more

(disable nice)

;;;  here's some simple fact about (last S)
(prove-lemma last-is-member (rewrite) (implies
	(and (setp S) (listp S) )
	(member (last S) S)))

(prove-lemma subset-of-last-aux1 (rewrite) (implies
	(and (listp Z) (setp (cons v Z)))
	(lessp v (last Z)))
( ; hints
(do-not-induct T)
(use (increasing (s (cons v Z)) (x (last Z))))
(disable increasing)
))

(prove-lemma subset-of-last-aux2 (rewrite) (implies
	(and (setp S) (listp S) (member x (all-but-last S)) )
	(lessp x (last S)))
( ; hints
(induct (all-but-last S))
))

(prove-lemma subset-of-last-aux3 (rewrite) (implies
	(and (setp S) (listp S) (member x (all-but-last S)) )
	(member x (vn (last S)))))

(prove-lemma subset-of-last (rewrite) (implies
	(and (setp S) (listp S) )
	(subsetp (all-but-last S) (vn (last S))))
( ; hints
(do-not-induct T)
(use (subsetp-works-2 (s1 (all-but-last S)) (s2 (vn (last S)))))
(disable vn members-of-vn subsetp-works-2)
))

(disable subset-of-last-aux1)
(disable subset-of-last-aux2)
(disable subset-of-last-aux3)

(prove-lemma nice-and-last (rewrite) (implies
	(and
		(nice g z XX)
		(setp S) (listp S)
		(member x1 XX) (member x2 XX)
		(equal (last S) z)  )
	(equal
		(funcall g (add-on-end x1 S))
		(funcall g (add-on-end x2 S)) )) 
( ; hints
(do-not-induct T)
(use
	(nice-implies-same-values (S (all-but-last S))))
(disable nice-implies-same-values)
))


;;;;;;;  rephrase the nice set lemma
;; for iterating extract-nice, it will be simpler to have an
;; explicit name for the hypotheses under which it works
; then, this can be disabled when not needed

(defn nice-set-hyp (g ZZ alpha c) (and
	(ordinalp alpha) (not (zerop c)) (ord-leq 1 alpha)
	(rangep g c)
	(setp ZZ) (o-largep ZZ (phi alpha c))) )


; if the hyp fails, extract-nice returns nil

(prove-lemma extract-nice-is-nil (rewrite) (implies
	(not (nice-set-hyp g ZZ alpha c))
	(equal (extract-nice g ZZ alpha c)  NIL)))

; now, restate the four parts of the nice set lemma
; using this hyp

; probably, we don't need the defn of extract-nice any more

(disable extract-nice)

(prove-lemma simple-nice-set-A (rewrite) (implies
	(nice-set-hyp g ZZ alpha c)
    (setp (extract-nice g ZZ alpha c))) 
( ; hints
(do-not-induct T)
(disable o-largep large-goes-up subsetp)
))

(prove-lemma simple-nice-set-B (rewrite) (implies
	(nice-set-hyp g ZZ alpha c)
	(subsetp (extract-nice g ZZ alpha c) (cdr ZZ)))
( ; hints
(do-not-induct T)
(disable o-largep large-goes-up subsetp)
))


(prove-lemma simple-nice-set-C (rewrite) (implies
	(nice-set-hyp g ZZ alpha c)
	(nice g (car ZZ) (extract-nice g ZZ alpha c) ) )
( ; hints
(do-not-induct T)
(disable o-largep large-goes-up subsetp)
))

(prove-lemma simple-nice-set-D (rewrite) (implies
	(nice-set-hyp g ZZ alpha c)
    (o-largep
        (extract-nice g ZZ alpha c)
        (phi (pred alpha (car ZZ)) c)))
( ; hints
(do-not-induct T)
(disable o-largep large-goes-up subsetp)
))


;;;;;;  iterability

;; to prove that iterating extract-nice to a set produces
;; a subset, all we need is

(prove-lemma extract-nice-produces-subset (rewrite) (implies
	(and (setp ZZ) (listp ZZ))
	(subsetp (extract-nice g ZZ alpha c) (cdr ZZ)))  
( ; hints
(do-not-induct T)
(use (simple-nice-set-B) (extract-nice-is-nil))
(disable simple-nice-set-B extract-nice-is-nil nice-set-hyp)
))

(prove-lemma extract-nice-produces-set (rewrite) (implies
	(and (setp ZZ) (listp ZZ))
	(setp (extract-nice g ZZ alpha c)))  
( ; hints
(do-not-induct T)
(use (simple-nice-set-A) (extract-nice-is-nil))
(disable simple-nice-set-A extract-nice-is-nil nice-set-hyp)
))

; in the iteration, we also need that the hypotheses replicate
; themselves until alpha becomes 0

(prove-lemma replication-of-hyp-aux1 (rewrite) (implies
	(and
		(nice-set-hyp g ZZ alpha c)
		(ord-leq 1  (pred alpha (car ZZ)) )  )
	(nice-set-hyp g (extract-nice g ZZ alpha c) (pred alpha (car ZZ)) c))
( ; hints
(do-not-induct T)
(disable  recursive-case-for-large
	o-largep successor-large large-goes-up subsetp tail-lemma-2)
))

(prove-lemma replication-of-hyp-aux2 (rewrite) (implies
	(nice-set-hyp g ZZ alpha c)
	(ordinalp (pred alpha u)))
( ; hints
(disable  recursive-case-for-large
	o-largep successor-large large-goes-up subsetp tail-lemma-2)
))

(prove-lemma replication-of-hyp (rewrite) (implies
	(and
		(nice-set-hyp g ZZ alpha c)
		(not (equal (pred alpha (car ZZ)) 0)))
	(nice-set-hyp g (extract-nice g ZZ alpha c) (pred alpha (car ZZ)) c))
( ; hints
(do-not-induct T)
(disable car-cdr-elim nice-set-hyp  pred-is-an-ordinal
replication-of-hyp-aux1 replication-of-hyp-aux2)
(use 
	(replication-of-hyp-aux2 (u (car ZZ)))
	(replication-of-hyp-aux1))
(enable ord-leq ord-lessp)
))

(disable replication-of-hyp-aux1)
(disable replication-of-hyp-aux2)


;;;;;;;;;  End Preliminaries


;; we get extract-prehom by iterating extract-nice

; to prove the recursion works -- we should prove
; that extract-nice returns a set of smaller length

(prove-lemma sublists-smaller-length (rewrite) (implies
	(and (listp ZZ) (sublistp UU (cdr ZZ)))
	(lessp
		(length UU) (length ZZ))))

(prove-lemma subsets-smaller-length (rewrite) (implies
	(and (listp ZZ) (setp ZZ) (setp UU) (subsetp UU (cdr ZZ)))
	(lessp
		(length UU) (length ZZ)))
( ; hints
(do-not-induct T)
(use 
	(subset-implies-sublist (set1 UU) (set2 (cdr ZZ)))
	(tail-of-a-set (s ZZ))
	(sublists-smaller-length))
(disable  subsetp-is-idempotent transitivity-of-subset car-cdr-elim
	length sub1-add1 sublists-smaller-length tail-of-a-set)
))

(prove-lemma extract-prehom-aux1 (rewrite) (implies
	(and (setp ZZ) (listp ZZ))
	(lessp
		(length (extract-nice g ZZ alpha c))
		(length ZZ)))
( ; hints
(hands-off extract-nice)
))

; the following keep getting in the way of the next defn
(disable o-largep)  ; let's keep this off permanently
(disable large-goes-up)
(disable setp)
(disable simple-nice-set-A)

(defn extract-prehom (g ZZ alpha c) (if 
	(and (setp ZZ) (listp ZZ) (not (equal alpha 0)))
	(cons
		(car ZZ)
		(extract-prehom 
			g     ; same partition
			(extract-nice g ZZ alpha c)   ; smaller set
			(pred alpha (car ZZ))   ; smaller ordinal
			c))   ; same c = number of partitions
	NIL )
( ; hints
( lessp (length ZZ) )
))   
; use ordinary recursion, on length, not transfinite recursion on epsilon_0

(enable large-goes-up)
(enable setp)
(enable simple-nice-set-A)

; this will return an alpha-large set 
; so, if alpha = 0, any set will do
; so,   the intended hypotheses to extract-prehom are
; like that of extract-nice, except that alpha could be 0

(defn prehom-set-hyp (g ZZ alpha c) (and
	(ordinalp alpha) (not (zerop c)) 
	(rangep g c)
	(setp ZZ) (o-largep ZZ (phi alpha c))) )

(prove-lemma compare-hyps (rewrite) (implies
	(and 
		(prehom-set-hyp g ZZ alpha c)
		(not (equal alpha 0)))
	(nice-set-hyp g ZZ alpha c) )
( ; hints
(do-not-induct T)
(enable ord-leq ord-lessp)
(hands-off o-largep subsetp setp)
(disable tail-lemma-2 setp)
))


;;; now if ZZ is a set and XX = (extract-prehom g ZZ alpha c)
; the PREHOMOGENEOUS SET LEMMA has 6 parts.  the first
; 3 don't use any properties of extract-nice -- only the
; lemma above that it returns a subset of (cdr ZZ)

; "prehom-set-A" says that if (listp ZZ) and alpha != 0 then
;           (car XX) = (car ZZ)
; "prehom-set-B" says that 
;           XX is a sub-set of ZZ
; "prehom-set-C" says that if (listp ZZ) and alpha != 0  then
;            (listp XX)
; "prehom-set-D" says that XX is a set
; "prehom-set-E" says that if (prehom-set-hyp g ZZ alpha c)
;          then (o-largep XX alpha)
; "prehom-set-F" says that if (prehom-set-hyp g ZZ alpha c)
;          then (pre-homp XX g)

(prove-lemma prehom-set-A (rewrite) (implies
	(and (setp ZZ) (listp ZZ) (not (equal alpha 0)))
	(equal (car (extract-prehom g ZZ alpha c)) (car ZZ)))
( ; hints
(hands-off o-largep extract-nice)
(disable only-sublists subsetp setp)
))

(prove-lemma prehom-set-B-aux1 (rewrite) (implies
	(and 
		(listp ZZ)
		(subsetp UU WW) (subsetp WW (cdr ZZ)) )
	(subsetp (cons (car ZZ) UU) ZZ)) 
( ; hints
(enable subsetp)
(disable tail-lemma-2 min-is-first)
))

(prove-lemma prehom-set-B-aux2 (rewrite) (implies
	(and 
		(setp ZZ) (listp ZZ)
		(subsetp UU (extract-nice g ZZ alpha c)) )
	(subsetp (cons (car ZZ) UU) ZZ))
( ; hints
(do-not-induct T)
(hands-off o-largep setp)
(use (prehom-set-B-aux1 (WW (extract-nice g ZZ alpha c))))
(disable prehom-set-B-aux1 subsetp-is-idempotent transitivity-of-subset)
))

(prove-lemma prehom-set-B (rewrite)  (implies
	(setp ZZ)
	(subsetp  (extract-prehom g ZZ alpha c)  ZZ))
( ; hints
(hands-off o-largep)
(induct (extract-prehom g ZZ alpha c))
(disable successor-large extract-nice-is-nil)
))


(disable prehom-set-B-aux1)
(disable prehom-set-B-aux2)

(prove-lemma prehom-set-C (rewrite) (implies
	(and (setp ZZ) (listp ZZ) (not (equal alpha 0)))
	(listp (extract-prehom g ZZ alpha c) ))
( ; hints
(hands-off o-largep extract-nice)
(disable only-sublists subsetp setp)
))

; for D, we will have to force the correct induction
; first, consider some trivial cases

; first, when (extract-prehom g ZZ alpha c) is empty

(prove-lemma prehom-set-D-aux1 (rewrite) (implies
	(not (setp ZZ)) 
	(setp (extract-prehom g ZZ alpha c) )))
(prove-lemma prehom-set-D-aux2 (rewrite) (implies
	(not (listp ZZ)) 
	(setp (extract-prehom g ZZ alpha c) )))
(prove-lemma prehom-set-D-aux3 (rewrite) (implies
	(equal alpha 0)
	(setp (extract-prehom g ZZ alpha c) )))

; next, when (extract-prehom g ZZ alpha c) is a singleton

(prove-lemma prehom-set-D-aux4 (rewrite) (implies
	(and 
		(setp ZZ) (listp ZZ) (not (equal alpha 0))
		(nlistp (extract-nice g ZZ alpha c)) )
	(setp (extract-prehom g ZZ alpha c) ))
( ; hints
(hands-off o-largep extract-nice)
(disable only-sublists subsetp setp)
))

; we can summarize the only case left to consider as:

(prove-lemma prehom-set-D-aux5 (rewrite) (implies
	(not (setp (extract-prehom g ZZ alpha c) ))
	(and
		(setp ZZ) (listp ZZ) (not (equal alpha 0))
		(listp (extract-nice g ZZ alpha c)) ) )
( ; hints
(do-not-induct T)
(hands-off o-largep extract-nice)
(use (prehom-set-D-aux1) (prehom-set-D-aux2) (prehom-set-D-aux3) )
(disable only-sublists subsetp setp extract-prehom)
))

(disable prehom-set-D-aux1)
(disable prehom-set-D-aux2)
(disable prehom-set-D-aux3)
(disable prehom-set-D-aux4)

; in the inductive case, we use lemma "set-builder", but we
; have to check that it applies.  It does, because 
; "extract-nice" returns a subset of the cdr
; let UU = (extract-nice g ZZ alpha c) 
; and let VV = (extract-prehom g  UU (pred alpha (car ZZ)) c)   
; then (extract-prehom g ZZ alpha c)  = 
; (cons (car ZZ) VV)

; first, state abstractly what we're using about sets:

(prove-lemma prehom-set-D-aux6 (rewrite) (implies
	(and
		(setp ZZ) (listp ZZ)
		(listp UU)
		(subsetp UU (cdr ZZ)))
	(lessp (car ZZ) (car UU)))
( ; hints
(do-not-induct T)
(use (increasing (x (car UU)) (s ZZ)))
(disable members-are-numbers smaller-cars-in-subset
	increasing subset-of-empty-set)
))

(prove-lemma prehom-set-D-aux7 (rewrite) (implies
	(and
		(setp ZZ) (listp ZZ)
		(setp UU) (listp UU)
		(setp VV) (listp VV)
		(equal (car VV) (car UU))
		(subsetp UU (cdr ZZ)))
	(setp (cons (car ZZ) VV)))
( ; hints
(do-not-induct T)
(use
	(set-builder (s VV) (x (car ZZ))))
(disable smaller-cars-in-subset setp
	increasing subset-of-empty-set set-builder)
))

(disable prehom-set-D-aux6)

; now, plug in what VV is:  of form
;    (extract-prehom g  UU delta c)
;  we still assume VV is a set (that's the induction), but
; we can drop the other hypotheses, since they follow
; from parts A,B,C of the lemma

(prove-lemma prehom-set-D-aux8 (rewrite) (implies
	(and (setp EE) (setp (cons z X)) (not (listp EE)))
	(setp (cons z EE))))

(prove-lemma prehom-set-D-aux9 (rewrite) (implies
	(listp (extract-prehom g UU delta c))
	(equal (car (extract-prehom g UU delta c)) (car UU)))
( ; hints
(hands-off o-largep)
(disable setp large-with-smaller-ord)
))

(prove-lemma prehom-set-D-aux10 (rewrite) (implies
	(and
		(setp ZZ) (listp ZZ)
		(setp UU) (listp UU) (subsetp UU (cdr ZZ))
		(setp (extract-prehom g  UU delta c))  )
	(setp (cons (car ZZ) (extract-prehom g  UU delta c)))  )
( ; hints
(do-not-induct T)
(hands-off o-largep extract-nice)
(use 
	(prehom-set-D-aux9)
	(prehom-set-D-aux7 (VV (extract-prehom g  UU delta c)) ))
(disable only-sublists subsetp setp extract-prehom)
))

(disable prehom-set-D-aux7)

; now, plug in what UU is :  (extract-nice g ZZ alpha c) 
; this is a set -- it may be empty, but we've already
; considered that case, so keep the hypothesis that it's non-empty
; it is always a subset of (cdr ZZ)

(prove-lemma prehom-set-D-aux11 (rewrite) (implies
	(and
		(setp ZZ) (listp ZZ)
		(listp (extract-nice g ZZ alpha c)) 
		(setp (extract-prehom g  (extract-nice g ZZ alpha c) delta c))  )
	(setp (cons 
		(car ZZ) 
		(extract-prehom g  (extract-nice g ZZ alpha c) delta c)))  )  
( ; hints
(do-not-induct T)
(hands-off o-largep extract-nice)
(use (prehom-set-D-aux10 (UU (extract-nice g ZZ alpha c))))
(disable only-sublists subsetp setp extract-prehom)
))

(disable prehom-set-D-aux10)

; now, with delta =  (pred alpha (car ZZ)) , we have the induction step

(prove-lemma prehom-set-D-aux12 (rewrite) (implies
	(and
		(setp ZZ) (listp ZZ)
		(listp (extract-nice g ZZ alpha c)) 
		(setp (extract-prehom 
			g  
			(extract-nice g ZZ alpha c) 
			(pred alpha (car ZZ))
			c))  )
	(setp (extract-prehom g ZZ alpha c)))
( ; hints
(do-not-induct T)
(hands-off o-largep extract-nice)
(use (prehom-set-D-aux11 (delta (pred alpha (car ZZ)))))
(disable  prehom-set-D-aux11 prehom-set-D-aux4 only-sublists subsetp setp)
))

; now, the induction should work

(prove-lemma prehom-set-D (rewrite) 
	(setp  (extract-prehom g ZZ alpha c) )
( ; hints
(hands-off o-largep)
(induct (extract-prehom g ZZ alpha c))
(use  
	(prehom-set-D-aux3 )
	(prehom-set-D-aux12 ))
(disable setp simple-nice-set-A
	prehom-set-D-aux12 successor-large extract-nice-is-nil extract-prehom)
))

(disable prehom-set-D-aux5)
(disable prehom-set-D-aux8)
(disable prehom-set-D-aux9)
(disable prehom-set-D-aux11)
(disable prehom-set-D-aux12)

; to do the inductions in E and F, we should check that
; the hypotheses replicates to the inductive call

; the following seem useful in general:


(prove-lemma prehom-hyp-implies-non-empty (rewrite)  (implies
	(prehom-set-hyp g ZZ alpha c)
	(listp ZZ)))

(prove-lemma positive-ordinals (rewrite) (implies
	(and (ordinalp alpha) (not (equal alpha 0)))
	(ord-leq 1 alpha))
( ; hints
(enable ord-leq ord-lessp)
))

(prove-lemma replication-of-prehom-hyp-aux1 (rewrite) (implies
	(o-largep ZZ (phi alpha c))
	(listp ZZ)))

(prove-lemma replication-of-prehom-hyp (rewrite) (implies
	(and
		(prehom-set-hyp g ZZ alpha c)
		(not (equal alpha 0)) )
	(prehom-set-hyp g (extract-nice g ZZ alpha c) (pred alpha (car ZZ)) c))
( ; hints
(do-not-induct T)
(use (nice-set-D))
(disable o-largep subsetp setp large-with-smaller-ord)
(hands-off o-largep)
))

(disable replication-of-prehom-hyp-aux1)


; now, on to E.
; for the basis:
(prove-lemma prehom-set-E-aux1 (rewrite) 
    (o-largep (extract-prehom g ZZ alpha c) 0) 
( ; hints
(use (all-zero-large (set (extract-prehom g ZZ alpha c))))
))

; for the induction, we need
(prove-lemma prehom-set-E-aux2 (rewrite) (implies 
	(and
		(not (equal alpha 0))
		(o-largep 
			(extract-prehom 
				g     
				(extract-nice g ZZ alpha c)   
				(pred alpha (car ZZ))   
				c)   
			(pred alpha (car ZZ)) ))
	(o-largep 
	(cons
		(car ZZ)
		(extract-prehom 
			g     
			(extract-nice g ZZ alpha c)   
			(pred alpha (car ZZ))   
			c))    
	alpha )     )
( ; hints
(hands-off extract-prehom extract-nice)
(disable prehom-set-C simple-nice-set-A nice-set-hyp)
))

(prove-lemma prehom-set-E-aux3 (rewrite) (implies 
	(and
		(listp ZZ) (setp ZZ)
		(not (equal alpha 0))
		(o-largep 
			(extract-prehom 
				g     
				(extract-nice g ZZ alpha c)   
				(pred alpha (car ZZ))   
				c)   
			(pred alpha (car ZZ)) ))
	(o-largep (extract-prehom g ZZ alpha c) alpha) )
( ; hints
(do-not-induct T)
(use (prehom-set-E-aux2))
(hands-off o-largep)
(disable prehom-set-C simple-nice-set-A nice-set-hyp)
))

; to force the correct induction

(prove-lemma prehom-set-E-aux4 (rewrite) (implies 
	(and
		(prehom-set-hyp g ZZ alpha c)
		(not (o-largep (extract-prehom g ZZ alpha c) alpha) ))
	(not 
		(o-largep 
			(extract-prehom 
				g     
				(extract-nice g ZZ alpha c)   
				(pred alpha (car ZZ))   
				c)   
			(pred alpha (car ZZ)) ))  )
( ; hints
(do-not-induct T)
(use (prehom-set-E-aux3))
(disable setp large-with-smaller-ord recursive-case-for-large
	tail-lemma-2 subsetp extract-prehom prehom-set-E-aux3)
))

(prove-lemma prehom-set-E-aux5 (rewrite) (implies 
	(and
		(prehom-set-hyp g ZZ alpha c)
		(not (o-largep (extract-prehom g ZZ alpha c) alpha) ))
	(prehom-set-hyp g (extract-nice g ZZ alpha c) (pred alpha (car ZZ)) c))
( ; hints
(do-not-induct T)
(use (replication-of-prehom-hyp))
(disable replication-of-prehom-hyp
	setp large-with-smaller-ord recursive-case-for-large
	tail-lemma-2 subsetp extract-prehom prehom-set-hyp)
))

(prove-lemma prehom-set-E (rewrite) (implies 
	(prehom-set-hyp g ZZ alpha c)
	(o-largep (extract-prehom g ZZ alpha c) alpha) )
( ; hints
(induct (extract-prehom g ZZ alpha c))
(disable o-largep subsetp tail-lemma-2 setp extract-prehom)
))

(disable prehom-set-E-aux1)
(disable prehom-set-E-aux2)
(disable prehom-set-E-aux3)
(disable prehom-set-E-aux4)
(disable prehom-set-E-aux5)

; finally, F -- that the resulting set
;  XX = (extract-prehom g ZZ alpha c) is pre-homogeneous
; so, we have to look at all non-empty subsets of XX  --
; but in fact, the defn of pre-homogeneous works will ALL sets
; S whose last element is in XX -- regardless of whether S is
; a subset of XX.

; That's not relevant to Ramsey's Theoreom, but this stronger
; statement is a lot easier to prove by induction.

; let's summarize what we're saying can't happen:

(defn bad-for-prehom-set (g ZZ alpha c XX S x1 x2) (and
	(prehom-set-hyp g ZZ alpha c)
	(equal XX (extract-prehom g ZZ alpha c))
	(setp S) (listp S) 
	(member (last S) XX) (member x1 XX) (member x2 XX)  
	(lessp (last S) x1)   (lessp (last S) x2)
	(not (equal
		(funcall g (add-on-end x1 S))
		(funcall g (add-on-end x2 S)) )  )))

; we show this can't happen by induction on ZZ (with a fixed SS)
; first, note that XX and ZZ are non-empty sets and 1 <= alpha
; and (car XX) = (car ZZ)

(prove-lemma prehom-set-F-aux1  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(listp XX))
( ; hints
(hands-off o-largep)
(disable extract-prehom)
))

(prove-lemma prehom-set-F-aux2  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(setp XX))
( ; hints
(hands-off o-largep)
(disable extract-prehom setp subsetp)
))

(prove-lemma prehom-set-F-aux3  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(listp ZZ))
( ; hints
(hands-off o-largep)
(disable setp subsetp)
))

(prove-lemma prehom-set-F-aux4  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(setp ZZ))
( ; hints
(hands-off o-largep)
(disable setp subsetp)
))

(prove-lemma prehom-set-F-aux5  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(ordinalp alpha))
( ; hints
(hands-off o-largep)
(disable setp subsetp)
))

(prove-lemma prehom-set-F-aux6  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(ord-leq 1 alpha) )
( ; hints
(hands-off o-largep)
(disable setp subsetp)
(use (positive-ordinals))
))

(prove-lemma prehom-set-F-aux7  () (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(equal XX
		(cons
			(car ZZ)
			(extract-prehom 
				g  
				(extract-nice g ZZ alpha c)   
				(pred alpha (car ZZ))   
				c))    ) )
( ; hints
(hands-off o-largep)
(disable members-are-numbers extract-nice extract-nice-is-nil
	setp subsetp prehom-set-hyp last-is-a-candidate-1 sublistp)
))

(prove-lemma prehom-set-F-aux8  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(equal (car XX) (car ZZ))) 
( ; hints
(do-not-induct T)
(use (prehom-set-F-aux7))
(hands-off prehom-set-hyp o-largep bad-for-prehom-set)
(disable prehom-set-hyp o-largep bad-for-prehom-set)
))

(prove-lemma prehom-set-F-aux9  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(equal 
		(cdr XX) 
		(extract-prehom 
			g  
			(extract-nice g ZZ alpha c)   
			(pred alpha (car ZZ))   
			c))    ) 
( ; hints
(do-not-induct T)
(use (prehom-set-F-aux7))
(hands-off prehom-set-hyp o-largep bad-for-prehom-set)
(disable prehom-set-hyp o-largep bad-for-prehom-set)
))

; now, we plan to use the nice set lemma to contradict (last S) = (car XX),
; so then (last S) > (car XX), whence we can use induction on ZZ
; in either case, we need that x1,x2 are in 
; (extract-prehom g (extract-nice g ZZ alpha c) (pred alpha (car ZZ))  c)

(prove-lemma prehom-set-F-aux10  (rewrite) (implies 
	(and (setp XX) (member u XX) (member x XX) (lessp u x))
	(member x (cdr XX))) 
( ; hints
(disable subsetp)
))

(prove-lemma prehom-set-F-aux11  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(member x1 (cdr XX)))
( ; hints
(do-not-induct T)
(hands-off o-largep prehom-set-hyp)
(use (prehom-set-F-aux10 (x x1) (u (last S))))
(disable  prehom-set-F-aux9 member prehom-set-hyp
	sublistp min-is-first last-is-a-candidate-1 only-sublists
	o-largep extract-prehom setp)
))

(prove-lemma prehom-set-F-aux12  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(member x2 (cdr XX)))
( ; hints
(do-not-induct T)
(hands-off o-largep prehom-set-hyp)
(use (prehom-set-F-aux10 (x x2) (u (last S))))
(disable  prehom-set-F-aux9 member prehom-set-hyp
	sublistp min-is-first last-is-a-candidate-1 only-sublists
	o-largep extract-prehom setp)
))

(prove-lemma prehom-set-F-aux13  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(member x1
		(extract-prehom 
			g  
			(extract-nice g ZZ alpha c)   
			(pred alpha (car ZZ))   
			c))    ) 
( ; hints
(do-not-induct T)
(use (prehom-set-F-aux11))
(hands-off prehom-set-hyp o-largep)
(disable  bad-for-prehom-set
	sublistp min-is-first last-is-a-candidate-1 only-sublists
	prehom-set-hyp o-largep extract-prehom setp)
))

(prove-lemma prehom-set-F-aux14  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(member x2
		(extract-prehom 
			g  
			(extract-nice g ZZ alpha c)   
			(pred alpha (car ZZ))   
			c))    ) 
( ; hints
(do-not-induct T)
(use (prehom-set-F-aux12))
(hands-off prehom-set-hyp o-largep)
(disable  bad-for-prehom-set
	sublistp min-is-first last-is-a-candidate-1 only-sublists
	prehom-set-hyp o-largep extract-prehom setp)
))

; now, we work on refuting the case that (last S) = (car XX) ,
; using the nice set lemma
; for this, first note that x1,x2 are in (extract-nice g ZZ alpha c)

(prove-lemma prehom-set-F-aux15  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(member x1
		(extract-nice g ZZ alpha c)     ))
( ; hints
(do-not-induct T)
(use 
	(prehom-set-B 
		(alpha (pred alpha (car ZZ)))
		(ZZ (extract-nice g ZZ alpha c) ))
	(prehom-set-F-aux13))
(hands-off prehom-set-hyp o-largep)
(disable  bad-for-prehom-set prehom-set-B
	sublistp min-is-first last-is-a-candidate-1 only-sublists
	prehom-set-hyp o-largep extract-prehom setp)
))

(prove-lemma prehom-set-F-aux16  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(member x2
		(extract-nice g ZZ alpha c)     ))
( ; hints
(do-not-induct T)
(use 
	(prehom-set-B 
		(alpha (pred alpha (car ZZ)))
		(ZZ (extract-nice g ZZ alpha c) ))
	(prehom-set-F-aux14))
(hands-off prehom-set-hyp o-largep)
(disable  bad-for-prehom-set prehom-set-B
	sublistp min-is-first last-is-a-candidate-1 only-sublists
	prehom-set-hyp o-largep extract-prehom setp)
))

(prove-lemma prehom-set-F-aux17  (rewrite) (implies 
	(and
		(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
		(equal (last S) (car ZZ)))
	(not (nice g (car ZZ) (extract-nice g ZZ alpha c))))
( ; hints
(do-not-induct T)
(hands-off o-largep prehom-set-hyp)
(use
	(prehom-set-F-aux15)
	(prehom-set-F-aux16)
	(nice-and-last (z (car ZZ)) (XX (extract-nice g ZZ alpha c)) ) )
(disable   subsetp prehom-set-F-aux10 car-of-subset
	prehom-set-B nice-and-last nice nice-set-hyp setp members-are-numbers
	sublistp min-is-first last-is-a-candidate-1 only-sublists
	prehom-set-hyp o-largep extract-prehom setp)
))

; but it should be nice, by nice-set-C

(prove-lemma prehom-set-F-aux18  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(not (equal (last S) (car ZZ))))
( ; hints
(do-not-induct T)
(use 
	(prehom-set-F-aux17)
	(nice-set-C)  )
(hands-off o-largep)
(disable nice-set-C prehom-set-F-aux17 setp)
))

; now, (car ZZ) = (car XX), so (last S) is a member of (cdr XX)

(prove-lemma prehom-set-F-aux19  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(member (last S) (cdr XX)))
( ; hints
(do-not-induct T)
(use 
	(prehom-set-F-aux8)
	(prehom-set-F-aux18) )
(hands-off o-largep extract-prehom)
(disable  prehom-set-F-aux8 min-is-first funcall
	sublistp last-is-a-candidate-1 only-sublists
	extract-prehom members-are-numbers extract-nice
	prehom-set-hyp prehom-set-F-aux18 setp)
))

; now, applying aux9, we get for (last S) what we already have for x1,x2

(prove-lemma prehom-set-F-aux20  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(member (last S)
		(extract-prehom 
			g  
			(extract-nice g ZZ alpha c)   
			(pred alpha (car ZZ))   
			c))    )  
( ; hints
(do-not-induct T)
(use (prehom-set-F-aux9)
	(prehom-set-F-aux19))
(hands-off o-largep extract-prehom bad-for-prehom-set)
(disable last-is-a-candidate-1 prehom-set-F-aux19 
	prehom-set-F-aux9 o-largep extract-prehom bad-for-prehom-set)
))

; now, we almost have the induction, but we have to take
; car of the prehom-set-hyp part

(prove-lemma prehom-set-F-aux21  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(prehom-set-hyp g (extract-nice g ZZ alpha c) (pred alpha (car ZZ)) c))
( ; hints
(hands-off o-largep extract-prehom)
(use 
	(prehom-set-F-aux6)
	(replication-of-prehom-hyp))
(disable  setp sublistp members-are-numbers last-is-a-candidate-1
	extract-nice-is-nil pred-of-0  prehom-set-F-aux6 
	replication-of-prehom-hyp prehom-set-hyp)
))

(prove-lemma prehom-set-F-aux22  (rewrite) (implies 
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2)
	(bad-for-prehom-set 
		g 
		(extract-nice g ZZ alpha c)
		(pred alpha (car ZZ))
		c 
		(extract-prehom 
			g  
			(extract-nice g ZZ alpha c)   
			(pred alpha (car ZZ))   
			c)
		S x1 x2)  )
( ; hints
(do-not-induct T)
(hands-off o-largep extract-prehom extract-nice)
(use
	(prehom-set-F-aux13)
	(prehom-set-F-aux14)
	(prehom-set-F-aux20)
	(prehom-set-F-aux21))
(disable 
	prehom-set-F-aux13 prehom-set-F-aux14
	prehom-set-F-aux21 prehom-set-F-aux20
	min-is-first funcall funcall-outside-domain
	setp sublistp members-are-numbers last-is-a-candidate-1
	extract-nice-is-nil pred-of-0  prehom-set-F-aux6 
	prehom-set-hyp)
))

; now, force the correct induction
(enable extract-prehom-aux1)
(disable setp)
(disable length-of-subset)
(disable subsetp)

(defn prehom-set-F-kludge (g ZZ alpha c XX S x1 x2) (if
	(and (setp ZZ) (listp ZZ))
	(prehom-set-F-kludge
		g 
		(extract-nice g ZZ alpha c)
		(pred alpha (car ZZ))
		c 
		(extract-prehom 
			g  
			(extract-nice g ZZ alpha c)   
			(pred alpha (car ZZ))   
			c)
		S x1 x2)
	NIL )
( ; hint
(lessp (length ZZ))
))

(disable extract-prehom-aux1)
(enable setp)
(enable length-of-subset)
(enable subsetp)

(prove-lemma prehom-set-F-aux23  (rewrite) (not
	(bad-for-prehom-set g ZZ alpha c XX S x1 x2))
( ; hints
(induct (prehom-set-F-kludge g ZZ alpha c XX S x1 x2))
(disable bad-for-prehom-set)
))

; MAIN SUBGOAL:
(prove-lemma prehom-set-F-aux24  (rewrite) (implies 
	(and
		(prehom-set-hyp g ZZ alpha c)
		(equal XX (extract-prehom g ZZ alpha c))
		(setp S) (listp S) 
		(member (last S) XX) (member x1 XX) (member x2 XX)  
		(lessp (last S) x1)   (lessp (last S) x2) )
	(equal
		(funcall g (add-on-end x1 S))
		(funcall g (add-on-end x2 S)) )  )
( ; hints
(do-not-induct T)
(use (prehom-set-F-aux23))
(disable prehom-set-hyp
	sublistp prehom-set-F-aux23 setp subsetp extract-prehom o-largep)
(hands-off sublistp setp subsetp extract-prehom o-largep)
))

(disable bad-for-prehom-set)   (disable prehom-set-F-kludge)

(disable prehom-set-F-aux1) (disable prehom-set-F-aux2)
(disable prehom-set-F-aux3) (disable prehom-set-F-aux4)
(disable prehom-set-F-aux5) (disable prehom-set-F-aux6)
(disable prehom-set-F-aux7) (disable prehom-set-F-aux8)
(disable prehom-set-F-aux9) (disable prehom-set-F-aux10)
(disable prehom-set-F-aux11) (disable prehom-set-F-aux12)
(disable prehom-set-F-aux13) (disable prehom-set-F-aux14)
(disable prehom-set-F-aux15) (disable prehom-set-F-aux16)
(disable prehom-set-F-aux17) (disable prehom-set-F-aux18)
(disable prehom-set-F-aux19) (disable prehom-set-F-aux20)
(disable prehom-set-F-aux21) (disable prehom-set-F-aux22)
(disable prehom-set-F-aux23)

(prove-lemma prehom-set-F-aux25  (rewrite) (implies 
	(and
		(listp S) (subsetp S XX))
	(member (last S) XX)))

(prove-lemma prehom-set-F-aux26  (rewrite) (implies 
	(and
		(prehom-set-hyp g ZZ alpha c)
		(equal XX (extract-prehom g ZZ alpha c))
		(setp S) (listp S) 
		(subsetp S XX) (member x1 XX) (member x2 XX)  
		(lessp (last S) x1)   (lessp (last S) x2) )
	(equal
		(funcall g (add-on-end x1 S))
		(funcall g (add-on-end x2 S)) )  ) 
( ; hints
(do-not-induct T)
(use (prehom-set-F-aux24))
(disable subsetp o-largep extract-prehom setp
	prehom-set-hyp prehom-set-F-aux24)
))

(disable prehom-set-F-aux24)
(disable prehom-set-F-aux25)
(disable prehom-set-F-aux26)

(prove-lemma prehom-set-F (rewrite) (implies 
	(prehom-set-hyp g ZZ alpha c)
	(pre-homp (extract-prehom g ZZ alpha c) g) ) 
( ; hints
(do-not-induct T)
(use
	(sublist-implies-subset 
		(lst1 (counter-pre-hom-s1 (extract-prehom g ZZ alpha c) g)) 
		(lst2 (extract-prehom g ZZ alpha c)))
	(prehom-set-F-aux26 
		(XX (extract-prehom g ZZ alpha c))
		(S (counter-pre-hom-s1 (extract-prehom g ZZ alpha c) g))
		(x1 (counter-pre-hom-y (extract-prehom g ZZ alpha c) g))
		(x2 (counter-pre-hom-z (extract-prehom g ZZ alpha c) g))  ))
(disable subsetp setp funcall 
	prehom-set-F-aux26 extract-prehom prehom-set-hyp)
))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                    RAMSEY THEOREM -- ORDINAL VERSION                   ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; This is really the main Ramsey theorem
; It says: a partition on n-tuples of a Gamma(alpha,n,c) -- large
; set has a homogeneous alpha-large set.

; first, define Gamma:

(defn Gamma (alpha n c) (if (leq n 1)
	(star alpha c)
	(phi (Gamma alpha (sub1 n) c)  c )  ))

(prove-lemma Gamma-is-an-ord (rewrite)  (implies
	(ordinalp alpha)
	(ordinalp (Gamma alpha n c))) )

; now, extract-ramsey produces the homogeneous set
; assuming ZZ is Gamma(alpha,n,c) -- large

(defn extract-ramsey  (g ZZ alpha n c) (if (leq n 1)
	(extract-ramsey-basis g ZZ alpha c)  ; basis
	(extract-ramsey      ; apply procedure for n-1
		(derived g  ; the derived partition on n-1-tuples
			(extract-prehom g ZZ (Gamma alpha (sub1 n) c) c))
				; using the prehom set, 
				; which is (Gamma alpha (sub1 n) c) -- large
		(extract-prehom g ZZ (Gamma alpha (sub1 n) c) c)
		alpha (sub1 n) c)))

;;; now, if ZZ is a set and YY = (extract-prehom g ZZ alpha c)

; "ord-ramsey-A" says that YY is a set and a subset of ZZ
; "ord-ramsey-B" says that YY is alpha-large
;    assuming (ordinalp alpha) and (rangep g c) and (not (zerop n))
;       and (o-largep ZZ (Gamma alpha n c))
; "ord-ramsey-C" says that (homp YY g n)
;    assuming (ordinalp alpha) and (rangep g c) and (not (zerop n))
;       and (o-largep ZZ (Gamma alpha n c))

; Then, we put these together in one "official-looking" theorem, 
; "ord-ramsey"

; note -- (not (zerop c)) follows from "rangep-is-positive"

; the details of the following are probably all irrelevant now
(disable extract-prehom)
(disable extract-nice)
(disable extract-ramsey-basis)

(prove-lemma ord-ramsey-A (rewrite)  (implies
	(setp ZZ)
	(and
		(setp (extract-ramsey  g ZZ alpha n c))
		(subsetp (extract-ramsey  g ZZ alpha n c) ZZ)) ) 
( ; hints
(induct (extract-ramsey  g ZZ alpha n c))
))

; for B, and C, we need that if (rangep g c), then
;  (rangep (derived g WW) c), so that (rangep g c) can be
; applied inductively to the derived partition

(prove-lemma range-of-derived-aux1 (rewrite) (implies
	(and (rangep g c) (member pr (derived-aux g WW lst)))
	(lessp (cadr pr)  c)  )
( ; hints
(enable derived-aux)
(induct (derived-aux g WW lst))
))

(prove-lemma range-of-derived-aux2 (rewrite) (implies
	(and (rangep g c) (member pr (derived-aux g WW lst)))
	(numberp (cadr pr) )  )
( ; hints
(enable derived-aux)
(induct (derived-aux g WW lst))
))

(defn counter-range (g c) (if (nlistp g)
	nil
	(if (not (and (numberp (cadar g)) (lessp (cadar g) c)))
		(car g)
		(counter-range (cdr g) c))))

; let's list the ways rangep can fail if c is positive:

(enable rangep)

(prove-lemma range-of-derived-aux3 (rewrite) (implies
	(and (lessp 0 c) (not (rangep g c)))
	(listp g)))

(prove-lemma range-of-derived-aux4 (rewrite) (implies
	(and (lessp 0 c) (not (rangep g c)))
	(or
		(not (rangep (cdr g) c) )
		(not (numberp (cadar g)))
		(not (lessp (cadar g) c))))
(  ; hints
(disable setp subsetp first-before-last)
)) 

; in the positive direction
(prove-lemma range-of-derived-aux5 (rewrite) (implies
	(and (numberp (cadar g)) (lessp (cadar g) c) (rangep (cdr g) c))
	(rangep g c))
(  ; hints
(disable setp subsetp first-before-last)
)) 

(disable rangep)

(prove-lemma range-of-derived-aux6 (rewrite) (implies
	(and (not (equal c 0)) (numberp c) (not (rangep g c)))
	(listp g))
(  ; hints
(use (range-of-derived-aux3))
(disable range-of-derived-aux3)
))

(prove-lemma range-of-derived-aux7 (rewrite) (implies
	(and (lessp 0 c) (not (rangep g c)))
	(member (counter-range g c) g) ) 
( ; hints
(disable setp min-is-first)
(induct (counter-range g c))
))

(prove-lemma range-of-derived-aux8 (rewrite) (implies
	(and (lessp 0 c) (not (rangep g c)))
	(not (and
		(numberp (cadr (counter-range g c)))
		(lessp (cadr (counter-range g c)) c) )))
( ; hints
(disable setp min-is-first)
(induct (counter-range g c))
))

(prove-lemma range-of-derived-aux9 (rewrite) (implies
	(rangep g c)
	(rangep (derived-aux g WW lst) c))  
( ; hints
(use
	(range-of-derived-aux1 (pr (counter-range (derived-aux g WW lst) c)))
	(range-of-derived-aux2 (pr (counter-range (derived-aux g WW lst) c)))
	(range-of-derived-aux7 (g (derived-aux g WW lst) ))
	(range-of-derived-aux8 (g (derived-aux g WW lst) ))
)
(disable setp min-is-first range-of-derived-aux1
	range-of-derived-aux2 range-of-derived-aux7 range-of-derived-aux8)
(do-not-induct T)
))

(prove-lemma range-of-derived (rewrite) (implies
	(rangep g c)
	(rangep (derived g WW) c))  
( ; hints
(enable derived)
))

(disable counter-range)
(disable range-of-derived-aux1) (disable range-of-derived-aux2)
(disable range-of-derived-aux3) (disable range-of-derived-aux4)
(disable range-of-derived-aux5) (disable range-of-derived-aux6)
(disable range-of-derived-aux7) (disable range-of-derived-aux8)
(disable range-of-derived-aux9)


; for B and C, which require a non-trivial induction,
; it is convenient to summarize the hypotheses.

(defn ord-ramsey-hyp (g ZZ alpha n c) (and
	(ordinalp alpha)
	(rangep g c)
	(not (zerop n))
	(setp ZZ)
	(o-largep ZZ (Gamma alpha n c))  ))

; since some of the earlier hyps had c > 0,

(prove-lemma ord-ramsey-hyp-positive (rewrite) (implies
	(ord-ramsey-hyp g ZZ alpha n c)
	(not (zerop c)))
( ; hints
(do-not-induct T)
(use (rangep-is-positive))
(disable rangep-is-positive)
(hands-off o-largep)
))

;;;;;;;  replication results 
; these should be useful in inductions

(prove-lemma recursive-case-for-Gamma (rewrite) (implies
	(lessp 1 n)
	(equal 
		(Gamma alpha n c)
		(phi (Gamma alpha (sub1 n) c)  c )  )))

; first, note that ZZ satisfies the prehom set hyp

(prove-lemma ord-ramsey-to-prehom-set-hyp (rewrite) (implies
	(and
		(lessp 1 n)
		(ord-ramsey-hyp g ZZ alpha n c) )
	(prehom-set-hyp g ZZ (Gamma alpha (sub1 n) c) c )  )
( ; hints
(do-not-induct T)
(enable prehom-set-hyp)
(use 
	(recursive-case-for-Gamma)
	(ord-ramsey-hyp-positive))
(disable recursive-case-for-Gamma
	subsetp insert star setp members-are-numbers sharp
	ord-ramsey-hyp-positive large-goes-up subsetp-is-idempotent)
))

; now, consider XX = (extract-prehom g ZZ (Gamma alpha (sub1 n) c) c)
; XX will be (Gamma alpha (sub1 n) c) -- large and a set, so:

(prove-lemma replication-of-ord-ramsey-hyp (rewrite) (implies
	(and
		(lessp 1 n)
		(ord-ramsey-hyp g ZZ alpha n c)
		(equal XX (extract-prehom g ZZ (Gamma alpha (sub1 n) c) c))  )
	(ord-ramsey-hyp (derived g XX) XX alpha (sub1 n) c)  )
( ; hints
(do-not-induct T)
(use 
	(prehom-set-E (alpha (Gamma alpha (sub1 n) c)))
	(ord-ramsey-to-prehom-set-hyp))
(disable prehom-set-hyp prehom-set-E 
	gamma insert star sharp setp subsetp members-are-numbers
	recursive-case-for-Gamma  ord-ramsey-to-prehom-set-hyp)
(hands-off o-largep)
))

; also, formalize the recursive case for extract-ramsey:

(prove-lemma recursive-case-for-extract-ramsey (rewrite) (implies
	(and
		(lessp 1 n)
		(equal XX (extract-prehom g ZZ (Gamma alpha (sub1 n) c) c))  )
	(equal
		(extract-ramsey g ZZ alpha n c)
		(extract-ramsey (derived g XX) XX alpha (sub1 n) c))))


; the basis for ramsey-B is:
(prove-lemma ord-ramsey-B-aux1 (rewrite) (implies 
	(ord-ramsey-hyp g ZZ alpha 1 c)
	(o-largep (extract-ramsey g ZZ alpha 1 c) alpha)))
; this is immediate by ramsey-basis-D

; now, the induction should work because a counter-example with 
; n will generate a counter-example with n-1

(prove-lemma ord-ramsey-B-aux2 (rewrite) (implies 
	(and
		(leq 1 n)   
			; just so we can make the induction go
			; with ord-ramsey-hyp and extract-ramsey disabled
		(ord-ramsey-hyp g ZZ alpha n c) )
	(o-largep (extract-ramsey g ZZ alpha n c) alpha))
( ; hints
(induct (extract-ramsey g ZZ alpha n c))
(disable ord-ramsey-hyp extract-ramsey
	subsetp setp min-is-first large-goes-up members-are-numbers)
))

; but of course, the (leq 1 n) is irrelevant

(prove-lemma ord-ramsey-B (rewrite) (implies 
	(ord-ramsey-hyp g ZZ alpha n c)
	(o-largep (extract-ramsey g ZZ alpha n c) alpha)))

(disable ord-ramsey-B-aux1)
(disable ord-ramsey-B-aux2)

; the basis for ramsey-C is:
(prove-lemma ord-ramsey-C-aux1 (rewrite) (implies 
	(ord-ramsey-hyp g ZZ alpha 1 c)
	(homp (extract-ramsey g ZZ alpha 1 c) g 1)))
; this is immediate by ramsey-basis-C

; now, the induction should work because a counter-example with 
; n will generate a counter-example with n-1

; the induction will be:  if
; XX =  (extract-prehom g ZZ (Gamma alpha (sub1 n) c) c)
; YY = (extract-ramsey g ZZ alpha n c) = 
;      (extract-ramsey (derived g XX) XX alpha (sub1 n) c)
;         (by recursive-case-for-extract-ramsey)
; and inductively, 
;  (homp  YY  (derived g XX) (sub1 n))
; then by the derived partition lemma
; (homp YY g n)

; let's phrase the derived-partition-lemma in the current notation
(prove-lemma ord-ramsey-C-aux2 (rewrite) (implies
    (and
        (lessp 1 n) (pre-homp XX g)
        (sublistp YY XX)
        (homp YY (derived g XX) (sub1 n)) )
    (homp YY g n) ) )

; now, let's check that the XX and YY as above really
; satisfy the (pre-homp XX g)  and (sublistp YY XX)

(prove-lemma ord-ramsey-C-aux3 (rewrite) (implies 
	(and
		(lessp 1 n) 
		(ord-ramsey-hyp g ZZ alpha n c) 
		(equal XX (extract-prehom g ZZ (Gamma alpha (sub1 n) c) c)) )
	(pre-homp XX g))
( ; hints
(do-not-induct T)
(use 
	(prehom-set-F (alpha (Gamma alpha (sub1 n) c)) ))
(disable prehom-set-F ord-ramsey-hyp)
))

(prove-lemma ord-ramsey-C-aux4 (rewrite) (implies 
	(and
		(lessp 1 n) 
		(ord-ramsey-hyp g ZZ alpha n c) 
		(equal XX (extract-prehom g ZZ (Gamma alpha (sub1 n) c) c) )
		(equal YY (extract-ramsey g ZZ alpha n c) ))
	(sublistp YY XX)))

; it follows that aux2 gives

(prove-lemma ord-ramsey-C-aux5 (rewrite) (implies 
	(and
		(lessp 1 n) 
		(ord-ramsey-hyp g ZZ alpha n c) 
		(equal XX (extract-prehom g ZZ (Gamma alpha (sub1 n) c) c) )
		(equal YY (extract-ramsey g ZZ alpha n c) )
        (homp YY (derived g XX) (sub1 n)) )
    (homp YY g n) ) 
( ; hints
(do-not-induct T)
(use (ord-ramsey-C-aux2))
(disable ord-ramsey-C-aux2 recursive-case-for-extract-ramsey
	ord-ramsey-hyp extract-prehom extract-ramsey)
))

(prove-lemma ord-ramsey-C-aux6 (rewrite) (implies 
	(and
		(leq 1 n)   
			; just so we can make the induction go
			; with ord-ramsey-hyp and extract-ramsey disabled
		(ord-ramsey-hyp g ZZ alpha n c) )
	(homp (extract-ramsey g ZZ alpha n c) g n))
( ; hints
(induct (extract-ramsey g ZZ alpha n c))
(disable ord-ramsey-hyp extract-ramsey   
	subsetp setp min-is-first large-goes-up members-are-numbers)
(do-not-induct T) ;  don't generate sub-inductions
))

; but of course, the (leq 1 n) is irrelevant

(prove-lemma ord-ramsey-C (rewrite) (implies 
	(ord-ramsey-hyp g ZZ alpha n c)
	(homp (extract-ramsey g ZZ alpha n c) g n)) )

(disable ord-ramsey-C-aux1) (disable ord-ramsey-C-aux2)
(disable ord-ramsey-C-aux3) (disable ord-ramsey-C-aux4)
(disable ord-ramsey-C-aux5) (disable ord-ramsey-C-aux6)

; Finally, a version suitable for framing:

(prove-lemma ord-ramsey (rewrite) (implies 
	(and
		(ordinalp alpha)
		(rangep g c)
		(not (zerop n))
		(setp ZZ)
		(o-largep ZZ (Gamma alpha n c))  
		(equal YY (extract-ramsey  g ZZ alpha n c))  )
	(and
		(setp YY)
		(subsetp YY ZZ)
		(o-largep YY alpha)
		(homp YY g n))      ))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                  RAMSEY THEOREM -- PARIS-HARRINGTON VERSION            ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; FINALLY, we use epsilon_0 recursion/induction.  We define
; a function (lambda alpha k) such that ; (lambda alpha k) >= k,
; and the interval [k, (lamda alpha k)] is alpha - large
; This will show that applying the ordinal version of Ramsey's
; theorem to a suitable large interval will produce an
; omega-large (hence large) homogeneous set.

(defn lambda_kludge (alpha k)  (if (ordinalp alpha) alpha 0))
; just to get the prover to accept the following definition

(defn lambda (alpha k)  (if (and (ord-lessp 0 alpha) (ordinalp alpha))
	(lambda (pred alpha k) (add1 k))
	k )
( ; hints -- the prover won't do epsilon_0 recursion unless you tell it to
(ord-lessp (lambda_kludge  alpha k))
))

(disable lambda_kludge)

(prove-lemma lambda-is-a-number (rewrite) (implies
	(numberp k)
	(numberp (lambda alpha k))))

(prove-lemma lambda-is-big (rewrite) (implies
	(numberp k)
	(not (lessp (lambda alpha k) k))))

(prove-lemma base-case-for-lambda (rewrite) (implies 
	(not (ord-lessp 0 alpha))
	(equal (lambda  alpha k) k)))

(prove-lemma recursive-case-for-lambda (rewrite) (implies 
	(and (ordinalp alpha) (ord-lessp 0 alpha) )
	(equal 
		(lambda alpha k)
		(lambda (pred alpha k) (add1 k))  ) ))

(disable lambda)

; let's prove that (o-largep (segment k (lambda alpha k)) alpha)
; this is by induction

; base case:
(prove-lemma lambda-gives-large-segments-aux1 (rewrite) (implies
	(and (numberp k) (ordinalp alpha) (not (ord-lessp 0 alpha)))
	(o-largep (segment k (lambda alpha k)) alpha))  )

; for the recursive case:

(prove-lemma lambda-gives-large-segments-aux2 (rewrite) (implies
	(and (numberp k) (ordinalp alpha) (ord-lessp 0 alpha))
	(equal
		(segment k (lambda alpha k))
		(cons k (segment (add1 k) (lambda (pred alpha k) (add1 k)) ) )))
( ; hints
(do-not-induct T)
(use (recursive-case-for-segment (m k) (n  (lambda alpha k))))
(hands-off segment ordinalp)
))

(prove-lemma lambda-gives-large-segments-aux3 (rewrite) (implies
	(and 
		(numberp k) (ordinalp alpha) (ord-lessp 0 alpha)
		(o-largep (segment (add1 k) (lambda (pred alpha k) (add1 k))) 
			(pred alpha k) )  )
	(o-largep (segment k (lambda alpha k)) alpha)  )
( ; hints
(do-not-induct T)
(use
	(recursive-case-for-lambda (alpha alpha) (k k))
	(recursive-case-for-large (set (segment k (lambda alpha k))) (alpha alpha)))
(hands-off lambda ord-leq setp o-largep segment)
(disable setp set-builder o-largep segment recursive-case-for-lambda
	o-largep ord-leq recursive-case-for-large)
))

(prove-lemma lambda-gives-large-segments (rewrite) (implies
	(and (numberp k) (ordinalp alpha))
	(o-largep (segment k (lambda alpha k)) alpha))  
( ; hints
(induct (lambda alpha k))
(use 
	(lambda-gives-large-segments-aux3 (alpha alpha) (k k))
	(pred-is-an-ordinal (alpha alpha) (n k)) )
(hands-off segment ordinalp)
(disable ordinalp positive-large recursive-case-for-lambda
	base-case-for-lambda pred-is-an-ordinal lambda-gives-large-segments-aux3)
))

(disable lambda-gives-large-segments-aux1)
(disable lambda-gives-large-segments-aux2)
(disable lambda-gives-large-segments-aux3)
; so, the Ramsey number is:

(defn R (k n c) (lambda (Gamma '(1 . 0) n c) k))

; this is a number:
(prove-lemma R-is-a-number (rewrite) (implies
	(numberp k)
	(numberp (R k n c))))
(prove-lemma R-is-a-big (rewrite) (implies
	(numberp k)
	(not (lessp (R k n c) k))))

; now, we will get YY as an omega--large subset of ZZ = [k, (R k n c)]
; we want to show that that implies that YY is 
; large (in Paris-Harrington sense) and has size at least k
; (which follows from the defn of large)

(prove-lemma result-is-large-aux1 (rewrite)  (implies
	(and
		(setp YY)
		(o-largep YY '(1 . 0)) )
	(and
		(largep YY) (listp YY)
		(not (lessp (length YY) (car YY)))))
( ; hints
(do-not-induct T)
(use
	(omega-large (set YY))
	(omega-large-implies-large (set YY)) )
))

(prove-lemma result-is-large-aux2 (rewrite)  (implies
	(member x (segment k j))
	(equal (car (segment k j)) k))
( ; hints
(enable segment)
(induct (segment k j))
(disable cdr-of-segment setp min-is-first non-list-segment
	recursive-case-for-segment)
(hands-off o-largep)
))

(prove-lemma result-is-large-aux3 ()  (implies
	(member x (segment k j))
	(not (lessp x k)))
( ; hints
(do-not-induct T)
(use (min-is-first (x x) (s (segment k j))))
(disable min-is-first)
))

(prove-lemma result-is-large-aux4 (rewrite)  (implies
	(and
		(listp YY) (subsetp YY (segment k j)) )
	(not (lessp (car YY) k)))
( ; hints
(use (result-is-large-aux3 (x (car YY))))
))

(prove-lemma result-is-large (rewrite)  (implies
	(and
		(setp YY)
		(subsetp YY (segment k j))
		(o-largep YY '(1 . 0)) )
	(and
		(largep YY)
		(not (lessp (length YY) k))))
( ; hints
(do-not-induct T)
(disable subsetp segment cdr-of-segment setp min-is-first non-list-segment
	recursive-case-for-segment)
(hands-off o-largep)
))

(disable result-is-large-aux1) (disable result-is-large-aux2)
(disable result-is-large-aux3) (disable result-is-large-aux4)

;;;;;;;;  extracting the homogeneous set 

; (extract-ramsey-P-H g k n c)  finds a subset
; of (segment 0 (R k n c))  which is large and of size at least k
; actually, it just finds an omega-large subset of [k, (R k n c)]

(defn extract-ramsey-P-H (g k n c) 
	(extract-ramsey
		g  ; the partition
		(segment k (R k n c)) ;  the set
		'(1 . 0)  ; the ordinal (omega)
		n  ; partition of n-tuples
		c ; number of pieces  
))

; first, let's see what we get by a direct application
; of the ord-ramsey theorem.  To apply that, we need that
; the segment  (segment k (R k n c))  is
; (Gamma omega n c) -- large

(prove-lemma R-segment-is-large (rewrite) (implies
	(numberp k)
	(o-largep   (segment k (R k n c))   (Gamma '(1 . 0) n c) ))
( ; hints
(disable segment result-is-large recursive-case-for-segment)
))

; applying ord-ramsey,

(prove-lemma ramsey-P-H-aux1 (rewrite) (implies
	(and
		(rangep g c)        ; g maps into {0 ... c-1}
		(not (zerop n))     ; partitioning n-tuples for some n > 0
		(numberp k)         ; the desired size of the homogeneous set
		(equal R (R k n c)) ; the Ramsey number
		(equal YY (extract-ramsey-P-H g k n c)) )
			; YY is the computed homogeneous set
	(and
		(setp YY)
		(subsetp YY (segment k R))
		(homp YY g n)      
		(o-largep YY '(1 . 0)) ) )
( ; hints
(disable segment recursive-case-for-segment)
))

(disable ord-ramsey) (disable ord-ramsey-A) 
(disable ord-ramsey-B) (disable ord-ramsey-C) 

; to convert to intended Ramsey theorem:
; we need that (subsetp YY (segment k R))
; implies (subsetp YY (segment 0 R))

(prove-lemma ramsey-P-H-aux2 (rewrite) (implies
	(and
		(numberp k) (numberp R) (leq k R)
		(member x (segment k R)))
	(member x (segment 0 R)))
( ; hints
(use
	(members-of-segment (m k) (n R) (x x))
	(members-of-segment (m 0) (n R) (x x)) )
(disable members-of-segment recursive-case-for-segment tail-lemma-2)
))

(prove-lemma ramsey-P-H-aux3 (rewrite) (implies
	(and
		(numberp k) (numberp R) (leq k R) )
	(subsetp (segment k R) (segment 0 R)))
( ; hints
(use
	(subsetp-works-2
		(s1 (segment k R) ) (s2  (segment 0 R))))
(disable subsetp-works-2 recursive-case-for-segment tail-lemma-2)
))

(prove-lemma ramsey-P-H-aux4 (rewrite) (implies
	(and
		(numberp k) (numberp R) (leq k R)
		(subsetp YY (segment k R)) )
	(subsetp YY (segment 0 R)))
( ; hints
(disable recursive-case-for-segment tail-lemma-2)
))

(disable segment)
(disable subsetp)
(disable setp)
(disable extract-ramsey)
(disable extract-ramsey-P-H)
(disable recursive-case-for-segment)

; Paris - Harrington version of Ramsey Theorem:

(prove-lemma ramsey-P-H () (implies
	(and
		(rangep g c)        ; g maps into {0 ... c-1}
		(not (zerop n))     ; we are partitioning n-tuples for some n > 0
		(numberp k)         ; k = the desired size of the homogeneous set
		(equal R (R k n c)) ; the Ramsey number
		(equal YY (extract-ramsey-P-H g k n c)) )
			; YY is the computed homogeneous set
	(and
		(setp YY)        
			; YY is a set
		(subsetp YY (segment 0 R))  
			; YY is a subset of {0, 1,  ... R}
		(homp YY g n)     
			; YY is homogeneous for g as a partition of n-tuples
		(leq k (length YY))
			; YY has size at least k
		(largep YY) )
			; YY is large in the Paris - Harrington sense
)
( ; hints
(do-not-induct T)
(use (ramsey-P-H-aux1))
(disable ramsey-P-H-aux1)
))

;;; NOTE! : without the (largep YY), this would just be the
;;; standard Ramsey theorem, which is provable in PRA


)) ; END proveall