;;;***************************************************************
;;;An ACL2 Library of Floating Point Arithmetic

;;;David M. Russinoff
;;;Advanced Micro Devices, Inc.
;;;February, 1998
;;;***************************************************************

(in-package "ACL2")

(include-book "near")

(defun odd (x n)
  (let ((z (fl (* (expt 2 (1- n)) (sig x)))))
    (if (evenp z)
	(* (sgn x) (1+ z) (expt 2 (- (1+ (expo x)) n)))
      (* (sgn x) z (expt 2 (- (1+ (expo x)) n))))))

(defthm odd-pos
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (> n 0))
	     (> (odd x n) 0))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo sig fl-weakly-monotonic)
		  :use ((:instance sig-lower-bound)
			(:instance pos* 
				   (x (fl (* (sig x) (expt 2 (1- n))))) 
				   (y (expt 2 (- (1+ (expo x)) n))))
			(:instance pos* 
				   (x (1+ (fl (* (sig x) (expt 2 (1- n))))))
				   (y (expt 2 (- (1+ (expo x)) n))))
			(:instance sgn+1)
			(:instance expo-monotone (x 1) (y (1- n)))
			(:instance n<=fl (x (sig x)) (n 1))))))

(defthm odd>=trunc
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (> n 0))
	     (>= (odd x n) (trunc x n)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expt-pos)
		  :use ((:instance trunc)
			(:instance expt-pos (x (- (1+ (expo x)) n)))))))

(defthm odd-rewrite
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (> n 0))
	     (equal (odd x n)
		    (let ((z (fl (* (expt 2 (- (1- n) (expo x))) x))))
		      (if (evenp z)
			  (* (1+ z) (expt 2 (- (1+ (expo x)) n)))
			(* z (expt 2 (- (1+ (expo x)) n)))))))
  :rule-classes ()
  :hints (("Goal" :in-theory (enable sig expo sgn))))

(in-theory (disable odd))

(defthm hack2
    (implies (and (integerp n)
		  (rationalp x))
	     (= (fl (* 1/2 x (expt 2 n)))
		(fl (* x (expt 2 (1- n))))))
  :rule-classes ())

(defthm odd-other-1
    (implies (and (rationalp x)
		 (> x 0)
		 (integerp n)
		 (> n 1))
	     (= (trunc x (1- n))
		(* (fl (/ (* (expt 2 (- (1- n) (expo x))) x) 2))
		   (expt 2 (- (+ 2 (expo x)) n)))))
  :rule-classes ()
  :hints (("Goal" :in-theory (enable trunc-pos-rewrite)		  
		  :use ((:instance hack2 (n (- (1- n) (expo x))))))))

(defthm odd-other-2
    (implies (and (rationalp x)
		 (> x 0)
		 (integerp n)
		 (> n 1))
	     (= (trunc x (1- n))
		(* (fl (/ (fl (* (expt 2 (- (1- n) (expo x))) x)) 2))
		   (expt 2 (- (+ 2 (expo x)) n)))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable fl/int)
		  :use ((:instance odd-other-1)
			(:instance fl/int (x (* (expt 2 (- (1- n) (expo x))) x)) (n 2))))))

(defthm fl/2
    (implies (integerp z)
	     (= (fl (/ z 2))
		(if (evenp z)
		    (/ z 2)
		  (/ (1- z) 2))))
  :rule-classes ())

(defthm odd-other-3
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n) 
		  (> n 1)
		  (= z (fl (* (expt 2 (- (1- n) (expo x))) x)))
		  (evenp z))
	     (= (trunc x (1- n))
		(* z (expt 2 (- (1+ (expo x)) n)))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance fl/2)
			(:instance expo+ (n (- (1+ (expo x)) n)) (m 1))
			(:instance odd-other-2)))))

