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

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

(in-package "ACL2")

(include-book "away")

(defun re (x)
  (- x (fl x)))

(defun near (x n)
  (let ((z (fl (* (expt 2 (1- n)) (sig x))))
	(f (re (* (expt 2 (1- n)) (sig x)))))
    (if (< f 1/2)
	(trunc x n)
      (if (> f 1/2)
	  (away x n)
	(if (evenp z)
	    (trunc x n)
	  (away x n))))))

(defthm near-1-1
    (implies (and (rationalp x)
		  (>= x 0)
		  (integerp n)
		  (> n 0))
	     (= (- x (trunc x n))
		(* (expt 2 (- (1+ (expo x)) n)) (re (* (expt 2 (1- n)) (sig x))))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo sig)
		  :use ((:instance trunc)
			(:instance fp-rep)))))

(defthm near-1-2
    (implies (and (rationalp c)
		  (rationalp f)
		  (rationalp p)
		  (= c (+ 1 f)))
	     (= (* c p) (+ p (* f p))))
  :rule-classes ())

(defthm near-1-3
    (implies (and (rationalp x)
		  (>= x 0)
		  (integerp n)
		  (> n 0)
		  (not (integerp (* (expt 2 (1- n)) (sig x)))))
	     (= (- (away x n) x)
		(* (expt 2 (- (1+ (expo x)) n)) (- 1 (re (* (expt 2 (1- n)) (sig x)))))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo sig away-pos-rewrite)
		  :use ((:instance away)
			(:instance fl-cg (x (* (expt 2 (1- n)) (sig x))))
			(:instance fp-rep)
			(:instance near-1-2 
				   (c (cg (* (expt 2 (1- n)) (sig x))))
				   (f (fl (* (expt 2 (1- n)) (sig x))))
				   (p (expt 2 (- (1+ (expo x)) n))))))))

(defthm near-1-4
    (implies (and (rationalp x)
		  (>= x 0)
		  (integerp n)
		  (> n 0)
		  (integerp (* (expt 2 (1- n)) (sig x))))
	     (= (trunc x n) x))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo sig trunc-pos-rewrite)
		  :use ((:instance trunc)
			(:instance fl-int (x (* (expt 2 (1- n)) (sig x))))
			(:instance fp-rep)))))

(defthm near-1-5
    (implies (and (rationalp x)
		  (>= x 0)
		  (integerp n)
		  (> n 0)
		  (integerp (* (expt 2 (1- n)) (sig x))))
	     (= (away x n) x))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo sig away-pos-rewrite)
		  :use ((:instance away)
			(:instance cg-int (x (* (expt 2 (1- n)) (sig x))))
			(:instance fp-rep)))))

(defthm near-1-6
    (implies (and (rationalp p)
		  (> p 0)
		  (rationalp f)
		  (< (* p f) (* p (- 1 f))))
	     (< f 1/2))
  :rule-classes ())

(defthm near-1-7
    (implies (and (rationalp x)
		  (>= x 0)
		  (integerp n)
		  (> n 0)
		  (not (integerp (* (expt 2 (1- n)) (sig x))))
		  (< (- x (trunc x n)) (- (away x n) x)))
	     (= (near x n) (trunc x n)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo sig trunc-pos-rewrite away-pos-rewrite)
		  :use ((:instance near-1-1)
			(:instance near-1-3)
			(:instance near-1-6 
				   (p (expt 2 (- (1+ (expo x)) n))) 
				   (f (re (* (expt 2 (1- n)) (sig x)))))
			(:instance near)))))

(defthm near-1-8
    (implies (and (rationalp p)
		  (> p 0)
		  (rationalp f)
		  (> (* p f) (* p (- 1 f))))
	     (> f 1/2))
  :rule-classes ())

(defthm near-1-9
    (implies (and (rationalp x)
		  (>= x 0)
		  (integerp n)
		  (> n 0)
		  (not (integerp (* (expt 2 (1- n)) (sig x))))
		  (> (- x (trunc x n)) (- (away x n) x)))
	     (= (near x n) (away x n)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo sig trunc-pos-rewrite away-pos-rewrite)
		  :use ((:instance near-1-1)
			(:instance near-1-3)
			(:instance near-1-8 
				   (p (expt 2 (- (1+ (expo x)) n))) 
				   (f (re (* (expt 2 (1- n)) (sig x)))))
			(:instance near)))))

