(in-package "ACL2")

(include-book "lop1")

(local (defun lop2-induct (n a b)
  (if (and (integerp n) (>= n 0))
      (if (> n 0)
	  (lop2-induct (1- n) a (rem b (expt 2 (1- n))))
	a)
    b)))

(local (defthm lop2-1
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (= (bitn a (1- k)) 0)
		  (= (bitn b (1- k)) 1)
		  (IMPLIES (AND (INTEGERP A)
				(<= 0 A)
				(INTEGERP (REM B (EXPT 2 (+ -1 K))))
				(<= 0 (REM B (EXPT 2 (+ -1 K))))
				(INTEGERP (+ -1 K))
				(<= 0 (+ -1 K))
				(< A (EXPT 2 (+ -1 K)))
				(< (REM B (EXPT 2 (+ -1 K)))
				   (EXPT 2 (+ -1 K))))
			   (= (PHI A (REM B (EXPT 2 (+ -1 K)))
				   1 (+ -1 K))
			      (EXPO (LOGIOR (* 2 A)
					    (COMP1 (* 2 (REM B (EXPT 2 (+ -1 K))))
						   (+ 1 -1 K))))))
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (= (PHI A 
		     (REM B (EXPT 2 (+ -1 K)))
		     1 (1- K))
		(EXPO (LOGIOR (* 2 A)
			      (COMP1 (* 2 (REM B (EXPT 2 (+ -1 K))))
				     k)))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance rem<n (m b) (n (expt 2 (1- k))))
			(:instance rem>=0 (m b) (n (expt 2 (1- k))))
			(:instance bit-expo-b (x a) (n (1- k))))))))

(local (defthm lop2-2
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (= (bitn a (1- k)) 0)
		  (= (bitn b (1- k)) 1)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (= (PHI A b 1 k)
		(phi a b 1 (1- k))))
  :rule-classes ()))

(local (defthm lop2-3
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (= (bitn a (1- k)) 0)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K)))
	     (= (rem a (expt 2 (1- k)))
		a))
  :rule-classes ()
  :hints (("Goal" :use ((:instance rem< (m a) (n (expt 2 (1- k))))
			(:instance expt-pos (x (1- k)))
			(:instance bit-expo-b (x a) (n (- k 1))))))))

(local (defthm lop2-4
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (= (bitn a (1- k)) 0)
		  (= (bitn b (1- k)) 1)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (= (PHI A b 1 k)
		(phi a (rem b (expt 2 (1- k))) 1 (1- k))))
  :rule-classes ()
  :hints (("Goal" :use (lop2-3
			lop2-2
			(:instance phi-rem (d 1) (j (1- k)) (k (1- k))))))))

(local (defthm lop2-5
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (= (bitn a (1- k)) 0)
		  (= (bitn b (1- k)) 1)
		  (IMPLIES (AND (INTEGERP A)
				(<= 0 A)
				(INTEGERP (REM B (EXPT 2 (+ -1 K))))
				(<= 0 (REM B (EXPT 2 (+ -1 K))))
				(INTEGERP (+ -1 K))
				(<= 0 (+ -1 K))
				(< A (EXPT 2 (+ -1 K)))
				(< (REM B (EXPT 2 (+ -1 K)))
				   (EXPT 2 (+ -1 K))))
			   (= (PHI A (REM B (EXPT 2 (+ -1 K)))
				   1 (+ -1 K))
			      (EXPO (LOGIOR (* 2 A)
					    (COMP1 (* 2 (REM B (EXPT 2 (+ -1 K))))
						   (+ 1 -1 K))))))
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (= (PHI A b 1 k)
		(EXPO (LOGIOR (* 2 A)
			      (COMP1 (* 2 (REM B (EXPT 2 (+ -1 K))))
				     k)))))
  :rule-classes ()
  :hints (("Goal" :use (lop2-1 lop2-4)))))

(local (defthm lop2-6
    (IMPLIES (AND (INTEGERP k)
		  (< 0 k)
		  (= (bitn b (- k 1)) 1)
		  (INTEGERP b)
		  (INTEGERP k)
		  (<= 0 b)
		  (< b (EXPT 2 k)))
	     (= (rem b (expt 2 (- k 1)))
		(- b (expt 2 (- k 1)))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance rem< (m (- b (expt 2 (- k 1)))) (n (expt 2 (- k 1))))
			(:instance expt-pos (x (- k 1)))
			(:instance expo+ (m (- k 1)) (n 1))
			(:instance bit-expo-a (x b) (n (- k 1)))
			(:instance rem+ (m (- b (expt 2 (- k 1)))) (a 1) (n (expt 2 (- k 1)))))))))