(defthm odd-other-4
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n) 
		  (> n 1)
		  (= z (fl (* (expt 2 (- (1- n) (expo x))) x)))
		  (not (evenp z)))
	     (= (* (fl (/ (fl (* (expt 2 (- (1- n) (expo x))) x)) 2))
		   (expt 2 (- (+ 2 (expo x)) n)))
		(* (fl (/ z 2)) (expt 2 (- (+ 2 (expo x)) n)))))
  :rule-classes ())

(defthm odd-other-5
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n) 
		  (> n 1)
		  (= z (fl (* (expt 2 (- (1- n) (expo x))) x)))
		  (not (evenp z)))
	     (= (trunc x (1- n))
		(* (fl (/ z 2)) (expt 2 (- (+ 2 (expo x)) n)))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance odd-other-2)
			(:instance odd-other-4)))))

(defthm hack3
    (implies (and (rationalp x)
		  (rationalp y)
		  (rationalp z)
		  (equal x y))
	     (= (* x z) (* y z)))
  :rule-classes ())

(defthm odd-other-6
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (> n 1)
		  (= z (fl (* (expt 2 (- (1- n) (expo x))) x)))
		  (not (evenp z)))
	     (= (trunc x (1- n))
		(* (/ (1- z) 2) (expt 2 (- (+ 2 (expo x)) n)))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance fl/2)
			(:instance odd-other-5)
			(:instance hack3
				   (x (/ (1- z) 2))
				   (y (fl (/ z 2)))
				   (z (expt 2 (- (+ 2 (expo x)) n))))))))

(defthm odd-other-7
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (> n 1)
		  (= z (fl (* (expt 2 (- (1- n) (expo x))) x)))
		  (not (evenp z)))
	     (= (trunc x (1- n))
		(* (1- z) (expt 2 (- (1+ (expo x)) n)))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance odd-other-6)
			(:instance expo+ (n (- (1+ (expo x)) n)) (m 1))))))

(defthm odd-other
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n) 
		  (> n 1))
	     (= (odd x n)
		(+ (trunc x (1- n))
		   (expt 2 (- (1+ (expo x)) n)))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance odd-other-3 (z (fl (* (expt 2 (- (1- n) (expo x))) x))))
			(:instance odd-other-7 (z (fl (* (expt 2 (- (1- n) (expo x))) x))))
			(:instance odd-rewrite)))))

(defthm expo-odd-1
    (implies (and (rationalp x)
		  (integerp n)
		  (> x 0)
		  (> n 0))
	     (< (trunc x n) (expt 2 (1+ (expo x)))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo-trunc abs-trunc)
		  :use ((:instance expo-trunc)
			(:instance trunc-pos)
			(:instance expo-upper-bound (x (trunc x n)))))))

(defthm expo-odd-2
    (implies (and (rationalp x)
		  (integerp n)
		  (> x 0)
		  (> n 1))
	     (< (odd x n) (expt 2 (1+ (expo x)))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo-trunc abs-trunc)
		  :use ((:instance expo-odd-1 (n (1- n)))
			(:instance odd-other)
			(:instance exactp-2**n (m (1- n)) (n (1+ (expo x))))
			(:instance expo-trunc (n (1- n)))
			(:instance expt-strong-monotone (n (- (1+ (expo x)) n)) (m (- (1+ (expo x)) (1- n))))
			(:instance trunc-pos (n (1- n)))
			(:instance fp+1 (n (1- n)) (x (trunc x (1- n))) (y (expt 2 (1+ (expo x)))))))))

(defthm expo-odd-3
    (implies (and (rationalp x)
		  (integerp n)
		  (> x 0)
		  (> n 1))
	     (<= (expo (odd x n)) (expo x)))
  :rule-classes ()
  :hints (("Goal" :use ((:instance expo-odd-2)
			(:instance odd-pos)
			(:instance expo-upper-2 (x (odd x n)) (n (1+ (expo x))))))))