(defthm near1-a
    (implies (and (rationalp x)
		  (>= x 0)
		  (integerp n)
		  (> n 0)
		  (< (- x (trunc x n)) (- (away x n) x)))
	     (= (near x n) (trunc x n)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo sig trunc-pos-rewrite away-pos-rewrite)
		  :use ((:instance near-1-7)
			(:instance near-1-4)
			(:instance near-1-5)))))

(defthm near1-b
    (implies (and (rationalp x)
		  (>= x 0)
		  (integerp n)
		  (> n 0)
		  (> (- x (trunc x n)) (- (away x n) x)))
	     (= (near x n) (away x n)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo sig trunc-pos-rewrite away-pos-rewrite)
		  :use ((:instance near-1-9)
			(:instance near-1-4)
			(:instance near-1-5)))))

(defthm near2-1
    (implies (and (rationalp x)
		  (rationalp y)
		  (> x 0)
		  (> y 0)
		  (integerp n)
		  (> n 0)
		  (exactp y n)
		  (= (near x n) (trunc x n)))
	     (>= (abs (- x y)) (- x (trunc x n))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo sig exactp2 trunc-pos-rewrite away-exactp-c 
				      near trunc-exactp-c away-pos-rewrite)
		  :use ((:instance near1-b)
			(:instance away-lower-pos)
			(:instance trunc-upper-pos)
			(:instance trunc-exactp-c (a y))
			(:instance away-exactp-c (a y))))))

(defthm near2-2
    (implies (and (rationalp x)
		  (rationalp y)
		  (> x 0)
		  (> y 0)
		  (integerp n)
		  (> n 0)
		  (exactp y n)
		  (= (near x n) (away x n)))
	     (>= (abs (- x y)) (- (away x n) x)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable expo sig exactp2 trunc-pos-rewrite away-exactp-c 
				      near trunc-exactp-c away-pos-rewrite)
		  :use ((:instance near1-a)
			(:instance away-lower-pos)
			(:instance trunc-upper-pos)
			(:instance trunc-exactp-c (a y))
			(:instance away-exactp-c (a y))))))

(in-theory (disable expo sig exactp2 trunc-pos-rewrite away-exactp-c 
		    trunc-exactp-c away-pos-rewrite exactp2-lemma))

(defthm near-choice
    (or (= (near x n) (trunc x n))
	(= (near x n) (away x n)))
  :rule-classes ())

(defthm near2
    (implies (and (rationalp x)
		  (rationalp y)
		  (> x 0)
		  (> y 0)
		  (integerp n)
		  (> n 0)
		  (exactp y n))
	     (>= (abs (- x y)) (abs (- x (near x n)))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near)
		  :use ((:instance near2-1)
			(:instance near2-2)
			(:instance near-choice)
			(:instance away-lower-pos)
			(:instance trunc-upper-pos)))))

(defthm exactp-near
    (implies (and (rationalp x)
		  (integerp n)
		  (> n 0))
	     (exactp (near x n) n))
  :hints (("Goal" :in-theory (disable near trunc-exactp-b away-exactp-b)
		  :use ((:instance near-choice)
			(:instance trunc-exactp-b)
			(:instance away-exactp-b)))))

(defthm near-pos
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (> n 0))
	     (> (near x n) 0))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near)
		  :use ((:instance near-choice)
			(:instance away-pos)
			(:instance trunc-pos)))))

(defthm monotone-near
    (implies (and (rationalp x)
		  (rationalp y)
		  (< 0 x)
		  (<= x y)
		  (integerp n)
		  (> n 0))
	     (<= (near x n) (near y n)))
  :hints (("Goal" :in-theory (disable near trunc-exactp-b away-exactp-b)
		  :use ((:instance near-pos)
			(:instance near-pos (x y))
			(:instance near2 (y (near y n)))
			(:instance near2 (x y) (y (near x n)))))))