(local (defthm lop2-7
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (= (bitn a (1- k)) 0)
		  (= (bitn b (1- k)) 1)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (= (comp1 (* 2 (rem b (expt 2 (1- k))))
		       k)
		(comp1 (* 2 b) (1+ k))))		
  :rule-classes ()
  :hints (("Goal" :use (lop2-6)))))

(local (defthm lop2-8
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (= (bitn a (1- k)) 0)
		  (= (bitn b (1- k)) 1)
		  (IMPLIES (AND (INTEGERP A)
				(<= 0 A)
				(INTEGERP (REM B (EXPT 2 (+ -1 K))))
				(<= 0 (REM B (EXPT 2 (+ -1 K))))
				(INTEGERP (+ -1 K))
				(<= 0 (+ -1 K))
				(< A (EXPT 2 (+ -1 K)))
				(< (REM B (EXPT 2 (+ -1 K)))
				   (EXPT 2 (+ -1 K))))
			   (= (PHI A (REM B (EXPT 2 (+ -1 K)))
				   1 (+ -1 K))
			      (EXPO (LOGIOR (* 2 A)
					    (COMP1 (* 2 (REM B (EXPT 2 (+ -1 K))))
						   (+ 1 -1 K))))))
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (= (PHI A b 1 k)
		(EXPO (LOGIOR (* 2 A)
			      (COMP1 (* 2 b) (1+ k))))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable comp1 phi)
		  :use (lop2-5 lop2-7)))))

(local (defthm lop2-9
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (not (and (= (bitn a (1- k)) 0)
			    (= (bitn b (1- k)) 1)))
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (= (PHI A b 1 k) k))
  :rule-classes ()
  :hints (("Goal" :use ((:instance bitn-0-1 (x a) (n (1- k)))
			(:instance bitn-0-1 (x b) (n (1- k))))))))

(local (defthm lop2-10
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (< (* 2 a) (expt 2 (1+ k))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance *-strongly-monotonic (x 2) (y a) (y+ (expt 2 k))))))))

(local (defthm lop2-11
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (< (COMP1 (* 2 b) (1+ k))
		(expt 2 (1+ k))))
  :rule-classes ()))

(local (defthm lop2-12
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (< (logior (* 2 a)
			(COMP1 (* 2 b) (1+ k)))
		(expt 2 (1+ k))))
  :rule-classes ()
  :hints (("Goal" :use (lop2-10
			lop2-11
			(:instance or-dist-a
				   (x (* 2 a))
				   (y (comp1 (* 2 b) (1+ k)))
				   (n (1+ k))))))))

(local (defthm lop2-13
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (<= (expo (logior (* 2 a)
			       (COMP1 (* 2 b) (1+ k))))
		 k))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable logior)
		  :use (lop2-12
			(:instance logior-nat (i (* 2 a)) (j (comp1 (* 2 b) (1+ k))))
			(:instance expo<= (x (logior (* 2 a) (COMP1 (* 2 b) (1+ k)))) (n k)))))))

(local (defthm bitn-rewrite
    (implies (and (integerp x)
		  (integerp k)
		  (>= x 0)
		  (>= k 0))
	     (equal (bitn x k)
		    (rem (fl (/ x (expt 2 k)))
			 2)))
  :hints (("Goal" :use (bitn-def)))))

(local (in-theory (disable bitn-rewrite)))

(defthm BITN-N+K
    (implies (and (integerp x)
		  (>= x 0)
		  (integerp n)
		  (>= n 0)
		  (integerp k)
		  (>= k 0))
	     (= (bitn (* x (expt 2 k)) (+ n k))
		(bitn x n)))
  :rule-classes ()
  :hints (("Goal" :in-theory (enable bitn-rewrite)
		  :use ((:instance expo+ (m k))))))

(local (defthm lop2-14
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (= (bitn a (1- k)) 1)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (= (bitn (logior (* 2 a) (COMP1 (* 2 b) (1+ k)))
		      k)
		1))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable logior)
		  :use ((:instance bitn-n+k (x a) (k 1) (n (1- k)))
			(:instance bitn-0-1 (x (COMP1 (* 2 b) (1+ k))) (n k))
			(:instance bit-dist-b
				   (x (* 2 a))
				   (y (COMP1 (* 2 b) (1+ k)))
				   (n k)))))))