(defthm expo-odd
    (implies (and (rationalp x)
		  (integerp n)
		  (> x 0)
		  (> n 1))
	     (equal (expo (odd x n)) (expo x)))
  :hints (("Goal" :in-theory (disable expt-pos abs-trunc)
		  :use ((:instance expo-odd-3)
			(:instance odd-other)
			(:instance expt-pos (x (- (1+ (expo x)) n)))
			(:instance expo-monotone (y (odd x n)) (x (trunc x (1- n))))
			(:instance odd-pos)
			(:instance trunc-pos (n (1- n)))))))

(defthm exactp-odd-1
    (implies (and (rationalp x)
		  (integerp n)
		  (> x 0)
		  (> n 1))
	     (= (* (+ (trunc x (1- n))
		      (expt 2 (- (1+ (expo x)) n)))
		   (expt 2 (- (1- n) (expo x))))
		(1+ (* (trunc x (1- n)) (expt 2 (- (1- n) (expo x)))))))
	     :rule-classes ()
  :hints (("Goal" :in-theory (disable expt-pos abs-trunc)
		  :use ((:instance expo+ (n (- (1- n) (expo x))) (m (- (1+ (expo x)) n)))))))

(defthm exactp-odd-2
    (implies (and (rationalp x)
		  (integerp n)
		  (> x 0)
		  (> n 1))
	     (= (* (odd x n) (expt 2 (- (1- n) (expo x))))
		(1+ (* (trunc x (1- n)) (expt 2 (- (1- n) (expo x)))))))
	     :rule-classes ()
  :hints (("Goal" :in-theory (disable expt-pos abs-trunc)
		  :use ((:instance odd-other)
			(:instance exactp-odd-1)))))

(defthm exactp-odd-3
    (implies (and (rationalp x)
		  (integerp n))
	     (= (expt 2 (- (1- n) (expo x)))
		(* 2 (expt 2 (- (- n 2) (expo x))))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance expo+ (n (- (- n 2) (expo x))) (m 1))))))

(defthm exactp-odd-4
    (implies (and (rationalp x)
		  (rationalp y)
		  (integerp n))
	     (= (* y 2 (expt 2 (- (- n 2) (expo x))))
		(* 2 y (expt 2 (- (- n 2) (expo x))))))
  :rule-classes ())

(defthm exactp-odd-5
    (implies (and (rationalp x)
		  (integerp n))
	     (= (* (trunc x (1- n)) (expt 2 (- (1- n) (expo x))))
		(* 2 (trunc x (1- n)) (expt 2 (- (- n 2) (expo x))))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance exactp-odd-3)
			(:instance exactp-odd-4 (y (trunc x (1- n))))))))

(defthm exactp-odd-6
    (implies (and (rationalp x)
		  (integerp n)
		  (> x 0)
		  (> n 1))
	     (= (* (odd x n) (expt 2 (- (1- n) (expo x))))
		(1+ (* 2 (* (trunc x (1- n)) (expt 2 (- (- n 2) (expo x))))))))
	     :rule-classes ()
  :hints (("Goal" :in-theory (disable expt-pos abs-trunc)
		  :use ((:instance exactp-odd-2)
			(:instance exactp-odd-5)))))

(defthm exactp-odd
    (implies (and (rationalp x)
		  (integerp n)
		  (> x 0)
		  (> n 1))
	     (exactp (odd x n) n))
	     :rule-classes ()
  :hints (("Goal" :in-theory (disable expt-pos abs-trunc)
		  :use ((:instance exactp-odd-6)
			(:instance exactp2 (x (odd x n)))
			(:instance exactp2 (x (trunc x (1- n))) (n (1- n)))))))

(defthm not-exactp-odd-1
    (implies (and (rationalp x)
		  (integerp n)
		  (> x 0)
		  (> n 1))
	     (= (* (+ (trunc x (1- n)) (expt 2 (- (1+ (expo x)) n)))
		   (expt 2 (- (- n 2) (expo x))))
		(+ (* (trunc x (1- n)) (expt 2 (- (- n 2) (expo x)))) 1/2)))
	     :rule-classes ()
	     :hints (("Goal" :use ((:instance expo+ (m (- (- n 2) (expo x))) (n (- (1+ (expo x)) n)))))))