(defun near-witness (x y n)
  (if (= (expo x) (expo y))
      (/ (+ (near x n) (near y n)) 2)
    (expt 2 (expo y))))

(defthm near-near-1
    (implies (and (rationalp x)
		  (rationalp y)
		  (< 0 x)
		  (< x y)
		  (integerp n)
		  (> n 0)
		  (not (= (expo x) (expo y))))
	     (and (<= x (near-witness x y n))
		  (<= (near-witness x y n) y)
		  (exactp (near-witness x y n) (1+ n))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near)
		  :use ((:instance exactp-2**n (n (expo y)) (m (1+ n)))
			(:instance expo-upper-bound)
			(:instance expo-monotone)
			(:instance expt-monotone (n (1+ (expo x))) (m (expo y)))
			(:instance expo-lower-bound (x y))))))

(defthm near-near-2
    (implies (and (rationalp x)
		  (rationalp y)
		  (< 0 x)
		  (< x y)
		  (integerp n)
		  (> n 0)
		  (< (near x n) (near y n))
		  (= (expo x) (expo y)))
	     (and (<= x (near-witness x y n))
		  (<= (near-witness x y n) y)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near)
		  :use ((:instance near2 (y (near y n)))
			(:instance near2 (x y) (y (near x n)))
			(:instance near-pos)
			(:instance near-pos (x y))))))

(defthm near-near-3
    (implies (and (rationalp x)
		  (rationalp y)
		  (< 0 x)
		  (< x y)
		  (integerp n)
		  (> n 0)
		  (not (= (near x n) (near y n)))
		  (= (expo x) (expo y)))
	     (and (<= x (near-witness x y n))
		  (<= (near-witness x y n) y)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near monotone-near near-witness)
		  :use ((:instance near-near-2)
			(:instance monotone-near)))))

(defthm near<=away
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (> n 0))
	     (<= (near x n) (away x n)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near)
		  :use ((:instance near-choice)
			(:instance trunc-upper-pos)
			(:instance away-lower-pos)))))

(defthm near>=trunc
    (implies (and (rationalp x)
		  (> x 0)
		  (integerp n)
		  (> n 0))
	     (>= (near x n) (trunc x n)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near)
		  :use ((:instance near-choice)
			(:instance trunc-upper-pos)
			(:instance away-lower-pos)))))

(defthm near-near-4
    (implies (and (rationalp x)
		  (rationalp y)
		  (< 0 x)
		  (< x y)
		  (integerp n)
		  (> n 0)
		  (< (near x n) (near y n))
		  (= (expo x) (expo y)))
	     (<= (expo (near-witness x y n)) (expo y)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near abs-away)
		  :use ((:instance near<=away (x y))
			(:instance away-exactp-d (x y))
			(:instance near-pos)
			(:instance away-pos (x y))
			(:instance expo-upper-2 (x (near-witness x y n)) (n (1+ (expo y))))))))

(defthm near-neg
    (implies (and (rationalp x)
		  (< x 0)
		  (integerp n)
		  (> n 0))
	     (< (near x n) 0))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near)
		  :use ((:instance near-choice)
			(:instance trunc-neg)
			(:instance away-neg)))))

(defthm near-0-0
    (implies (and (rationalp x)
		  (integerp n)
		  (> n 0))
	     (iff (= (near x n) 0)
		  (= x 0)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near)
		  :use ((:instance near-choice)
			(:instance trunc-0-0)
			(:instance away-0-0)))))

(defthm near-near-5
    (implies (and (rationalp x)
		  (rationalp y)
		  (< 0 x)
		  (< x y)
		  (integerp n)
		  (> n 0)
		  (< (near x n) (near y n))
		  (= (expo x) (expo y)))
	     (integerp (* (near x n) (expt 2 (- (1- n) (expo y))))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near expo-trunc abs-trunc abs-away)
		  :use ((:instance exactp-<=-expo (e (expo y)) (x (near x n)))
			(:instance expo-monotone (x (trunc x n)) (y (near x n)))
			(:instance near-0-0)
			(:instance trunc-pos)
			(:instance near-pos)
			(:instance expo-trunc)
			(:instance trunc-0-0)
			(:instance near>=trunc)))))