(local (defthm lop2-15
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (= (bitn b (1- k)) 0)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (= (bitn (logior (* 2 a) (COMP1 (* 2 b) (1+ k)))
		      k)
		1))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable logior)
		  :use ((:instance bitn-n+k (x b) (k 1) (n (1- k)))
			(:instance bitn-0-1 (x (COMP1 (* 2 b) (1+ k))) (n k))
			(:instance bitn-0-1 (x (* 2 a)) (n k))
			(:instance bitn-comp1
				   (x (* 2 b))
				   (n (1+ k)))
			(:instance bit-dist-b
				   (x (* 2 a))
				   (y (COMP1 (* 2 b) (1+ k)))
				   (n k)))))))

(local (defthm lop2-16
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (not (and (= (bitn a (1- k)) 0)
			    (= (bitn b (1- k)) 1)))
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (= (bitn (logior (* 2 a) (COMP1 (* 2 b) (1+ k)))
		      k)
		1))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable logior)
		  :use (lop2-14
			lop2-15
			(:instance bitn-0-1 (x a) (n (1- k)))
			(:instance bitn-0-1 (x b) (n (1- k))))))))

(local (defthm lop2-17
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (not (and (= (bitn a (1- k)) 0)
			    (= (bitn b (1- k)) 1)))
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (>= (logior (* 2 a) (COMP1 (* 2 b) (1+ k)))
		 (expt 2 k)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable logior)
		  :use (lop2-16
			(:instance logior-nat (i (* 2 a)) (j (comp1 (* 2 b) (1+ k))))
			(:instance bit-expo-a (x (logior (* 2 a) (COMP1 (* 2 b) (1+ k)))) (n k)))))))

(local (defthm lop2-18
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (not (and (= (bitn a (1- k)) 0)
			    (= (bitn b (1- k)) 1)))
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (>= (expo (logior (* 2 a) (COMP1 (* 2 b) (1+ k))))
		 k))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable logior)
		  :use (lop2-17
			(:instance expo>= (x (logior (* 2 a) (COMP1 (* 2 b) (1+ k)))) (n k)))))))

(local (defthm lop2-19
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (not (and (= (bitn a (1- k)) 0)
			    (= (bitn b (1- k)) 1)))
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (= (expo (logior (* 2 a) (COMP1 (* 2 b) (1+ k))))
		k))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable logior)
		  :use (lop2-13 lop2-18)))))

(local (defthm lop2-20
    (IMPLIES (AND (INTEGERP K)
		  (< 0 K)
		  (IMPLIES (AND (INTEGERP A)
				(<= 0 A)
				(INTEGERP (REM B (EXPT 2 (+ -1 K))))
				(<= 0 (REM B (EXPT 2 (+ -1 K))))
				(INTEGERP (+ -1 K))
				(<= 0 (+ -1 K))
				(< A (EXPT 2 (+ -1 K)))
				(< (REM B (EXPT 2 (+ -1 K)))
				   (EXPT 2 (+ -1 K))))
			   (= (PHI A (REM B (EXPT 2 (+ -1 K)))
				   1 (+ -1 K))
			      (EXPO (LOGIOR (* 2 A)
					    (COMP1 (* 2 (REM B (EXPT 2 (+ -1 K))))
						   (+ 1 -1 K))))))
		  (INTEGERP A)
		  (<= 0 A)
		  (INTEGERP B)
		  (<= 0 B)
		  (INTEGERP K)
		  (<= 0 K)
		  (< A (EXPT 2 K))
		  (< B (EXPT 2 K)))
	     (= (PHI A b 1 k)
		(EXPO (LOGIOR (* 2 A)
			      (COMP1 (* 2 b) (1+ k))))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable comp1 logior phi)
		  :use (lop2-8 lop2-19 lop2-9)))))

(local (defthm lop2-21
    (implies (and (integerp a)
		  (>= a 0)
		  (integerp b)
		  (>= b 0)
		  (integerp k)
		  (>= k 0)
		  (< a (expt 2 k))
		  (< b (expt 2 k)))
	     (= (phi a b 1 k)
		(expo (logior (* 2 a) (comp1 (* 2 b) (1+ k))))))
  :rule-classes ()
  :hints (("Goal" :induct (lop2-induct k a b))
	  ("Subgoal *1/1" :use (lop2-20)))))