(defthm not-exactp-odd-2
    (implies (and (rationalp x)
		  (integerp n)
		  (> x 0)
		  (> n 1))
	     (= (* (odd x n)
		   (expt 2 (- (- n 2) (expo x))))
		(+ (* (trunc x (1- n)) (expt 2 (- (- n 2) (expo x)))) 1/2)))
	     :rule-classes ()
  :hints (("Goal" :use ((:instance odd-other)
			(:instance not-exactp-odd-1)))))

(defthm not-exactp-odd
    (implies (and (rationalp x)
		  (integerp n)
		  (> x 0)
		  (> n 1))
	     (not (exactp (odd x n) (1- n))))
	     :rule-classes ()
  :hints (("Goal" :in-theory (disable expt-pos abs-trunc)
		  :use ((:instance not-exactp-odd-2)
			(:instance exactp2 (x (odd x n)) (n (1- n)))
			(:instance exactp2 (x (trunc x (1- n))) (n (1- n)))))))

(defthm trunc-odd-1
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (> n 1))
	     (= (trunc (odd x n) (1- n))
		(* (fl (* (expt 2 (- (- n 2) (expo x))) 
			  (+ (* (fl (* (expt 2 (- (- n 2) (expo x)))
				       x))
				(expt 2 (- (+ (expo x) 2) n)))
			     (expt 2 (- (1+ (expo x)) n)))))
		   (expt 2 (- (+ (expo x) 2) n)))))
  :rule-classes ()
  :hints (("Goal" :in-theory (enable trunc-pos-rewrite)
		  :use ((:instance odd-other)
			(:instance odd-pos)))))

(defthm trunc-odd-2
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (> n 1))
	     (= (trunc (odd x n) (1- n))
		(* (fl (+ (fl (* (expt 2 (- (- n 2) (expo x)))
				 x))
			  1/2))
		   (expt 2 (- (+ (expo x) 2) n)))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance trunc-odd-1)
			(:instance expo+ (m (- (- n 2) (expo x))) (n (- (+ (expo x) 2) n)))
			(:instance expo+ (m (- (- n 2) (expo x))) (n (- (+ (expo x) 1) n)))))))

(defthm trunc-odd-3
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (> n 1))
	     (= (trunc (odd x n) (1- n))
		(* (fl (* (expt 2 (- (- n 2) (expo x)))
			  x))
		   (expt 2 (- (+ (expo x) 2) n)))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance trunc-odd-2)))))

(defthm trunc-odd-4
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (> n 1))
	     (= (trunc (odd x n) (1- n))
		(trunc x (1- n))))
  :rule-classes ()
  :hints (("Goal" :in-theory (enable trunc-pos-rewrite)
		  :use ((:instance trunc-odd-3)))))

(defthm trunc-odd
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (integerp m)
		  (> m 0)
		  (> n m))
	     (= (trunc (odd x n) m)
		(trunc x m)))
  :rule-classes ()
  :hints (("Goal" :use ((:instance trunc-odd-4)
			(:instance odd-pos)
			(:instance trunc-trunc (n (1- n)))
			(:instance trunc-trunc (n (1- n)) (x (odd x n)))))))

(defun kp (k x y)
  (+ k (- (expo (+ x y)) (expo y))))

(defthm odd-plus
    (implies (and (rationalp x)
		  (rationalp y)
		  (integerp k)
		  (> x 0)
		  (> y 0)
		  (> k 1)
		  (> (+ (1- k) (- (expo x) (expo y))) 0)
		  (exactp x (+ (1- k) (- (expo x) (expo y)))))
	     (= (+ x (odd y k))
		(odd (+ x y) (kp k x y))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance odd-other (n k) (x y))
			(:instance expo-monotone (x y) (y (+ x y)))
			(:instance plus-trunc (k (1- k)) (n (+ (1- k) (- (expo x) (expo y)))))
			(:instance odd-other (x (+ x y)) (n (kp k x y)))))))