(defthm near-near-6
    (implies (and (rationalp x)
		  (rationalp y)
		  (< 0 x)
		  (< x y)
		  (integerp n)
		  (> n 0)
		  (< (near x n) (near y n))
		  (= (expo x) (expo y)))
	     (integerp (* (near y n) (expt 2 (- (1- n) (expo y))))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near expo-trunc abs-trunc abs-away)
		  :use ((:instance exactp-<=-expo (e (expo y)) (x (near y n)))
			(:instance expo-monotone (x (trunc x n)) (y (near y n)))
			(:instance near-0-0)
			(:instance monotone-near)
			(:instance trunc-pos)
			(:instance near-pos)
			(:instance expo-trunc)
			(:instance trunc-0-0)
			(:instance near>=trunc)))))

(in-theory (disable near))

(defthm near-near-7
    (implies (and (rationalp x)
		  (rationalp y)
		  (integerp k))
	     (= (+ (* x (expt 2 (1- k)))
		   (* y (expt 2 (1- k))))
		(* (/ (+ x y) 2) (expt 2 k))))
  :rule-classes ())

(defthm near-near-8
    (implies (and (rationalp x)
		  (rationalp y)
		  (integerp k)
	          (integerp (* x (expt 2 (1- k))))
	          (integerp (* y (expt 2 (1- k)))))
	     (integerp (* (/ (+ x y) 2) (expt 2 k))))
  :rule-classes ()
  :hints (("Goal" :use ((:instance near-near-7)))))

(defthm near-near-9
    (implies (and (rationalp x)
		  (rationalp y)
		  (< 0 x)
		  (< x y)
		  (integerp n)
		  (> n 0)
		  (< (near x n) (near y n))
		  (= (expo x) (expo y)))
	     (exactp (near-witness x y n) (1+ n)))
  :rule-classes ()
  :hints (("Goal" :use ((:instance near-near-5)
			(:instance near-near-6)
			(:instance near-near-4)
			(:instance near-near-8 (x (near x n)) (y (near y n)) (k (- n (expo y))))
			(:instance exactp->=-expo (n (1+ n)) (e (expo y)) (x (near-witness x y n)))))))

(defthm near-near-lemma
    (implies (and (rationalp x)
		  (rationalp y)
		  (< 0 x)
		  (< x y)
		  (integerp n)
		  (> n 0)
		  (not (= (near x n) (near y n))))
	     (and (<= x (near-witness x y n))
		  (<= (near-witness x y n) y)
		  (exactp (near-witness x y n) (1+ n))))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near monotone-near)
		  :use ((:instance near-near-2)
			(:instance near-near-1)
			(:instance near-near-9)
			(:instance monotone-near)))))

(in-theory (disable near-witness near monotone-near))

(defthm near-near-10
    (implies (and (rationalp x)
		  (rationalp y)
		  (rationalp a)
		  (integerp n)
		  (integerp k)
		  (> k 0)
		  (>= n k)		  
		  (< 0 a)
		  (< a x)
		  (< 0 y)
		  (< x y)
		  (< y (fp+ a (1+ n)))
		  (exactp a (1+ n)))
	     (= (near y k) (near x k)))
  :rule-classes ()
  :hints (("Goal" :in-theory (disable near monotone-near)
		  :use ((:instance near-near-lemma (n k))
			(:instance exactp-<= (x (near-witness x y k)) (m (1+ k)) (n (1+ n)))
			(:instance fp+1 (x a) (y (near-witness x y k)) (n (1+ n)))))))

(defthm near-near
    (implies (and (rationalp x)
		  (rationalp y)
		  (rationalp a)
		  (integerp n)
		  (integerp k)
		  (> k 0)
		  (>= n k)		  
		  (< 0 a)
		  (< a x)
		  (< 0 y)
		  (< y (fp+ a (1+ n)))
		  (exactp a (1+ n)))
	     (<= (near y k) (near x k)))
  :rule-classes ()
  :hints (("Goal" :use ((:instance near-near-10)
			(:instance monotone-near (n k) (x y) (y x))))))