(local (defthm lop2-22
    (implies (and (integerp a)
		  (> a 0)
		  (integerp b)
		  (> b 0)
		  (= e (expo a))
		  (< (expo b) e))
	     (= (bitn a e) 1))
  :rule-classes ()
  :hints (("Goal" :use ((:instance expo-upper-bound (x a))
			(:instance expo-monotone (x 1) (y a))
			(:instance expo-lower-bound (x a))
			(:instance bit-expo-b (x a) (n e)))))))

(local (defthm lop2-23
    (implies (and (integerp a)
		  (> a 0)
		  (integerp b)
		  (> b 0)
		  (= e (expo a))
		  (< (expo b) e))
	     (= (bitn b e) 0))
  :rule-classes ()
  :hints (("Goal" :use ((:instance expo-upper-bound (x b))
			(:instance expo-monotone (x 1) (y a))
			(:instance expt-monotone (n (1+ (expo b))) (m e))
			(:instance bit-expo-a (x b) (n e)))))))

(local (defthm lop2-24
    (implies (and (integerp a)
		  (> a 0)
		  (integerp b)
		  (> b 0)
		  (= e (expo a))
		  (< (expo b) e))
	     (= (phi a b 0 (1+ e))
		(phi a b 1 e)))
  :rule-classes ()
  :hints (("Goal" :use (lop2-22 
			lop2-23
			(:instance expo-monotone (x 1) (y a)))))))

(local (defthm lop2-25
    (implies (and (integerp a)
		  (> a 0)
		  (integerp b)
		  (> b 0)
		  (= e (expo a))
		  (< (expo b) e)
		  (= lambda
		     (logior (* 2 (rem a (expt 2 e)))
			     (comp1 (* 2 b) (1+ e)))))
	     (= (phi (rem a (expt 2 e)) b 1 e)
		(expo lambda)))
  :rule-classes ()
  :hints (("Goal" :use ((:instance lop2-21 (a (rem a (expt 2 e))) (k e))
			(:instance expo-upper-bound (x b))
			(:instance expo-monotone (x 1) (y a))
			(:instance expt-monotone (n (1+ (expo b))) (m e))
			(:instance rem>=0 (m a) (n (expt 2 e)))
			(:instance rem<n (m a) (n (expt 2 e))))))) )

(local (defthm lop2-26
    (implies (and (integerp a)
		  (> a 0)
		  (integerp b)
		  (> b 0)
		  (= e (expo a))
		  (< (expo b) e)
		  (= lambda
		     (logior (* 2 (rem a (expt 2 e)))
			     (comp1 (* 2 b) (1+ e)))))
	     (= (phi (rem a (expt 2 e)) b 1 e)
		(phi a b 1 e)))
  :rule-classes ()
  :hints (("Goal" :use ((:instance phi-rem (d 1) (j e) (k e))
			(:instance rem< (m b) (n (expt 2 e)))
			(:instance expo-upper-bound (x b))
			(:instance expo-monotone (x 1) (y a))
			(:instance expt-monotone (n (1+ (expo b))) (m e)))))))

(local (defthm lop2-27
    (implies (and (integerp a)
		  (> a 0)
		  (integerp b)
		  (> b 0)
		  (= e (expo a))
		  (< (expo b) e)
		  (= lambda
		     (logior (* 2 (rem a (expt 2 e)))
			     (comp1 (* 2 b) (1+ e)))))
	     (= (phi a b 0 (1+ e))
		(expo lambda)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable logior phi)
		  :use (lop2-24 lop2-25 lop2-26)))))

(defthm LOP-THM-2
    (implies (and (integerp a)
		  (> a 0)
		  (integerp b)
		  (> b 0)
		  (= e (expo a))
		  (< (expo b) e)
		  (= lambda
		     (logior (* 2 (rem a (expt 2 e)))
			     (comp1 (* 2 b) (1+ e)))))
	     (or (= (expo (- a b)) (expo lambda))
		 (= (expo (- a b)) (1- (expo lambda)))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable logior phi)
		  :use (lop2-27
			(:instance expo-upper-bound (x b))
			(:instance expo-monotone (x 1) (y a))
			(:instance expt-monotone (n (1+ (expo b))) (m e))
			(:instance expo-upper-bound (x a))
			(:instance lop-thm-1 (n (1+ e)))))))