(defthm trunc-trunc-odd
    (implies (and (rationalp x)
		  (rationalp y)
		  (integerp m)
		  (integerp k)
		  (> x y)
		  (> y 0)
		  (> k 0)
		  (>= (- m 2) k))
	     (>= (trunc x k) (trunc (odd y m) k)))
  :rule-classes ()
  :hints (("Goal" :use ((:instance trunc-odd (x y) (m k) (n m))
			(:instance trunc-monotone (x y) (y x) (n k))))))

(defthm away-away-odd-1
    (implies (and (rationalp x)
		  (rationalp y)
		  (integerp m)
		  (integerp k)
		  (> x y)
		  (> y 0)
		  (> k 0)
		  (>= (- m 2) k))
	     (> (away x k) (trunc y (1- m))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance away-lower-pos (n k))
			(:instance trunc-upper-pos (x y) (n (1- m)))))))

(defthm away-away-odd-2
    (implies (and (rationalp x)
		  (rationalp y)
		  (integerp m)
		  (integerp k)
		  (> x y)
		  (> y 0)
		  (> k 0)
		  (>= (- m 2) k))
	     (>= (away x k) (+ (trunc y (1- m)) (expt 2 (- (+ (expo y) 2) m)))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance away-away-odd-1)
			(:instance fp+1 (x (trunc y (1- m))) (y (away x k)) (n (1- m)))
			(:instance expo-trunc (x y) (n (1- m)))
			(:instance trunc-exactp-b (x y) (n (1- m)))
			(:instance away-exactp-b (n k))
			(:instance trunc-pos (x y) (n (1- m)))
			(:instance exactp-<= (x (away x k)) (m k) (n (1- m)))))))

(defthm away-away-odd-3
    (implies (and (rationalp x)
		  (rationalp y)
		  (integerp m)
		  (integerp k)
		  (> x y)
		  (> y 0)
		  (> k 0)
		  (>= (- m 2) k))
	     (> (away x k) (odd y m)))
  :rule-classes ()
  :hints (("Goal" :use ((:instance away-away-odd-2)
			(:instance odd-other (x y) (n m))
			(:instance expt-strong-monotone (n (- (1+ (expo y)) m)) (m (- (+ (expo y) 2) m)))))))

(defthm away-away-odd
    (implies (and (rationalp x)
		  (rationalp y)
		  (integerp m)
		  (integerp k)
		  (> x y)
		  (> y 0)
		  (> k 0)
		  (>= (- m 2) k))
	     (>= (away x k) (away (odd y m) k)))
  :rule-classes ()
  :hints (("Goal" :use ((:instance away-away-odd-3)
			(:instance odd-pos (x y) (n m))
			(:instance away-exactp-c (a (away x k)) (x (odd y m)) (n k))
			(:instance away-exactp-b (n k))))))

(defthm near-near-odd
    (implies (and (rationalp x)
		  (rationalp y)
		  (integerp m)
		  (integerp k)
		  (> x y)
		  (> y 0)
		  (> k 0)
		  (>= (- m 2) k))
	     (>= (near x k) (near (odd y m) k)))
  :rule-classes ()
  :hints (("Goal" :use ((:instance trunc-exactp-b (n (1- m)) (x y))
			(:instance odd-pos (x y) (n m))
			(:instance trunc-pos (x y) (n (1- m)))
			(:instance trunc-upper-pos (x y) (n (1- m)))
			(:instance expo-trunc (x y) (n (1- m)))
			(:instance odd-other (x y) (n m))
			(:instance expt-strong-monotone 
				   (n (- (1+ (expo y)) m)) 
				   (m (- (+ 2 (expo y)) m)))
			(:instance near-near
				   (n (- m 2))
				   (a (trunc y (1- m)))
				   (y (odd y m)))))))