← Back to branch summary

~ubuntu-branches/ubuntu/gutsy/acl2/gutsy

« back to all changes in this revision

Viewing changes to books/rtl/rel6/support/lib1.delta1/round-extra2.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2006-12-04 10:35:42 UTC
  • mfrom: (1.1.5 upstream) (3.1.1 etch)
  • Revision ID: james.westby@ubuntu.com-20061204103542-68nf4pkilci0018n
Tags: 3.1-1
New upstream release

Show diffs side-by-side

added added

removed removed

Lines of Context:
books/rtl/rel6/support/lib1.delta1/round-extra2.lisp
 
1
(in-package "ACL2")
 
2
 
 
3
 
 
4
 
 
5
(include-book "../lib1/top")
 
6
 
 
7
(set-inhibit-warnings "theory")
 
8
 
 
9
;;;**********************************************************************
 
10
;;;                         Truncation
 
11
;;;**********************************************************************
 
12
 
 
13
;; (defund trunc (x n)
 
14
;;   (declare (xargs :guard (integerp n)))
 
15
;;   (* (sgn x) 
 
16
;;      (fl (* (expt 2 (1- n)) (sig x))) 
 
17
;;      (expt 2 (- (1+ (expo x)) n))))
 
18
 
 
19
;; (defthmd trunc-integer-type-prescription
 
20
;;   (implies (and (>= (expo x) n)
 
21
;;                 (case-split (integerp n))
 
22
;;                 )
 
23
;;            (integerp (trunc x n)))
 
24
;;   :rule-classes :type-prescription)
 
25
 
 
26
;; (defthmd trunc-rewrite
 
27
;;     (implies (and (rationalp x)
 
28
;;                (integerp n)
 
29
;;                (> n 0))
 
30
;;           (equal (trunc x n)
 
31
;;                  (* (sgn x) 
 
32
;;                     (fl (* (expt 2 (- (1- n) (expo x))) (abs x))) 
 
33
;;                     (expt 2 (- (1+ (expo x)) n))))))
 
34
 
 
35
;; (defthmd abs-trunc
 
36
;;   (equal (abs (trunc x n))
 
37
;;          (* (fl (* (expt 2 (1- n)) (sig x))) (expt 2 (- (1+ (expo x)) n)))))
 
38
 
 
39
 
 
40
 
 
41
;; (encapsulate ()
 
42
;;   (local 
 
43
;;    (defthm fl-sig-expt-2-lemma-1
 
44
;;      (implies (and (<= n 0)
 
45
;;                    (integerp n))
 
46
;;               (< (* (SIG X) (EXPT 2 (+ -1 N))) 1))
 
47
;;      :hints (("Goal" :in-theory (enable expt-weak-monotone-linear)
 
48
;;               :cases ((not (<= (expt 2 (+ -1 n)) (/ 2)))))
 
49
;;              ("Subgoal 2" 
 
50
;;               :use ((:instance sig-upper-bound)))
 
51
;;              ("Subgoal 1" 
 
52
;;               :use ((:instance expt-weak-monotone-linear
 
53
;;                                (n (+ -1 n))
 
54
;;                                (m -1)))))))
 
55
              
 
56
 
 
57
;;   (local 
 
58
;;    (defthm fl-is-0
 
59
;;      (implies (and (rationalp x)
 
60
;;                    (< x 1)
 
61
;;                    (<= 0 x))
 
62
;;               (equal (fl x) 0))
 
63
;;      :rule-classes nil))
 
64
                               
 
65
 
 
66
 
 
67
;;   (local 
 
68
;;    (defthm fl-sig-expt-2
 
69
;;      (implies (and (<= n 0)
 
70
;;                    (rationalp x)
 
71
;;                    (integerp n))
 
72
;;               (equal (fl (* (SIG X) (EXPT 2 (+ -1 N)))) 0))
 
73
;;      :hints (("Goal" :use ((:instance fl-is-0
 
74
;;                                       (x (* (sig x)
 
75
;;                                             (expt 2 (+ -1 n)))))
 
76
;;                            (:instance sig-lower-bound))))))
 
77
 
 
78
 
 
79
;;   (defthm trunc-to-0
 
80
;;       (implies (and (rationalp x)
 
81
;;                (integerp n)
 
82
;;                (<= n 0))
 
83
;;           (equal (trunc x n) 0))
 
84
;;       :hints (("Goal" :in-theory (enable trunc)))))
 
85
 
 
86
;; ;; moved to trunc.lisp
 
87
;; (defthm trunc-to-0
 
88
;;   (implies (and (rationalp x)
 
89
;;                 (integerp n)
 
90
;;                 (<= n 0))
 
91
;;            (equal (trunc x n) 0))
 
92
;;   :hints (("Goal" :in-theory (enable trunc))))
 
93
 
 
94
 
 
95
;; (defthmd sgn-trunc
 
96
;;       (implies (and (< 0 n)
 
97
;;                     (rationalp x)
 
98
;;                (integerp n))
 
99
;;           (equal (sgn (trunc x n))
 
100
;;                  (sgn x))))
 
101
 
 
102
 
 
103
(encapsulate ()
 
104
  (local (include-book "../support/trunc"))
 
105
  (set-enforce-redundancy nil)
 
106
  (defthm trunc-to-0
 
107
    (implies (and (integerp n)
 
108
                  (<= n 0))
 
109
             (equal (trunc x n) 0))))
 
110
 
 
111
; (set-enforce-redundancy t)
 
112
 
 
113
;; (defthm trunc-positive
 
114
;;    (implies (and (< 0 x)
 
115
;;                  (case-split (rationalp x))
 
116
;;                  (case-split (integerp n))
 
117
;;                  (case-split (< 0 n))
 
118
;;                  )
 
119
;;             (< 0 (trunc x n)))
 
120
;;    :rule-classes (:rewrite :linear))
 
121
 
 
122
 
 
123
;; (defthm trunc-negative
 
124
;;   (implies (and (< x 0)
 
125
;;                 (case-split (rationalp x))
 
126
;;                 (case-split (integerp n))
 
127
;;                 (case-split (< 0 n)))
 
128
;;            (< (trunc x n) 0))
 
129
;;   :rule-classes (:rewrite :linear))
 
130
 
 
131
 
 
132
;; (defthm trunc-0
 
133
;;   (equal (trunc 0 n) 0))
 
134
 
 
135
 
 
136
;; (defthmd trunc-minus
 
137
;;   (equal (trunc (* -1 x) n)
 
138
;;          (* -1 (trunc x n))))
 
139
 
 
140
 
 
141
;; (defthmd trunc-shift
 
142
;;   (implies (integerp n)
 
143
;;            (equal (trunc (* x (expt 2 k)) n)
 
144
;;                   (* (trunc x n) (expt 2 k)))))
 
145
 
 
146
 
 
147
;; (defthmd trunc-upper-bound
 
148
;;     (implies (and (rationalp x)
 
149
;;                (integerp n))
 
150
;;           (<= (abs (trunc x n)) (abs x)))
 
151
;;   :rule-classes :linear)
 
152
 
 
153
;; (defthmd trunc-upper-pos
 
154
;;     (implies (and (<= 0 x)
 
155
;;                   (rationalp x)
 
156
;;                (integerp n))
 
157
;;           (<= (trunc x n) x))
 
158
;;   :rule-classes :linear)
 
159
 
 
160
 
 
161
;; (defthm expo-trunc
 
162
;;     (implies (and (< 0 n)
 
163
;;                   (rationalp x)
 
164
;;                (integerp n))
 
165
;;           (equal (expo (trunc x n))
 
166
;;                     (expo x))))
 
167
 
 
168
 
 
169
;; (defthm expo-trunc-strong
 
170
;;     (implies (and (nat n)
 
171
;;                   (rationalp x)
 
172
;;                (integerp n))
 
173
;;           (equal (expo (trunc x n))
 
174
;;                     (expo x))))
 
175
;;; wrong
 
176
;;;
 
177
(set-enforce-redundancy nil)
 
178
 
 
179
(encapsulate () 
 
180
 (local (include-book "../support/trunc"))
 
181
 (defthmd trunc-lower-bound
 
182
    (implies (and (rationalp x)
 
183
                  (integerp n))
 
184
             (> (abs (trunc x n)) (- (abs x) (expt 2 (- (1+ (expo x)) n)))))
 
185
    :hints (("Goal" :by trunc-lower-1))
 
186
    :rule-classes (:linear))
 
187
 
 
188
 (defthmd trunc-lower-2
 
189
   (implies (and (rationalp x)
 
190
                 (not (= x 0))
 
191
                 (integerp n)
 
192
                 (> n 0))
 
193
            (> (abs (trunc x n)) (* (abs x) (- 1 (expt 2 (- 1 n))))))
 
194
   :rule-classes :linear)
 
195
 
 
196
 (defthmd trunc-lower-2-pos
 
197
    (implies (and (rationalp x)
 
198
                  (> x 0)
 
199
                  (integerp n)
 
200
                  (> n 0))
 
201
             (> (trunc x n) (* x (- 1 (expt 2 (- 1 n))))))
 
202
  :rule-classes :linear
 
203
  :hints (("Goal" :by trunc-lower-pos))))
 
204
 
 
205
;; moved into trunc.lisp ?? 
 
206
 
 
207
 
 
208
;----------------------------------------------------------------------
 
209
 
 
210
;; (defthm trunc-diff
 
211
;;     (implies (and (rationalp x)
 
212
;;                (integerp n)
 
213
;;                   (> n 0))
 
214
;;           (< (abs (- x (trunc x n))) (expt 2 (- (1+ (expo x)) n))))
 
215
;;   :rule-classes ())
 
216
 
 
217
;; (defthm trunc-diff-pos
 
218
;;     (implies (and (rationalp x)
 
219
;;                (>= x 0)
 
220
;;                (integerp n)
 
221
;;                (> n 0))
 
222
;;           (< (- x (trunc x n)) (expt 2 (- (1+ (expo x)) n))))
 
223
;;   :rule-classes ())
 
224
 
 
225
 
 
226
;; (defthm trunc-exactp-a
 
227
;;   (exactp (trunc x n) n)
 
228
;;   :hints (("Goal" :use ((:instance trunc-exactp-b---rtl-rel5-support)))))
 
229
 
 
230
 
 
231
;; (defthm trunc-diff-expo
 
232
;;     (implies (and (rationalp x)
 
233
;;                (not (exactp x n))
 
234
;;                (integerp n)
 
235
;;                (> n 0))
 
236
;;           (<= (expo (- x (trunc x n))) (- (expo x) n)))
 
237
;;   :rule-classes ())
 
238
 
 
239
 
 
240
;; (defthm trunc-exactp-b
 
241
;;     (implies (and (rationalp x)
 
242
;;                (integerp n) 
 
243
;;                (> n 0))
 
244
;;           (iff (= x (trunc x n))
 
245
;;                (exactp x n)))
 
246
;;   :hints (("Goal" :use ((:instance trunc-exactp-a---rtl-rel5-support))))
 
247
;;   :rule-classes ())
 
248
 
 
249
 
 
250
;; (defthmd trunc-exactp-c
 
251
;;     (implies (and (exactp a n)
 
252
;;                (<= a x)
 
253
;;                   (rationalp x)
 
254
;;                (integerp n)
 
255
;;                (rationalp a))
 
256
;;           (<= a (trunc x n))))
 
257
 
 
258
 
 
259
;; (defthmd trunc-monotone
 
260
;;   (implies (and (<= x y)
 
261
;;                 (rationalp x)
 
262
;;                 (rationalp y)
 
263
;;                 (integerp n))
 
264
;;            (<= (trunc x n) (trunc y n)))
 
265
;;   :rule-classes :linear)
 
266
 
 
267
;----------------------------------------------------------------------
 
268
 
 
269
 
 
270
;; (defthm trunc-diff
 
271
;;     (implies (and (rationalp x)
 
272
;;                (integerp n)
 
273
;;                   (> n 0))
 
274
;;           (< (abs (- x (trunc x n))) (expt 2 (- (1+ (expo x)) n))))
 
275
;;   :rule-classes ())
 
276
 
 
277
;; (defthm exactp-diff-cor
 
278
;;     (implies (and (rationalp x)
 
279
;;                (rationalp y)
 
280
;;                (integerp n)
 
281
;;                (> n 0)
 
282
;;                (exactp x n)
 
283
;;                (exactp y n)
 
284
;;                (<= (abs (- x y)) (abs x))
 
285
;;                (<= (abs (- x y)) (abs y)))
 
286
;;           (exactp (- x y) n))
 
287
;;   :rule-classes ())
 
288
 
 
289
 
 
290
(encapsulate () 
 
291
  (local (include-book "../../arithmetic/basic"))
 
292
  (local 
 
293
  (defthm not-exact-strictly-greater-than
 
294
    (implies (and (rationalp x)
 
295
                  (not (exactp x n))
 
296
                  (integerp n)
 
297
                  (> n 0)
 
298
                  (> x 0))
 
299
             (> x (expt 2 (expo x))))
 
300
    :hints (("Goal" :in-theory (enable exactp-2**n)
 
301
             :cases ((= x (expt 2 (expo x)))))
 
302
            ("Subgoal 2" :use ((:instance expo-lower-bound))))))
 
303
 
 
304
  ;; (defthm fp+2
 
305
  ;;     (implies (and (rationalp x)
 
306
  ;;              (> x 0)
 
307
  ;;              (rationalp y)
 
308
  ;;              (> y x)
 
309
  ;;              (integerp n)
 
310
  ;;              (> n 0)
 
311
  ;;              (exactp x n)
 
312
  ;;              (exactp y n))
 
313
  ;;         (>= y (fp+ x n)))
 
314
  ;;   :rule-classes ())
 
315
 
 
316
             
 
317
  (local 
 
318
  (defthm strictly-greater-than-implies-no-less-than-fp+
 
319
    (implies (and (rationalp x)
 
320
                  (exactp x (1+ n))
 
321
                  (> x (expt 2 (expo x)))
 
322
                  (integerp n)
 
323
                  (> n 0))
 
324
            (>= x (+ (expt 2 (expo x))
 
325
                     (expt 2 (- (EXPO X) N)))))
 
326
    :hints (("Goal" :in-theory (enable exactp-2**n)
 
327
             :use ((:instance fp+2 
 
328
                              (x (expt 2 (expo x)))
 
329
                              (y x)
 
330
                              (n (1+ n))))))))
 
331
 
 
332
  ;; (defthmd expo-monotone
 
333
  ;;   (implies (and (<= (abs x) (abs y))
 
334
  ;;                 (case-split (rationalp x))
 
335
  ;;                 (case-split (not (equal x 0)))
 
336
  ;;                 (case-split (rationalp y)))
 
337
  ;;            (<= (expo x) (expo y)))
 
338
  ;;   :rule-classes :linear)
 
339
 
 
340
  (local 
 
341
   (defthm expo-of-x-minus-extra-bit-is-expo-x
 
342
     (implies (and (exactp x (1+ n))
 
343
                   (not (exactp x n))
 
344
                   (rationalp x)
 
345
                   (integerp n)
 
346
                   (> x 0)
 
347
                   (> n 0))
 
348
              (equal (expo (+  x (* -1 (expt 2 (+ (expo x) (* -1 n))))))
 
349
                     (expo x)))
 
350
     :hints (("Goal" :in-theory (enable exactp-2**n)
 
351
              :use ((:instance expo-monotone
 
352
                               (x (- x (expt 2 (- (expo x) n))))
 
353
                               (y x))
 
354
                    (:instance expo-monotone
 
355
                               (x (expt 2 (expo x)))
 
356
                               (y (- x (expt 2 (- (expo x) n)))))
 
357
                    (:instance strictly-greater-than-implies-no-less-than-fp+))))))
 
358
 
 
359
   ;; next we want to prove (- x (expt 2 (- (exp x) n))) is exactp  n
 
360
 
 
361
  (local 
 
362
   (encapsulate ()
 
363
                (local (include-book "../../arithmetic/even-odd"))
 
364
                (defthm integerp-x-not-1/2x-lemma
 
365
                  (implies (and (integerp x)
 
366
                                (not (integerp (* x (/ 2)))))
 
367
                           (integerp (+ (* x (/ 2)) (* -1 (/ 2))))))))
 
368
   
 
369
   ;; may need some rule to merge 1/2 into expt 2 
 
370
   (local 
 
371
    (defthm merged-1/2-into-expt2
 
372
      (implies (and (integerp n)
 
373
                    (rationalp x))
 
374
               (equal (* 1/2 x (expt 2 n))
 
375
                      (* x (expt 2 (+ -1 n)))))
 
376
      :hints (("Goal" 
 
377
               :use ((:instance a15 
 
378
                                (i 2)
 
379
                                (j1 -1)
 
380
                                (j2 n)))))))
 
381
 
 
382
 
 
383
   (local 
 
384
    (defthm a-is-n-exact
 
385
     (implies (and (not (exactp x n))
 
386
                   (exactp x (1+ n))
 
387
                   (> x 0)
 
388
                   (rationalp x)
 
389
                   (integerp n)
 
390
                   (> n 0))
 
391
              (exactp (+ x (* -1 (expt 2 (+ (expo x) (* -1 n)))))
 
392
                      n))
 
393
     :hints (("Goal" :in-theory (enable exactp2 a15)
 
394
              :use ((:instance integerp-x-not-1/2x-lemma
 
395
                               (x (* X (EXPT 2 (+ N (* -1 (EXPO X))))))))))))
 
396
                      
 
397
   ;; (defthm fp+1
 
398
   ;;     (implies (and (rationalp x)
 
399
   ;;             (> x 0)
 
400
   ;;             (integerp n)
 
401
   ;;             (> n 0)
 
402
   ;;             (exactp x n))
 
403
   ;;        (exactp (fp+ x n) n))
 
404
   ;;   :rule-classes ())
 
405
 
 
406
 
 
407
   ;; (local 
 
408
   ;; (defthm not-exact-strictly-greater-than
 
409
   ;;   (implies (and (rationalp x)
 
410
   ;;                 (not (exactp x n))
 
411
   ;;                 (integerp n)
 
412
   ;;                 (> n 0)
 
413
   ;;                 (> x 0))
 
414
   ;;            (> x (expt 2 (expo x))))
 
415
   ;;   :hints (("Goal" :in-theory (enable exactp-2**n)
 
416
   ;;            :cases ((= x (expt 2 (expo x)))))
 
417
   ;;           ("Subgoal 2" :use ((:instance expo-lower-bound))))))
 
418
 
 
419
 
 
420
   (local 
 
421
    (defthm expt-2-minus-half
 
422
      (implies (integerp n)
 
423
               (equal (+ (EXPT 2 (+ 1 n))
 
424
                         (* -1 (EXPT 2 n)))
 
425
                      (expt 2 n)))
 
426
      :hints (("Goal" 
 
427
               :use ((:instance a15 
 
428
                                (i 2)
 
429
                                (j1 1)
 
430
                                (j2 n)))))))
 
431
 
 
432
  ;;; lots of stupid lemmas!!  
 
433
 
 
434
   (local 
 
435
    (defthm b-is-n-exact
 
436
      (implies (and (not (exactp x n))
 
437
                    (exactp x (1+ n))
 
438
                    (> x 0)
 
439
                    (rationalp x)
 
440
                    (integerp n)
 
441
                    (> n 0))
 
442
               (exactp (+ x (expt 2 (+ (expo x) (* -1 n)))) n))
 
443
      :hints (("Goal" 
 
444
               :use ((:instance a-is-n-exact)
 
445
                     (:instance expo-lower-bound)
 
446
                     (:instance expt-strong-monotone-linear
 
447
                                (m (expo x))
 
448
                                (n (+ (expo x) (* -1 n))))
 
449
                     (:instance fp+1 
 
450
                                (x (- x (expt 2 (+ (expo x) (* -1 n)))))))))))
 
451
 
 
452
  ;; (defthmd trunc-exactp-c
 
453
  ;;     (implies (and (exactp a n)
 
454
  ;;              (<= a x)
 
455
  ;;                   (rationalp x)
 
456
  ;;              (integerp n)
 
457
  ;;              (rationalp a))
 
458
  ;;         (<= a (trunc x n))))
 
459
 
 
460
   (local 
 
461
    (defthm trunc-midpoint-lemma
 
462
      (implies (and (> n 0)
 
463
                    (integerp n)
 
464
                    (rationalp x) (> x 0)
 
465
                    (exactp x (1+ n))
 
466
                    (not (exactp x n)))
 
467
               (= (- x (expt 2 (- (expo x) n)))
 
468
                  (trunc x n)))
 
469
      :hints (("Goal" :in-theory (enable trunc-upper-pos)
 
470
               :cases ((< (- x (expt 2 (- (expo x) n))) (trunc x n))))
 
471
              ("Subgoal 2" :use ((:instance trunc-exactp-c
 
472
                                            (a (- x (expt 2 (- (expo x) n)))))))
 
473
              ("Subgoal 1" :use ((:instance fp+2
 
474
                                            (y (trunc x n))
 
475
                                            (x (- x (expt 2 (- (expo x) n)))))
 
476
                                 (:instance expo-lower-bound)
 
477
                                 (:instance expt-strong-monotone-linear
 
478
                                            (m (expo x))
 
479
                                            (n (+ (expo x) (* -1 n)))))))
 
480
      :rule-classes ()))
 
481
 
 
482
   ;; (defthmd sig-lower-bound
 
483
   ;;   (implies (and (rationalp x)
 
484
   ;;                 (not (equal x 0)))
 
485
   ;;            (<= 1 (sig x)))
 
486
   ;;   :rule-classes (:rewrite :linear))
 
487
 
 
488
 
 
489
   ;; (defthmd sig-upper-bound
 
490
   ;;   (< (sig x) 2)
 
491
   ;;   :rule-classes (:rewrite :linear))
 
492
 
 
493
 
 
494
 
 
495
   (local 
 
496
    (defthm sig-x-integerp
 
497
      (implies (and (integerp (sig x))
 
498
                    (rationalp x)
 
499
                    (< 0 x))
 
500
               (equal (sig x) 1))
 
501
      :hints (("Goal" :in-theory (enable sig-lower-bound
 
502
                                         sig-upper-bound)))))
 
503
                      
 
504
 
 
505
 
 
506
   ;;; The following are exported!!! 
 
507
   ;;; Thu Oct 12 13:57:55 2006
 
508
 
 
509
   (defthm trunc-midpoint
 
510
     (implies (and (natp n)
 
511
                   (rationalp x) (> x 0)
 
512
                   (exactp x (1+ n))
 
513
                   (not (exactp x n)))
 
514
              (= (- x (expt 2 (- (expo x) n)))
 
515
                 (trunc x n)))
 
516
     :hints (("Goal" :cases ((equal n 0)))
 
517
             ("Subgoal 2" :use ((:instance trunc-midpoint-lemma)))
 
518
             ("Subgoal 1" :in-theory (enable exactp sgn trunc)
 
519
              :use ((:instance fp-rep (x x)))))
 
520
     :rule-classes ())
 
521
 
 
522
 
 
523
   (defthm expo-of-x-minus-extra-bit-is-expo-x
 
524
     (implies (and (exactp x (1+ n))
 
525
                   (not (exactp x n))
 
526
                   (rationalp x)
 
527
                   (integerp n)
 
528
                   (> x 0)
 
529
                   (> n 0))
 
530
              (equal (expo (+  x (* -1 (expt 2 (+ (expo x) (* -1 n))))))
 
531
                     (expo x))))
 
532
 
 
533
 
 
534
 
 
535
   (defthm a-is-n-exact
 
536
     (implies (and (not (exactp x n))
 
537
                   (exactp x (1+ n))
 
538
                   (> x 0)
 
539
                   (rationalp x)
 
540
                   (integerp n)
 
541
                   (> n 0))
 
542
              (exactp (+ x (* -1 (expt 2 (+ (expo x) (* -1 n)))))
 
543
                      n)))
 
544
 
 
545
 
 
546
 
 
547
   (defthm b-is-n-exact
 
548
     (implies (and (not (exactp x n))
 
549
                   (exactp x (1+ n))
 
550
                   (> x 0)
 
551
                   (rationalp x)
 
552
                   (integerp n)
 
553
                   (> n 0))
 
554
              (exactp (+ x (expt 2 (+ (expo x) (* -1 n))))
 
555
                      n)))
 
556
 
 
557
 
 
558
     )
 
559
 
 
560
;; TODO: consider move this to trunc.lisp and trunc-proofs.lisp
 
561
;; Thu Oct 12 09:28:40 2006
 
562
 
 
563
 
 
564
;----------------------------------------------------------------------
 
565
 
 
566
;; (defthmd trunc-trunc
 
567
;;     (implies (and (>= n m)
 
568
;;                   (integerp n)
 
569
;;                (integerp m))
 
570
;;           (equal (trunc (trunc x n) m)
 
571
;;                  (trunc x m))))
 
572
 
 
573
 
 
574
;; (defthm plus-trunc
 
575
;;     (implies (and (rationalp x)
 
576
;;                (>= x 0)
 
577
;;                (rationalp y)
 
578
;;                (>= y 0)
 
579
;;                (integerp k)
 
580
;;                (exactp x (+ k (- (expo x) (expo y)))))
 
581
;;           (= (+ x (trunc y k))
 
582
;;              (trunc (+ x y) (+ k (- (expo (+ x y)) (expo y))))))
 
583
;;   :rule-classes ())
 
584
 
 
585
;----------------------------------------------------------------------
 
586
 
 
587
;;(i-am-here)
 
588
(encapsulate () 
 
589
  (local 
 
590
   (defthm minus-trunc-1-lemma
 
591
     (implies (and (rationalp x)
 
592
                   (> x 0)
 
593
                  (rationalp y)
 
594
                  (> y 0)
 
595
                  (< x y)
 
596
                  (integerp k)
 
597
                  (> k 0)
 
598
                  (> (+ k (- (expo (- x y)) (expo y))) 0)
 
599
                  (= n (+ k (- (expo x) (expo y)))) ;; why we need "n"??
 
600
                  (exactp x (+ k (- (expo x) (expo y)))))
 
601
             (equal (- x (trunc y k))
 
602
                    (trunc (- x y) (+ k (- (expo (- x y)) (expo y))))))
 
603
    :hints (("Goal" :in-theory (enable trunc-rewrite exactp2 sgn a15)
 
604
             :use ((:instance fl+int-rewrite
 
605
                              (x (* Y (EXPT 2 (+ -1 K (* -1 (EXPO Y))))))
 
606
                              (n (* -1 X (EXPT 2 (+ -1 K (* -1 (EXPO Y))))))))))))
 
607
 
 
608
 
 
609
  (defthm minus-trunc-1
 
610
    (implies (and (rationalp x)
 
611
                  (> x 0)
 
612
                  (rationalp y)
 
613
                  (> y 0)
 
614
                  (< x y)
 
615
                  (integerp k)
 
616
                  (> k 0)
 
617
                  (> (+ k (- (expo (- x y)) (expo y))) 0)
 
618
                  (= n (+ k (- (expo x) (expo y)))) ;; why we need "n"??
 
619
                  (exactp x (+ k (- (expo x) (expo y)))))
 
620
             (equal (- x (trunc y k))
 
621
                    (- (trunc (- y x) (+ k (- (expo (- x y)) (expo y)))))))
 
622
    :hints (("Goal" :use ((:instance trunc-minus
 
623
                                     (x (- x y))
 
624
                                     (n (+ k (- (expo (- x y)) (expo y)))))
 
625
                          (:instance minus-trunc-1-lemma))))
 
626
    :rule-classes nil)
 
627
                                      
 
628
 
 
629
)
 
630
 
 
631
;----------------------------------------------------------------------
 
632
 
 
633
;; (defthm bits-trunc
 
634
;;   (implies (and (= n (1+ (expo x)))
 
635
;;                 (>= x 0)
 
636
;;                 (integerp k)
 
637
;;                 (> k 0))
 
638
;;            (= (trunc x k)
 
639
;;               (* (expt 2 (- n k))
 
640
;;                  (bits x (1- n) (- n k)))))
 
641
;;   :hints (("Goal" :use ((:instance bits-trunc-2---rtl-rel5-support))))
 
642
;;   :rule-classes ())
 
643
 
 
644
 
 
645
;; (defthm trunc-land
 
646
;;     (implies (and (>= x (expt 2 (1- n)))
 
647
;;                (< x (expt 2 n))
 
648
;;                   (integerp x) (> x 0)
 
649
;;                (integerp m) (>= m n)
 
650
;;                (integerp n) (> n k)
 
651
;;                (integerp k) (> k 0))
 
652
;;           (= (trunc x k)
 
653
;;              (land x (- (expt 2 m) (expt 2 (- n k))) n)))
 
654
;;     :hints (("Goal" :use ((:instance bits-trunc-
 
655
;;   :rule-classes ())
 
656
 
 
657
;;
 
658
;; make change directly into rel5/lib/round.lisp, rel5/support/lextra.lisp
 
659
;; 
 
660
 
 
661
;; (defthmd trunc-split
 
662
;;   (implies (and (= n (1+ (expo x)))
 
663
;;                 (>= x 0)
 
664
;;                 (integerp m)
 
665
;;                 (> m k)
 
666
;;                 (integerp k)
 
667
;;                 (> k 0))
 
668
;;            (equal (trunc x m)
 
669
;;                   (+ (trunc x k)
 
670
;;                      (* (expt 2 (- n m))
 
671
;;                         (bits x (1- (- n k)) (- n m)))))))
 
672
 
 
673
 
 
674
;;;**********************************************************************
 
675
;;;                    Rounding Away from Zero
 
676
;;;**********************************************************************
 
677
 
 
678
 
 
679
;; (defund away (x n)
 
680
;;   (* (sgn x) 
 
681
;;      (cg (* (expt 2 (1- n)) (sig x))) 
 
682
;;      (expt 2 (- (1+ (expo x)) n))))
 
683
 
 
684
 
 
685
(defthmd away-integer-type-prescription
 
686
  (implies (and (>= (expo x) n)
 
687
                (case-split (integerp n))
 
688
                )
 
689
           (integerp (away x n)))
 
690
  :hints (("Goal" :in-theory (enable away)))
 
691
  :rule-classes :type-prescription)
 
692
 
 
693
;; (defthmd away-rewrite
 
694
;;     (implies (and (rationalp x)
 
695
;;                (integerp n)
 
696
;;                (> n 0))
 
697
;;           (equal (away x n)
 
698
;;                  (* (sgn x) 
 
699
;;                     (cg (* (expt 2 (- (1- n) (expo x))) (abs x))) 
 
700
;;                     (expt 2 (- (1+ (expo x)) n))))))
 
701
 
 
702
 
 
703
;; (defthmd abs-away
 
704
;;     (implies (and (rationalp x)
 
705
;;                (integerp n))
 
706
;;           (equal (abs (away x n)) 
 
707
;;                  (* (cg (* (expt 2 (1- n)) (sig x))) (expt 2 (- (1+ (expo x)) n))))))
 
708
 
 
709
 
 
710
;;; this is true?? 
 
711
 
 
712
;; ;; (local 
 
713
;; ;;  (defthm fl-sig-is-minus-1
 
714
;; ;;    (implies (and (rationalp x)
 
715
;; ;;                  (not (equal x 0)))
 
716
;; ;;             (equal (FL (* -1/2 (SIG X)))
 
717
;; ;;                    -1))
 
718
;; ;;    :hints (("Goal" 
 
719
;; ;;             :in-theory (enable fl-minus)
 
720
;; ;;             :use ((:instance sig-upper-bound)
 
721
;; ;;                   (:instance sig-lower-bound))))))
 
722
 
 
723
 
 
724
 
 
725
(encapsulate () 
 
726
   (local (include-book "../support/away"))
 
727
   (defthm away-to-0
 
728
     (implies (and (<= n 0)
 
729
                   (rationalp x)
 
730
                   (integerp n)
 
731
                   )
 
732
              (equal (away x n)
 
733
                  (* (sgn x) (expt 2 (+ 1 (expo x) (- n))))))
 
734
     :hints (("Goal" :by  away-to-0-or-fewer-bits))))
 
735
 
 
736
 
 
737
 
 
738
 
 
739
;;    (defthm away-to-0
 
740
;;      (implies (and (rationalp x) (not (= x 0)))
 
741
;;               (equal (away x 0)
 
742
;;                      (* (sgn x) (expt 2 (1+ (expo x))))))
 
743
;; 
 
744
;; druss this is what you wrote in the  lemma
 
745
 
 
746
 
 
747
 
 
748
;; (defthmd sgn-away
 
749
;;   (equal (sgn (away x n))
 
750
;;          (sgn x)))
 
751
 
 
752
;; (defthm away-positive
 
753
;;   (implies (and (< 0 x)
 
754
;;                 (case-split (rationalp x))
 
755
;;                 )
 
756
;;            (< 0 (away x n)))
 
757
;;   :rule-classes (:rewrite :linear))
 
758
 
 
759
;; (defthm away-negative
 
760
;;     (implies (and (< x 0)
 
761
;;                   (case-split (rationalp x))
 
762
;;                   )
 
763
;;           (< (away x n) 0))
 
764
;;     :rule-classes (:rewrite :linear))
 
765
 
 
766
;; (defthm away-0
 
767
;;   (equal (away 0 n) 0))
 
768
 
 
769
 
 
770
;; (defthmd away-minus
 
771
;;   (= (away (* -1 x) n) (* -1 (away x n))))
 
772
 
 
773
 
 
774
;; (defthmd away-shift
 
775
;;     (implies (integerp n)
 
776
;;           (= (away (* x (expt 2 k)) n)
 
777
;;              (* (away x n) (expt 2 k)))))
 
778
 
 
779
 
 
780
;; (defthmd away-lower-bound
 
781
;;     (implies (and (case-split (rationalp x))
 
782
;;                (case-split (integerp n)))
 
783
;;           (>= (abs (away x n)) (abs x)))
 
784
;;   :rule-classes :linear)
 
785
 
 
786
;; (defthmd away-lower-pos
 
787
;;     (implies (and (>= x 0)
 
788
;;                   (case-split (rationalp x))
 
789
;;                (case-split (integerp n)))
 
790
;;           (>= (away x n) x))
 
791
;;   :rule-classes :linear)
 
792
 
 
793
 
 
794
;; ;----------------------------------------------------------------------
 
795
 
 
796
(defthmd away-upper-bound
 
797
  (implies (and (rationalp x)
 
798
                (integerp n)
 
799
                (> n 0))
 
800
           (< (abs (away x n)) (+ (abs x) (expt 2 (- (1+ (expo x)) n)))))
 
801
  :hints (("Goal" :use away-upper-1))
 
802
  :rule-classes :linear)
 
803
 
 
804
;; ;----------------------------------------------------------------------
 
805
 
 
806
;; (defthmd away-upper-2
 
807
;;     (implies (and (rationalp x)
 
808
;;                (not (= x 0))
 
809
;;                (integerp n)
 
810
;;                (> n 0))
 
811
;;           (< (abs (away x n)) (* (abs x) (+ 1 (expt 2 (- 1 n))))))
 
812
;;   :rule-classes :linear)
 
813
 
 
814
 
 
815
;; (defthmd away-diff
 
816
;;     (implies (and (rationalp x)
 
817
;;                (integerp n)
 
818
;;                (> n 0))
 
819
;;           (< (abs (- (away x n) x)) (expt 2 (- (1+ (expo x)) n))))
 
820
;;   :rule-classes :linear)
 
821
 
 
822
;; (defthmd away-diff-pos
 
823
;;     (implies (and (rationalp x)
 
824
;;                (>= x 0)
 
825
;;                (integerp n)
 
826
;;                (> n 0))
 
827
;;           (< (- (away x n) x) (expt 2 (- (1+ (expo x)) n))))
 
828
;;   :rule-classes :linear)
 
829
 
 
830
;; ;; (defthm away-exactp-d
 
831
;; ;;     (implies (and (rationalp x)
 
832
;; ;;             (not (= x 0))
 
833
;; ;;             (integerp n)
 
834
;; ;;             (> n 0))
 
835
;; ;;        (<= (abs (away x n)) (expt 2 (1+ (expo x)))))
 
836
;; ;;   :rule-classes ())
 
837
 
 
838
(defthm away-expo-upper
 
839
    (implies (and (rationalp x)
 
840
                  (not (= x 0))
 
841
                  (natp n))
 
842
             (<= (abs (away x n)) (expt 2 (1+ (expo x)))))
 
843
    :hints (("Goal" 
 
844
             :cases ((equal n 0)))
 
845
            ("Subgoal 2" :use ((:instance away-exactp-d)))
 
846
            ("Subgoal 1" :in-theory (enable abs away sgn natp)))
 
847
  :rule-classes ())
 
848
;; why not :linear? 
 
849
 
 
850
;; (defthmd expo-away-lower-bound
 
851
;;     (implies (and (rationalp x)
 
852
;;                (natp n))
 
853
;;           (>= (expo (away x n)) (expo x)))
 
854
;;     :hints (("Goal" :cases ((equal n 0)))
 
855
;;             ("Subgoal 2" :use ((:instance
 
856
;;                                 expo-away-lower-bound---rtl-rel5-support)))
 
857
;;             ("Subgoal 1" :cases ((equal x 0))
 
858
;;              :in-theory (enable sgn))
 
859
;;             ("Subgoal 1.2" :use ((:instance expo-prod-lower
 
860
;;                                             (x (sgn x))
 
861
;;                                             (y (expt 2 (+ 1 (expo x))))))))
 
862
;;     :rule-classes (:linear))
 
863
 
 
864
;; included in round.lisp already. 
 
865
;; Thu Oct 12 10:15:13 2006. Fixed (and (integerp n) (> n 0)) into (natp n)
 
866
 
 
867
 
 
868
(encapsulate () 
 
869
 (local 
 
870
 (defthm away-x-zero-implies-zero
 
871
   (implies (rationalp x)
 
872
            (equal (equal (away x n) 0)
 
873
                   (equal x 0)))
 
874
   :hints (("Goal" :cases ((< 0 x)
 
875
                           (< x 0)
 
876
                           (equal x 0))))))
 
877
 
 
878
 (defthmd expo-away-upper-bound
 
879
    (implies (and (rationalp x)
 
880
                  (natp n))
 
881
             (<= (expo (away x n)) (1+ (expo x))))
 
882
    :hints (("Goal" :in-theory (enable expo-monotone)
 
883
             :cases ((equal x 0)))
 
884
            ("Subgoal 2" 
 
885
             :use ((:instance away-expo-upper)
 
886
                   (:instance expo-monotone
 
887
                              (x (away x n))
 
888
                              (y (expt 2 (+ 1 (expo x)))))
 
889
                   (:instance expo-monotone
 
890
                              (x (* -1 (away x n)))
 
891
                              (y (expt 2 (+ 1 (expo x))))))))
 
892
  :rule-classes :linear))
 
893
 
 
894
;;
 
895
;; TODO: refactor into away.lisp!!! 
 
896
;; Thu Oct 12 10:17:09 2006
 
897
 
 
898
 
 
899
;; (defthm expo-away
 
900
;;     (implies (and (rationalp x)
 
901
;;                (natp n)
 
902
;;                (not (= (abs (away x n)) (expt 2 (1+ (expo x))))))
 
903
;;           (equal (expo (away x n))
 
904
;;                     (expo x)))
 
905
;;     :hints (("Goal" :cases ((equal x 0) (< x 0) (> x 0)))
 
906
;;             ("Subgoal 2" :in-theory (enable sgn)
 
907
;;              :use ((:instance expo-away---rtl-rel5-support)))
 
908
;;             ("Subgoal 1" :in-theory (enable sgn)
 
909
;;              :use ((:instance expo-away---rtl-rel5-support)))))
 
910
 
 
911
 
 
912
;; (defthm away-exactp-a
 
913
;;     (implies (case-split (< 0 n))
 
914
;;           (exactp (away x n) n))
 
915
;;     :hints (("Goal" :use ((:instance away-exactp-b---rtl-rel5-support)))))
 
916
 
 
917
 
 
918
;; (defthmd away-diff-expo
 
919
;;     (implies (and (rationalp x)
 
920
;;                (not (exactp x n))
 
921
;;                (integerp n)
 
922
;;                (> n 0))
 
923
;;           (<= (expo (- (away x n) x)) (- (expo x) n)))
 
924
;;   :rule-classes :linear)
 
925
 
 
926
 
 
927
;; (defthm away-exactp-b
 
928
;;     (implies (and (rationalp x)
 
929
;;                (integerp n) 
 
930
;;                (> n 0))
 
931
;;           (iff (= x (away x n))
 
932
;;                (exactp x n)))
 
933
;;     :hints (("Goal" :use ((:instance away-exactp-a---rtl-rel5-support))))
 
934
;;   :rule-classes ())
 
935
 
 
936
;; (defthmd away-exactp-c
 
937
;;     (implies (and (exactp a n)
 
938
;;                (>= a x)
 
939
;;                   (rationalp x)
 
940
;;                (> x 0)
 
941
;;                (integerp n)
 
942
;;                (> n 0)
 
943
;;                (rationalp a)
 
944
;;                )
 
945
;;           (>= a (away x n))))
 
946
 
 
947
;; (defthmd away-exactp-c
 
948
;;     (implies (and (exactp a n)
 
949
;;                (>= a x)
 
950
;;                   (rationalp x)
 
951
;;                (integerp n)
 
952
;;                (> n 0)
 
953
;;                (rationalp a))
 
954
;;           (>= a (away x n))))
 
955
 
 
956
 
 
957
;; (defthmd away-monotone
 
958
;;     (implies (and (rationalp x)
 
959
;;                (rationalp y)
 
960
;;                (integerp n)
 
961
;;                (<= x y))
 
962
;;           (<= (away x n) (away y n)))
 
963
;;   :rule-classes :linear)
 
964
 
 
965
 
 
966
;; (defthm trunc-away
 
967
;;     (implies (and (rationalp x) (> x 0)
 
968
;;                (integerp n) (> n 0)
 
969
;;                (not (exactp x n)))
 
970
;;           (= (away x n)
 
971
;;              (+ (trunc x n)
 
972
;;                 (expt 2 (+ (expo x) 1 (- n))))))             
 
973
;;   :rule-classes ())
 
974
 
 
975
;----------------------------------------------------------------------
 
976
 
 
977
(encapsulate () 
 
978
 
 
979
   (local 
 
980
    (defthm local-expt-expand
 
981
      (implies (integerp n)
 
982
               (equal (EXPT 2 (+ 1 n))
 
983
                      (* 2 (expt 2 n))))
 
984
      :hints (("Goal" :use ((:instance a15
 
985
                                       (i 2)
 
986
                                       (j1 1)
 
987
                                       (j2 n)))))))
 
988
 
 
989
   (local 
 
990
    (defthm away-midpoint-lemma
 
991
      (implies (and (> n 0)
 
992
                    (integerp n)
 
993
                    (rationalp x) (> x 0)
 
994
                    (exactp x (1+ n))
 
995
                    (not (exactp x n)))
 
996
               (= (+ x (expt 2 (- (expo x) n)))
 
997
                  (away x n)))
 
998
      :hints (("Goal" :in-theory (enable a15)
 
999
               :use ((:instance trunc-away)
 
1000
                     (:instance trunc-midpoint)
 
1001
                     (:instance local-expt-expand
 
1002
                                (n (expt 2 (+ (expo x) (* -1 n))))))))
 
1003
      :rule-classes ()))
 
1004
 
 
1005
 
 
1006
   (local 
 
1007
    (defthm sig-x-integerp
 
1008
      (implies (and (integerp (sig x))
 
1009
                    (rationalp x)
 
1010
                    (< 0 x))
 
1011
               (equal (sig x) 1))
 
1012
      :hints (("Goal" :in-theory (enable sig-lower-bound
 
1013
                                         sig-upper-bound)))))
 
1014
 
 
1015
   (defthm away-midpoint
 
1016
     (implies (and (natp n)
 
1017
                   (rationalp x) (> x 0)
 
1018
                   (exactp x (1+ n))
 
1019
                   (not (exactp x n)))
 
1020
               (= (away x n)
 
1021
                  (+ x (expt 2 (- (expo x) n)))))
 
1022
     :hints (("Goal" :cases ((equal n 0)))
 
1023
             ("Subgoal 2" :use away-midpoint-lemma)
 
1024
             ("Subgoal 1" :in-theory (enable exactp sgn)
 
1025
              :use ((:instance fp-rep (x x)))))
 
1026
      :rule-classes ())
 
1027
 
 
1028
)
 
1029
;----------------------------------------------------------------------
 
1030
 
 
1031
;; (defthmd away-away
 
1032
;;     (implies (and (rationalp x)
 
1033
;;                (>= x 0)
 
1034
;;                (integerp n)
 
1035
;;                (integerp m)
 
1036
;;                (> m 0)
 
1037
;;                (>= n m))
 
1038
;;           (equal (away (away x n) m)
 
1039
;;                  (away x m))))
 
1040
 
 
1041
 
 
1042
;; (defthm plus-away
 
1043
;;   (implies (and (exactp x (+ k (- (expo x) (expo y))))
 
1044
;;                 (rationalp x)
 
1045
;;                 (>= x 0)
 
1046
;;                 (rationalp y)
 
1047
;;                 (>= y 0)
 
1048
;;                 (integerp k))
 
1049
;;            (= (+ x (away y k))
 
1050
;;               (away (+ x y)
 
1051
;;                     (+ k (- (expo (+ x y)) (expo y))))))
 
1052
;;   :rule-classes ())
 
1053
 
 
1054
;----------------------------------------------------------------------
 
1055
 
 
1056
 
 
1057
 
 
1058
;; (defthm minus-trunc-1
 
1059
;;   (implies (and (rationalp x)
 
1060
;;                 (> x 0)
 
1061
;;                 (rationalp y)
 
1062
;;                 (> y 0)
 
1063
;;                 (< x y)
 
1064
;;                 (integerp k)
 
1065
;;                 (> k 0)
 
1066
;;                 (> (+ k (- (expo (- x y)) (expo y))) 0)
 
1067
;;                 (= n (+ k (- (expo x) (expo y)))) ;; why we need "n"??
 
1068
;;                 (exactp x (+ k (- (expo x) (expo y)))))
 
1069
;;            (equal (- x (trunc y k))
 
1070
;;                   (- (trunc (- y x) (+ k (- (expo (- x y)) (expo y)))))))
 
1071
;;   :hints (("Goal" :use ((:instance trunc-minus
 
1072
;;                                    (x (- x y))
 
1073
;;                                    (n (+ k (- (expo (- x y)) (expo y)))))
 
1074
;;                         (:instance minus-trunc-1-lemma)))))
 
1075
                                    
 
1076
 
 
1077
(defthm minus-trunc-2
 
1078
  (implies (and (rationalp x)
 
1079
                (> x 0)
 
1080
                (rationalp y)
 
1081
                (> y 0)
 
1082
                (< y x)
 
1083
                (integerp k)
 
1084
                (> k 0)
 
1085
                (> (+ k (- (expo (- x y)) (expo y))) 0)
 
1086
                (= n (+ k (- (expo x) (expo y)))) ;; why we need "n"??
 
1087
                (exactp x (+ k (- (expo x) (expo y)))))
 
1088
           (equal (- x (trunc y k))
 
1089
                  (away (- x y) (+ k (- (expo (- x y)) (expo y))))))
 
1090
  :hints (("Goal" :in-theory (enable away-rewrite trunc-rewrite cg exactp2 sgn
 
1091
                                     a15)))
 
1092
  :rule-classes ())
 
1093
 
 
1094
;----------------------------------------------------------------------
 
1095
 
 
1096
(encapsulate () 
 
1097
 
 
1098
  (local 
 
1099
   (defthm trunc-minus-specific
 
1100
     (equal (TRUNC (+ (* -1 X) (* -1 Y)) n)
 
1101
            (* -1 (trunc (+ x y) n)))
 
1102
     :hints (("Goal" :use ((:instance  trunc-minus
 
1103
                                       (x (+ (* -1 x)
 
1104
                                             (* -1 y)))))))))
 
1105
                   
 
1106
  (local 
 
1107
   (defthm expo-minus-specific
 
1108
     (equal (EXPO (+ (* -1 X) (* -1 Y)))
 
1109
            (expo (+ x y)))
 
1110
     :hints (("Goal" :use ((:instance  expo-minus
 
1111
                                       (x (+ (* -1 x)
 
1112
                                             (* -1 y)))))))))
 
1113
 
 
1114
  (local 
 
1115
   (defthm away-minus-specific
 
1116
     (equal (away (+ (* -1 X) (* -1 Y)) n)
 
1117
            (* -1 (away (+ x y) n)))
 
1118
     :hints (("Goal" :use ((:instance  away-minus
 
1119
                                       (x (+ (* -1 x)
 
1120
                                             (* -1 y)))))))))
 
1121
 
 
1122
 
 
1123
  (local 
 
1124
   (defthm trunc-plus-minus-lemmma
 
1125
     (implies (and (rationalp x)
 
1126
                   (rationalp y)
 
1127
                   (> x 0)
 
1128
                   (not (= y 0))
 
1129
                   (not (= (+ x y) 0))
 
1130
                   (integerp k)
 
1131
                   (> k 0)
 
1132
                   (= k1 (+ k (- (expo x) (expo y))))
 
1133
                   (= k2 (+ k (expo (+ x y)) (* -1 (expo y))))
 
1134
                   (exactp x k1)
 
1135
                   (> k2 0))
 
1136
              (equal (+ x (trunc y k))
 
1137
                     (if (= (sgn (+ x y)) (sgn y))
 
1138
                         (trunc (+ x y) k2)
 
1139
                       (away (+ x y) k2))))
 
1140
     :hints (("Goal" :cases ((< y 0))
 
1141
              :in-theory (enable sgn trunc-minus away-minus expo-minus))
 
1142
             ("Subgoal 2" :use ((:instance plus-trunc)))
 
1143
             ("Subgoal 1" :cases ((< (* -1 y) x)))
 
1144
             ("Subgoal 1.2" :use ((:instance minus-trunc-1
 
1145
                                             (y (* -1 y))
 
1146
                                             (n k1))))
 
1147
             ("Subgoal 1.1" :use ((:instance minus-trunc-2
 
1148
                                             (y (* -1 y))
 
1149
                                             (n k1)))))))
 
1150
 
 
1151
  (defthm trunc-plus-minus
 
1152
    (implies (and (rationalp x)
 
1153
                  (rationalp y)
 
1154
                  (not (= x 0))
 
1155
                  (not (= y 0))
 
1156
                  (not (= (+ x y) 0))
 
1157
                  (integerp k)
 
1158
                  (> k 0)
 
1159
                  (= k1 (+ k (- (expo x) (expo y))))
 
1160
                  (= k2 (+ k (expo (+ x y)) (* -1 (expo y))))
 
1161
                  (exactp x k1)
 
1162
                  (> k2 0))
 
1163
             (equal (+ x (trunc y k))
 
1164
                    (if (= (sgn (+ x y)) (sgn y))
 
1165
                        (trunc (+ x y) k2)
 
1166
                      (away (+ x y) k2))))
 
1167
    :rule-classes ()
 
1168
    :hints (("Goal" :cases ((not (< 0 x)))
 
1169
             :in-theory (enable sgn trunc-minus away-minus expo-minus))
 
1170
            ("Subgoal 2" :use ((:instance trunc-plus-minus-lemmma)))
 
1171
            ("Subgoal 1" :use ((:instance trunc-plus-minus-lemmma
 
1172
                                          (x (* -1 x))
 
1173
                                          (y (* -1 y)))))))
 
1174
 
 
1175
)
 
1176
 
 
1177
;; (defthm away-imp
 
1178
;;     (implies (and (rationalp x)
 
1179
;;                (> x 0)
 
1180
;;                (integerp n)
 
1181
;;                (> n 0)
 
1182
;;                (integerp m)
 
1183
;;                (>= m n)
 
1184
;;                (exactp x m))
 
1185
;;           (= (away x n)
 
1186
;;              (trunc (+ x
 
1187
;;                        (expt 2 (- (1+ (expo x)) n))
 
1188
;;                        (- (expt 2 (- (1+ (expo x)) m))))
 
1189
;;                     n)))
 
1190
;;   :rule-classes ())
 
1191
 
 
1192
;;;**********************************************************************
 
1193
;;;                    Unbiased Rounding
 
1194
;;;**********************************************************************
 
1195
 
 
1196
;; (defun re (x)
 
1197
;;   (- x (fl x)))
 
1198
 
 
1199
 
 
1200
;; (defund near (x n)
 
1201
;;   (let ((z (fl (* (expt 2 (1- n)) (sig x))))
 
1202
;;      (f (re (* (expt 2 (1- n)) (sig x)))))
 
1203
;;     (if (< f 1/2)
 
1204
;;      (trunc x n)
 
1205
;;       (if (> f 1/2)
 
1206
;;        (away x n)
 
1207
;;      (if (evenp z)
 
1208
;;          (trunc x n)
 
1209
;;        (away x n))))))
 
1210
 
 
1211
 
 
1212
;; (defthm near-choice
 
1213
;;     (or (= (near x n) (trunc x n))
 
1214
;;      (= (near x n) (away x n)))
 
1215
;;   :rule-classes ())
 
1216
 
 
1217
 
 
1218
(defthmd sgn-near
 
1219
    (implies (and (rationalp x)
 
1220
                  (integerp n)
 
1221
                  (> n 0))
 
1222
             (equal (sgn (near x n))
 
1223
                    (sgn x)))
 
1224
    :hints (("Goal" :in-theory (enable sgn-near-2))))
 
1225
 
 
1226
;; probably want to disable sgn-near in support/near.lisp    
 
1227
;; this is what originall is sgn-near-2 in the rel5
 
1228
 
 
1229
;; ;; (defthm near-pos
 
1230
;; ;;     (implies (and (< 0 x)
 
1231
;; ;;                   (< 0 n)
 
1232
;; ;;                   (rationalp x)
 
1233
;; ;;             (integerp n))
 
1234
;; ;;        (< 0 (near x n)))
 
1235
;; ;;   :rule-classes (:TYPE-PRESCRIPTION :LINEAR))
 
1236
 
 
1237
;; ;; (defthmd near-neg
 
1238
;; ;;   (implies (and (< x 0)
 
1239
;; ;;                 (< 0 n)
 
1240
;; ;;                 (rationalp x)
 
1241
;; ;;                 (integerp n)
 
1242
;; ;;           )
 
1243
;; ;;            (< (near x n) 0))
 
1244
;; ;;   :rule-classes (:TYPE-PRESCRIPTION :LINEAR))
 
1245
 
 
1246
;; ;; (defthm near-0
 
1247
;; ;;   (equal (near 0 n) 
 
1248
;; ;;          0))
 
1249
 
 
1250
 
 
1251
(defthm near-positive
 
1252
    (implies (and (< 0 x)
 
1253
                  (< 0 n)
 
1254
                  (rationalp x)
 
1255
                  (integerp n))
 
1256
             (< 0 (near x n)))
 
1257
    :hints (("Goal" :by near-pos))
 
1258
    :rule-classes (:type-prescription :linear))
 
1259
 
 
1260
(defthmd near-negative
 
1261
  (implies (and (< x 0)
 
1262
                (< 0 n)
 
1263
                (rationalp x)
 
1264
                (integerp n)
 
1265
                )
 
1266
           (< (near x n) 0))
 
1267
  :hints (("Goal" :in-theory (enable near-neg)))
 
1268
  :rule-classes (:type-prescription :linear))
 
1269
 
 
1270
(defthm near-0
 
1271
   (equal (near 0 n) 
 
1272
          0))
 
1273
 
 
1274
 
 
1275
;; (defthm near-exactp-a
 
1276
;;     (implies (< 0 n)
 
1277
;;           (exactp (near x n) n))
 
1278
;;     :hints (("Goal" :use ((:instance near-exactp-b---rtl-rel5-support)))))
 
1279
 
 
1280
 
 
1281
;; (defthm near-exactp-b
 
1282
;;     (implies (and (rationalp x)
 
1283
;;                (integerp n) 
 
1284
;;                (> n 0))
 
1285
;;           (iff (= x (near x n))
 
1286
;;                (exactp x n)))
 
1287
;;     :hints (("Goal" :use ((:instance near-exactp-a---rtl-rel5-support))))
 
1288
;;   :rule-classes ())
 
1289
 
 
1290
 
 
1291
;; (encapsulate () 
 
1292
 
 
1293
;;  (local 
 
1294
;;   (defthmd near-minus
 
1295
;;     (equal (near (* -1 x) n)
 
1296
;;            (* -1 (near x n)))))
 
1297
 
 
1298
;;   (local
 
1299
;;    (defthmd near-exactp-c-lemma
 
1300
;;        (implies (and (exactp a n)
 
1301
;;                      (> x 0)
 
1302
;;                (>= a x)
 
1303
;;                      (rationalp x)
 
1304
;;                (integerp n)
 
1305
;;                (> n 0)
 
1306
;;                (rationalp a)
 
1307
;;                )
 
1308
;;           (>= a (near x n)))
 
1309
;;        :hints (("Goal" 
 
1310
;;                 :use ((:instance near-exactp-c---rtl-rel5-support))))))
 
1311
 
 
1312
;;   (local 
 
1313
;;    (defthmd near-exactp-d-lemma
 
1314
;;        (implies (and (rationalp x)
 
1315
;;                      (> x 0)
 
1316
;;                (integerp n)
 
1317
;;                (> n 0)
 
1318
;;                (rationalp a)
 
1319
;;                (exactp a n)
 
1320
;;                (<= a x))
 
1321
;;           (<= a (near x n)))
 
1322
;;        :hints (("Goal" 
 
1323
;;                 :use ((:instance near-exactp-d---rtl-rel5-support))))))
 
1324
      
 
1325
 
 
1326
;;   (defthmd near-exactp-c
 
1327
;;       (implies (and (exactp a n)
 
1328
;;                (>= a x)
 
1329
;;                     (rationalp x)
 
1330
;;                (integerp n)
 
1331
;;                (> n 0)
 
1332
;;                (rationalp a)
 
1333
;;                )
 
1334
;;           (>= a (near x n)))
 
1335
;;       :hints (("Goal" :cases ((< x 0))
 
1336
;;                :in-theory (enable near-minus))
 
1337
;;               ("Subgoal 2" :use ((:instance near-exactp-c-lemma)))
 
1338
;;               ("Subgoal 1" :use ((:instance near-exactp-d-lemma
 
1339
;;                                             (x (* -1 x))
 
1340
;;                                             (a (* -1 a)))))))
 
1341
              
 
1342
 
 
1343
               
 
1344
 
 
1345
;;   (defthmd near-exactp-d
 
1346
;;       (implies (and (rationalp x)
 
1347
;;                (integerp n)
 
1348
;;                (> n 0)
 
1349
;;                (rationalp a)
 
1350
;;                (exactp a n)
 
1351
;;                (<= a x))
 
1352
;;           (<= a (near x n)))
 
1353
;;       :hints (("Goal" :cases ((< x 0))
 
1354
;;                :in-theory (enable near-minus))
 
1355
;;               ("Subgoal 2" :use ((:instance near-exactp-d-lemma)))
 
1356
;;               ("Subgoal 1" :use ((:instance near-exactp-c-lemma
 
1357
;;                                             (x (* -1 x))
 
1358
;;                                             (a (* -1 a)))))))
 
1359
 
 
1360
;; )
 
1361
 
 
1362
 
 
1363
 
 
1364
;; (defthm expo-trunc-strong
 
1365
;;      (implies (and (natp n)
 
1366
;;                    (rationalp x)
 
1367
;;                    (not (= (abs (trunc x n)) (expt 2 (1+ (expo x))))))
 
1368
;;           (equal (expo (trunc x n))
 
1369
;;                     (expo x)))
 
1370
;;      :hints (("Goal" :cases ((equal n 0)))))
 
1371
;;              ("Subgoal 1" :in-theory (enable trunc-rewrite))))
 
1372
             
 
1373
 
 
1374
(defthm expo-near
 
1375
    (implies (and (rationalp x)
 
1376
                  (> n 0)
 
1377
                  (integerp n)
 
1378
                  (not (= (abs (near x n)) (expt 2 (1+ (expo x))))))
 
1379
             (equal (expo (near x n))
 
1380
                    (expo x)))
 
1381
    :hints (("Goal" :cases ((equal (near x n) (trunc x n))))
 
1382
            ("Subgoal 2"   :use ((:instance near-choice)
 
1383
                                 (:instance expo-away))))
 
1384
  :rule-classes ())
 
1385
 
 
1386
 
 
1387
;; (defthm near<=away
 
1388
;;     (implies (and (rationalp x)
 
1389
;;                (> x 0)
 
1390
;;                (integerp n)
 
1391
;;                (> n 0))
 
1392
;;           (<= (near x n) (away x n)))
 
1393
;;   :rule-classes ())
 
1394
 
 
1395
 
 
1396
;; (defthm near>=trunc
 
1397
;;     (implies (and (rationalp x)
 
1398
;;                (> x 0)
 
1399
;;                (integerp n)
 
1400
;;                (> n 0))
 
1401
;;           (>= (near x n) (trunc x n)))
 
1402
;;   :rule-classes ())
 
1403
 
 
1404
 
 
1405
;; (defthmd near-shift
 
1406
;;     (implies (and (rationalp x)
 
1407
;;                   (integerp n)
 
1408
;;                (integerp k))
 
1409
;;           (= (near (* x (expt 2 k)) n)
 
1410
;;              (* (near x n) (expt 2 k)))))
 
1411
 
 
1412
 
 
1413
;; (defthmd near-minus
 
1414
;;   (equal (near (* -1 x) n)
 
1415
;;          (* -1 (near x n))))
 
1416
 
 
1417
 
 
1418
 
 
1419
;----------------------------------------------------------------------
 
1420
 
 
1421
;; (encapsulate () 
 
1422
 
 
1423
;;      (local 
 
1424
;;      (defthm equal-diff-trunc-away-1
 
1425
;;        (implies (and (exactp y n)
 
1426
;;                      (rationalp x)
 
1427
;;                      (> x 0)
 
1428
;;                      (case-split (<= x y))
 
1429
;;                      (rationalp y)
 
1430
;;                      (equal (abs (- x (trunc x n))) (abs (- (away x n)
 
1431
;;                                                             x)))
 
1432
;;                      (integerp n)
 
1433
;;                      (> n 0))
 
1434
;;                   (>= (abs (- x y)) (abs (- x (near x n)))))
 
1435
;;        :hints (("Goal" :use ((:instance trunc-upper-pos)
 
1436
;;                              (:instance near-choice)
 
1437
;;                              (:instance away-lower-pos)
 
1438
;;                              (:instance away-exactp-c
 
1439
;;                                         (a y)))))))
 
1440
 
 
1441
 
 
1442
;;      (local 
 
1443
;;      (defthm equal-diff-trunc-away-2
 
1444
;;        (implies (and (exactp y n)
 
1445
;;                      (rationalp x)
 
1446
;;                      (> x 0)
 
1447
;;                      (case-split (<= y x))
 
1448
;;                      (rationalp y)
 
1449
;;                      (equal (abs (- x (trunc x n))) (abs (- (away x n)
 
1450
;;                                                             x)))
 
1451
;;                      (integerp n)
 
1452
;;                      (> n 0))
 
1453
;;                   (>= (abs (- x y)) (abs (- x (near x n)))))
 
1454
;;        :hints (("Goal" :use ((:instance near-choice)
 
1455
;;                              (:instance trunc-upper-pos)
 
1456
;;                              (:instance away-lower-pos)
 
1457
;;                              (:instance trunc-exactp-c
 
1458
;;                                         (a y)))))))
 
1459
 
 
1460
 
 
1461
 
 
1462
;;      (local
 
1463
;;      (defthm near2-lemma
 
1464
;;          (implies (and (exactp y n)
 
1465
;;                        (rationalp x)
 
1466
;;                        (> x 0)
 
1467
;;                        (rationalp y)
 
1468
;;                        (case-split (not (equal (abs (- x (trunc x n))) (abs (- (away x n)
 
1469
;;                                                                                x)))))
 
1470
;;                        (integerp n)
 
1471
;;                        (> n 0))
 
1472
;;                   (>= (abs (- x y)) (abs (- x (near x n)))))
 
1473
;;          :hints (("Goal" :cases ((not (> (abs (- x (trunc x n))) (abs (- (away x n)
 
1474
;;                                                                          x))))))
 
1475
;;                  ("Subgoal 2" :cases ((not (< x y))))
 
1476
;;                  ("Subgoal 2.2" :use  ((:instance near1-b)
 
1477
;;                                        (:instance trunc-upper-pos)
 
1478
;;                                        (:instance away-lower-pos)
 
1479
;;                                        (:instance away-exactp-c
 
1480
;;                                                   (a y))))
 
1481
;;                  ("Subgoal 2.1" :use  ((:instance near1-b)
 
1482
;;                                        (:instance trunc-upper-pos)
 
1483
;;                                        (:instance away-lower-pos)
 
1484
;;                                        (:instance trunc-exactp-c
 
1485
;;                                                   (a y))))
 
1486
;;                  ("Subgoal 1" :cases ((not (< x y))))
 
1487
;;                  ("Subgoal 1.2" :use  ((:instance near1-a)
 
1488
;;                                        (:instance trunc-upper-pos)
 
1489
;;                                        (:instance away-lower-pos)
 
1490
;;                                        (:instance away-exactp-c
 
1491
;;                                                   (a y))))
 
1492
;;                  ("Subgoal 1.1" :use  ((:instance near1-a)
 
1493
;;                                        (:instance trunc-upper-pos)
 
1494
;;                                        (:instance away-lower-pos)
 
1495
;;                                        (:instance trunc-exactp-c
 
1496
;;                                                   (a y)))))))
 
1497
 
 
1498
 
 
1499
;;      ;; (loca
 
1500
;;      ;; (defthm exactp-equal-trunc-equal
 
1501
;;      ;;   (implies (and (exactp x n)
 
1502
;;      ;;                 (integerp n)
 
1503
;;      ;;                 (rationalp x))
 
1504
;;      ;;            (equal (trunc x n) x))
 
1505
;;      ;;   :hints (("Goal" :in-theory (enable exactp trunc)
 
1506
;;      ;;            :use ((:instance fp-rep)
 
1507
;;      ;;                  (:instance a15
 
1508
;;      ;;                             (i 2)
 
1509
;;      ;;                             (j1 (+ -1 N))
 
1510
;;      ;;                             (j2 (+ 1 (EXPO X) (* -1 N))))))))
 
1511
 
 
1512
 
 
1513
 
 
1514
 
 
1515
;;      ;; (defthm exactp-equal-away-equal
 
1516
;;      ;;   (implies (and (exactp x n)
 
1517
;;      ;;                 (integerp n)
 
1518
;;      ;;                 (rationalp x))
 
1519
;;      ;;            (equal (away x n) x))
 
1520
;;      ;;   :hints (("Goal" :in-theory (enable cg exactp away)
 
1521
;;      ;;            :use ((:instance fp-rep)
 
1522
;;      ;;                  (:instance a15
 
1523
;;      ;;                             (i 2)
 
1524
;;      ;;                             (j1 (+ -1 N))
 
1525
;;      ;;                             (j2 (+ 1 (EXPO X) (* -1 N))))))))
 
1526
 
 
1527
 
 
1528
;;      (local 
 
1529
;;      (defthm near2-lemma-futher
 
1530
;;          (implies (and (exactp y n)
 
1531
;;                        (rationalp x)
 
1532
;;                        (> x 0)
 
1533
;;                        (rationalp y)
 
1534
;;                        (integerp n)
 
1535
;;                        (> n 0))
 
1536
;;                   (>= (abs (- x y)) (abs (- x (near x n)))))
 
1537
;;          :hints (("Goal" :cases ((equal (abs (- x (trunc x n))) (abs (- (away x n)
 
1538
;;                                                                                x)))))
 
1539
;;                  ("Subgoal 2" :use ((:instance near2-lemma)))
 
1540
;;                  ("Subgoal 1" :cases ((not (< x y))))
 
1541
;;                  ("Subgoal 1.2" :use ((:instance equal-diff-trunc-away-1)))
 
1542
;;                  ("Subgoal 1.1" :use ((:instance equal-diff-trunc-away-2))))))
 
1543
 
 
1544
 
 
1545
 
 
1546
;;      (defthm near2
 
1547
;;          (implies (and (exactp y n)
 
1548
;;                        (rationalp x)
 
1549
;;                        (rationalp y)
 
1550
;;                        (integerp n)
 
1551
;;                        (> n 0))
 
1552
;;                   (>= (abs (- x y)) (abs (- x (near x n)))))
 
1553
;;          :hints (("Goal" :cases ((not (> x 0)))
 
1554
;;                   :in-theory (enable near-minus trunc-minus away-minus
 
1555
;;                                      exactp-minus))
 
1556
;;                  ("Subgoal 2" :use ((:instance near2-lemma-futher)))
 
1557
;;                  ("Subgoal 1" :use ((:instance near2-lemma-futher
 
1558
;;                                                (x (* -1 x))
 
1559
;;                                                (y (* -1 y)))))))
 
1560
;; )
 
1561
 
 
1562
;; (defthm near-est
 
1563
;;     (implies (and (integerp n) 
 
1564
;;                (> n 0)
 
1565
;;                (rationalp x))
 
1566
;;           (<= (abs (- x (near x n)))
 
1567
;;               (expt 2 (- (expo x) n))))
 
1568
;;     :hints (("Goal" :cases ((not (> x 0)))
 
1569
;;              :in-theory (enable near-minus expo-minus))
 
1570
;;             ("Subgoal 2" :use ((:instance near-est---rtl-rel5-support)))
 
1571
;;             ("Subgoal 1" :use ((:instance near-est---rtl-rel5-support
 
1572
;;                                           (x (* -1 x))))))
 
1573
;;   :rule-classes ())
 
1574
 
 
1575
 
 
1576
 
 
1577
;; (encapsulate ()
 
1578
 
 
1579
;; (local 
 
1580
;;  (defthm fl-1/2-sig-x-is-zero-specific
 
1581
;;    (implies (rationalp x)
 
1582
;;             (equal (fl (* 1/2 (sig x)))
 
1583
;;                    0))
 
1584
;;    :hints (("Goal" :use ((:instance sig-upper-bound)
 
1585
;;                          (:instance sig-lower-bound))))))
 
1586
 
 
1587
 
 
1588
;; (defthm near-monotone
 
1589
;;   (implies (and (<= x y)
 
1590
;;                 (rationalp x)
 
1591
;;                 (rationalp y)
 
1592
;;                 (integerp n)
 
1593
;;                 (natp n)
 
1594
;;                 (> n 0))
 
1595
;;            (<= (near x n) (near y n)))
 
1596
;;   :hints (("Goal" :in-theory (enable near-minus)
 
1597
;;            :cases ((not (equal x 0))))
 
1598
;;           ("Subgoal 2" :use ((:instance near-negative
 
1599
;;                                           (x (* -1 y)))))
 
1600
;;           ("Subgoal 1" :cases ((not (> x 0))))
 
1601
;;           ("Subgoal 1.2" :use ((:instance
 
1602
;;                                 near-monotone---rtl-rel5-support)))
 
1603
;;           ("Subgoal 1.1" :cases ((not (> y 0))))
 
1604
;;           ("Subgoal 1.1.2" :use ((:instance near-positive (x y))
 
1605
;;                                  (:instance near-positive (x (* -1 x)))))
 
1606
;;           ("Subgoal 1.1.1" :use ((:instance near-monotone---rtl-rel5-support
 
1607
;;                                             (x (* -1 y))
 
1608
;;                                             (y (* -1 x)))
 
1609
;;                                  (:instance near-positive (x (* -1 x)))))))
 
1610
                                 
 
1611
;; )
 
1612
 
 
1613
 
 
1614
;;(i-am-here)
 
1615
 
 
1616
;; (defund near-witness (x y n)
 
1617
;;   (if (= (expo x) (expo y))
 
1618
;;       (/ (+ (near x n) (near y n)) 2)
 
1619
;;     (expt 2 (expo y))))
 
1620
 
 
1621
 
 
1622
 
 
1623
;; (defthm near-near-lemma
 
1624
;;     (implies (and (rationalp x)
 
1625
;;                (rationalp y)
 
1626
;;                (< 0 x)
 
1627
;;                (< x y)
 
1628
;;                (integerp n)
 
1629
;;                (> n 0)
 
1630
;;                (not (= (near x n) (near y n))))
 
1631
;;           (and (<= x (near-witness x y n))
 
1632
;;                (<= (near-witness x y n) y)
 
1633
;;                (exactp (near-witness x y n) (1+ n))))
 
1634
;;   :rule-classes ())
 
1635
 
 
1636
;; (defthm near-near
 
1637
;;     (implies (and (rationalp x)
 
1638
;;                (rationalp y)
 
1639
;;                (rationalp a)
 
1640
;;                (integerp n)
 
1641
;;                (integerp k)
 
1642
;;                (> k 0)
 
1643
;;                (>= n k)                
 
1644
;;                (< 0 a)
 
1645
;;                (< a x)
 
1646
;;                (< 0 y)
 
1647
;;                (< y (fp+ a (1+ n)))
 
1648
;;                (exactp a (1+ n)))
 
1649
;;           (<= (near y k) (near x k)))
 
1650
;;   :rule-classes ())
 
1651
 
 
1652
 
 
1653
;----------------------------------------------------------------------
 
1654
 
 
1655
;;;
 
1656
;;; either (near x n) < (near a n)
 
1657
;;; or     (near a n) < (near y n)
 
1658
;;;
 
1659
 
 
1660
;;(encapsulate () 
 
1661
;----------------------------------------------------------------------
 
1662
 
 
1663
; i am here !!! 
 
1664
 
 
1665
;;   (defthm a-is-n-exact
 
1666
;;      (implies (and (not (exactp x n))
 
1667
;;                    (exactp x (1+ n))
 
1668
;;                    (> x 0)
 
1669
;;                    (rationalp x)
 
1670
;;                    (integerp n)
 
1671
;;                    (> n 0))
 
1672
;;               (exactp (+ x (* -1 (expt 2 (+ (expo x) (* -1 n)))))
 
1673
;;                       n))
 
1674
;;      :hints (("Goal" :in-theory (enable exactp2 a15)
 
1675
;;               :use ((:instance integerp-x-not-1/2x-lemma
 
1676
;;                                (x (* X (EXPT 2 (+ N (* -1 (EXPO X)))))))))))
 
1677
                      
 
1678
;; >             (DEFTHM FP+2
 
1679
;;                       (IMPLIES (AND (RATIONALP X)
 
1680
;;                                     (> X 0)
 
1681
;;                                     (RATIONALP Y)
 
1682
;;                                     (> Y X)
 
1683
;;                                     (INTEGERP N)
 
1684
;;                                     (> N 0)
 
1685
;;                                     (EXACTP X N)
 
1686
;;                                     (EXACTP Y N))
 
1687
;;                                (>= Y (FP+ X N)))
 
1688
;;                       :RULE-CLASSES NIL)
 
1689
 
 
1690
 
 
1691
 
 
1692
(encapsulate ()
 
1693
      (local (include-book "../../arithmetic/basic"))
 
1694
      (local 
 
1695
      (defthm hack-artithm-1
 
1696
        (implies (and (< 0 x)
 
1697
                      (< x y)
 
1698
                      (rationalp x)
 
1699
                      (rationalp y)
 
1700
                      (rationalp z)
 
1701
                      (<= 1 z))
 
1702
                 (< x (* z y)))))
 
1703
 
 
1704
 
 
1705
      (local
 
1706
      (defthm expo-a-less-than-specific
 
1707
        (implies (and (integerp n)
 
1708
                      (< 0 n)
 
1709
                      (< 0 a)
 
1710
                      (rationalp a))
 
1711
                 (< (EXPT 2 (+ (EXPO A) (* -1 N))) a))
 
1712
        :hints (("Goal" :in-theory (enable sgn)
 
1713
                 :use ((:instance expt-strong-monotone-linear
 
1714
                                  (n (+ (expo a) (* -1 n)))
 
1715
                                  (m (expo a)))
 
1716
                       (:instance fp-rep (x a))
 
1717
                       (:instance sig-lower-bound (x a))
 
1718
                       (:instance hack-artithm-1 
 
1719
                                  (x (expt 2 (+ (expo a) (* -1 n))))
 
1720
                                  (y (expt 2 (expo a)))
 
1721
                                  (z (sig a))))))
 
1722
        :rule-classes :linear))
 
1723
        
 
1724
      (local
 
1725
      (defthm abs-less-than-lemma
 
1726
        (implies (and (equal (- a b) d)
 
1727
                      (equal (- c a) d)
 
1728
                      (> d 0)
 
1729
                      (< 0 x)
 
1730
                      (< x a)
 
1731
                      (>= y c))
 
1732
                 (< (abs (- b x))
 
1733
                    (abs (- y x))))))
 
1734
 
 
1735
 
 
1736
      ;; (defthm abs-less-than-lemma-2
 
1737
      ;;   (implies (and (< x b)
 
1738
      ;;                 (> y x)
 
1739
      ;;                 (rationalp b)
 
1740
      ;;                 (rationalp y)
 
1741
      ;;                 (rationalp x))
 
1742
      ;;            (< (abs (- b x))
 
1743
      ;;               (abs (- y x)))))
 
1744
 
 
1745
 
 
1746
      (local 
 
1747
       (defthm local-expt-2-expand
 
1748
         (implies (and (rationalp x)
 
1749
                       (integerp n))
 
1750
                  (equal (EXPT 2 (+ 1 (EXPO X) (* -1 N)))
 
1751
                         (* 2 (EXPT 2 (+ (expo x) (* -1 N))))))
 
1752
         :hints (("Goal" :use ((:instance a15 (i 2) (j1 1) (j2 (+ (expo x)
 
1753
              
 
1754
                                                          (* -1 N)))))))))
 
1755
 
 
1756
      (local
 
1757
      (defthm near-boundary-lemma-1-lemma
 
1758
        (implies (and (rationalp x)
 
1759
                      (rationalp a)
 
1760
                      (< 0 x)
 
1761
                      (< x a)
 
1762
                      (< (+ a (* -1 
 
1763
                                     (expt 2 (+ (expo a) 
 
1764
                                                (* -1 n)))))
 
1765
                         (near x n))
 
1766
                      (integerp n)
 
1767
                      (> n 0)
 
1768
                      (exactp a (1+ n))
 
1769
                      (not (exactp a n)))
 
1770
                 (<  (abs (- (+ a (* -1 
 
1771
                                     (expt 2 (+ (expo a) 
 
1772
                                                (* -1 n)))))
 
1773
                             x))
 
1774
                     (abs (- (near x n) x))))
 
1775
        :hints (("Goal" :in-theory (disable a-is-n-exact
 
1776
                                            b-is-n-exact)
 
1777
                :use ((:instance a-is-n-exact
 
1778
                                 (x a))
 
1779
                      (:instance fp+2 
 
1780
                                 (x (+ a (* -1 
 
1781
                                            (expt 2 (+ (expo a) 
 
1782
                                                       (* -1 n))))))
 
1783
                                 (y (near x n)))
 
1784
                      (:instance abs-less-than-lemma
 
1785
                                 (a a)
 
1786
                                 (b (+ a (* -1 
 
1787
                                            (expt 2 (+ (expo a) 
 
1788
                                                       (* -1 n))))))
 
1789
                                 (c (+ a (expt 2 (+ (expo a) 
 
1790
                                                    (* -1 n)))))
 
1791
                                 (d (expt 2 (+ (expo a) (* -1 n))))
 
1792
                                 (y (near x n))
 
1793
                                 (x x)))))))
 
1794
 
 
1795
      ;;      (defthm near2
 
1796
      ;;          (implies (and (exactp y n)
 
1797
      ;;                        (rationalp x)
 
1798
      ;;                  (rationalp y)
 
1799
      ;;                  (integerp n)
 
1800
      ;;                  (> n 0))
 
1801
      ;;             (>= (abs (- x y)) (abs (- x (near x n)))))
 
1802
      ;;          :hints (("Goal" :cases ((not (> x 0)))
 
1803
      ;;                   :in-theory (enable near-minus trunc-minus away-minus
 
1804
      ;;                                      exactp-minus))
 
1805
      ;;                  ("Subgoal 2" :use ((:instance near2-lemma-futher)))
 
1806
      ;;                  ("Subgoal 1" :use ((:instance near2-lemma-futher
 
1807
      ;;                                                (x (* -1 x))
 
1808
      ;;                                                (y (* -1 y)))))))
 
1809
 
 
1810
      (local
 
1811
      (defthm near-boundary-lemma-1
 
1812
        (implies (and (rationalp x)
 
1813
                      (rationalp a)
 
1814
                      (< 0 x)
 
1815
                      (< x a)
 
1816
                      (integerp n)
 
1817
                      (> n 0)
 
1818
                      (exactp a (1+ n))
 
1819
                      (not (exactp a n)))
 
1820
                 (<=  (near x n)
 
1821
                      (+ a (* -1 
 
1822
                              (expt 2 (+ (expo a) 
 
1823
                                         (* -1 n)))))))
 
1824
        :hints (("Goal" :in-theory (disable a-is-n-exact
 
1825
                                            b-is-n-exact)
 
1826
                :use 
 
1827
                ((:instance near-boundary-lemma-1-lemma)
 
1828
                 (:instance a-is-n-exact (x a))
 
1829
                 (:instance near2 
 
1830
                            (x x)
 
1831
                            (y (+ a (* -1 
 
1832
                                       (expt 2 (+ (expo a) 
 
1833
                                                  (* -1 n))))))))))
 
1834
        :rule-classes :linear))
 
1835
                                  
 
1836
 
 
1837
      (local
 
1838
      (defthm abs-less-than-lemma-2
 
1839
        (implies (and (equal (- a b) d)
 
1840
                      (equal (- c a) d)
 
1841
                      (> d 0)
 
1842
                      (< 0 a)
 
1843
                      (< a y)
 
1844
                      (<= near-y b)
 
1845
                      (rationalp a)
 
1846
                      (rationalp b)
 
1847
                      (rationalp c) 
 
1848
                      (rationalp d) 
 
1849
                      (rationalp y) 
 
1850
                      (rationalp near-y))
 
1851
                 (< (abs (- c y))
 
1852
                    (abs (- near-y y))))
 
1853
        :rule-classes nil))
 
1854
 
 
1855
 
 
1856
      ;; (defthm fp-+
 
1857
      ;;   (implies (and (rationalp x)
 
1858
      ;;                 (> x 0)
 
1859
      ;;                 (integerp n)
 
1860
      ;;                 (> n 0)
 
1861
      ;;                 (exactp x n))
 
1862
      ;;            (equal (fp- (fp+ x n) n)
 
1863
      ;;                   x)))
 
1864
 
 
1865
      (local
 
1866
      (defthm near-boundary-lemma-2-lemma
 
1867
        (implies (and (rationalp a)
 
1868
                      (rationalp y)
 
1869
                      (< 0 a)
 
1870
                      (< a y)
 
1871
                      (< (near y n)
 
1872
                         (+ a (expt 2 (+ (expo a) 
 
1873
                                         (* -1 n)))))
 
1874
                      (integerp n)
 
1875
                      (> n 0)
 
1876
                      (exactp a (1+ n))
 
1877
                      (not (exactp a n)))
 
1878
                 (<  (abs (- (+ a (expt 2 (+ (expo a) 
 
1879
                                             (* -1 n))))
 
1880
                             y))
 
1881
                     (abs (- (near y n) y))))
 
1882
        :hints (("Goal" :in-theory (disable a-is-n-exact
 
1883
                                            b-is-n-exact)
 
1884
                :use ((:instance b-is-n-exact
 
1885
                                 (x a))
 
1886
                      (:instance a-is-n-exact
 
1887
                                 (x a))
 
1888
                      (:instance  fp-+
 
1889
                                  (x (+ a (* -1 (expt 2 (+ (expo a) 
 
1890
                                                           (* -1 n))))))
 
1891
                                  (n n))
 
1892
                      (:instance fp-2 
 
1893
                                 (x (+ a (expt 2 (+ (expo a) 
 
1894
                                                    (* -1 n)))))
 
1895
                                 (y (near y n)))
 
1896
                      (:instance abs-less-than-lemma-2
 
1897
                                 (a a)
 
1898
                                 (b (- a (expt 2 (+ (expo a) 
 
1899
                                                    (* -1 n)))))
 
1900
                                 (c (+ a (expt 2 (+ (expo a) 
 
1901
                                                    (* -1 n)))))
 
1902
                                 (d (expt 2 (+ (expo a) (* -1 n))))
 
1903
                                 (near-y (near y n))
 
1904
                                 (y y)))))))
 
1905
 
 
1906
      (local
 
1907
      (defthm near-boundary-lemma-2
 
1908
        (implies (and (rationalp y)
 
1909
                      (rationalp a)
 
1910
                      (< 0 a)
 
1911
                      (< a y)
 
1912
                      (integerp n)
 
1913
                      (> n 0)
 
1914
                      (exactp a (1+ n))
 
1915
                      (not (exactp a n)))
 
1916
                 (<=  (+ a (expt 2 (+ (expo a) 
 
1917
                                      (* -1 n))))
 
1918
                      (near y n)))
 
1919
        :hints (("Goal" :in-theory (disable a-is-n-exact
 
1920
                                            b-is-n-exact)
 
1921
                :use 
 
1922
                ((:instance near-boundary-lemma-2-lemma)
 
1923
                 (:instance b-is-n-exact (x a))
 
1924
                 (:instance near2 
 
1925
                            (x y)
 
1926
                            (y (+ a (expt 2 (+ (expo a) 
 
1927
                                               (* -1 n)))))))))
 
1928
        :rule-classes :linear))
 
1929
                                  
 
1930
 
 
1931
          
 
1932
  (defthm near-boundary
 
1933
      (implies (and (rationalp x)
 
1934
                  (rationalp y)
 
1935
                  (rationalp a)
 
1936
                  (< 0 x)
 
1937
                  (< x a)
 
1938
                  (< a y)
 
1939
                  (integerp n)
 
1940
                  (> n 0)
 
1941
                  (exactp a (1+ n))
 
1942
                  (not (exactp a n)))
 
1943
             (< (near x n) (near y n)))
 
1944
    :rule-classes ())
 
1945
 
 
1946
)
 
1947
 
 
1948
;; Thu Oct 12 17:22:29 2006. New.
 
1949
 
 
1950
 
 
1951
;----------------------------------------------------------------------
 
1952
 
 
1953
;; (defthm near-exact
 
1954
;;     (implies (and (rationalp x)
 
1955
;;                (integerp n) 
 
1956
;;                (> n 1)
 
1957
;;                (exactp x (1+ n))
 
1958
;;                (not (exactp x n)))
 
1959
;;           (exactp (near x n) (1- n)))
 
1960
;;     :hints (("Goal" :cases ((not (equal x 0)))
 
1961
;;              :in-theory (enable near-minus))
 
1962
;;             ("Subgoal 2" :in-theory (enable exactp))
 
1963
;;             ("Subgoal 1" :cases  ((not (> x 0))))
 
1964
;;             ("Subgoal 1.2" :use near-exact---rtl-rel5-support)
 
1965
;;             ("Subgoal 1.1" :use ((:instance near-exact---rtl-rel5-support
 
1966
;;                                             (x (* -1 x))))))
 
1967
;;   :rule-classes ())
 
1968
 
 
1969
 
 
1970
;; (defund near+ (x n)
 
1971
;;   (if (< (re (* (expt 2 (1- n)) (sig x)))
 
1972
;;       1/2)
 
1973
;;       (trunc x n)
 
1974
;;     (away x n)))
 
1975
 
 
1976
 
 
1977
;; (defthm near+-choice
 
1978
;;     (or (= (near+ x n) (trunc x n))
 
1979
;;      (= (near+ x n) (away x n)))
 
1980
;;   :rule-classes ())
 
1981
 
 
1982
 
 
1983
;; (defthm near+<=away
 
1984
;;     (implies (and (rationalp x)
 
1985
;;                (> x 0)
 
1986
;;                (integerp n)
 
1987
;;                (> n 0))
 
1988
;;           (<= (near+ x n) (away x n)))
 
1989
;;   :rule-classes ())
 
1990
 
 
1991
 
 
1992
;; (defthm near+>=trunc
 
1993
;;     (implies (and (rationalp x)
 
1994
;;                (> x 0)
 
1995
;;                (integerp n)
 
1996
;;                (> n 0))
 
1997
;;           (>= (near+ x n) (trunc x n)))
 
1998
;;   :rule-classes ())
 
1999
 
 
2000
 
 
2001
;; (defthmd near+-shift
 
2002
;;     (implies (and (rationalp x)
 
2003
;;                (integerp n)
 
2004
;;                (integerp k))
 
2005
;;           (= (near+ (* x (expt 2 k)) n)
 
2006
;;              (* (near+ x n) (expt 2 k)))))
 
2007
 
 
2008
 
 
2009
;; (defthmd near+-minus
 
2010
;;   (= (near+ (* -1 x) n) (* -1 (near+ x n))))
 
2011
 
 
2012
(defthm near+-positive
 
2013
  (implies (and (rationalp x)
 
2014
                (> x 0)
 
2015
                (integerp n)
 
2016
                (> n 0))
 
2017
           (> (near+ x n) 0))
 
2018
  :rule-classes :linear)
 
2019
 
 
2020
(defthm near+-negative
 
2021
    (implies (and (< x 0)
 
2022
                  (rationalp x)
 
2023
                  (integerp n)
 
2024
                  (> n 0))
 
2025
             (< (near+ x n) 0))
 
2026
  :rule-classes :linear)
 
2027
 
 
2028
;; (defthm near+-0
 
2029
;;   (equal (near+ 0 n) 0))
 
2030
 
 
2031
;; (defthm near+-0-0
 
2032
;;   (implies (and (case-split (< 0 n))
 
2033
;;                 (case-split (rationalp x))
 
2034
;;                 (case-split (integerp n)))
 
2035
;;            (equal (equal (near+ x n) 0)
 
2036
;;                (equal x 0)))
 
2037
;;   :rule-classes ())
 
2038
 
 
2039
;; >             (DEFTHM SGN-NEAR+
 
2040
;;                       (IMPLIES (AND (RATIONALP X) (INTEGERP N) (> N 0))
 
2041
;;                                (= (NEAR+ X N)
 
2042
;;                                   (* (SGN X) (NEAR+ (ABS X) N))))
 
2043
;;                       :RULE-CLASSES NIL)
 
2044
 
 
2045
;; (defthm sgn-near+
 
2046
;;     (implies (and (rationalp x)
 
2047
;;                (integerp n)
 
2048
;;                (> n 0))
 
2049
;;           (equal (sgn (near+ x n))
 
2050
;;                  (sgn x)))
 
2051
;;     :hints (("Goal" :use ((:instance sgn-near+---rtl-rel5-support)))))
 
2052
 
 
2053
;; (i-am-here) ;; Fri Oct 13 09:45:43 2006
 
2054
 
 
2055
;; (defthm near+-exactp-a
 
2056
;;     (implies (and (rationalp x)
 
2057
;;                (integerp n)
 
2058
;;                (> n 0))
 
2059
;;           (exactp (near+ x n) n))
 
2060
;;     :hints (("Goal" :use ((:instance near+-exactp-b---rtl-rel5-support)))))
 
2061
 
 
2062
 
 
2063
;; (defthm near+-exactp-b
 
2064
;;     (implies (and (rationalp x)
 
2065
;;                (integerp n) 
 
2066
;;                (> n 0))
 
2067
;;           (iff (= x (near+ x n))
 
2068
;;                (exactp x n)))
 
2069
;;     :hints (("Goal" :use ((:instance near+-exactp-a---rtl-rel5-support))))
 
2070
;;   :rule-classes ())
 
2071
 
 
2072
 
 
2073
;;  (defthm near+-exactp-d
 
2074
;;     (implies (and (rationalp x)
 
2075
;;                (integerp n)
 
2076
;;                (> n 0)
 
2077
;;                (rationalp a)
 
2078
;;                (exactp a n)
 
2079
;;                (<= a x))
 
2080
;;           (<= a (near+ x n)))
 
2081
;;     :hints (("Goal" :cases ((not (equal x 0))))
 
2082
;;             ("Subgoal 2" :in-theory (enable near+))
 
2083
;;             ("Subgoal 1" :cases ((not (> x 0))))
 
2084
;;             ("Subgoal 1.2" :use ((:instance near+-exactp-d---rtl-rel5-support)))
 
2085
;;             ("Subgoal 1.1" :use ((:instance near+-exactp-c---rtl-rel5-support
 
2086
;;                                             (x (* -1 x)) (a (* -1 a))))
 
2087
;;              :in-theory (e/d (near+ trunc-minus away-minus fl-minus 
 
2088
;;                                     sig-minus) ()))))
 
2089
;; )
 
2090
 
 
2091
;; ACL2 !>(expo (near+ (+ 1/4 1/8) 0))
 
2092
;; -1
 
2093
;; ACL2 !>(expo (+ 1/4 1/8))
 
2094
;; -2
 
2095
 
 
2096
;;     :hints (("Goal" :cases ((equal (near x n) (trunc x n))))
 
2097
;;             ("Subgoal 2"   :use ((:instance near-choice)
 
2098
;
 
2099
;                                  (:instance expo-away))))
 
2100
 
 
2101
;; (i-am-here) ;; Thu Oct 12 18:15:18 2006
 
2102
 
 
2103
(encapsulate ()
 
2104
             (local 
 
2105
              (defthm fl-1/2-sig-x-is-zero-specific
 
2106
                (implies (rationalp x)
 
2107
                         (equal (fl (* 1/2 (sig x)))
 
2108
                                0))
 
2109
                :hints (("Goal" :use ((:instance sig-upper-bound)
 
2110
                                      (:instance sig-lower-bound))))))
 
2111
 
 
2112
 (defthm expo-near+
 
2113
   (implies (and (rationalp x)
 
2114
                 (natp n)
 
2115
                 (not (= (abs (near+ x n)) (expt 2 (1+ (expo x))))))
 
2116
            (equal (expo (near+ x n))
 
2117
                   (expo x)))
 
2118
   :hints (("Goal" :in-theory (e/d (near+ sgn
 
2119
                                          expo-trunc expo-away re
 
2120
                                          sig-lower-bound)
 
2121
                                   (trunc away))
 
2122
            :cases ((equal (near+ x n) (trunc x n))))
 
2123
           ("Subgoal 1" :cases ((equal n 0)))
 
2124
           ("Subgoal 1.1" :cases ((not (equal x 0)))))
 
2125
   :rule-classes ())
 
2126
)
 
2127
 
 
2128
;----------------------------------------------------------------------
 
2129
 
 
2130
;; 
 
2131
;; (defthm near+1-a-1
 
2132
;;     (implies (and (rationalp x)
 
2133
;;                (integerp n)
 
2134
;;                (> n 0)
 
2135
;;                (< (abs (- x (trunc x n))) (abs (- (away x n) x))))
 
2136
;;           (= (near+ x n) (trunc x n)))
 
2137
;;     :hints (("Goal" :cases ((not (equal x 0)))
 
2138
;;              :in-theory (enable trunc-minus near+-minus trunc-upper-pos
 
2139
;;                                 away-lower-pos
 
2140
;;                                 away-minus))
 
2141
;;             ("Subgoal 1" :cases ((not (> x 0))))
 
2142
;;             ("Subgoal 1.2" :use ((:instance near+1-a---rtl-rel5-support)))
 
2143
;;             ("Subgoal 1.1" :use ((:instance near+1-a---rtl-rel5-support
 
2144
;;                                             (x (* -1 x)))
 
2145
;;                                  (:instance trunc-upper-pos
 
2146
;;                                             (x (* -1 x)))
 
2147
;;                                  (:instance away-lower-pos
 
2148
;;                                             (x (* -1 x)))
 
2149
;;                                  (:instance trunc-exactp-b)
 
2150
;;                                  (:instance away-exactp-b))))
 
2151
;;   :rule-classes ())
 
2152
 
 
2153
 
 
2154
;; (defthm near+1-b-1
 
2155
;;     (implies (and (rationalp x)
 
2156
;;                (integerp n)
 
2157
;;                (> n 0)
 
2158
;;                (> (abs (- x (trunc x n))) (abs (- (away x n) x))))
 
2159
;;           (= (near+ x n) (away x n)))
 
2160
;;     :hints (("Goal" :cases ((not (equal x 0)))
 
2161
;;              :in-theory (enable trunc-minus near+-minus trunc-upper-pos
 
2162
;;                                 away-lower-pos
 
2163
;;                                 away-minus))
 
2164
;;             ("Subgoal 1" :cases ((not (> x 0))))
 
2165
;;             ("Subgoal 1.2" :use ((:instance near+1-b---rtl-rel5-support)))
 
2166
;;             ("Subgoal 1.1" :use ((:instance near+1-b---rtl-rel5-support
 
2167
;;                                             (x (* -1 x)))
 
2168
;;                                  (:instance trunc-upper-pos
 
2169
;;                                             (x (* -1 x)))
 
2170
;;                                  (:instance away-lower-pos
 
2171
;;                                             (x (* -1 x)))
 
2172
;;                                  (:instance trunc-exactp-b)
 
2173
;;                                  (:instance away-exactp-b))))
 
2174
;;   :rule-classes ())
 
2175
 
 
2176
 
 
2177
;; (encapsulate ()
 
2178
;;   (local   
 
2179
;;   (encapsulate ()
 
2180
;;                (local          
 
2181
;;                 (defthm fl-1/2-sig-x-is-zero-lemma
 
2182
;;                   (implies (and (rationalp x)
 
2183
;;                                 (rationalp y)
 
2184
;;                                 (< 0 y)
 
2185
;;                                 (<= y 1/2))
 
2186
;;                            (equal (fl (* (sig x) y))
 
2187
;;                                   0))
 
2188
;;                   :hints (("Goal" :use ((:instance sig-upper-bound)
 
2189
;;                                         (:instance sig-lower-bound))))))
 
2190
 
 
2191
       
 
2192
;;                (local 
 
2193
;;                 (defthm fl-1/2-sig-x-is-zero-lemma-2
 
2194
;;                   (implies (and (rationalp x)
 
2195
;;                                 (rationalp y)
 
2196
;;                                 (not (equal x 0))
 
2197
;;                                 (< 0 y)
 
2198
;;                                 (<= y 1/2))
 
2199
;;                            (equal (fl (* -1 (sig x) y))
 
2200
;;                                   -1))
 
2201
;;                   :hints (("Goal" :in-theory (enable sig fl-minus)
 
2202
;;                            :use ((:instance fl-1/2-sig-x-is-zero-lemma))))))
 
2203
 
 
2204
 
 
2205
;;                (local 
 
2206
;;                 (defthm expt-merge
 
2207
;;                   (implies (and (rationalp x)
 
2208
;;                                 (integerp n))
 
2209
;;                            (equal (* (expt 2 (expo x))
 
2210
;;                                      (EXPT 2 (+ -1 N))
 
2211
;;                                      (EXPT 2 (* -1 (EXPO X))))
 
2212
;;                                   (expt 2 (+ -1 n))))
 
2213
;;                   :hints (("Goal" :in-theory (enable a15)))))
 
2214
 
 
2215
;;                (local (defthm expt-fact-1
 
2216
;;                         (implies (and (integerp n)
 
2217
;;                                       (<= n 0))
 
2218
;;                                  (<= (* 2 (EXPT 2 (+ -1 N))) 1))
 
2219
;;                         :hints (("Goal" :use ((:instance expt-weak-monotone-linear
 
2220
;;                                                          (n (+ -1 n))
 
2221
;;                                                          (m -1)))))
 
2222
;;                         :rule-classes :linear))
 
2223
 
 
2224
;;                (local
 
2225
;;                 (defthm fl-is-zero-if-n-less-than-minus-1
 
2226
;;                   (implies (and (rationalp x)
 
2227
;;                                 (> x 0)
 
2228
;;                                 (integerp n)
 
2229
;;                                 (<= n 0))
 
2230
;;                            (equal (FL (* -1 X (EXPT 2 (+ -1 N))
 
2231
;;                                          (EXPT 2 (* -1 (EXPO X)))))
 
2232
;;                                   -1))
 
2233
;;                   :hints (("Goal" :in-theory (e/d (expo-shift sgn)
 
2234
;;                                                   (fl-1/2-sig-x-is-zero-lemma-2))
 
2235
;;                            :use ((:instance fp-rep (x x))
 
2236
;;                                  (:instance fl-1/2-sig-x-is-zero-lemma-2
 
2237
;;                                             (y (expt 2 (+ -1 n)))))))))
 
2238
 
 
2239
;;                (local 
 
2240
;;                 (defthm fl-is-zero-if-n-less-than-zero
 
2241
;;                   (implies (and (rationalp x)
 
2242
;;                                 (> x 0)
 
2243
;;                                 (integerp n)
 
2244
;;                                 (<= n 0))
 
2245
;;                            (equal (FL (* X (EXPT 2 (+ -1 N))
 
2246
;;                                          (EXPT 2 (* -1 (EXPO X)))))
 
2247
;;                                   0))
 
2248
;;                   :hints (("Goal" :in-theory (e/d (expo-shift sgn)
 
2249
;;                                                   (fl-1/2-sig-x-is-zero-lemma))
 
2250
;;                            :use ((:instance fp-rep (x x))
 
2251
;;                                  (:instance fl-1/2-sig-x-is-zero-lemma
 
2252
;;                                             (y (expt 2 (+ -1 n)))))))))
 
2253
 
 
2254
 
 
2255
 
 
2256
 
 
2257
 
 
2258
;;                (local (defthm expt-fact-2
 
2259
;;                         (implies (and (integerp n)
 
2260
;;                                       (< n 0))
 
2261
;;                                  (<= (* 4 (EXPT 2 (+ -1 N))) 1))
 
2262
;;                         :hints (("Goal" :use ((:instance expt-weak-monotone-linear
 
2263
;;                                                          (n (+ -1 n))
 
2264
;;                                                          (m -2)))))
 
2265
;;                         :rule-classes :linear))
 
2266
 
 
2267
;;                (local 
 
2268
;;                 (defthm arith-hack
 
2269
;;                   (implies (and (< sig-x 2)
 
2270
;;                                 (> y 0)
 
2271
;;                                 (<= (* 4 y) 1)
 
2272
;;                                 (rationalp y))
 
2273
;;                            (< (* 2 sig-x y)
 
2274
;;                               (* 1)))))
 
2275
    
 
2276
 
 
2277
 
 
2278
;;                (local 
 
2279
;;                 (defthm less-than-1-if-n-is-negative
 
2280
;;                   (implies (and (rationalp x)
 
2281
;;                                 (> x 0)
 
2282
;;                                 (integerp n)
 
2283
;;                                 (< n 0))
 
2284
;;                            (< (* 2 X (EXPT 2 (+ -1 N))
 
2285
;;                                  (EXPT 2 (* -1 (EXPO X))))
 
2286
;;                               1))
 
2287
;;                   :hints (("Goal" :in-theory (e/d (expo-shift  sgn) ())
 
2288
;;                            :use ((:instance fp-rep (x x))
 
2289
;;                                  (:instance sig-upper-bound)
 
2290
;;                                  (:instance arith-hack
 
2291
;;                                             (sig-x (sig x))
 
2292
;;                                             (y (expt 2 (+ -1 n)))))))
 
2293
;;                   :rule-classes :linear))
 
2294
 
 
2295
;;                (local 
 
2296
;;                 (encapsulate () 
 
2297
;;                              (local 
 
2298
;;                               (defthm local-expt-expand
 
2299
;;                                 (implies (rationalp x)
 
2300
;;                                          (equal (EXPT 2 (+ 1 (EXPO X)))
 
2301
;;                                                 (* 2 (expt 2 (expo x)))))
 
2302
;;                                 :hints (("Goal" :use ((:instance a15 (i 2) (j1 1) (j2 (expo x))))))))
 
2303
                  
 
2304
;;                              (defthm x-lower-bound
 
2305
;;                                (implies (and (rationalp x)
 
2306
;;                                              (> x 0))
 
2307
;;                                         (>= (* 2 X) (EXPT 2 (+ 1 (EXPO X)))))
 
2308
;;                                :hints (("Goal" :use ((:instance expo-lower-bound))))
 
2309
;;                                :rule-classes :linear)))
 
2310
 
 
2311
 
 
2312
 
 
2313
;;      ;;;; these 4 are important!!! 
 
2314
 
 
2315
;;                (defthm fl-is-zero-if-n-less-than-minus-1
 
2316
;;                  (implies (and (rationalp x)
 
2317
;;                                (> x 0)
 
2318
;;                                (integerp n)
 
2319
;;                                (<= n 0))
 
2320
;;                           (equal (FL (* -1 X (EXPT 2 (+ -1 N))
 
2321
;;                                         (EXPT 2 (* -1 (EXPO X)))))
 
2322
;;                                  -1)))
 
2323
 
 
2324
 
 
2325
;;                (defthm fl-is-zero-if-n-less-than-zero
 
2326
;;                  (implies (and (rationalp x)
 
2327
;;                                (> x 0)
 
2328
;;                                (integerp n)
 
2329
;;                                (<= n 0))
 
2330
;;                           (equal (FL (* X (EXPT 2 (+ -1 N))
 
2331
;;                                         (EXPT 2 (* -1 (EXPO X)))))
 
2332
;;                                  0)))
 
2333
 
 
2334
;;                (defthm less-than-1-if-n-is-negative
 
2335
;;                  (implies (and (rationalp x)
 
2336
;;                                (> x 0)
 
2337
;;                                (integerp n)
 
2338
;;                                (< n 0))
 
2339
;;                           (< (* 2 X (EXPT 2 (+ -1 N))
 
2340
;;                                 (EXPT 2 (* -1 (EXPO X))))
 
2341
;;                              1))
 
2342
;;                  :rule-classes :linear)
 
2343
 
 
2344
;;                (defthm x-lower-bound
 
2345
;;                  (implies (and (rationalp x)
 
2346
;;                                (> x 0))
 
2347
;;                           (>= (* 2 X) (EXPT 2 (+ 1 (EXPO X)))))
 
2348
;;                  :rule-classes :linear)))
 
2349
 
 
2350
;;   (local
 
2351
;;    (defthm near+1-a-2-2
 
2352
;;      (implies (and (rationalp x)
 
2353
;;                    (> x 0)
 
2354
;;                    (integerp n)
 
2355
;;                    (<= n 0)
 
2356
;;                    (< (abs (- x (trunc x n))) (abs (- (away x n) x))))
 
2357
;;               (= (near+ x n) (trunc x n)))
 
2358
;;      :hints (("Goal" :in-theory (enable near+ sgn cg away trunc sig re)
 
2359
;;               :cases ((equal n 0))))
 
2360
;;      :rule-classes ()))
 
2361
 
 
2362
 
 
2363
  
 
2364
;;   (local (defthm x-upper-bound-1
 
2365
;;          (implies (and (rationalp x)
 
2366
;;                        (> x 0)
 
2367
;;                        (integerp n)
 
2368
;;                        (< n 0))
 
2369
;;                   (> (EXPT 2 (+ 1 (EXPO X) (* -1 N))) X))
 
2370
;;          :rule-classes :linear
 
2371
;;          :hints (("Goal" :in-theory (enable expo-upper-bound)
 
2372
;;                   :use ((:instance expt-strong-monotone-linear
 
2373
;;                                    (n (+ 1 (expo x)))
 
2374
;;                                    (m (+ 1 (expo x) (* -1 n)))))))))
 
2375
 
 
2376
 
 
2377
;;   (local (defthm x-upper-bound-2
 
2378
;;          (implies (and (rationalp x)
 
2379
;;                        (> x 0)
 
2380
;;                        (integerp n)
 
2381
;;                        (< n 0))
 
2382
;;                   (>= (EXPT 2 (+ 1 (EXPO X) (* -1 N))) (* 2 X)))
 
2383
;;          :rule-classes :linear
 
2384
;;          :hints (("Goal" :in-theory (enable expo-upper-bound)
 
2385
;;                   :use ((:instance expt-weak-monotone-linear
 
2386
;;                                    (n (+ 2 (expo x)))
 
2387
;;                                    (m (+ 1 (expo x) (* -1 n))))
 
2388
;;                         (:instance a15 (i 2)
 
2389
;;                                    (j1 1) (j2 (+ 1 (expo x)))))))))
 
2390
 
 
2391
 
 
2392
;;   (local (defthm x-upper-bound-3
 
2393
;;          (implies (and (rationalp x)
 
2394
;;                        (> x 0))
 
2395
;;                   (> (EXPT 2 (+ 1 (EXPO X))) x))
 
2396
;;          :rule-classes :linear
 
2397
;;          :hints (("Goal" :in-theory (enable expo-upper-bound)))))
 
2398
 
 
2399
 
 
2400
 
 
2401
 
 
2402
 
 
2403
 
 
2404
;; ;;      (defthm fl-is-zero-if-n-less-than-zero
 
2405
;; ;;        (implies (and (rationalp x)
 
2406
;; ;;                      (> x 0)
 
2407
;; ;;                      (integerp n)
 
2408
;; ;;                      (<= n 0))
 
2409
;; ;;                 (equal (FL (* X (EXPT 2 (+ -1 N))
 
2410
;; ;;                               (EXPT 2 (* -1 (EXPO X)))))
 
2411
;; ;;                        0)))
 
2412
 
 
2413
 
 
2414
 
 
2415
;;   (local (defthm x-upper-bound-4
 
2416
;;          (implies (and (rationalp x)
 
2417
;;                        (> x 0))
 
2418
;;                   (<= 1 (* X (EXPT 2 (* -1 (EXPO X))))))
 
2419
;;          :rule-classes :linear
 
2420
;;          :hints (("Goal" :use ((:instance fp-rep))
 
2421
;;                   :in-theory (enable sgn a15 sig-lower-bound
 
2422
;;                                      expo-shift)))))
 
2423
 
 
2424
 
 
2425
 
 
2426
 
 
2427
;;   (local
 
2428
;;      (defthm fl-is-zero-if-n-less-than-zero-2
 
2429
;;        (implies (and (rationalp x)
 
2430
;;                      (> x 0))
 
2431
;;                 (equal (FL (* 1/2 X 
 
2432
;;                               (EXPT 2 (* -1 (EXPO X)))))
 
2433
;;                        0))
 
2434
;;        :hints (("Goal" :use ((:instance fl-is-zero-if-n-less-than-zero
 
2435
;;                                         (n 0)))
 
2436
;;                 :in-theory (disable fl-is-zero-if-n-less-than-zero)))))
 
2437
       
 
2438
 
 
2439
;;   (local
 
2440
;;    (defthm near+1-b-2-2
 
2441
;;      (implies (and (rationalp x)
 
2442
;;                    (> x 0)
 
2443
;;                    (integerp n)
 
2444
;;                    (<= n 0)
 
2445
;;                    (> (abs (- x (trunc x n))) (abs (- (away x n) x))))
 
2446
;;               (= (near+ x n) (away x n)))
 
2447
;;      :hints (("Goal" :in-theory (enable away-lower-pos trunc-upper-pos
 
2448
;;                                         near+ sgn cg away trunc sig re)
 
2449
;;               :cases ((equal n 0))))
 
2450
;;      :rule-classes ()))
 
2451
 
 
2452
 
 
2453
 
 
2454
;;   (defthm near+1-a-2
 
2455
;;     (implies (and (rationalp x)
 
2456
;;                (integerp n)
 
2457
;;                   (<= n 0)
 
2458
;;                (< (abs (- x (trunc x n))) (abs (- (away x n) x))))
 
2459
;;           (= (near+ x n) (trunc x n)))
 
2460
;;     :hints (("Goal" :cases ((not (equal x 0)))
 
2461
;;              :in-theory (enable  trunc-minus near+-minus trunc-upper-pos
 
2462
;;                                  away-lower-pos
 
2463
;;                                  away-minus))
 
2464
;;             ("Subgoal 1" :cases ((not (> x 0))))
 
2465
;;             ("Subgoal 1.2" :use ((:instance near+1-a-2-2)))
 
2466
;;             ("Subgoal 1.1" :use ((:instance near+1-a-2-2
 
2467
;;                                             (x (* -1 x))))))
 
2468
;;     :rule-classes ())
 
2469
 
 
2470
;;   (defthm near+1-b-2
 
2471
;;     (implies (and (rationalp x)
 
2472
;;                (integerp n)
 
2473
;;                   (<= n 0)
 
2474
;;                (> (abs (- x (trunc x n))) (abs (- (away x n) x))))
 
2475
;;           (= (near+ x n) (away x n)))
 
2476
;;     :hints (("Goal" :cases ((not (equal x 0)))
 
2477
;;              :in-theory (enable  trunc-minus near+-minus trunc-upper-pos
 
2478
;;                                  away-lower-pos
 
2479
;;                                  away-minus))
 
2480
;;             ("Subgoal 1" :cases ((not (> x 0))))
 
2481
;;             ("Subgoal 1.2" :use ((:instance near+1-b-2-2)))
 
2482
;;             ("Subgoal 1.1" :use ((:instance near+1-b-2-2
 
2483
;;                                             (x (* -1 x))))))
 
2484
;;     :rule-classes ()))
 
2485
 
 
2486
 
 
2487
 
 
2488
 
 
2489
 
 
2490
;; (defthm near+1-a
 
2491
;;     (implies (and (rationalp x)
 
2492
;;                (natp n)
 
2493
;;                (< (abs (- x (trunc x n))) (abs (- (away x n) x))))
 
2494
;;           (= (near+ x n) (trunc x n)))
 
2495
;;     :hints (("Goal" :cases ((not (> n 0))))
 
2496
;;             ("Subgoal 2" :use ((:instance near+1-a-1)))
 
2497
;;             ("Subgoal 1" :use ((:instance near+1-a-2))))
 
2498
;;   :rule-classes ())
 
2499
 
 
2500
 
 
2501
;; (defthm near+1-b
 
2502
;;     (implies (and (rationalp x)
 
2503
;;                   (natp n)
 
2504
;;                (> (abs (- x (trunc x n))) (abs (- (away x n) x))))
 
2505
;;           (= (near+ x n) (away x n)))
 
2506
;;     :hints (("Goal" :cases ((not (> n 0))))
 
2507
;;             ("Subgoal 2" :use ((:instance near+1-b-1)))
 
2508
;;             ("Subgoal 1" :use ((:instance near+1-b-2))))
 
2509
;;   :rule-classes ())
 
2510
 
 
2511
 
 
2512
;----------------------------------------------------------------------
 
2513
 
 
2514
;; (i-am-here) ;; Fri Oct 13 11:19:13 2006
 
2515
 
 
2516
 
 
2517
;; (encapsulate () 
 
2518
 
 
2519
;;     (local 
 
2520
;;     (defthm equal-diff-trunc-away-1
 
2521
;;       (implies (and (exactp y n)
 
2522
;;                     (rationalp x)
 
2523
;;                     (> x 0)
 
2524
;;                     (case-split (<= x y))
 
2525
;;                     (rationalp y)
 
2526
;;                     (equal (abs (- x (trunc x n))) (abs (- (away x n)
 
2527
;;                                                            x)))
 
2528
;;                     (integerp n)
 
2529
;;                     (> n 0))
 
2530
;;           (>= (abs (- x y)) (abs (- x (near+ x n)))))
 
2531
;;       :hints (("Goal" :use ((:instance trunc-upper-pos)
 
2532
;;                             (:instance near+-choice)
 
2533
;;                             (:instance away-lower-pos)
 
2534
;;                             (:instance away-exactp-c
 
2535
;;                                        (a y)))))))
 
2536
 
 
2537
 
 
2538
;;     (local 
 
2539
;;     (defthm equal-diff-trunc-away-2
 
2540
;;       (implies (and (exactp y n)
 
2541
;;                     (rationalp x)
 
2542
;;                     (> x 0)
 
2543
;;                     (case-split (<= y x))
 
2544
;;                     (rationalp y)
 
2545
;;                     (equal (abs (- x (trunc x n))) (abs (- (away x n)
 
2546
;;                                                            x)))
 
2547
;;                     (integerp n)
 
2548
;;                     (> n 0))
 
2549
;;           (>= (abs (- x y)) (abs (- x (near+ x n)))))
 
2550
;;       :hints (("Goal" :in-theory (disable NEAR+-EXACTP-D)
 
2551
;;                :use ((:instance near+-choice)
 
2552
;;                      (:instance trunc-upper-pos)
 
2553
;;                      (:instance away-lower-pos)
 
2554
;;                      (:instance trunc-exactp-c
 
2555
;;                                 (a y)))))))
 
2556
 
 
2557
 
 
2558
 
 
2559
;;     (local
 
2560
;;     (defthm near2+-lemma
 
2561
;;         (implies (and (exactp y n)
 
2562
;;                       (rationalp x)
 
2563
;;                       (> x 0)
 
2564
;;                (rationalp y)
 
2565
;;                       (case-split (not (equal (abs (- x (trunc x n))) (abs (- (away x n)
 
2566
;;                                                                               x)))))
 
2567
;;                (integerp n)
 
2568
;;                (> n 0))
 
2569
;;           (>= (abs (- x y)) (abs (- x (near+ x n)))))
 
2570
;;         :hints (("Goal" :cases ((not (> (abs (- x (trunc x n))) (abs (- (away x n)
 
2571
;;                                                                         x)))))
 
2572
;;                  :in-theory (disable near+-exactp-d))
 
2573
;;                 ("Subgoal 2" :cases ((not (< x y))))
 
2574
;;                 ("Subgoal 2.2" :use  ((:instance near+1-b)
 
2575
;;                                       (:instance trunc-upper-pos)
 
2576
;;                                       (:instance away-lower-pos)
 
2577
;;                                       (:instance away-exactp-c
 
2578
;;                                                  (a y))))
 
2579
;;                 ("Subgoal 2.1" :use  ((:instance near+1-b)
 
2580
;;                                       (:instance trunc-upper-pos)
 
2581
;;                                       (:instance away-lower-pos)
 
2582
;;                                       (:instance trunc-exactp-c
 
2583
;;                                                  (a y))))
 
2584
;;                 ("Subgoal 1" :cases ((not (< x y))))
 
2585
;;                 ("Subgoal 1.2" :use  ((:instance near+1-a)
 
2586
;;                                       (:instance trunc-upper-pos)
 
2587
;;                                       (:instance away-lower-pos)
 
2588
;;                                       (:instance away-exactp-c
 
2589
;;                                                  (a y))))
 
2590
;;                 ("Subgoal 1.1" :use  ((:instance near+1-a)
 
2591
;;                                       (:instance trunc-upper-pos)
 
2592
;;                                       (:instance away-lower-pos)
 
2593
;;                                       (:instance trunc-exactp-c
 
2594
;;                                                  (a y)))))))
 
2595
 
 
2596
 
 
2597
;;     ;; (loca
 
2598
;;     ;; (defthm exactp-equal-trunc-equal
 
2599
;;     ;;   (implies (and (exactp x n)
 
2600
;;     ;;                 (integerp n)
 
2601
;;     ;;                 (rationalp x))
 
2602
;;     ;;            (equal (trunc x n) x))
 
2603
;;     ;;   :hints (("Goal" :in-theory (enable exactp trunc)
 
2604
;;     ;;            :use ((:instance fp-rep)
 
2605
;;     ;;                  (:instance a15
 
2606
;;     ;;                             (i 2)
 
2607
;;     ;;                             (j1 (+ -1 N))
 
2608
;;     ;;                             (j2 (+ 1 (EXPO X) (* -1 N))))))))
 
2609
 
 
2610
 
 
2611
 
 
2612
 
 
2613
;;     ;; (defthm exactp-equal-away-equal
 
2614
;;     ;;   (implies (and (exactp x n)
 
2615
;;     ;;                 (integerp n)
 
2616
;;     ;;                 (rationalp x))
 
2617
;;     ;;            (equal (away x n) x))
 
2618
;;     ;;   :hints (("Goal" :in-theory (enable cg exactp away)
 
2619
;;     ;;            :use ((:instance fp-rep)
 
2620
;;     ;;                  (:instance a15
 
2621
;;     ;;                             (i 2)
 
2622
;;     ;;                             (j1 (+ -1 N))
 
2623
;;     ;;                             (j2 (+ 1 (EXPO X) (* -1 N))))))))
 
2624
 
 
2625
 
 
2626
;;     (local 
 
2627
;;     (defthm near2+-lemma-futher
 
2628
;;         (implies (and (exactp y n)
 
2629
;;                       (rationalp x)
 
2630
;;                       (> x 0)
 
2631
;;                (rationalp y)
 
2632
;;                (integerp n)
 
2633
;;                (> n 0))
 
2634
;;           (>= (abs (- x y)) (abs (- x (near+ x n)))))
 
2635
;;         :hints (("Goal" :cases ((equal (abs (- x (trunc x n))) (abs (- (away x n)
 
2636
;;                                                                               x)))))
 
2637
;;                 ("Subgoal 2" :use ((:instance near2+-lemma)))
 
2638
;;                 ("Subgoal 1" :cases ((not (< x y))))
 
2639
;;                 ("Subgoal 1.2" :use ((:instance equal-diff-trunc-away-1)))
 
2640
;;                 ("Subgoal 1.1" :use ((:instance equal-diff-trunc-away-2))))))
 
2641
 
 
2642
 
 
2643
 
 
2644
;;     (defthm near+2
 
2645
;;         (implies (and (exactp y n)
 
2646
;;                       (rationalp x)
 
2647
;;                (rationalp y)
 
2648
;;                (integerp n)
 
2649
;;                (> n 0))
 
2650
;;           (>= (abs (- x y)) (abs (- x (near+ x n)))))
 
2651
;;         :hints (("Goal" :cases ((not (> x 0)))
 
2652
;;                  :in-theory (enable near+-minus trunc-minus away-minus
 
2653
;;                                     exactp-minus))
 
2654
;;                 ("Subgoal 2" :use ((:instance near2+-lemma-futher)))
 
2655
;;                 ("Subgoal 1" :use ((:instance near2+-lemma-futher
 
2656
;;                                               (x (* -1 x))
 
2657
;;                                                    (y (* -1 y))))))
 
2658
;;         :rule-classes ())
 
2659
;;     )
 
2660
 
 
2661
;; (i-am-here) ;; Fri Oct 13 11:38:14 2006
 
2662
 
 
2663
;; (encapsulate ()
 
2664
;;     (local 
 
2665
;;     (defthm fl-1/2-sig-x-is-zero-specific
 
2666
;;       (implies (rationalp x)
 
2667
;;                (equal (fl (* 1/2 (sig x)))
 
2668
;;                       0))
 
2669
;;       :hints (("Goal" :use ((:instance sig-upper-bound)
 
2670
;;                             (:instance sig-lower-bound))))))
 
2671
 
 
2672
 
 
2673
;;    (local 
 
2674
;;     (defthm near+-monotone-lemma1
 
2675
;;       (implies (and (<= x y)
 
2676
;;                     (rationalp x)
 
2677
;;                     (rationalp y))
 
2678
;;                (<= (near+ x 0) (near+ y 0)))
 
2679
;;       :hints (("Goal" :in-theory (enable near+ sgn away-minus)
 
2680
;;                :cases ((not (equal x 0))))
 
2681
;;               ("Subgoal 2" :use ((:instance away-negative
 
2682
;;                                             (x (* -1 y)) (n 0))))
 
2683
;;               ("Subgoal 1" :cases ((not (> x 0))))
 
2684
;;               ("Subgoal 1.2" :use ((:instance sig-lower-bound (x y))
 
2685
;;                                    (:instance expt-weak-monotone-linear
 
2686
;;                                               (n (+ 1 (expo x)))
 
2687
;;                                               (m (+ 1 (expo y))))
 
2688
;;                                    (:instance expo-monotone)))
 
2689
;;               ("Subgoal 1.1" :cases ((not (> y 0)))
 
2690
;;                :in-theory (enable away near+ sgn cg))
 
2691
;;               ("Subgoal 1.1.1" 
 
2692
;;                :use ((:instance expt-weak-monotone-linear
 
2693
;;                                 (n (+ 1 (expo y)))
 
2694
;;                                 (m (+ 1 (expo x))))
 
2695
;;                      (:instance expo-monotone
 
2696
;;                                 (x y) (y x))
 
2697
;;                      (:instance sig-lower-bound))))))
 
2698
            
 
2699
 
 
2700
;;  (defthm near+-monotone
 
2701
;;    (implies (and (<= x y)
 
2702
;;                 (rationalp x)
 
2703
;;                 (rationalp y)
 
2704
;;                 (integerp n)
 
2705
;;                 (natp n))
 
2706
;;            (<= (near+ x n) (near+ y n)))
 
2707
;;   :hints (("Goal" :cases ((not (equal n 0)))
 
2708
;;            :in-theory (enable near+-minus))
 
2709
;;           ("Subgoal 2" :use ((:instance near+-monotone-lemma1)))
 
2710
;;           ("Subgoal 1" :cases ((not (equal x 0))))
 
2711
;;           ("Subgoal 1.2" :use ((:instance near+-negative
 
2712
;;                                           (x (* -1 y)))))
 
2713
;;           ("Subgoal 1.1" :cases ((not (> x 0))))
 
2714
;;           ("Subgoal 1.1.2" :use ((:instance
 
2715
;;                                   near+-monotone---rtl-rel5-support)))
 
2716
;;           ("Subgoal 1.1.1" :use ((:instance near+-monotone---rtl-rel5-support
 
2717
;;                                             (x (* -1 y))
 
2718
;;                                             (y (* -1 x)))))))
 
2719
          
 
2720
;; )
 
2721
 
 
2722
;----------------------------------------------------------------------
 
2723
 
 
2724
(encapsulate ()
 
2725
  (local (include-book "../../arithmetic/top"))
 
2726
  (local 
 
2727
   (defthm z-integerp-not-integer
 
2728
     (implies (and (not (integerp x))
 
2729
                   (rationalp x)
 
2730
                   (integerp (* 2 x)))
 
2731
              (equal (+ x (* -1 (fl x))) 1/2))))
 
2732
 
 
2733
  (local 
 
2734
     (defthm integerp-x-integerp-2*x
 
2735
       (implies (and (integerp (* x (expt 2 n)))
 
2736
                     (integerp n))
 
2737
                (integerp (* 2 x (expt 2 (+ -1 n)))))
 
2738
       :hints (("Goal" 
 
2739
                :use ((:instance a15 
 
2740
                                 (i 2)
 
2741
                                 (j1 1)
 
2742
                                 (j2 (+ -1 n))))))))
 
2743
 
 
2744
  (defthm near+-midpoint
 
2745
      (implies (and (rationalp x)
 
2746
                  (integerp n)
 
2747
                  (exactp x (1+ n))
 
2748
                  (not (exactp x n)))
 
2749
             (equal (near+ x n) (away x n)))
 
2750
      :hints (("Goal" :in-theory (enable exactp near+)
 
2751
               :use ((:instance z-integerp-not-integer
 
2752
                                (x (* (sig x)
 
2753
                                      (expt 2 (+ -1 n))))))))
 
2754
    :rule-classes ())
 
2755
)
 
2756
;----------------------------------------------------------------------
 
2757
 
 
2758
;; (defthm near-power-a
 
2759
;;     (implies (and (rationalp x) (> x 0)
 
2760
;;                (integerp n) (> n 1)
 
2761
;;                (>= (+ x (expt 2 (- (expo x) n)))
 
2762
;;                    (expt 2 (1+ (expo x)))))
 
2763
;;           (= (near x n)
 
2764
;;              (expt 2 (1+ (expo x)))))
 
2765
;;   :rule-classes ())
 
2766
 
 
2767
 
 
2768
;; (defthm near-power-b
 
2769
;;     (implies (and (rationalp x) (> x 0)
 
2770
;;                (integerp n) (> n 1)
 
2771
;;                (>= (+ x (expt 2 (- (expo x) n)))
 
2772
;;                    (expt 2 (1+ (expo x)))))
 
2773
;;           (= (trunc (+ x (expt 2 (- (expo x) n))) n)
 
2774
;;              (expt 2 (1+ (expo x)))))
 
2775
;;   :rule-classes ())
 
2776
 
 
2777
 
 
2778
;; (defthm near+-power
 
2779
;;     (implies (and (rationalp x) (> x 0)
 
2780
;;                (integerp n) (> n 1)
 
2781
;;                (>= (+ x (expt 2 (- (expo x) n)))
 
2782
;;                    (expt 2 (1+ (expo x)))))
 
2783
;;           (= (near+ x n)
 
2784
;;              (expt 2 (1+ (expo x)))))
 
2785
;;   :rule-classes ())
 
2786
 
 
2787
 
 
2788
;----------------------------------------------------------------------
 
2789
 
 
2790
(encapsulate () 
 
2791
  ;; referring to the folllowing
 
2792
  ;;                            Fri Oct 13 12:05:54 2006
 
2793
  ;; (defthm plus-trunc
 
2794
  ;;     (implies (and (rationalp x)
 
2795
  ;;              (>= x 0)
 
2796
  ;;              (rationalp y)
 
2797
  ;;              (>= y 0)
 
2798
  ;;              (integerp k)
 
2799
  ;;              (exactp x (+ k (- (expo x) (expo y)))))
 
2800
  ;;         (= (+ x (trunc y k))
 
2801
  ;;            (trunc (+ x y) (+ k (- (expo (+ x y)) (expo y))))))
 
2802
  ;;   :rule-classes ())
 
2803
 
 
2804
 
 
2805
 
 
2806
  ;; (defthm plus-away
 
2807
  ;;   (implies (and (exactp x (+ k (- (expo x) (expo y))))
 
2808
  ;;                 (rationalp x)
 
2809
  ;;                 (>= x 0)
 
2810
  ;;                 (rationalp y)
 
2811
  ;;                 (>= y 0)
 
2812
  ;;                 (integerp k))
 
2813
  ;;            (= (+ x (away y k))
 
2814
  ;;               (away (+ x y)
 
2815
  ;;                     (+ k (- (expo (+ x y)) (expo y))))))
 
2816
  ;;   :rule-classes ())
 
2817
 
 
2818
  ;; (local (include-book "../../arithmetic/top"))
 
2819
           
 
2820
  ;; Following the steps in Lemma 5.3.33. on 
 
2821
  ;; http://www.russinoff.com/libman/top.html
 
2822
 
 
2823
  (local 
 
2824
   (defun z (y k)
 
2825
     (fl (* (sig y) (expt 2 (+ -1 k))))))
 
2826
 
 
2827
  (local 
 
2828
   (defun f (y k)
 
2829
     (- (* (expt 2 (+ -1 k)) (sig y))  (z y k))))
 
2830
 
 
2831
  (local 
 
2832
   (defthm re-equal-if-f-equal
 
2833
     (implies (equal (f y1 k1)
 
2834
                     (f y2 k2))
 
2835
              (equal (re (* (expt 2 (+ -1 k1)) (sig y1)))
 
2836
                     (re (* (expt 2 (+ -1 k2)) (sig y2)))))
 
2837
     :rule-classes nil))
 
2838
                     
 
2839
  (local 
 
2840
  (defthm integerp-1/2-integerp
 
2841
    (implies (and (integerp d)
 
2842
                  (rationalp x))
 
2843
             (iff (integerp (+ d x))
 
2844
                  (integerp x)))))
 
2845
 
 
2846
  (local
 
2847
  (defthm evenp-perserved-by-plus-even
 
2848
    (implies (and (evenp d)
 
2849
                  (integerp d)
 
2850
                  (integerp x))
 
2851
             (and (iff (evenp (+ x d))
 
2852
                       (evenp x))
 
2853
                  (iff (oddp (+ x d))
 
2854
                       (oddp x))))))
 
2855
 
 
2856
 
 
2857
  (local 
 
2858
   (defthm evenp-iff-difference
 
2859
     (implies (and (evenp (- z1 z2))
 
2860
                   (integerp z1)
 
2861
                   (integerp z2))
 
2862
              (iff (evenp z1)
 
2863
                   (evenp z2)))
 
2864
     :hints (("Goal" :use ((:instance evenp-perserved-by-plus-even
 
2865
                                      (d (- z1 z2))
 
2866
                                      (x z2)))))))
 
2867
 
 
2868
 
 
2869
  (local 
 
2870
   (defthm evenp-iff-difference-specific
 
2871
     (implies (evenp (+ (z y k) (* -1 (z (+ x y) (+ k (expo (+ x y)) (* -1 (expo y)))))))
 
2872
              (iff (evenp (fl (* (sig (+ x y)) (expt 2 (+ -1 k  (* -1 (expo y)) (expo (+ x y)))))))
 
2873
                   (evenp (fl (* (sig y) (expt 2 (+ -1 k)))))))
 
2874
     :hints (("Goal" :in-theory (disable evenp EVENP-IFF-DIFFERENCE)
 
2875
              :use ((:instance evenp-iff-difference
 
2876
                                      (z1 (z y k))
 
2877
                                      (z2 (z (+ x y) (+ k (expo (+ x y)) (* -1 (expo y)))))))))))
 
2878
 
 
2879
  
 
2880
  (local
 
2881
  (defthm near-plus-lemma-if-fl-equal
 
2882
    (implies (and (exactp x (1- (+ k (- (expo x) (expo y)))))
 
2883
                  (equal (f y k)
 
2884
                         (f (+ x y) (+ k (expo (+ x y)) (* -1 (expo y)))))
 
2885
                  (evenp (+ (z y k) 
 
2886
                            (* -1 (z (+ x y) (+ k (* -1 (expo y)) (expo (+ x y)))))))
 
2887
                  (rationalp x)
 
2888
                  (>= x 0)
 
2889
                  (rationalp y)
 
2890
                  (>= y 0)
 
2891
                  (integerp k))
 
2892
             (= (+ x (near y k))
 
2893
                (near (+ x y)
 
2894
                      (+ k (- (expo (+ x y)) (expo y))))))
 
2895
    :hints (("Goal" :in-theory (e/d (near exactp-<=) (evenp z f re))
 
2896
             :use ((:instance plus-trunc)
 
2897
                   (:instance plus-away)
 
2898
                   (:instance evenp-iff-difference-specific)
 
2899
                   (:instance re-equal-if-f-equal
 
2900
                              (y1 y) (k1 k)
 
2901
                              (y2 (+ x y)) (k2 (+ k (- (expo (+ x y)) (expo y))))))))
 
2902
    :rule-classes ()))
 
2903
 
 
2904
  ;; >             (DEFTHM FL+INT-REWRITE
 
2905
  ;;                       (IMPLIES (AND (INTEGERP N) (RATIONALP X))
 
2906
  ;;                                (EQUAL (FL (+ X N)) (+ (FL X) N))))
 
2907
  
 
2908
  (local 
 
2909
  (defthm f-equal-if-difference-integerp
 
2910
    (implies (and (integerp (+ (* (sig y1) (expt 2 (+ -1 k1)))
 
2911
                               (* -1 (sig y2) (expt 2 (+ -1 k2)))))
 
2912
                  (rationalp y2))
 
2913
             (equal (f y1 k1)
 
2914
                    (f y2 k2)))
 
2915
    :hints (("Goal" 
 
2916
             :use ((:instance fl+int-rewrite
 
2917
                              (x (* (sig y2) (expt 2 (+ -1 k2))))
 
2918
                              (n (+ (* (sig y1) (expt 2 (+ -1 k1)))
 
2919
                                    (* -1 (sig y2) (expt 2 (+ -1 k2)))))))))
 
2920
    :rule-classes nil))
 
2921
  
 
2922
  (local 
 
2923
  (defthm z-difference-evenp-evenp
 
2924
    (implies (equal (f y1 k1)
 
2925
                    (f y2 k2))
 
2926
             (equal (+ (z y1 k1)
 
2927
                       (* -1 (z y2 k2)))
 
2928
                    (+ (* (sig y1) (expt 2 (+ -1 k1)))
 
2929
                       (* -1 (sig y2) (expt 2 (+ -1 k2))))))
 
2930
    :rule-classes nil))
 
2931
 
 
2932
  (local
 
2933
  (defthm expo-normalize
 
2934
    (implies (rationalp x)
 
2935
             (equal (EXPO (* (SGN X)
 
2936
                             (SIG X)
 
2937
                             (EXPT 2 (EXPO X))))
 
2938
                    (expo x)))
 
2939
    :hints (("Goal" :use ((:instance fp-rep))))))
 
2940
 
 
2941
  (local 
 
2942
  (defthm sig-multiply-normalize
 
2943
    (implies (and (rationalp x)
 
2944
                  (>= x 0)
 
2945
                  (integerp v)
 
2946
                  (integerp w))
 
2947
             (equal (* (sig x) (expt 2 (+ v w (expo x))))
 
2948
                    (* x (expt 2 (+ v w)))))
 
2949
    :hints (("Goal" :in-theory (enable sgn)
 
2950
             :use ((:instance fp-rep (x x))
 
2951
                          (:instance a15 (i 2)
 
2952
                                     (j1 (expo x))
 
2953
                                     (j2 (+ v w))))))
 
2954
    :rule-classes nil))
 
2955
                                     
 
2956
  (local 
 
2957
  (defthm sig-y1-y2-equal
 
2958
    (implies (and (rationalp y)
 
2959
                  (>= x 0)
 
2960
                  (>= y 0)
 
2961
                  (integerp k)
 
2962
                  (rationalp x))
 
2963
             (equal (+ (* (sig (+ x y))
 
2964
                          (expt 2 (+ -1 k (* -1 (expo y))
 
2965
                                     (expo (+ x y)))))
 
2966
                       (* -1 (sig y) (expt 2 (+ -1 k))))
 
2967
                    (* x (expt 2 (+ -1 k (* -1 (expo y)))))))
 
2968
    :hints (("Goal" :in-theory (enable sgn)
 
2969
             :cases ((not (equal (* (sig (+ x y))
 
2970
                                    (expt 2 (+ -1 k (* -1 (expo y))
 
2971
                                               (expo (+ x y)))))
 
2972
                                 (* (+ x y) 
 
2973
                                    (expt 2 (+ -1 k (* -1 (expo y)))))))
 
2974
                     (not (equal (* (sig y)
 
2975
                                    (expt 2 (+ -1 k)))
 
2976
                                 (* y (expt 2 (+ -1 k (* -1 (expo y)))))))))
 
2977
            ("Subgoal 2" :use ((:instance sig-multiply-normalize
 
2978
                                          (x (+ x y))
 
2979
                                          (v -1)
 
2980
                                          (w (+ K (* -1 (EXPO Y)))))))
 
2981
            ("Subgoal 1" :use ((:instance fp-rep (x y))
 
2982
                               (:instance a15 (i 2) (j1 (expo y)) 
 
2983
                                          (j2 (+ -1 K (* -1 (EXPO Y))))))))))
 
2984
 
 
2985
 
 
2986
 
 
2987
  (local 
 
2988
   (defthm local-expt-2-expand
 
2989
     (implies (and (rationalp x)
 
2990
                   (integerp k))
 
2991
              (equal (EXPT 2 (+ -1 K (* -1 (EXPO Y))))
 
2992
                     (* 2 (EXPT 2 (+ -2 K (* -1 (EXPO Y)))))))
 
2993
     :hints (("Goal" :use ((:instance a15 (i 2) (j1 1) 
 
2994
                                      (j2 (+ -2 K (* -1 (EXPO Y))))))))))
 
2995
 
 
2996
  (local 
 
2997
  (defthm integerp-x-expt-k
 
2998
    (implies (and (exactp x (1- (+ k (- (expo x) (expo y)))))
 
2999
                  (rationalp x)
 
3000
                  (integerp k))
 
3001
             (integerp (* x (expt 2 (+ -1 k (* -1 (expo y)))))))
 
3002
    :hints (("Goal" :use ((:instance exactp2 (x x)
 
3003
                                     (n (1- (+ k (- (expo x) (expo y)))))))))))
 
3004
 
 
3005
 
 
3006
  (local 
 
3007
  (defthm evenp-x-expt-k
 
3008
    (implies (and (exactp x (1- (+ k (- (expo x) (expo y)))))
 
3009
                  (rationalp x)
 
3010
                  (integerp k))
 
3011
             (evenp (* x (expt 2 (+ -1 k (* -1 (expo y)))))))
 
3012
    :hints (("Goal" :use ((:instance exactp2 (x x)
 
3013
                                     (n (1- (+ k (- (expo x) (expo y)))))))))))
 
3014
 
 
3015
  (local
 
3016
   (defthm integerp-minus
 
3017
     (implies (acl2-numberp x)
 
3018
              (iff (integerp (* -1 x))
 
3019
                   (integerp x)))
 
3020
     :hints (("Goal" :in-theory (disable a2)
 
3021
              :cases ((equal (* -1 x) (- x)))))))
 
3022
              
 
3023
 
 
3024
  (local 
 
3025
   (defthm even-minus
 
3026
     (implies (acl2-numberp x)
 
3027
              (iff (evenp (* -1 x))
 
3028
                   (evenp x)))
 
3029
     :hints (("Goal" :in-theory (disable a2 a5)
 
3030
              :cases ((equal (* -1 x) (- x)))))))
 
3031
 
 
3032
  (defthm near-plus
 
3033
    (implies (and (exactp x (1- (+ k (- (expo x) (expo y)))))
 
3034
                  (rationalp x)
 
3035
                  (>= x 0)
 
3036
                  (rationalp y)
 
3037
                  (>= y 0)
 
3038
                  (integerp k))
 
3039
             (= (+ x (near y k))
 
3040
                (near (+ x y)
 
3041
                      (+ k (- (expo (+ x y)) (expo y))))))
 
3042
    :hints (("Goal" :in-theory (disable evenp z f
 
3043
                                        evenp-x-expt-k
 
3044
                                        integerp-x-expt-k
 
3045
                                        LOCAL-EXPT-2-EXPAND
 
3046
                                        SIG-Y1-Y2-EQUAL near)
 
3047
             :use ((:instance near-plus-lemma-if-fl-equal)
 
3048
                   (:instance f-equal-if-difference-integerp
 
3049
                              (k1 k) (k2 (+ k (expo (+ x y)) (* -1 (expo y))))
 
3050
                              (y1 y) (y2 (+ x y)))
 
3051
                   (:instance z-difference-evenp-evenp
 
3052
                              (k1 k) (k2 (+ k (expo (+ x y)) (* -1 (expo y))))
 
3053
                              (y1 y) (y2 (+ x y)))
 
3054
                   (:instance sig-y1-y2-equal)
 
3055
                   (:instance integerp-x-expt-k)
 
3056
                   (:instance evenp-x-expt-k))))
 
3057
    :rule-classes ())
 
3058
 
 
3059
 
 
3060
 
 
3061
 
 
3062
  (local
 
3063
    (defthm near+-plus-lemma-if-fl-equal
 
3064
      (implies (and (exactp x (+ k (- (expo x) (expo y))))
 
3065
                    (equal (f y k)
 
3066
                           (f (+ x y) (+ k (expo (+ x y)) (* -1 (expo y)))))
 
3067
                    (rationalp x)
 
3068
                    (>= x 0)
 
3069
                    (rationalp y)
 
3070
                    (>= y 0)
 
3071
                    (integerp k))
 
3072
               (= (+ x (near+ y k))
 
3073
                  (near+ (+ x y)
 
3074
                         (+ k (- (expo (+ x y)) (expo y))))))
 
3075
      :hints (("Goal" :in-theory (e/d (near+ exactp-<=) (evenp z f re))
 
3076
               :use ((:instance plus-trunc)
 
3077
                     (:instance plus-away)
 
3078
                     (:instance re-equal-if-f-equal
 
3079
                                (y1 y) (k1 k)
 
3080
                                (y2 (+ x y)) (k2 (+ k (- (expo (+ x y)) (expo y))))))))
 
3081
      :rule-classes ()))
 
3082
 
 
3083
 
 
3084
 
 
3085
  (local 
 
3086
    (defthm integerp-x-expt-k-2
 
3087
      (implies (and (exactp x (+ k (- (expo x) (expo y))))
 
3088
                    (rationalp x)
 
3089
                    (integerp k))
 
3090
               (integerp (* x (expt 2 (+ -1 k (* -1 (expo y)))))))
 
3091
      :hints (("Goal" :use ((:instance exactp2 (x x)
 
3092
                                       (n (+ k (- (expo x) (expo y))))))))))
 
3093
 
 
3094
 
 
3095
  (defthm near+-plus
 
3096
    (implies (and (exactp x (+ k (- (expo x) (expo y))))
 
3097
                  (rationalp x)
 
3098
                  (>= x 0)
 
3099
                  (rationalp y)
 
3100
                  (>= y 0)
 
3101
                  (integerp k))
 
3102
             (= (+ x (near+ y k))
 
3103
                (near+ (+ x y)
 
3104
                       (+ k (- (expo (+ x y)) (expo y))))))
 
3105
    :hints (("Goal" :in-theory (disable evenp z f
 
3106
                                        integerp-x-expt-k-2
 
3107
                                        LOCAL-EXPT-2-EXPAND
 
3108
                                        SIG-Y1-Y2-EQUAL near+)
 
3109
             :use ((:instance near+-plus-lemma-if-fl-equal)
 
3110
                          (:instance f-equal-if-difference-integerp
 
3111
                                     (k1 k) (k2 (+ k (expo (+ x y)) (* -1 (expo y))))
 
3112
                                     (y1 y) (y2 (+ x y)))
 
3113
                          (:instance sig-y1-y2-equal)
 
3114
                          (:instance integerp-x-expt-k-2))))
 
3115
    :rule-classes ())
 
3116
)
 
3117
 
 
3118
 
 
3119
;----------------------------------------------------------------------
 
3120
 
 
3121
;----------------------------------------------------------------------
 
3122
 
 
3123
;; (defthm near-trunc
 
3124
;;     (implies (and (rationalp x) (> x 0)
 
3125
;;                (integerp n) (> n 1))
 
3126
;;           (= (near x n)
 
3127
;;              (if (and (exactp x (1+ n)) (not (exactp x n)))
 
3128
;;                  (trunc (+ x (expt 2 (- (expo x) n))) (1- n))
 
3129
;;                (trunc (+ x (expt 2 (- (expo x) n))) n))))
 
3130
;;   :rule-classes ())
 
3131
 
 
3132
 
 
3133
;; (defthm near+trunc
 
3134
;;     (implies (and (rationalp x)
 
3135
;;                (> x 0)
 
3136
;;                (integerp n)
 
3137
;;                (> n 0))
 
3138
;;           (= (near+ x n)
 
3139
;;              (trunc (+ x (expt 2 (- (expo x) n))) n)))               
 
3140
;;   :rule-classes ())
 
3141
 
 
3142
;----------------------------------------------------------------------
 
3143
 
 
3144
(encapsulate () 
 
3145
    ;; (defthm fp+2
 
3146
    ;;     (implies (and (rationalp x)
 
3147
    ;;            (> x 0)
 
3148
    ;;            (rationalp y)
 
3149
    ;;            (> y x)
 
3150
    ;;            (integerp n)
 
3151
    ;;            (> n 0)
 
3152
    ;;            (exactp x n)
 
3153
    ;;            (exactp y n))
 
3154
    ;;       (>= y (fp+ x n)))
 
3155
    ;;   :rule-classes ())
 
3156
 
 
3157
     
 
3158
    (local (include-book "../../arithmetic/expt"))
 
3159
    ;; we just want expt-weak-monotone-linear 
 
3160
 
 
3161
    (local 
 
3162
     (defun y (x m)
 
3163
       (+ (trunc x (+ 1 m)) 
 
3164
          (expt 2 (+ (* -1 m) (expo x))))))
 
3165
 
 
3166
 
 
3167
 
 
3168
 
 
3169
    ;; (local 
 
3170
    ;;  (defun y (x m)
 
3171
    ;;    (+ (trunc x (+ 1 m)) 
 
3172
    ;;       (expt 2 (+ -1 (* -1 m) (expo x))))))
 
3173
 
 
3174
 
 
3175
 
 
3176
    ;; (defthm expo-trunc
 
3177
    ;;     (implies (and (< 0 n)
 
3178
    ;;                   (rationalp x)
 
3179
    ;;            (integerp n))
 
3180
    ;;       (equal (expo (trunc x n))
 
3181
    ;;                     (expo x))))
 
3182
 
 
3183
 
 
3184
    (local 
 
3185
     (defthm expt-2-less-than-specific
 
3186
       (implies (and (rationalp x)
 
3187
                     (> x 0)
 
3188
                     (integerp m)
 
3189
                     (> m 0))
 
3190
                (<= (expt 2 (+ (expo x) (* -1 M)))
 
3191
                    (EXPT 2
 
3192
                          (+ (* -1 M)
 
3193
                             (EXPO (+ (TRUNC X (+ 1 M))
 
3194
                                      (EXPT 2 (+ (EXPO X) (* -1 M)))))))))
 
3195
       :hints (("Goal" :use ((:instance trunc-lower-bound
 
3196
                                        (x x) (n (+ 1 m)))
 
3197
                             (:instance expo-monotone
 
3198
                                        (x (trunc x (+ 1 m)))
 
3199
                                        (y (+ (trunc x (+ 1 m))
 
3200
                                              (EXPT 2 (+ (EXPO X) (* -1 M))))))
 
3201
                             (:instance expt-weak-monotone-linear
 
3202
                                        (n (+ (EXPO X) (* -1 M)))
 
3203
                                        (m (+ (* -1 M)
 
3204
                                              (EXPO (+ (TRUNC X (+ 1 M))
 
3205
                                                       (EXPT 2 (+ (EXPO X) (* -1 M)))))))))))
 
3206
       :rule-classes :linear))
 
3207
 
 
3208
 
 
3209
 
 
3210
    ;; (local 
 
3211
    ;;  (defthm expt-2-less-than-specific
 
3212
    ;;    (implies (and (rationalp x)
 
3213
    ;;                  (> x 0)
 
3214
    ;;                  (integerp m)
 
3215
    ;;                  (> m 0))
 
3216
    ;;             (<= (expt 2 (+ (expo x) (* -1 M)))
 
3217
    ;;                 (EXPT 2
 
3218
    ;;                       (+ (* -1 M)
 
3219
    ;;                          (EXPO (+ (TRUNC X (+ 1 M))
 
3220
    ;;                                   (EXPT 2 (+ -1 (EXPO X) (* -1 M)))))))))
 
3221
    ;;    :hints (("Goal" :use ((:instance trunc-lower-bound
 
3222
    ;;                                     (x x) (n (+ 1 m)))
 
3223
    ;;                          (:instance expo-monotone
 
3224
    ;;                                     (x (trunc x (+ 1 m)))
 
3225
    ;;                                     (y (+ (trunc x (+ 1 m))
 
3226
    ;;                                           (EXPT 2 (+ -1 (EXPO X) (* -1 M))))))
 
3227
    ;;                          (:instance expt-weak-monotone-linear
 
3228
    ;;                                     (n (+ (EXPO X) (* -1 M)))
 
3229
    ;;                                     (m (+ (* -1 M)
 
3230
    ;;                                           (EXPO (+ (TRUNC X (+ 1 M))
 
3231
    ;;                                                    (EXPT 2 (+ -1 (EXPO X) (* -1 M)))))))))))
 
3232
    ;;    :rule-classes :linear))
 
3233
 
 
3234
    (local 
 
3235
     (defthm trunc-less-than
 
3236
       (implies (and (rationalp x)
 
3237
                     (> x 0)
 
3238
                     (integerp m))
 
3239
                (< (trunc (+ x (expt 2 (+ (* -1 m) (expo x)))) m)
 
3240
                   (fp+ (y x m) (+ 1 m))))
 
3241
       :hints (("Goal" :use ((:instance trunc-upper-pos
 
3242
                                        (x (+ x (expt 2 (+ (* -1 m) (expo x)))))
 
3243
                                        (n m))
 
3244
                             (:instance trunc-lower-bound
 
3245
                                        (x x)
 
3246
                                        (n (+ 1 m)))
 
3247
                             (:instance expt-2-less-than-specific))))))
 
3248
                             
 
3249
 
 
3250
 
 
3251
 
 
3252
    ;; (local 
 
3253
    ;;  (defthm trunc-less-than
 
3254
    ;;    (implies (and (rationalp x)
 
3255
    ;;                  (> x 0)
 
3256
    ;;                  (integerp m))
 
3257
    ;;             (< (trunc (+ x (expt 2 (+ (* -1 m) (expo x)))) m)
 
3258
    ;;                (fp+ (y x m) (+ 1 m))))
 
3259
    ;;    :hints (("Goal" :use ((:instance trunc-upper-pos
 
3260
    ;;                                     (x (+ x (expt 2 (+ (* -1 m) (expo x)))))
 
3261
    ;;                                     (n m))
 
3262
    ;;                          (:instance trunc-lower-bound
 
3263
    ;;                                     (x x)
 
3264
    ;;                                     (n (+ 1 m)))
 
3265
    ;;                          (:instance expt-2-less-than-specific))))))
 
3266
                             
 
3267
 
 
3268
 
 
3269
    (local 
 
3270
     (defthm exactp-fact
 
3271
       (implies (and (rationalp x)
 
3272
                     (integerp m)
 
3273
                     (> m 0))
 
3274
                (EXACTP (TRUNC (+ X (EXPT 2 (+ (EXPO X) (* -1 M))))
 
3275
                               M)
 
3276
                        (+ 1 M)))
 
3277
       :hints (("Goal" :in-theory (enable trunc-exactp-a)
 
3278
                :use ((:instance exactp-<=
 
3279
                                 (m m)
 
3280
                                 (x (TRUNC (+ X (EXPT 2 (+ (EXPO X) (* -1 M))))
 
3281
                                           M))
 
3282
                                 (n (+ 1 m))))))))
 
3283
                                 
 
3284
 
 
3285
 
 
3286
    (local 
 
3287
     (defthm exactp-fact-1
 
3288
       (implies (and (rationalp x)
 
3289
                     (integerp m)
 
3290
                     (> m 0))
 
3291
                (EXACTP (TRUNC (+ X (EXPT 2 (+ (EXPO X) (* -1 M))))
 
3292
                               M)
 
3293
                        M))
 
3294
       :hints (("Goal" :in-theory (enable trunc-exactp-a)
 
3295
                :use ((:instance exactp-<=
 
3296
                                 (m m)
 
3297
                                 (x (TRUNC (+ X (EXPT 2 (+ (EXPO X) (* -1 M))))
 
3298
                                           M))
 
3299
                                 (n (+ 1 m))))))))
 
3300
                                 
 
3301
 
 
3302
 
 
3303
    (local 
 
3304
     (defthm exactp-fact-2
 
3305
          (implies (and (rationalp x)
 
3306
                        (> x 0)
 
3307
                        (integerp m)
 
3308
                        (> m 0))
 
3309
                   (EXACTP (+ (TRUNC X (+ 1 M))
 
3310
                              (EXPT 2 (+ (EXPO X) (* -1 M))))
 
3311
                           (+ 1 M)))
 
3312
          :hints (("Goal" :use ((:instance fp+1
 
3313
                                           (x (TRUNC X (+ 1 M)))
 
3314
                                           (n (+ 1 m))))))))
 
3315
 
 
3316
 
 
3317
 
 
3318
 
 
3319
    (local 
 
3320
     (defthm trunc-m+1-plus-is-trunc-plus-C-lemma
 
3321
       (implies (and (integerp m)
 
3322
                     (rationalp x)
 
3323
                     (> x 0)
 
3324
                     (> m 0))
 
3325
                (>= (y x m)
 
3326
                    (trunc (+ x (expt 2 (+ (* -1 m) (expo x)))) m)))
 
3327
       :hints (("Goal" :in-theory (disable fp+)
 
3328
                :use ((:instance fp+2
 
3329
                                 (y (trunc (+ x (expt 2 (+ (* -1 m) (expo x)))) m))
 
3330
                                 (x (y x m))
 
3331
                                 (n (+ 1 m)))
 
3332
                      (:instance trunc-less-than))))))
 
3333
 
 
3334
 
 
3335
 
 
3336
    ;; (local 
 
3337
    ;;  (defun y (x m)
 
3338
    ;;    (+ (trunc x (+ 1 m)) 
 
3339
    ;;       (expt 2 (+ (* -1 m) (expo x))))))
 
3340
 
 
3341
                      
 
3342
 
 
3343
 
 
3344
    (local 
 
3345
     (defthm trunc-m+1-plus-is-trunc-plus-C
 
3346
       (implies (and (integerp m)
 
3347
                     (rationalp x)
 
3348
                     (> x 0)
 
3349
                     (> m 0))
 
3350
                (= (trunc (y x m) m)
 
3351
                   (trunc (+ x (expt 2 (+ (* -1 m) (expo x)))) m)))
 
3352
       :hints (("Goal" :in-theory (disable fp+)
 
3353
                :use ((:instance trunc-m+1-plus-is-trunc-plus-C-lemma)
 
3354
                      (:instance trunc-exactp-c
 
3355
                                 (a (trunc (+ x (expt 2 (+ (* -1 m) (expo x)))) m))
 
3356
                                 (x (y x m))
 
3357
                                 (n m))
 
3358
                      (:instance trunc-monotone
 
3359
                                 (x (y x m))
 
3360
                                 (y (+ x (expt 2 (+ (* -1 m) (expo x)))))
 
3361
                                 (n m))
 
3362
                      (:instance trunc-upper-pos
 
3363
                                 (x x)
 
3364
                                 (n (+ 1 m))))))
 
3365
       :rule-classes nil))
 
3366
 
 
3367
    ;; (defthm near+trunc
 
3368
    ;;     (implies (and (rationalp x)
 
3369
    ;;            (> x 0)
 
3370
    ;;            (integerp n)
 
3371
    ;;            (> n 0))
 
3372
    ;;       (= (near+ x n)
 
3373
    ;;          (trunc (+ x (expt 2 (- (expo x) n))) n)))               
 
3374
    ;;   :rule-classes ())
 
3375
 
 
3376
    (local
 
3377
    (defthm near+-trunc-cor-lemma
 
3378
        (implies (and (rationalp x)
 
3379
                      (> x 0)
 
3380
                  (integerp m)
 
3381
                  (> m 0))
 
3382
             (= (near+ (trunc x (+ 1 m)) m)
 
3383
                (near+ x m)))
 
3384
        :hints (("Goal" :in-theory (enable trunc-trunc)
 
3385
                 :use ((:instance near+trunc
 
3386
                                  (x (trunc x (+ 1 m)))
 
3387
                                  (n m))
 
3388
                       (:instance near+trunc
 
3389
                                  (x x)
 
3390
                                  (n m))
 
3391
                       (:instance trunc-m+1-plus-is-trunc-plus-C))))
 
3392
      :rule-classes ()))
 
3393
 
 
3394
    (local 
 
3395
    (defthm near+-trunc-cor-lemma-2
 
3396
        (implies (and (rationalp x)
 
3397
                  (integerp m)
 
3398
                  (> m 0))
 
3399
             (= (near+ (trunc x (+ 1 m)) m)
 
3400
                (near+ x m)))
 
3401
        :hints (("Goal" :cases ((not (equal x 0)))
 
3402
                 :in-theory (enable trunc-minus near+-minus))
 
3403
                ("Subgoal 1" :cases ((not (> x 0))))
 
3404
                ("Subgoal 1.2" :use ((:instance near+-trunc-cor-lemma)))
 
3405
                ("Subgoal 1.1" :use ((:instance near+-trunc-cor-lemma
 
3406
                                                (x (* -1 x))))))
 
3407
      :rule-classes ()))
 
3408
 
 
3409
 
 
3410
    (defthm near+-trunc-cor
 
3411
        (implies (and (rationalp x)
 
3412
                      (integerp m)
 
3413
                      (integerp n)
 
3414
                      (> n m)
 
3415
                  (> m 0))
 
3416
             (= (near+ (trunc x n) m)
 
3417
                (near+ x m)))
 
3418
        :hints (("Goal" :cases ((not (> n (+ 1 m)))))
 
3419
                ("Subgoal 2" :use ((:instance near+-trunc-cor-lemma-2
 
3420
                                              (x (trunc x n))
 
3421
                                              (m m))
 
3422
                                   (:instance near+-trunc-cor-lemma-2
 
3423
                                              (x x)
 
3424
                                              (m m))
 
3425
                                   (:instance trunc-trunc
 
3426
                                              (x x)
 
3427
                                              (n n)
 
3428
                                              (m (+ 1 m)))))
 
3429
                ("Subgoal 1" :use ((:instance near+-trunc-cor-lemma-2))))
 
3430
      :rule-classes ())
 
3431
 
 
3432
)
 
3433
 
 
3434
;----------------------------------------------------------------------
 
3435
 
 
3436
;;;**********************************************************************
 
3437
;;;                          Sticky Rounding
 
3438
;;;**********************************************************************
 
3439
 
 
3440
 
 
3441
;; (defund sticky (x n)
 
3442
;;   (cond ((exactp x (1- n)) x)
 
3443
;;      (t (+ (trunc x (1- n))
 
3444
;;               (* (sgn x) (expt 2 (1+ (- (expo x) n))))))))
 
3445
 
 
3446
 
 
3447
;; (i-am-here)
 
3448
 
 
3449
(local 
 
3450
 (defthm sgn-x-plus-y
 
3451
   (implies (and (equal (sgn x) (sgn y))
 
3452
                 (rationalp x)
 
3453
                 (rationalp y))
 
3454
            (equal (sgn (+ x y))
 
3455
                   (sgn x)))
 
3456
   :hints (("Goal" :in-theory (enable sgn)))))
 
3457
 
 
3458
(local 
 
3459
 (defthm sgn-sgn-id
 
3460
   (equal (sgn (sgn x)) 
 
3461
          (sgn x))
 
3462
   :hints (("Goal" :in-theory (enable sgn)))))
 
3463
 
 
3464
(local 
 
3465
 (defthm sgn-expt-1
 
3466
   (equal (SGN (EXPT 2 n))
 
3467
          1)
 
3468
   :hints (("Goal" :in-theory (enable sgn)))))
 
3469
 
 
3470
(defthm sgn-sticky
 
3471
    (implies (and (rationalp x)
 
3472
                  (integerp n)
 
3473
                  (> n 0))
 
3474
             (equal (sgn (sticky x n))
 
3475
                    (sgn x)))
 
3476
    :hints (("Goal" :in-theory (enable sticky  
 
3477
                                       sgn-trunc
 
3478
                                       sgn-prod)
 
3479
             :cases ((not (> n 1))))
 
3480
            ("Subgoal 2" 
 
3481
             :use ((:instance sgn-x-plus-y
 
3482
                              (x (trunc x (+ -1 n)))
 
3483
                              (y (* (SGN X)
 
3484
                                    (EXPT 2 (+ 1 (EXPO X) (* -1 N))))))))))
 
3485
 
 
3486
(local 
 
3487
 (defthm positive-sgn-1
 
3488
   (implies (rationalp x)
 
3489
            (iff (equal (sgn x) 1)
 
3490
                 (> x 0)))
 
3491
   :hints (("Goal" :in-theory (enable sgn)))))
 
3492
 
 
3493
 
 
3494
(defthmd sticky-positive
 
3495
    (implies (and (< 0 x)
 
3496
                  (rationalp x) 
 
3497
                  (integerp n)
 
3498
                  (> n 0))
 
3499
             (> (sticky x n) 0))
 
3500
    :hints (("Goal" :use ((:instance sgn-sticky)
 
3501
                          (:instance positive-sgn-1
 
3502
                                     (x x))
 
3503
                          (:instance positive-sgn-1
 
3504
                                     (x (sticky x n))))))
 
3505
  :rule-classes :linear)
 
3506
 
 
3507
(local 
 
3508
 (defthm positive-sgn-2
 
3509
   (implies (rationalp x)
 
3510
            (iff (equal (sgn x) -1)
 
3511
                 (< x 0)))
 
3512
   :hints (("Goal" :in-theory (enable sgn)))))
 
3513
 
 
3514
 
 
3515
(defthmd sticky-negative
 
3516
    (implies (and (< x 0)
 
3517
                  (rationalp x) 
 
3518
                  (integerp n)
 
3519
                  (> n 0))
 
3520
             (< (sticky x n) 0))
 
3521
    :hints (("Goal" :use ((:instance sgn-sticky)
 
3522
                          (:instance positive-sgn-2
 
3523
                                     (x x))
 
3524
                          (:instance positive-sgn-2
 
3525
                                     (x (sticky x n))))))
 
3526
  :rule-classes :linear)
 
3527
 
 
3528
;; (defthm sticky-0
 
3529
;;   (equal (sticky 0 n) 0))
 
3530
 
 
3531
 
 
3532
;; (defthmd sticky-minus
 
3533
;;   (equal (sticky (* -1 x) n) (* -1 (sticky x n))))
 
3534
 
 
3535
 
 
3536
;; (defthm sticky-shift
 
3537
;;     (implies (and (rationalp x)
 
3538
;;                (integerp n) (> n 0)
 
3539
;;                (integerp k))
 
3540
;;           (= (sticky (* (expt 2 k) x) n)
 
3541
;;              (* (expt 2 k) (sticky x n))))           
 
3542
;;   :rule-classes ())
 
3543
 
 
3544
 
 
3545
;; (defthm expo-sticky
 
3546
;;     (implies (and (rationalp x) (> x 0)
 
3547
;;                (integerp n) (> n 0))
 
3548
;;           (= (expo (sticky x n))
 
3549
;;              (expo x)))
 
3550
;;   :rule-classes ())
 
3551
 
 
3552
 
 
3553
(local 
 
3554
 (defthm sticky-exactp-a-lemma
 
3555
    (implies (and (rationalp x)
 
3556
                  (> x 0)
 
3557
                  (integerp n) (> n 0))
 
3558
             (exactp (sticky x n) n))
 
3559
    :hints (("Goal" :in-theory (enable sgn exactp-2**n sticky)
 
3560
             :cases ((not (equal n 1))))
 
3561
            ("Subgoal 1" 
 
3562
             :use ((:instance trunc-exactp-a (n (- 1 n)))
 
3563
                   (:instance fp+1 
 
3564
                              (x (trunc x (+ -1 n)))
 
3565
                              (n n))
 
3566
                   (:instance exactp-<=
 
3567
                              (m (+ -1 n))
 
3568
                              (n n)
 
3569
                              (x (trunc x (+ -1 n))))
 
3570
                   (:instance exactp-<=
 
3571
                              (m (+ -1 n))
 
3572
                              (n n)
 
3573
                              (x x)))))
 
3574
    :rule-classes ()))
 
3575
 
 
3576
 
 
3577
(defthm sticky-exactp-a
 
3578
    (implies (and (rationalp x)
 
3579
                  (integerp n) (> n 0))
 
3580
             (exactp (sticky x n) n))
 
3581
    :hints (("Goal" :cases ((not (equal x 0)))
 
3582
             :in-theory (enable sticky-minus))
 
3583
            ("Subgoal 2" :in-theory (enable sticky exactp))
 
3584
            ("Subgoal 1" :cases ((not (> x 0))))
 
3585
            ("Subgoal 1.2" :use ((:instance sticky-exactp-a-lemma)))
 
3586
            ("Subgoal 1.1" :use ((:instance sticky-exactp-a-lemma
 
3587
                                            (x (* -1 x))))))
 
3588
    :rule-classes ())
 
3589
 
 
3590
 
 
3591
(local 
 
3592
  (defthm sig-fact
 
3593
    (implies (and (rationalp x)
 
3594
                  (> x 0))
 
3595
             (iff (equal (EXPT 2 (EXPO X)) x)
 
3596
                  (INTEGERP (SIG X))))
 
3597
    :hints (("Goal" :use ((:instance fp-rep)
 
3598
                          (:instance sig-lower-bound)
 
3599
                          (:instance sig-upper-bound))
 
3600
             :in-theory (enable sgn))
 
3601
            ("Subgoal 1" :cases ((not (< 1 (sig x))))))))
 
3602
 
 
3603
 
 
3604
(local
 
3605
 (defthm sticky-exactp-b-lemma
 
3606
    (implies (and (rationalp x)
 
3607
                  (> x 0)
 
3608
                  (integerp n) 
 
3609
                  (> n 0))
 
3610
             (iff (= x (sticky x n))
 
3611
                  (exactp x n)))
 
3612
    :hints (("Goal" :in-theory (enable expo-trunc 
 
3613
                                       trunc-exactp-a
 
3614
                                       sig-upper-bound
 
3615
                                       sig-lower-bound
 
3616
                                exactp-2**n sticky sgn)
 
3617
             :cases ((not (exactp x (+ -1 n)))))
 
3618
            ("Subgoal 2" :use ((:instance exactp-<=
 
3619
                                          (m (+ -1 n))
 
3620
                                          (n n)
 
3621
                                          (x x))))
 
3622
            ("Subgoal 1" :cases ((not (equal n 1))))
 
3623
            ("Subgoal 1.2" :in-theory (enable exactp
 
3624
                                              exactp-2**n
 
3625
                                              sticky sgn))
 
3626
            ("Subgoal 1.1" :use ((:instance trunc-midpoint
 
3627
                                            (x x)
 
3628
                                            (n (+ -1 n)))
 
3629
                                 (:instance fp+1 
 
3630
                                            (x (trunc x (+ -1 n)))
 
3631
                                            (n n))
 
3632
                                 (:instance exactp-<=
 
3633
                                          (m (+ -1 n))
 
3634
                                          (n n)
 
3635
                                          (x (trunc x (+ -1 n)))))))
 
3636
  :rule-classes ()))
 
3637
 
 
3638
 
 
3639
(defthm sticky-exactp-b
 
3640
    (implies (and (rationalp x)
 
3641
                  (integerp n) 
 
3642
                  (> n 0))
 
3643
             (iff (= x (sticky x n))
 
3644
                  (exactp x n)))
 
3645
    :hints (("Goal" :cases ((not (equal x 0)))
 
3646
             :in-theory (enable sticky-minus))
 
3647
            ("Subgoal 2" :in-theory (enable sticky exactp))
 
3648
            ("Subgoal 1" :cases ((not (> x 0))))
 
3649
            ("Subgoal 1.2" :use ((:instance sticky-exactp-b-lemma)))
 
3650
            ("Subgoal 1.1" :use ((:instance sticky-exactp-b-lemma
 
3651
                                            (x (* -1 x))))))
 
3652
    :rule-classes ())
 
3653
 
 
3654
;; (local 
 
3655
;;  (defthm fl-1/2-sig-x-is-zero-lemma
 
3656
;;    (implies (and (rationalp x)
 
3657
;;                  (rationalp y)
 
3658
;;                  (< 0 y)
 
3659
;;                  (<= y 1/2))
 
3660
;;             (equal (fl (* (sig x) y))
 
3661
;;                    0))
 
3662
;;    :hints (("Goal" :use ((:instance sig-upper-bound)
 
3663
;;                          (:instance sig-lower-bound))))))
 
3664
 
 
3665
 
 
3666
 
 
3667
;; (local 
 
3668
;;   (defthm |1/2-sig-x-not-integerp-lemma|
 
3669
;;     (implies (and (rationalp x)
 
3670
;;                   (not (equal x 0))
 
3671
;;                   (rationalp y)
 
3672
;;                   (< 0 y)
 
3673
;;                   (<= y 1/2))
 
3674
;;              (not (integerp (* (sig x) y))))
 
3675
;;     :hints (("Goal" :use ((:instance sig-upper-bound)
 
3676
;;                           (:instance sig-lower-bound))))))
 
3677
 
 
3678
 
 
3679
;; (local (include-book "../../arithmetic/expt"))
 
3680
 
 
3681
;; (local 
 
3682
;;  (defthm exactp-minus-fact
 
3683
;;    (implies (and (integerp n)
 
3684
;;                  (rationalp x)
 
3685
;;                  (not (equal x 0))
 
3686
;;                  (<= n 0))
 
3687
;;             (not (exactp x n)))
 
3688
;;    :hints (("Goal" :in-theory (enable exactp)
 
3689
;;             :use ((:instance sig-upper-bound)
 
3690
;;                   (:instance sig-lower-bound)
 
3691
;;                   (:instance |1/2-sig-x-not-integerp-lemma|
 
3692
;;                              (y (expt 2 (+ -1 n))))
 
3693
;;                   (:instance expt-weak-monotone-linear
 
3694
;;                              (n (+ -1 n))
 
3695
;;                              (m -1)))))))
 
3696
 
 
3697
;; (defthmd sticky-monotone
 
3698
;;   (implies (and (<= x y)
 
3699
;;                 (rationalp x)
 
3700
;;                 (rationalp y)
 
3701
;;                 (natp n))
 
3702
;;            (<= (sticky x n) (sticky y n)))
 
3703
;;   :hints (("Goal" :cases ((not (equal n 0)))
 
3704
;;            :in-theory (enable sticky sgn))
 
3705
;;           ("Subgoal 2" :cases ((not (equal y 0))))
 
3706
;;           ("Subgoal 2.1" :use ((:instance expo-monotone
 
3707
;;                                           (y x)
 
3708
;;                                           (x y))
 
3709
;;                                (:instance expo-monotone
 
3710
;;                                           (x x)
 
3711
;;                                           (y y))
 
3712
;;                                (:instance expt-weak-monotone-linear
 
3713
;;                                           (n (+ 1 (expo y)))
 
3714
;;                                           (m (+ 1 (expo x))))
 
3715
;;                                (:instance expt-weak-monotone-linear
 
3716
;;                                           (n (+ 1 (expo x)))
 
3717
;;                                           (m (+ 1 (expo y))))))
 
3718
;;           ("Subgoal 1" :use ((:instance sticky-monotone---rtl-rel5-support))))
 
3719
;;   :rule-classes :linear)
 
3720
 
 
3721
 
 
3722
;; (defthm sticky-exactp-m
 
3723
;;     (implies (and (rationalp x)
 
3724
;;                (integerp m)
 
3725
;;                (integerp n) 
 
3726
;;                (> n m)
 
3727
;;                (> m 0))
 
3728
;;           (iff (exactp (sticky x n) m)
 
3729
;;                (exactp x m)))
 
3730
;;   :rule-classes ())
 
3731
 
 
3732
;; (i-am-here)
 
3733
 
 
3734
;; (defthm trunc-sticky
 
3735
;;     (implies (and (rationalp x)
 
3736
;;                (integerp m) (> m 0)
 
3737
;;                (integerp n) (> n m))
 
3738
;;           (= (trunc (sticky x n) m)
 
3739
;;              (trunc x m)))
 
3740
;;     :hints (("Goal" :cases ((not (equal x 0))))
 
3741
;;             ("Subgoal 1" :cases ((not (> x 0))))
 
3742
;;             ("Subgoal 1.2" :use ((:instance trunc-sticky---rtl-rel5-support)))
 
3743
;;             ("Subgoal 1.1" :use ((:instance trunc-sticky---rtl-rel5-support
 
3744
;;                                             (x (* -1 x))))
 
3745
;;              :in-theory (enable trunc-minus sticky-minus)))
 
3746
;;   :rule-classes ())
 
3747
 
 
3748
 
 
3749
;; (defthm away-sticky
 
3750
;;     (implies (and (rationalp x)
 
3751
;;                (integerp m) (> m 0)
 
3752
;;                (integerp n) (> n m))
 
3753
;;           (= (away (sticky x n) m)
 
3754
;;              (away x m)))
 
3755
;;     :hints (("Goal" :cases ((not (equal x 0))))
 
3756
;;             ("Subgoal 1" :cases ((not (> x 0))))
 
3757
;;             ("Subgoal 1.2" :use ((:instance away-sticky---rtl-rel5-support)))
 
3758
;;             ("Subgoal 1.1" :use ((:instance away-sticky---rtl-rel5-support
 
3759
;;                                             (x (* -1 x))))
 
3760
;;              :in-theory (enable away-minus sticky-minus)))
 
3761
;;   :rule-classes ())
 
3762
 
 
3763
 
 
3764
;; (defthm near-sticky
 
3765
;;     (implies (and (rationalp x)
 
3766
;;                (integerp m) (> m 0)
 
3767
;;                (integerp n) (> n (1+ m)))
 
3768
;;           (= (near (sticky x n) m)
 
3769
;;              (near x m)))
 
3770
;;     :hints (("Goal" :cases ((not (equal x 0))))
 
3771
;;             ("Subgoal 1" :cases ((not (> x 0))))
 
3772
;;             ("Subgoal 1.2" :use ((:instance near-sticky---rtl-rel5-support)))
 
3773
;;             ("Subgoal 1.1" :use ((:instance near-sticky---rtl-rel5-support
 
3774
;;                                             (x (* -1 x))))
 
3775
;;              :in-theory (enable near-minus sticky-minus)))
 
3776
;;   :rule-classes ())
 
3777
 
 
3778
 
 
3779
;----------------------------------------------------------------------
 
3780
 
 
3781
 
 
3782
;; (defthm near+-sticky
 
3783
;;     (implies (and (rationalp x)
 
3784
;;                (integerp m) (> m 0)
 
3785
;;                (integerp n) (> n (1+ m)))
 
3786
;;           (= (near+ (sticky x n) m)
 
3787
;;              (near+ x m)))
 
3788
;;     :hints (("Goal" :use ((:instance near+-trunc-cor
 
3789
;;                                      (x (sticky x n))
 
3790
;;                                      (n (+ 1 m))
 
3791
;;                                      (m m))
 
3792
;;                           (:instance trunc-sticky
 
3793
;;                                      (m (+ 1 m)))
 
3794
;;                           (:instance near+-trunc-cor
 
3795
;;                                      (x x)
 
3796
;;                                      (n (+ 1 m))
 
3797
;;                                      (m m)))))
 
3798
;;   :rule-classes ())
 
3799
 
 
3800
;----------------------------------------------------------------------
 
3801
 
 
3802
;; (defthm sticky-sticky
 
3803
;;     (implies (and (rationalp x)
 
3804
;;                (integerp m)
 
3805
;;                (> m 1)
 
3806
;;                (integerp n)
 
3807
;;                (>= n m))
 
3808
;;           (= (sticky (sticky x n) m)
 
3809
;;              (sticky x m)))
 
3810
;;   :rule-classes ())
 
3811
 
 
3812
;----------------------------------------------------------------------
 
3813
 
 
3814
;;
 
3815
;; sticky-plus---rtl-rel5-support
 
3816
;;     (implies (and (rationalp x)
 
3817
;;                (> x 0)
 
3818
;;                (rationalp y)
 
3819
;;                (> y 0)
 
3820
;;                (integerp k)
 
3821
;;                (= k1 (+ k (- (expo x) (expo y))))
 
3822
;;                (= k2 (+ k (- (expo (+ x y)) (expo y))))
 
3823
;;                (> k 1)
 
3824
;;                (> k1 1)
 
3825
;;                (> k2 1)
 
3826
;;                (exactp x (1- k1)))
 
3827
;;           (= (+ x (sticky y k))
 
3828
;;              (sticky (+ x y) k2)))
 
3829
;;     :hints (("Goal" :by sticky-plus))
 
3830
;;   :rule-classes ())
 
3831
;;
 
3832
;; doesn't support well. Tue Jan 31 12:56:09 2006
 
3833
;;
 
3834
 
 
3835
;;   (defthm trunc-plus-minus
 
3836
;;     (implies (and (rationalp x)
 
3837
;;                   (rationalp y)
 
3838
;;                   (not (= x 0))
 
3839
;;                   (not (= y 0))
 
3840
;;                   (not (= (+ x y) 0))
 
3841
;;                   (integerp k)
 
3842
;;                   (> k 0)
 
3843
;;                   (= k1 (+ k (- (expo x) (expo y))))
 
3844
;;                   (= k2 (+ k (expo (+ x y)) (* -1 (expo y))))
 
3845
;;                   (exactp x k1)
 
3846
;;                   (> k2 0))
 
3847
;;              (equal (+ x (trunc y k))
 
3848
;;                     (if (= (sgn (+ x y)) (sgn y))
 
3849
;;                         (trunc (+ x y) k2)
 
3850
;;                       (away (+ x y) k2))))
 
3851
 
 
3852
 
 
3853
 
 
3854
(encapsulate ()
 
3855
 
 
3856
   (local 
 
3857
    (defthm exactp-fact-1
 
3858
      (implies (and (EXACTP X  (+ -1 K (EXPO X) (* -1 (EXPO Y))))
 
3859
                    (rationalp x)
 
3860
                    (rationalp y)
 
3861
                    (integerp k))
 
3862
               (iff (exactp (+ x y) (+ -1 K (* -1 (EXPO Y))
 
3863
                                       (EXPO (+ X Y))))
 
3864
                    (exactp y  (+ -1 k))))
 
3865
      :hints (("Goal" :in-theory (enable exactp2)))))
 
3866
 
 
3867
 
 
3868
 
 
3869
   (local 
 
3870
    (defthm local-expt-2-expand
 
3871
      (implies (and (rationalp x)
 
3872
                    (integerp k))
 
3873
               (equal (EXPT 2 (+ 2 (EXPO Y) (* -1 K)))
 
3874
                      (* 2 (EXPT 2 (+ 1 (EXPO Y) (* -1 k))))))
 
3875
      :hints (("Goal" :use ((:instance a15 (i 2) (j1 1) 
 
3876
                                       (j2 (+ 1 (EXPO Y)
 
3877
                                              (* -1 k)))))))))
 
3878
 
 
3879
   (defthm sticky-plus
 
3880
     (implies (and (rationalp x)
 
3881
                   (rationalp y)
 
3882
                   (not (= y 0))
 
3883
                   (not (= (+ x y) 0))
 
3884
                   (integerp k)
 
3885
                   (= k1 (+ k (- (expo x) (expo y))))
 
3886
                   (= k2 (+ k (- (expo (+ x y)) (expo y))))
 
3887
                   (> k 1)
 
3888
                   (> k1 1)
 
3889
                   (> k2 1)
 
3890
                   (exactp x (1- k1)))
 
3891
              (= (+ x (sticky y k))
 
3892
                 (sticky (+ x y) k2)))
 
3893
     :hints (("Goal" :cases ((not (exactp y (+ -1 k))))
 
3894
              :in-theory (enable sticky))
 
3895
             ("Subgoal 1" :use ((:instance trunc-plus-minus
 
3896
                                           (k1 (+ -1 k (expo x) (* -1 (expo y))))
 
3897
                                           (k2 (+ -1 k (* -1 (expo y)) (expo (+
 
3898
                                                                              x
 
3899
                                                                              y))))
 
3900
                                           (k (+ -1 k)))))
 
3901
             ("Subgoal 1.1" :cases ((not (> (+ x y) 0))))
 
3902
             ("Subgoal 1.1.2" :use ((:instance trunc-away 
 
3903
                                               (x (+ x y))
 
3904
                                               (n (+ -1 K (* -1 (EXPO Y))
 
3905
                                                     (EXPO (+ X Y))))))
 
3906
              :in-theory (enable sgn expo-minus trunc-minus away-minus))
 
3907
             ("Subgoal 1.1.1" :use ((:instance trunc-away 
 
3908
                                               (x (* -1 (+ x y)))
 
3909
                                               (n (+ -1 K (* -1 (EXPO Y))
 
3910
                                                     (EXPO (+ X Y))))))
 
3911
              :in-theory (enable sgn expo-minus trunc-minus away-minus)))
 
3912
     :rule-classes ()))
 
3913
 
 
3914
 
 
3915
 
 
3916
;;;**********************************************************************
 
3917
;;;                    IEEE Rounding
 
3918
;;;**********************************************************************
 
3919
 
 
3920
;; (i-am-here);; Fri Oct 13 15:10:44 2006
 
3921
;; (defun inf (x n)
 
3922
;;   (if (>= x 0)
 
3923
;;       (away x n)
 
3924
;;     (trunc x n)))
 
3925
 
 
3926
 
 
3927
(defthmd inf-lower-bound
 
3928
    (implies (and (case-split (rationalp x))
 
3929
                  (case-split (integerp n)))
 
3930
             (>= (inf x n) x))
 
3931
    :hints (("Goal" :use ((:instance trunc-upper-bound)
 
3932
                          (:instance away-lower-bound)))
 
3933
            ("Subgoal 1" :cases ((not (equal x 0)))))
 
3934
  :rule-classes :linear)
 
3935
 
 
3936
 
 
3937
;; (defun minf (x n)
 
3938
;;   (if (>= x 0)
 
3939
;;       (trunc x n)
 
3940
;;     (away x n)))
 
3941
 
 
3942
(defthmd minf-lower-bound
 
3943
    (implies (and (case-split (rationalp x))
 
3944
                  (case-split (integerp n)))
 
3945
             (<= (minf x n) x))
 
3946
    :hints (("Goal" :use ((:instance trunc-upper-bound)
 
3947
                          (:instance away-lower-bound))))
 
3948
  :rule-classes :linear)
 
3949
 
 
3950
;; (defund IEEE-mode-p (mode)
 
3951
;;   (member mode '(trunc inf minf near)))
 
3952
 
 
3953
 
 
3954
;; (defun common-rounding-mode-p (mode)
 
3955
;;   (or (IEEE-mode-p mode) (equal mode 'away) (equal mode 'near+)))
 
3956
 
 
3957
;; (defthmd ieee-mode-p-implies-common-rounding-mode-p
 
3958
;;   (implies (IEEE-mode-p mode)
 
3959
;;            (common-rounding-mode-p mode)))
 
3960
 
 
3961
;; (defund rnd (x mode n)
 
3962
;;   (case mode
 
3963
;;     (away (away x n))
 
3964
;;     (near+ (near+ x n))
 
3965
;;     (trunc (trunc x n))
 
3966
;;     (inf (inf x n))
 
3967
;;     (minf (minf x n))
 
3968
;;     (near (near x n))
 
3969
;;     (otherwise 0)))
 
3970
 
 
3971
 
 
3972
;; (defthm rationalp-rnd
 
3973
;;   (rationalp (rnd x mode n))
 
3974
;;   :rule-classes (:type-prescription))
 
3975
 
 
3976
 
 
3977
(defthm rnd-choice
 
3978
  (implies (and (rationalp x)
 
3979
                (integerp n)
 
3980
                (common-rounding-mode-p mode))
 
3981
           (or (= (rnd x mode n) (trunc x n))
 
3982
               (= (rnd x mode n) (away x n))))
 
3983
  :hints (("Goal" :use ((:instance near+-choice)
 
3984
                        (:instance near-choice))
 
3985
           :in-theory (enable rnd IEEE-mode-p)))
 
3986
  :rule-classes ())
 
3987
 
 
3988
;; (encapsulate ()
 
3989
;;    (local 
 
3990
;;     (defthm not-rational-rnd-redcue-to-zero
 
3991
;;       (implies (not (rationalp x))
 
3992
;;                (equal (rnd x mode n) 0))
 
3993
;;       :hints (("Goal" :in-theory (enable away near sig trunc near+ rnd)))))
 
3994
 
 
3995
;;    (local 
 
3996
;;     (defthm not-rational-sgn-redcue-to-zero
 
3997
;;       (implies (not (rationalp x))
 
3998
;;                (equal (sgn x) 0))
 
3999
;;       :hints (("Goal" :in-theory (enable sgn)))))
 
4000
 
 
4001
 
 
4002
;;    (defthmd sgn-rnd
 
4003
;;        (implies (and (common-rounding-mode-p mode)
 
4004
;;                      (integerp n)
 
4005
;;                      (> n 0))
 
4006
;;           (equal (sgn (rnd x mode n))
 
4007
;;                  (sgn x)))
 
4008
;;        :hints (("Goal" :cases ((not (rationalp x)))
 
4009
;;                 :in-theory 
 
4010
;;                 (enable sgn-away sgn-trunc 
 
4011
;;                      sgn-near rnd IEEE-mode-p)))))
 
4012
 
 
4013
 
 
4014
 
 
4015
(defthm rnd-positive
 
4016
  (implies (and (< 0 x)
 
4017
                (rationalp x)
 
4018
                (integerp n)
 
4019
                (> n 0)
 
4020
                (common-rounding-mode-p mode))
 
4021
           (> (rnd x mode n) 0))
 
4022
  :hints (("Goal" 
 
4023
           :in-theory 
 
4024
           (enable rnd IEEE-mode-p)))
 
4025
  :rule-classes (:type-prescription))
 
4026
 
 
4027
(defthm rnd-negative
 
4028
    (implies (and (< x 0)
 
4029
                  (rationalp x)
 
4030
                  (integerp n)
 
4031
                  (> n 0)
 
4032
                  (common-rounding-mode-p mode))
 
4033
             (< (rnd x mode n) 0))
 
4034
  :hints (("Goal" 
 
4035
           :in-theory 
 
4036
           (enable rnd near IEEE-mode-p)))
 
4037
  :rule-classes (:type-prescription))
 
4038
 
 
4039
;; (defthm rnd-0
 
4040
;;   (equal (rnd 0 mode n)
 
4041
;;          0))
 
4042
 
 
4043
; Unlike the above, we leave the following two as rewrite rules because we may
 
4044
; want to use the rewriter to relieve their hypotheses.
 
4045
 
 
4046
;; (defthm rnd-non-pos
 
4047
;;     (implies (<= x 0)
 
4048
;;           (<= (rnd x mode n) 0))
 
4049
;;   :rule-classes (:rewrite :type-prescription :linear))
 
4050
 
 
4051
;; (defthm rnd-non-neg
 
4052
;;     (implies (<= 0 x)
 
4053
;;           (<= 0 (rnd x mode n)))
 
4054
;;   :rule-classes (:rewrite :type-prescription :linear))
 
4055
 
 
4056
;; (defund flip (m)
 
4057
;;   (case m
 
4058
;;     (inf 'minf)
 
4059
;;     (minf 'inf)
 
4060
;;     (t m)))
 
4061
 
 
4062
;; (defthm ieee-mode-p-flip
 
4063
;;     (implies (ieee-mode-p m)
 
4064
;;           (ieee-mode-p (flip m))))
 
4065
 
 
4066
 
 
4067
;; (defthm common-rounding-mode-p-flip
 
4068
;;     (implies (common-rounding-mode-p m)
 
4069
;;           (common-rounding-mode-p (flip m))))
 
4070
 
 
4071
 
 
4072
;; (defthmd rnd-minus
 
4073
;;   (equal (rnd (* -1 x) mode n)
 
4074
;;          (* -1 (rnd x (flip mode) n))))
 
4075
 
 
4076
 
 
4077
 
 
4078
 
 
4079
;; (defthm rnd-exactp-a
 
4080
;;     (implies (< 0 n)
 
4081
;;           (exactp (rnd x mode n) n))
 
4082
;;     :hints (("Goal" :by rnd-exactp-b---rtl-rel5-support)))
 
4083
 
 
4084
 
 
4085
;; (defthm rnd-exactp-b
 
4086
;;   (implies (and (rationalp x)
 
4087
;;                 (common-rounding-mode-p mode)
 
4088
;;                 (integerp n) 
 
4089
;;                 (> n 0))
 
4090
;;            (equal (equal x (rnd x mode n))
 
4091
;;                (exactp x n)))
 
4092
;;   :hints (("Goal" :use ((:instance rnd-exactp-a---rtl-rel5-support)))))
 
4093
 
 
4094
 
 
4095
;; (defthmd rnd-exactp-c
 
4096
;;     (implies (and (rationalp x)
 
4097
;;                (common-rounding-mode-p mode)
 
4098
;;                (integerp n)
 
4099
;;                (> n 0)
 
4100
;;                (rationalp a)
 
4101
;;                (exactp a n)
 
4102
;;                (>= a x))
 
4103
;;           (>= a (rnd x mode n)))
 
4104
;;     :hints (("Goal" :in-theory (enable trunc-minus 
 
4105
;;                                        ieee-mode-p flip rnd)
 
4106
;;              :use ((:instance trunc-exactp-c
 
4107
;;                               (x (* -1 x)) (a (* -1 a)))
 
4108
;;                    (:instance away-exactp-c)
 
4109
;;                    (:instance near-exactp-c)
 
4110
;;                    (:instance near+-exactp-c)))))
 
4111
 
 
4112
 
 
4113
;; (defthmd rnd-exactp-d
 
4114
;;     (implies (and (rationalp x)
 
4115
;;                (common-rounding-mode-p mode)
 
4116
;;                (integerp n)
 
4117
;;                (> n 0)
 
4118
;;                (rationalp a)
 
4119
;;                (exactp a n)
 
4120
;;                (<= a x))
 
4121
;;           (<= a (rnd x mode n)))
 
4122
;;     :hints (("Goal" :in-theory (enable away-minus 
 
4123
;;                                        ieee-mode-p flip rnd)
 
4124
;;              :use ((:instance trunc-exactp-c)
 
4125
;;                    (:instance away-exactp-c
 
4126
;;                               (x (* -1 x)) (a (* -1 a)))
 
4127
;;                    (:instance near-exactp-d)
 
4128
;;                    (:instance near+-exactp-d)))))
 
4129
 
 
4130
 
 
4131
;; (defthm rnd<=away
 
4132
;;     (implies (and (rationalp x)
 
4133
;;                (>= x 0)
 
4134
;;                (common-rounding-mode-p mode)
 
4135
;;                (natp n))
 
4136
;;           (<= (rnd x mode n) (away x n)))
 
4137
;;     :hints (("Goal" :in-theory (enable ieee-mode-p
 
4138
;;                                        near near+
 
4139
;;                                        minf inf
 
4140
;;                                        trunc-upper-pos
 
4141
;;                                        away-lower-pos
 
4142
;;                                        flip rnd)))
 
4143
;;   :rule-classes ())
 
4144
 
 
4145
 
 
4146
 
 
4147
;; (defthm rnd>=trunc
 
4148
;;     (implies (and (rationalp x)
 
4149
;;                (>= x 0)
 
4150
;;                (common-rounding-mode-p mode)
 
4151
;;                (natp n))
 
4152
;;           (>= (rnd x mode n) (trunc x n)))
 
4153
;;     :hints (("Goal" :in-theory (enable ieee-mode-p
 
4154
;;                                        near near+
 
4155
;;                                        inf minf
 
4156
;;                                        common-rounding-mode-p
 
4157
;;                                        trunc-upper-pos
 
4158
;;                                        away-lower-pos
 
4159
;;                                        flip rnd)))
 
4160
;;   :rule-classes ())
 
4161
 
 
4162
 
 
4163
;; (defthmd rnd-diff
 
4164
;;   (implies (and (rationalp x)
 
4165
;;                 (integerp n)
 
4166
;;                 (> n 0)
 
4167
;;                 (common-rounding-mode-p mode))
 
4168
;;            (< (abs (- x (rnd x mode n))) (expt 2 (- (1+ (expo x)) n))))
 
4169
;;   :hints (("Goal" :use ((:instance rnd-diff---rtl-rel5-support)))))
 
4170
 
 
4171
;; (i-am-here) ;; Fri Oct 13 15:29:42 2006
 
4172
 
 
4173
;; (defthm expo-rnd
 
4174
;;     (implies (and (rationalp x)
 
4175
;;                (integerp n)
 
4176
;;                (> n 0)
 
4177
;;                (common-rounding-mode-p mode)
 
4178
;;                (not (= (abs (rnd x mode n))
 
4179
;;                        (expt 2 (1+ (expo x))))))
 
4180
;;           (= (expo (rnd x mode n))
 
4181
;;              (expo x)))
 
4182
;;   :hints (("Goal" :use ((:instance expo-rnd---rtl-rel5-support))))
 
4183
;;   :rule-classes ())
 
4184
 
 
4185
 
 
4186
;; (encapsulate ()
 
4187
 
 
4188
;; (local 
 
4189
;;  (defthm |Subgoal 5|
 
4190
;;    (IMPLIES (AND (RATIONALP X)
 
4191
;;                  (RATIONALP Y)
 
4192
;;                  (INTEGERP N)
 
4193
;;                  (<= 0 N)
 
4194
;;                  (<= 0 Y)
 
4195
;;                  (< X 0))
 
4196
;;             (<= (TRUNC X N) (AWAY Y N)))
 
4197
;;    :hints (("Goal" :cases ((not (equal y 0)))
 
4198
;;             :in-theory (enable trunc-negative sgn
 
4199
;;                                away-positive)))
 
4200
;;    :rule-classes :linear))
 
4201
 
 
4202
 
 
4203
 
 
4204
;; ;; (defthm near+-monotone
 
4205
;; ;;   (implies (and (<= x y)
 
4206
;; ;;                 (rationalp x)
 
4207
;; ;;                 (rationalp y)
 
4208
;; ;;                 (< 0 x)    ;;; not good enough!!! 
 
4209
;; ;;                 (integerp n)
 
4210
;; ;;                 (> n 0))   
 
4211
;; ;;            (<= (near+ x n) (near+ y n))))
 
4212
 
 
4213
 
 
4214
;; (defthmd rnd-monotone
 
4215
;;     (implies (and (<= x y)
 
4216
;;                   (rationalp x)
 
4217
;;                (rationalp y)
 
4218
;;                (common-rounding-mode-p mode)
 
4219
;;                   (integerp n)
 
4220
;;                   (> n 0))
 
4221
;;           (<= (rnd x mode n) (rnd y mode n)))
 
4222
;;     :hints (("Goal" :in-theory (enable ieee-mode-p
 
4223
;;                                        common-rounding-mode-p
 
4224
;;                                 trunc-positive
 
4225
;;                                 trunc-negative
 
4226
;;                                 away-positive
 
4227
;;                                 away-negative
 
4228
;;                                 away-monotone
 
4229
;;                                 trunc-monotone
 
4230
;;                                 near-monotone
 
4231
;;                                 near+-monotone
 
4232
;;                                 flip rnd)
 
4233
;;              :use ((:instance away-monotone)))))
 
4234
 
 
4235
;; )
 
4236
 
 
4237
 
 
4238
;; (defthm rnd-shift
 
4239
;;     (implies (and (rationalp x)
 
4240
;;                (integerp n)
 
4241
;;                (common-rounding-mode-p mode)
 
4242
;;                (integerp k))
 
4243
;;           (= (rnd (* x (expt 2 k)) mode n)
 
4244
;;              (* (rnd x mode n) (expt 2 k))))
 
4245
;;     :hints (("Goal" :use ((:instance rnd-shift---rtl-rel5-support))))
 
4246
;;   :rule-classes ())
 
4247
 
 
4248
 
 
4249
;; (defthm plus-rnd
 
4250
;;   (implies (and (rationalp x)
 
4251
;;                 (>= x 0)
 
4252
;;                 (rationalp y)
 
4253
;;                 (>= y 0)
 
4254
;;                 (integerp k)
 
4255
;;                 (exactp x (+ -1 k (- (expo x) (expo y))))
 
4256
;;                 (common-rounding-mode-p mode))
 
4257
;;            (= (+ x (rnd y mode k))
 
4258
;;               (rnd (+ x y)
 
4259
;;                    mode
 
4260
;;                    (+ k (- (expo (+ x y)) (expo y))))))
 
4261
;;   :hints (("Goal" :use ((:instance plus-rnd---rtl-rel5-support))))
 
4262
;;   :rule-classes ())
 
4263
 
 
4264
 
 
4265
;; (defthmd rnd-sticky
 
4266
;;   (implies (and (common-rounding-mode-p mode)
 
4267
;;                 (rationalp x)
 
4268
;;                 (integerp m) 
 
4269
;;              (> m 0)
 
4270
;;                 (integerp n) 
 
4271
;;              (>= n (+ m 2)))
 
4272
;;            (equal (rnd (sticky x n) mode m)
 
4273
;;                   (rnd x mode m)))
 
4274
;;   :hints (("Goal" :cases ((not (equal x 0)))
 
4275
;;            :in-theory (enable rnd-minus flip rnd sticky-minus))
 
4276
;;           ("Subgoal 1" :cases ((not (> x 0))))
 
4277
;;           ("Subgoal 1.2" 
 
4278
;;            :use ((:instance rnd-sticky---rtl-rel5-support
 
4279
;;                                         (k m))))
 
4280
;;           ("Subgoal 1.1" 
 
4281
;;            :use ((:instance rnd-sticky---rtl-rel5-support
 
4282
;;                                         (k m)
 
4283
;;                                         (mode (flip mode))
 
4284
;;                                         (x (* -1 x)))))))
 
4285
 
 
4286
 
 
4287
 
 
4288
 
 
4289
;; (defun rnd-const (e mode n)
 
4290
;;   (case mode
 
4291
;;     ((near near+) (expt 2 (- e n)))
 
4292
;;     ((inf away) (1- (expt 2 (1+ (- e n)))))
 
4293
;;     (otherwise 0)))
 
4294
 
 
4295
 
 
4296
;; (defthm rnd-const-thm
 
4297
;;     (implies (and (common-rounding-mode-p mode)
 
4298
;;                (integerp n)
 
4299
;;                (> n 1)
 
4300
;;                (integerp x)
 
4301
;;                (> x 0)
 
4302
;;                (>= (expo x) n))
 
4303
;;           (= (rnd x mode n)
 
4304
;;              (if (and (eql mode 'near)
 
4305
;;                       (exactp x (1+ n))
 
4306
;;                       (not (exactp x n)))
 
4307
;;                  (trunc (+ x (rnd-const (expo x) mode n)) (1- n))
 
4308
;;                (trunc (+ x (rnd-const (expo x) mode n)) n))))
 
4309
;;     :hints (("Goal" :use rnd-const-thm---rtl-rel5-support))
 
4310
;;   :rule-classes ())
 
4311
 
 
4312
 
 
4313
;; (defun roundup (x mode n)
 
4314
;;   (case mode
 
4315
;;     (near+ (= (bitn x (- (expo x) n)) 1))
 
4316
;;     (near (and (= (bitn x (- (expo x) n)) 1)
 
4317
;;                (or (not (exactp x (1+ n)))
 
4318
;;                    (= (bitn x (- (1+ (expo x)) n)) 1))))
 
4319
;;     ((inf away) (not (exactp x n)))
 
4320
;;     (otherwise ())))
 
4321
 
 
4322
 
 
4323
;; (defthm roundup-thm
 
4324
;;     (implies (and (common-rounding-mode-p mode)
 
4325
;;                (integerp n)
 
4326
;;                (> n 1)
 
4327
;;                (integerp x)
 
4328
;;                (> x 0)
 
4329
;;                (>= (expo x) n))
 
4330
;;           (= (rnd x mode n)
 
4331
;;                 (if (roundup x mode n)
 
4332
;;                     (fp+ (trunc x n) n)
 
4333
;;                   (trunc x n))))
 
4334
;;     :hints (("Goal" :use roundup-thm---rtl-rel5-support))
 
4335
;;   :rule-classes ())
 
4336
 
 
4337
;;;
 
4338
;;; very nice theorems!! good!! Tue Jan 31 16:37:49 2006
 
4339
;;; relating bits and their rounded values!! 
 
4340
;;;
 
4341
 
 
4342
;;; Sun Oct 15 16:41:11 2006
 
4343
 
 
4344
;; (i-am-here) ;; Sun Oct 15 17:00:23 2006
 
4345
 
 
4346
;;;**********************************************************************
 
4347
;;;                         Denormal Rounding 
 
4348
;;;**********************************************************************
 
4349
 
 
4350
;;; because of the drnd definition changed, we abandon all the proofs in
 
4351
;;; lib/round.lisp
 
4352
;;;
 
4353
;;; we could prove that two definitions are the same thus reuse the older
 
4354
;;; proofs!
 
4355
 
 
4356
(defund drnd (x mode p q)
 
4357
  (rnd x mode (+ p (expo x) (- (expo (spn q))))))
 
4358
 
 
4359
(defthmd drnd-minus
 
4360
  (equal (drnd (* -1 x) mode p q)
 
4361
         (* -1 (drnd x (flip mode) p q)))
 
4362
  :hints (("Goal" :in-theory (enable drnd expo-minus  rnd-minus))))
 
4363
 
 
4364
;----------------------------------------------------------------------
 
4365
 
 
4366
(local 
 
4367
 (encapsulate ()
 
4368
 
 
4369
       (include-book "../../arithmetic/expt")
 
4370
       (local 
 
4371
          (defthm fl-1/2-sig-x-is-zero-lemma
 
4372
            (implies (and (rationalp x)
 
4373
                          (rationalp y)
 
4374
                          (< 0 y)
 
4375
                          (<= y 1/2))
 
4376
                     (equal (fl (* (sig x) y))
 
4377
                            0))
 
4378
            :hints (("Goal" :use ((:instance sig-upper-bound)
 
4379
                                  (:instance sig-lower-bound))))))
 
4380
 
 
4381
       ;; we really need these two lemma
 
4382
       (defthm fl-1/2-sig-x-is-zero-lemma-2
 
4383
         (implies (and (rationalp x)
 
4384
                       (rationalp y)
 
4385
                       (not (equal x 0))
 
4386
                       (< 0 y)
 
4387
                       (<= y 1/2))
 
4388
                  (equal (fl (* -1 (sig x) y))
 
4389
                         -1))
 
4390
         :hints (("Goal" :in-theory (enable sig fl-minus)
 
4391
                  :use ((:instance fl-1/2-sig-x-is-zero-lemma)))))
 
4392
 
 
4393
       (defthm expt-2-no-greater-than-1 
 
4394
            (implies (and (<= (+ p (expo x))
 
4395
                              (expo (spn q)))
 
4396
                          (integerp p))
 
4397
                     (<= (* 2
 
4398
                            (EXPT 2
 
4399
                                  (+ -1 P (EXPO X)
 
4400
                                     (* -1 (EXPO (SPN Q))))))
 
4401
                         1))
 
4402
            :hints (("Goal" :use ((:instance expt-weak-monotone-linear
 
4403
                                             (n (+ -1 P (EXPO X)
 
4404
                                                   (* -1 (EXPO (SPN Q)))))
 
4405
                                             (m -1)))))
 
4406
            :rule-classes :linear)
 
4407
 
 
4408
       (defthm fl-1/2-sig-x-is-zero
 
4409
           (implies (and (rationalp x)
 
4410
                         (case-split (not (equal x 0)))
 
4411
                         (integerp p)
 
4412
                         (<= (+ p (expo x))
 
4413
                             (expo (spn q))))
 
4414
                    (equal (FL (* (SIG X)
 
4415
                                  (EXPT 2
 
4416
                                        (+ -1 P (EXPO X)
 
4417
                                           (* -1 (EXPO (SPN Q)))))))
 
4418
                           0))
 
4419
           :hints (("Goal" :use ((:instance fl-1/2-sig-x-is-zero-lemma
 
4420
                                            (y (EXPT 2
 
4421
                                                     (+ -1 P (EXPO X) 
 
4422
                                                        (* -1 (EXPO (SPN q)))))))))))
 
4423
 
 
4424
 
 
4425
       (defthm fl-1/2-sig-x-is-zero-2
 
4426
           (implies (and (rationalp x)
 
4427
                         (case-split (not (equal x 0)))
 
4428
                         (integerp p)
 
4429
                         (<= (+ p (expo x))
 
4430
                             (expo (spn q))))
 
4431
                    (equal (FL (* -1 (SIG X)
 
4432
                                  (EXPT 2
 
4433
                                        (+ -1 P (EXPO X)
 
4434
                                           (* -1 (EXPO (SPN Q)))))))
 
4435
                           -1))
 
4436
           :hints (("Goal" :use ((:instance fl-1/2-sig-x-is-zero-lemma-2
 
4437
                                            (y (EXPT 2
 
4438
                                                     (+ -1 P (EXPO X) 
 
4439
                                                        (* -1 (EXPO (SPN q)))))))))))))
 
4440
 
 
4441
 
 
4442
;----------------------------------------------------------------------
 
4443
 
 
4444
(encapsulate () 
 
4445
 
 
4446
 
 
4447
;;; prove the first condition in drepp 
 
4448
             ;;
 
4449
             ;;L d            (DEFUN DREPP (X P Q)
 
4450
             ;;                      (AND (RATIONALP X)
 
4451
             ;;                           (NOT (= X 0))
 
4452
             ;;                           (<= (- 2 P) (+ (EXPO X) (BIAS Q)))
 
4453
             ;;                           (<= (+ (EXPO X) (BIAS Q)) 0)
 
4454
             ;;                           (EXACTP X (+ -2 P (EXPT 2 (- Q 1)) (EXPO X)))))
 
4455
 
 
4456
             (local (encapsulate ()
 
4457
;;;;
 
4458
;;;;          (<= (+ (EXPO X) (BIAS Q)) 0)  if x < (spn q)
 
4459
;;;; 
 
4460
                                 (local
 
4461
                                  (defthm expo-less-than-minus-1-lemma
 
4462
                                    (IMPLIES (AND (< N (EXPO X))
 
4463
                                                  (< 0 X)
 
4464
                                                  (integerp n)
 
4465
                                                  (RATIONALP X))
 
4466
                                             (<= (EXPT 2 (+ 1 N)) X))
 
4467
                                    :hints (("Goal" :use ((:instance expt-weak-monotone-linear
 
4468
                                                                     (n (+ 1 n))
 
4469
                                                                     (m (expo x)))
 
4470
                                                          (:instance expo-lower-bound))))))
 
4471
 
 
4472
                                 (local
 
4473
                                  (defthm expo-less-than-minus-1
 
4474
                                    (implies (and (< 0 x)
 
4475
                                                  (integerp n)
 
4476
                                                  (rationalp x)
 
4477
                                                  (< X (EXPT 2 (+ 1 n))))
 
4478
                                             (<= (expo x) n))
 
4479
                                    :hints (("Goal" :cases ((> (expo x) n))))
 
4480
                                    :rule-classes :linear))
 
4481
 
 
4482
                                 (defthm less-than-spn-implies-expo-less
 
4483
                                   (implies (and (< (abs x) (spn q))
 
4484
                                                 (> q 0)
 
4485
                                                 (> x 0)
 
4486
                                                 (integerp q)
 
4487
                                                 (rationalp x))
 
4488
                                            (>= 0 (+ (bias q) (expo x))))
 
4489
                                   :hints (("Goal" :in-theory (enable spn expo-minus)
 
4490
                                            :use ((:instance expo-monotone (x (abs x)) (y (spn q))))))
 
4491
                                   :rule-classes :linear))
 
4492
 
 
4493
                    ) ;;; END OF    (<= (+ (EXPO X) (BIAS Q)) 0)  if x < (spn q)
 
4494
 
 
4495
 
 
4496
             (local (encapsulate () 
 
4497
 
 
4498
;;;
 
4499
;;;     (EXACTP X (+ -2 P (EXPT 2 (- Q 1)) (EXPO X)))))
 
4500
;;;
 
4501
 
 
4502
                                 (defthm exactp-drnd-specific
 
4503
                                   (implies (and (rationalp x)
 
4504
                                                 (> (+ p (expo x))
 
4505
                                                    (expo (spn q)))
 
4506
                                                 (integerp p)
 
4507
                                                 (integerp q)
 
4508
                                                 (> q 0))
 
4509
                                            (EXACTP (DRND X MODE P Q)
 
4510
                                                    (+ -2 P (EXPO X) (EXPT 2 (+ -1 Q)))))
 
4511
                                   :hints (("Goal" :in-theory (enable drnd spn bias)
 
4512
                                            :use ((:instance RND-EXACTP-A
 
4513
                                                             (X x) (mode MODE)
 
4514
                                                             (n (+ -1 P (BIAS Q) (EXPO X)))))))))
 
4515
                    ) ;;; END OF  (EXACTP X (+ -2 P (EXPT 2 (- Q 1)) (EXPO X)))))
 
4516
 
 
4517
 
 
4518
 
 
4519
             (local (encapsulate () 
 
4520
 
 
4521
                                 (local
 
4522
                                  (defthm expt-equal-specific-lemma
 
4523
                                    (implies (and (EQUAL 0 (+ y x))
 
4524
                                                  (integerp x)
 
4525
                                                  (integerp y))
 
4526
                                             (equal (expt 2 (+ 1 x))
 
4527
                                                    (expt 2 (+ 1 (* -1 y)))))
 
4528
                                    :hints (("Goal" :cases ((equal x (* -1 y)))))))
 
4529
 
 
4530
 
 
4531
                                 (defthm expt-equal-specific
 
4532
                                   (implies (and (EQUAL 0 (+ (BIAS Q) (EXPO X)))
 
4533
                                                 (rationalp x)
 
4534
                                                 (integerp q)
 
4535
                                                 (> q 0))
 
4536
                                            (equal (expt 2 (+ 1 (expo x)))
 
4537
                                                   (expt 2 (+ 1 (* -1 (bias q))))))
 
4538
                                   :hints (("Goal" :cases ((equal (expo x)
 
4539
                                                                  (* -1 (bias q)))))))
 
4540
                                 )) ;; don't know why we need this. 
 
4541
 
 
4542
 
 
4543
 
 
4544
 
 
4545
             (local (encapsulate () 
 
4546
 
 
4547
                                 (defthm minus-expt-reduce
 
4548
                                   (implies (and (integerp p)
 
4549
                                                 (integerp q)
 
4550
                                                 (> q 0)
 
4551
                                                 (rationalp x))
 
4552
                                            (equal (+ -1 P (EXPO X) (EXPT 2 (+ -1 Q)))
 
4553
                                                   (+ 1 p (expo x) (* -1 (expo (spn q))))))
 
4554
                                   :hints (("Goal" :in-theory (enable spn bias expo-2**n))))
 
4555
 
 
4556
 
 
4557
                                 ))
 
4558
 
 
4559
             (local (encapsulate ()
 
4560
;;;
 
4561
;;;           (<= (- 2 P) (+ (EXPO X) (BIAS Q)))
 
4562
;;;
 
4563
                                 (defthm p-expo-x-expo-spn
 
4564
                                   (implies (and (> (+ p (expo x))
 
4565
                                                    (expo (spn q)))
 
4566
                                                 (rationalp x)
 
4567
                                                 (integerp p)
 
4568
                                                 (integerp q)
 
4569
                                                 (> q 0))
 
4570
                                            (>= (+ (BIAS Q) (EXPO x))
 
4571
                                                (+ 2 (* -1 p))))
 
4572
                                   :hints (("Goal" :in-theory (enable spn)))
 
4573
                                   :rule-classes :linear))
 
4574
 
 
4575
                    ) ;;;  END OF          (<= (- 2 P) (+ (EXPO X) (BIAS Q)))
 
4576
 
 
4577
 
 
4578
             (local
 
4579
              (defthm drnd-exactp-a-lemma
 
4580
                (implies (and (rationalp x)
 
4581
                              (< (EXPO (SPN Q)) (+ P (EXPO X)))
 
4582
                              (> x 0)
 
4583
                              (< (abs x) (spn q))
 
4584
                              (integerp p)
 
4585
                              (> p 1)
 
4586
                              (integerp q)
 
4587
                              (> q 0)
 
4588
                              (common-rounding-mode-p mode))
 
4589
                         (or (drepp (drnd x mode p q) p q)
 
4590
                             (= (drnd x mode p q) 0)
 
4591
                             (= (drnd x mode p q) (* (sgn x) (spn q)))))
 
4592
                :rule-classes ()
 
4593
                :hints (("Goal"  :in-theory (e/d (drepp rnd) ())
 
4594
                         :do-not '(fertilize)
 
4595
                         :cases ((not (equal (expo (drnd x mode p q)) (expo x)))))
 
4596
                        ("Subgoal 2" :use ((:instance less-than-spn-implies-expo-less)))
 
4597
                        ("Subgoal 1" :in-theory (enable drepp exactp-2**n)
 
4598
                         :cases ((not (equal (drnd x mode p q) (expt 2 (+ 1 (expo x)))))))
 
4599
                        ("Subgoal 1.2" :cases ((not (equal (expo x) (* -1 (bias q))))))
 
4600
                        ("Subgoal 1.2.2" :in-theory (enable sgn spn))
 
4601
                        ("Subgoal 1.2.1" :use ((:instance less-than-spn-implies-expo-less)))
 
4602
                        ("Subgoal 1.1" :in-theory (enable drnd)
 
4603
                         :use ((:instance expo-rnd
 
4604
                                          (n (+ P (EXPO X) (- (EXPO (SPN Q)))))))))))
 
4605
 
 
4606
 
 
4607
             (defthm drepp-minus
 
4608
               (implies (and (rationalp x)
 
4609
                             (integerp p)
 
4610
                             (integerp q))
 
4611
                        (equal (drepp (* -1 x) p q)
 
4612
                               (drepp x p q)))
 
4613
               :hints (("Goal" :in-theory (enable expo-minus drepp))))
 
4614
 
 
4615
             (encapsulate ()
 
4616
                          (local 
 
4617
                           (defthm bias-expo-reduce
 
4618
                             (implies (and (integerp q)
 
4619
                                           (> q 0))
 
4620
                                      (equal (+ (bias q) (expo (spn q)))
 
4621
                                             1))
 
4622
                             :hints (("Goal" :in-theory (enable spn)))))
 
4623
         
 
4624
                          (local
 
4625
                           (defthm integerp-less-than
 
4626
                             (implies (and (integerp p)
 
4627
                                           (integerp q)
 
4628
                                           (> q 0)
 
4629
                                           (> p 1))
 
4630
                                      (<= (+ 1 (BIAS Q) (* -1 P) (EXPO (SPN Q))) 0))
 
4631
                             :hints (("Goal" :in-theory (enable spn)))
 
4632
                             :rule-classes :linear))
 
4633
 
 
4634
                          (local
 
4635
                           (defthm exactp-fact
 
4636
                             (implies (and (integerp p)
 
4637
                                           (integerp q)
 
4638
                                           (> q 0)
 
4639
                                           (> p 1))
 
4640
                                      (EXACTP (EXPT 2 (+ 1 (* -1 P) (EXPO (SPN Q))))
 
4641
                                              (+ -1 (EXPO (SPN Q))
 
4642
                                                 (EXPT 2 (+ -1 Q)))))
 
4643
                             :hints (("Goal" :in-theory (enable spn exactp-2**n bias)))))
 
4644
 
 
4645
 
 
4646
 
 
4647
                          (local 
 
4648
                           (defthm expt-2-no-greater-than-2
 
4649
                             (implies (and (integerp q)
 
4650
                                           (> q 0))
 
4651
                                      (<= (EXPT 2
 
4652
                                                (+ 1 (* -1 q)))
 
4653
                                          1))
 
4654
                             :hints (("Goal" :use ((:instance expt-weak-monotone-linear
 
4655
                                                              (n (+ 1 (* -1 q)))
 
4656
                                                              (m 0)))))
 
4657
                             :rule-classes :linear))
 
4658
 
 
4659
             (defthm exactp-spn-p
 
4660
               (implies (and (integerp p)
 
4661
                             (integerp q)
 
4662
                             (> q 0)
 
4663
                             (> p 1))
 
4664
                        (exactp (spn q) p))
 
4665
               :hints (("Goal" :in-theory (enable spn
 
4666
                                                  exactp-2**n))))
 
4667
 
 
4668
 
 
4669
 
 
4670
 
 
4671
             
 
4672
             (defthm local-rewrite-hack
 
4673
               (implies (and (equal (+ x (spn q)) 0)
 
4674
                             (< (EXPO (SPN Q)) (+ P (EXPO X)))
 
4675
                             (common-rounding-mode-p mode)
 
4676
                             (integerp p)
 
4677
                             (integerp q)
 
4678
                             (> p 1)
 
4679
                             (> q 0))
 
4680
                        (EQUAL (+ (SPN Q)
 
4681
                                  (RND X MODE
 
4682
                                       (+ P (EXPO X)
 
4683
                                          (* -1 (EXPO (SPN Q))))))
 
4684
                               0))
 
4685
               :hints (("Goal" :cases ((not (equal x (* -1 (spn
 
4686
                                                            q)))))
 
4687
                        :in-theory (enable rnd-exactp-b
 
4688
                                           expo-minus
 
4689
                                           rnd-minus))))
 
4690
 
 
4691
 
 
4692
 
 
4693
               (defthm drnd-exactp-a1
 
4694
                 (implies (and (rationalp x)
 
4695
                               (<= (abs x) (spn q))
 
4696
                               (integerp p)
 
4697
                               (> p 1)
 
4698
                               (integerp q)
 
4699
                               (> q 0)
 
4700
                               (common-rounding-mode-p mode))
 
4701
                          (or (drepp (drnd x mode p q) p q)
 
4702
                              (= (drnd x mode p q) 0)
 
4703
                              (= (drnd x mode p q) (* (sgn x) (spn q)))))
 
4704
                 :hints (("Goal" :in-theory (enable rnd-minus drepp-minus
 
4705
                                                    sgn 
 
4706
                                                    flip drnd rnd-exactp-b
 
4707
                                                    expo-minus sgn-minus)
 
4708
                          :cases ((not (<= (+ p (expo x) (- (expo (spn q))))
 
4709
                                           0))))
 
4710
                         ("Subgoal 2" :in-theory (enable drepp  expo-minus sgn
 
4711
                                                         drnd near near+ 
 
4712
                                                         away cg rnd))
 
4713
                         ("Subgoal 1" :cases ((not (equal x 0))))
 
4714
                         ("Subgoal 1.2" :in-theory (enable drnd))
 
4715
                         ("Subgoal 1.1" :cases ((not (> x 0))))
 
4716
                         ("Subgoal 1.1.2" :use ((:instance drnd-exactp-a-lemma)))
 
4717
                         ("Subgoal 1.1.1" :use ((:instance drnd-exactp-a-lemma
 
4718
                                                           (x (* -1 x))
 
4719
                                                           (mode (flip
 
4720
                                                                  mode)))
 
4721
                                                (:instance rnd-exactp-b
 
4722
                                                           (x (* -1 x))
 
4723
                                                           (mode (flip mode))))))
 
4724
                 :rule-classes ()))
 
4725
 
 
4726
 
 
4727
 
 
4728
         (defthm drnd-exactp-a
 
4729
           (implies (and (rationalp x)
 
4730
                         (<= (abs x) (spn q))
 
4731
                         (integerp p)
 
4732
                         (> p 1)
 
4733
                         (integerp q)
 
4734
                         (> q 0)
 
4735
                         (common-rounding-mode-p mode))
 
4736
                    (or (drepp (drnd x mode p q) p q)
 
4737
                        (= (drnd x mode p q) 0)
 
4738
                        (= (drnd x mode p q) (* (sgn x) (spn q)))))
 
4739
           :hints (("Goal" :cases ((not (equal (abs x) (spn q))))
 
4740
                    :in-theory (enable sgn drnd rnd-minus expo-minus))
 
4741
                   ("Subgoal 2" :cases ((equal x (spn q))
 
4742
                                        (equal x (* -1 (spn q)))))
 
4743
                   ("Subgoal 1" :use drnd-exactp-a1))
 
4744
           :rule-classes ())
 
4745
 
 
4746
 
 
4747
             ) ;; end of drnd-exactp-a
 
4748
 
 
4749
;;; 
 
4750
;;; extremely bad proof!! 
 
4751
;;;
 
4752
;;; We could resolve to mid-range, small-range, large range. 
 
4753
;;;
 
4754
 
 
4755
(defthmd drnd-exactp-b
 
4756
     (implies (and (rationalp x)
 
4757
                (drepp x p q)
 
4758
                   (integerp p)
 
4759
                   (> p 1)
 
4760
                   (integerp q)
 
4761
                   (> q 0)
 
4762
                   (common-rounding-mode-p mode))
 
4763
              (equal (drnd x mode p q)
 
4764
                     x))
 
4765
     :hints (("Goal" :in-theory (e/d (drepp spn bias drnd)
 
4766
                                     (common-rounding-mode-p))
 
4767
              :use ((:instance rnd-exactp-b
 
4768
                               (n (+ P (EXPO X) (- (EXPO (SPN Q))))))))))
 
4769
 
 
4770
 
 
4771
;----------------------------------------------------------------------
 
4772
 
 
4773
 
 
4774
 
 
4775
(defthm drnd-trunc
 
4776
  (implies (and (integerp p)
 
4777
                (> p 1)
 
4778
                (integerp q)
 
4779
                (> q 0)
 
4780
                (rationalp x)
 
4781
                (<= (abs x) (spn q)))
 
4782
           (<= (abs (drnd x 'trunc p q))
 
4783
               (abs x)))
 
4784
  :hints (("Goal" :in-theory (enable drnd rnd)
 
4785
           :use ((:instance trunc-upper-bound 
 
4786
                            (x x)
 
4787
                            (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))))))
 
4788
 
 
4789
(defthm drnd-away
 
4790
  (implies (and (integerp p)
 
4791
                (> p 1)
 
4792
                (integerp q)
 
4793
                (> q 0)
 
4794
                (rationalp x)
 
4795
                (<= (abs x) (spn q)))
 
4796
           (>= (abs (drnd x 'away p q))
 
4797
               (abs x)))
 
4798
  :hints (("Goal" :in-theory (enable drnd rnd)
 
4799
           :use ((:instance away-lower-bound
 
4800
                            (x x)
 
4801
                            (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))))))
 
4802
 
 
4803
(defthm drnd-minf
 
4804
  (implies (and (integerp p)
 
4805
                (> p 1)
 
4806
                (integerp q)
 
4807
                (> q 0)
 
4808
                (rationalp x)
 
4809
                (<= (abs x) (spn q)))
 
4810
           (<= (drnd x 'minf p q)
 
4811
               x))
 
4812
    :hints (("Goal" :in-theory (enable drnd rnd)
 
4813
           :use ((:instance minf-lower-bound
 
4814
                            (x x)
 
4815
                            (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))))))
 
4816
 
 
4817
 
 
4818
 
 
4819
(defthm drnd-inf
 
4820
  (implies (and (integerp p)
 
4821
                (> p 1)
 
4822
                (integerp q)
 
4823
                (> q 0)
 
4824
                (rationalp x)
 
4825
                (<= (abs x) (spn q)))
 
4826
           (>= (drnd x 'inf p q)
 
4827
               x))
 
4828
    :hints (("Goal" :in-theory (enable drnd rnd)
 
4829
           :use ((:instance inf-lower-bound
 
4830
                            (x x)
 
4831
                            (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))))))
 
4832
 
 
4833
 
 
4834
 
 
4835
;----------------------------------------------------------------------
 
4836
 
 
4837
 
 
4838
(local 
 
4839
 (defthm exactp-c-lemma-1
 
4840
   (IMPLIES (AND (RATIONALP X)
 
4841
                 (< 0 X)
 
4842
                 (<= X (SPN Q))
 
4843
                 (RATIONALP A)
 
4844
                 (DREPP A P Q)
 
4845
                 (<= X A)
 
4846
                 (INTEGERP P)
 
4847
                 (< 1 P)
 
4848
                 (INTEGERP Q)
 
4849
                 (< 0 Q))
 
4850
            (<= (TRUNC X (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))
 
4851
                A))
 
4852
      :hints (("Goal" 
 
4853
               :use ((:instance trunc-upper-bound 
 
4854
                                (x x)
 
4855
                                (n (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))))
 
4856
      :rule-classes :linear))
 
4857
 
 
4858
 
 
4859
;; (i-am-here) ;; Sun Oct 15 17:16:34 2006
 
4860
 
 
4861
 
 
4862
(local 
 
4863
   (encapsulate ()
 
4864
 
 
4865
      (local 
 
4866
       (encapsulate () 
 
4867
         (local (include-book "float-extra2"))               
 
4868
           (defthmd spd-mult
 
4869
             (implies (and (integerp p)
 
4870
                           (> p 1)
 
4871
                           (integerp q)
 
4872
                           (> q 0)
 
4873
                           (> r 0)
 
4874
                        (rationalp r)
 
4875
                        (= m (/ r (spd p q))))
 
4876
                   (iff (drepp r p q)
 
4877
                        (and (natp m)
 
4878
                             (<= 1 m)
 
4879
                             (< m (expt 2 (1- p)))))))))
 
4880
 
 
4881
      (local 
 
4882
         (defthm equal-spd
 
4883
           (implies (and (integerp p)
 
4884
                         (integerp q)
 
4885
                         (> p 1)
 
4886
                         (> q 0))
 
4887
                    (equal (spd p q)
 
4888
                           (EXPT 2 (+ 1 (* -1 P) (EXPO (SPN Q))))))
 
4889
           :hints (("Goal" :in-theory (enable spd spn bias)))))
 
4890
 
 
4891
      (local 
 
4892
           (defund denormal-norm (r p q)
 
4893
             (/ r (spd p q))))
 
4894
 
 
4895
      (local
 
4896
          (defthm spd-mult-specific
 
4897
            (implies (and (integerp p)
 
4898
                          (> p 1)
 
4899
                          (integerp q)
 
4900
                          (> q 0)
 
4901
                          (> r 0)
 
4902
                          (rationalp r))
 
4903
                     (= r (* (denormal-norm r p q) (spd p q))))
 
4904
            :hints (("Goal" :in-theory (enable denormal-norm)))
 
4905
            :rule-classes nil))
 
4906
 
 
4907
      (local 
 
4908
          (defthm drepp-implies-denormal-norm-integerp
 
4909
            (implies (and (drepp r p q)
 
4910
                          (integerp p)
 
4911
                          (> p 1)
 
4912
                          (integerp q)
 
4913
                          (> q 0)
 
4914
                          (> r 0)
 
4915
                          (rationalp r))
 
4916
                     (integerp (denormal-norm r p q)))
 
4917
            :hints (("Goal" :use ((:instance spd-mult
 
4918
                                             (m (denormal-norm r p q)))
 
4919
                                  (:instance spd-mult-specific))))
 
4920
            :rule-classes :type-prescription))
 
4921
 
 
4922
 
 
4923
      (local 
 
4924
          (defthm drepp-implies-denormal-norm-less-than
 
4925
            (implies (and (drepp r p q)
 
4926
                          (integerp p)
 
4927
                          (> p 1)
 
4928
                          (integerp q)
 
4929
                          (> q 0)
 
4930
                          (> r 0)
 
4931
                          (rationalp r))
 
4932
                     (<= (denormal-norm r p q)
 
4933
                         (+ -1 (expt 2 (+ -1 p)))))
 
4934
            :hints (("Goal" :use ((:instance spd-mult
 
4935
                                             (m (denormal-norm r p q)))
 
4936
                                  (:instance spd-mult-specific))))
 
4937
            :rule-classes :linear))
 
4938
 
 
4939
      (local
 
4940
          (defthm denormal-normal-monotone
 
4941
            (implies (and (< r1 r2)
 
4942
                          (integerp (denormal-norm r1 p q))
 
4943
                          (integerp (denormal-norm r2 p q)))
 
4944
                     (<= (+ 1 (denormal-norm r1 p q))
 
4945
                         (denormal-norm r2 p q)))
 
4946
            :hints (("Goal" :in-theory (enable spd denormal-norm)))
 
4947
            :rule-classes :linear))
 
4948
 
 
4949
      (local 
 
4950
      (defthm drepp-diff
 
4951
           (implies (and (rationalp r1)
 
4952
                         (rationalp r2)
 
4953
                         (> r1 r2)
 
4954
                         (> r2 0)
 
4955
                         (integerp p)
 
4956
                         (integerp q)
 
4957
                         (> p 1)
 
4958
                         (> q 0)
 
4959
                         (drepp r1 p q)
 
4960
                         (drepp r2 p q))
 
4961
                    (<= (+ r2 (EXPT 2 (+ 1 (* -1 P) (EXPO (SPN Q)))))
 
4962
                        r1))
 
4963
           :hints (("Goal" :use ((:instance spd-mult-specific
 
4964
                                            (r r1))
 
4965
                                 (:instance spd-mult-specific
 
4966
                                            (r r2))
 
4967
                                 (:instance denormal-normal-monotone
 
4968
                                            (r1 r2)
 
4969
                                            (r2 r1)))))
 
4970
           :rule-classes nil))
 
4971
 
 
4972
 
 
4973
      (local 
 
4974
       (defthm expt-merge
 
4975
         (implies (and (integerp p)
 
4976
                       (integerp q)
 
4977
                       (> q 0))
 
4978
                  (equal (* (EXPT 2 (+ -1 P))
 
4979
                            (EXPT 2 (+ 2 (* -1 P) (* -1 (BIAS Q)))))
 
4980
                         (expt 2 (+ 1 (* -1 (bias q))))))
 
4981
         :hints (("Goal" :in-theory (enable a15)))))
 
4982
 
 
4983
 
 
4984
      (local 
 
4985
       (encapsulate () 
 
4986
                   (local (include-book "../../arithmetic/basic"))
 
4987
                    (defthm arithm-hack-specific
 
4988
                      (implies (and (<= (DENORMAL-NORM R P Q)
 
4989
                                        (+ -1 (EXPT 2 (+ -1 P))))
 
4990
                                    (rationalp r)
 
4991
                                    (integerp p)
 
4992
                                    (integerp q)
 
4993
                                    (> q 0))
 
4994
                               (<= (+ (EXPT 2 (+ 1 (* -1 P) (EXPO (SPN Q))))
 
4995
                                      (* (EXPT 2 (+ 1 (* -1 P) (EXPO (SPN Q))))
 
4996
                                         (denormal-norm r p q)))
 
4997
                                   (spn q)))
 
4998
                      :hints (("Goal" :in-theory (e/d (spn denormal-norm 
 
4999
                                                           spd) ())))
 
5000
                      :rule-classes nil)))
 
5001
 
 
5002
 
 
5003
      (defthm maximal-drepp
 
5004
         (implies (and (drepp r p q)
 
5005
                       (integerp p)
 
5006
                       (> p 1)
 
5007
                       (integerp q)
 
5008
                       (> q 0)
 
5009
                       (> r 0)
 
5010
                       (rationalp r))
 
5011
                  (<= (+ r (EXPT 2 (+ 1 (* -1 P) (EXPO (SPN Q)))))
 
5012
                      (spn q)))
 
5013
         :hints (("Goal" :use ((:instance drepp-implies-denormal-norm-less-than)
 
5014
                               (:instance spd-mult-specific)
 
5015
                               (:instance arithm-hack-specific))))
 
5016
         :rule-classes :linear)
 
5017
 
 
5018
 
 
5019
      (defthm drepp-diff
 
5020
           (implies (and (rationalp r1)
 
5021
                         (rationalp r2)
 
5022
                         (> r1 r2)
 
5023
                         (> r2 0)
 
5024
                         (integerp p)
 
5025
                         (integerp q)
 
5026
                         (> p 1)
 
5027
                         (> q 0)
 
5028
                         (drepp r1 p q)
 
5029
                         (drepp r2 p q))
 
5030
                    (<= (+ r2 (EXPT 2 (+ 1 (* -1 P) (EXPO (SPN Q)))))
 
5031
                        r1))
 
5032
           :hints (("Goal" :use ((:instance spd-mult-specific
 
5033
                                            (r r1))
 
5034
                                 (:instance spd-mult-specific
 
5035
                                            (r r2))
 
5036
                                 (:instance denormal-normal-monotone
 
5037
                                            (r1 r2)
 
5038
                                            (r2 r1)))))
 
5039
           :rule-classes nil)
 
5040
 
 
5041
 
 
5042
 
 
5043
   ))
 
5044
 
 
5045
 
 
5046
 
 
5047
(local 
 
5048
 (encapsulate ()
 
5049
              (local 
 
5050
               (defthm spd-spd-less-than
 
5051
                 (implies (and (integerp p)
 
5052
                               (integerp q)
 
5053
                               (> p 1)
 
5054
                               (> q 0))
 
5055
                          (iff (<= (SPD P Q) A)
 
5056
                               (<= (EXPT 2 (+ 1 (* -1 P) (EXPO (SPN Q))))
 
5057
                                   A)))
 
5058
                 :hints (("Goal" :in-theory (enable spn spd)))))
 
5059
 
 
5060
              (defthm exactp-c-lemma-2
 
5061
                (implies (and (integerp p)
 
5062
                              (> p 1)
 
5063
                              (> x 0)
 
5064
                              (rationalp a)
 
5065
                              (integerp q)
 
5066
                              (> q 0)
 
5067
                              (rationalp x)
 
5068
                              (>= a x)
 
5069
                              (drepp a p q)
 
5070
                              (<= (abs x) (spn q)))
 
5071
                         (<= (AWAY X (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))
 
5072
                             a))
 
5073
                :hints (("Goal" :cases ((not (>= (+ p (expo x)) (expo (spn q))))))
 
5074
                        ("Subgoal 2"           
 
5075
                         :in-theory (enable drnd rnd sgn positive-spd)
 
5076
                         :use ((:instance drnd-exactp-a
 
5077
                                          (mode 'away))
 
5078
                               (:instance away-upper-bound
 
5079
                                          (x x)
 
5080
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5081
                               (:instance drepp-diff
 
5082
                                          (r2 a)
 
5083
                                          (r1 (AWAY X (+ P (EXPO X) 
 
5084
                                                         (* -1 (EXPO (SPN Q)))))))))
 
5085
                        ("Subgoal 1" :in-theory (enable drnd rnd away cg sgn)
 
5086
                         :use ((:instance smallest-spd (r a)))))
 
5087
                :rule-classes :linear)))
 
5088
 
 
5089
 
 
5090
(local 
 
5091
   (defthmd drnd-exactp-c-lemma
 
5092
     (implies (and (rationalp x)
 
5093
                   (> x 0)
 
5094
                   (<= (abs x) (spn q))
 
5095
                (rationalp a)
 
5096
                   (drepp a p q)
 
5097
                (>= a x)
 
5098
                   (integerp p)
 
5099
                   (> p 1)
 
5100
                   (integerp q)
 
5101
                   (> q 0)
 
5102
                   (common-rounding-mode-p mode))
 
5103
              (>= a (drnd x mode p q)))
 
5104
     :hints (("Goal" :in-theory (enable sgn drnd rnd))
 
5105
             ("Subgoal 5" 
 
5106
              :use ((:instance near-choice
 
5107
                               (x x)
 
5108
                               (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))))
 
5109
             ("Subgoal 2" 
 
5110
              :use ((:instance near+-choice
 
5111
                               (x x)
 
5112
                               (n (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))))))
 
5113
 
 
5114
              
 
5115
 
 
5116
 
 
5117
(local 
 
5118
    (defthm exactp-d-lemma-1
 
5119
      (IMPLIES (AND (RATIONALP X)
 
5120
                    (< 0 X)
 
5121
                    (<= X (SPN Q))
 
5122
                    (RATIONALP A)
 
5123
                    (DREPP A P Q)
 
5124
                    (<= A X)
 
5125
                    (INTEGERP P)
 
5126
                    (< 1 P)
 
5127
                    (INTEGERP Q)
 
5128
                    (< 0 Q))
 
5129
            (<= A (AWAY X (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))
 
5130
      :hints (("Goal" 
 
5131
               :use ((:instance away-lower-bound
 
5132
                                (x x)
 
5133
                                (n (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))))
 
5134
      :rule-classes :linear))
 
5135
 
 
5136
 
 
5137
 
 
5138
;;    (local 
 
5139
;;     (defthm never-zero-drepp
 
5140
;;       (not (DREPP 0 P Q))
 
5141
;;       :hints (("Goal" :in-theory (enable drepp)))))
 
5142
;;
 
5143
 
 
5144
(local 
 
5145
    (defthm x-less-than-spd-if-negative
 
5146
      (implies (and (<= (+ P (EXPO X) (* -1 (EXPO (SPN Q)))) 0)
 
5147
                    (> x 0)
 
5148
                    (rationalp x)
 
5149
                    (integerp p)
 
5150
                    (integerp q)
 
5151
                    (> q 0))
 
5152
               (< x (spd p q)))
 
5153
      :hints (("Goal" :in-theory (enable spd spn)
 
5154
               :use ((:instance expo-monotone
 
5155
                                (x (spd p q))
 
5156
                                (y x)))))))
 
5157
 
 
5158
(local 
 
5159
    (defthm exactp-d-lemma-2  
 
5160
      (IMPLIES (AND (RATIONALP X)
 
5161
                    (<= X (SPN Q))
 
5162
                    (< 0 X)
 
5163
                    (RATIONALP A)
 
5164
                    (DREPP A P Q)
 
5165
                    (<= A X)
 
5166
                    (INTEGERP P)
 
5167
                    (< 1 P)
 
5168
                    (INTEGERP Q)
 
5169
                    (< 0 Q))
 
5170
            (<= A
 
5171
                (TRUNC X
 
5172
                       (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))
 
5173
      :hints (("Goal" :cases ((not (> (+ p (expo x)) (expo (spn q))))))
 
5174
              ("Subgoal 2" 
 
5175
               :in-theory (enable drnd rnd sgn positive-spd)
 
5176
               :use ((:instance drnd-exactp-a
 
5177
                                (mode 'trunc))
 
5178
                     (:instance trunc-lower-bound
 
5179
                               (x x)
 
5180
                               (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5181
                     (:instance drepp-diff
 
5182
                               (r1 a)
 
5183
                               (r2 (trunc X (+ P (EXPO X)
 
5184
                                               (* -1 (EXPO (SPN Q)))))))))
 
5185
              ("Subgoal 1" :in-theory (enable drnd rnd spd trunc sgn)
 
5186
               :use ((:instance smallest-spd (r a))
 
5187
                     (:instance x-less-than-spd-if-negative))))
 
5188
     :rule-classes :linear))
 
5189
 
 
5190
 
 
5191
(defthmd drnd-exactp-d-lemma
 
5192
     (implies (and (rationalp x)
 
5193
                   (<= (abs x) (spn q))
 
5194
                   (> x 0)
 
5195
                (rationalp a)
 
5196
                   (drepp a p q)
 
5197
                (<= a x)
 
5198
                   (integerp p)
 
5199
                   (> p 1)
 
5200
                   (integerp q)
 
5201
                   (> q 0)
 
5202
                   (common-rounding-mode-p mode))
 
5203
              (<= a (drnd x mode p q)))
 
5204
     :hints (("Goal" :in-theory (enable ieee-mode-p drnd rnd))
 
5205
             ("Subgoal 2" 
 
5206
              :use ((:instance near+-choice
 
5207
                               (x x)
 
5208
                               (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))))
 
5209
             ("Subgoal 1" 
 
5210
              :use ((:instance near-choice
 
5211
                               (x x)
 
5212
                               (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))))))
 
5213
 
 
5214
 
 
5215
 
 
5216
 
 
5217
(defthmd drnd-exactp-c
 
5218
     (implies (and (rationalp x)
 
5219
                   (<= (abs x) (spn q))
 
5220
                   (rationalp a)
 
5221
                   (drepp a p q)
 
5222
                   (>= a x)
 
5223
                   (integerp p)
 
5224
                   (> p 1)
 
5225
                   (integerp q)
 
5226
                   (> q 0)
 
5227
                   (common-rounding-mode-p mode))
 
5228
              (>= a (drnd x mode p q)))
 
5229
     :hints (("Goal" :cases ((not (equal x 0)))
 
5230
              :in-theory (enable drnd-minus flip drepp-minus))
 
5231
             ("Subgoal 2" :in-theory (enable drnd rnd))
 
5232
             ("Subgoal 1" :cases ((not (> x 0))))
 
5233
             ("Subgoal 1.2" :use ((:instance drnd-exactp-c-lemma)))
 
5234
             ("Subgoal 1.1" :use ((:instance drnd-exactp-d-lemma
 
5235
                                             (x (* -1 x))
 
5236
                                             (a (* -1 a))                                         
 
5237
                                             (mode (flip mode)))))))
 
5238
 
 
5239
 
 
5240
 
 
5241
(defthmd drnd-exactp-d
 
5242
     (implies (and (rationalp x)
 
5243
                   (<= (abs x) (spn q))
 
5244
                (rationalp a)
 
5245
                   (drepp a p q)
 
5246
                (<= a x)
 
5247
                   (integerp p)
 
5248
                   (> p 1)
 
5249
                   (integerp q)
 
5250
                   (> q 0)
 
5251
                   (common-rounding-mode-p mode))
 
5252
              (<= a (drnd x mode p q)))
 
5253
     :hints (("Goal" :cases ((not (equal x 0)))
 
5254
              :in-theory (enable drnd-minus flip drepp-minus))
 
5255
             ("Subgoal 2" :in-theory (enable drnd rnd))
 
5256
             ("Subgoal 1" :cases ((not (> x 0))))
 
5257
             ("Subgoal 1.2" :use ((:instance drnd-exactp-d-lemma)))
 
5258
             ("Subgoal 1.1" :use ((:instance drnd-exactp-c-lemma
 
5259
                                             (x (* -1 x))
 
5260
                                             (a (* -1 a))                                         
 
5261
                                             (mode (flip mode)))))))
 
5262
 
 
5263
 
 
5264
 
 
5265
;----------------------------------------------------------------------
 
5266
 
 
5267
(local
 
5268
   (encapsulate ()
 
5269
    
 
5270
       (local 
 
5271
        (defthm equal-spd
 
5272
          (implies (and (integerp p)
 
5273
                        (integerp q)
 
5274
                        (> p 1)
 
5275
                        (> q 0))
 
5276
                   (equal (spd p q)
 
5277
                          (EXPT 2 (+ 1 (* -1 P) (EXPO (SPN Q))))))
 
5278
          :hints (("Goal" :in-theory (enable spd spn bias)))))
 
5279
 
 
5280
       (local 
 
5281
        (defthm x-less-than-spd-if-negative
 
5282
          (implies (and (<= (+ P (EXPO X) (* -1 (EXPO (SPN Q)))) 0)
 
5283
                        (> x 0)
 
5284
                        (rationalp x)
 
5285
                        (integerp p)
 
5286
                        (integerp q)
 
5287
                        (> q 0))
 
5288
                   (< x (spd p q)))
 
5289
          :hints (("Goal" :in-theory (enable spd spn)
 
5290
                   :use ((:instance expo-monotone
 
5291
                                    (x (spd p q))))))))
 
5292
 
 
5293
 
 
5294
       (defthm drnd-non-negative
 
5295
         (implies (and (< 0 x)
 
5296
                       (rationalp x)
 
5297
                       (integerp p)
 
5298
                       (integerp q)
 
5299
                       (> p 1)
 
5300
                       (> q 0)
 
5301
                       (common-rounding-mode-p mode))
 
5302
                  (>= (drnd x mode p q) 0))
 
5303
         :hints (("Goal" :in-theory (enable ieee-mode-p near near+ drnd rnd)))
 
5304
         :rule-classes (:type-prescription :linear))
 
5305
 
 
5306
 
 
5307
 
 
5308
       (defthm drnd-diff-lemma
 
5309
         (implies (and (rationalp x)
 
5310
                       (<= x (spn q))
 
5311
                       (> x 0)
 
5312
                       (integerp p)
 
5313
                       (> p 1)
 
5314
                       (integerp q)
 
5315
                       (> q 0)
 
5316
                       (common-rounding-mode-p mode))
 
5317
                  (< (abs (- x (drnd x mode p q))) (spd p q)))
 
5318
         :hints (("Goal" :cases ((not (> (+ p (expo x)) (expo (spn q))))))
 
5319
                 ("Subgoal 2" :in-theory (enable drnd)
 
5320
                  :use ((:instance rnd-diff
 
5321
                                   (n (+ P (EXPO X) (* -1 (EXPO (SPN
 
5322
                                                                 Q))))))))
 
5323
                 ("Subgoal 1" 
 
5324
                  :use ((:instance drnd-exactp-c
 
5325
                                   (a (spd p q)))
 
5326
                        (:instance drepp-spd)
 
5327
                        (:instance x-less-than-spd-if-negative)))))))
 
5328
 
 
5329
(defthm drnd-diff
 
5330
        (implies (and (rationalp x)
 
5331
                   (<= (abs x) (spn q))
 
5332
                   (integerp p)
 
5333
                   (> p 1)
 
5334
                   (integerp q)
 
5335
                   (> q 0)
 
5336
                   (common-rounding-mode-p mode))
 
5337
              (< (abs (- x (drnd x mode p q))) (spd p q)))
 
5338
     :hints (("Goal" :cases ((not (equal x 0))))
 
5339
             ("Subgoal 2" :in-theory (enable drnd rnd spd))
 
5340
             ("Subgoal 1" :cases ((not (> x 0))))
 
5341
             ("Subgoal 1.2" :use ((:instance drnd-diff-lemma)))
 
5342
             ("Subgoal 1.1" :in-theory (enable flip drnd drnd-minus)
 
5343
              :use ((:instance drnd-diff-lemma
 
5344
                               (x (* -1 x))
 
5345
                               (mode (flip mode)))))))
 
5346
 
 
5347
 
 
5348
 
 
5349
;----------------------------------------------------------------------
 
5350
 
 
5351
(encapsulate () 
 
5352
 
 
5353
             (local
 
5354
              (defthm drnd-near-est-lemma-1
 
5355
                (implies (and (rationalp x)
 
5356
                              (equal (expo a) (expo x))
 
5357
                              (<= x (spn q))
 
5358
                              (> x 0)
 
5359
                              (integerp p)
 
5360
                              (> p 1)
 
5361
                              (integerp q)
 
5362
                              (> q 0)
 
5363
                              (drepp a p q))
 
5364
                         (>= (abs (- x a)) (abs (- x (drnd x 'near p q)))))
 
5365
                :hints (("Goal" 
 
5366
                         :in-theory (enable rnd drnd bias DREPP spn)
 
5367
                         :use ((:instance near2
 
5368
                                          (y a)
 
5369
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))))))
 
5370
 
 
5371
 
 
5372
 
 
5373
             (local
 
5374
              (defthm rationalp-drepp
 
5375
                (implies (drepp a p q)
 
5376
                         (rationalp a))
 
5377
                :hints (("Goal" :in-theory (enable drepp)))
 
5378
                :rule-classes :forward-chaining))
 
5379
 
 
5380
             (local
 
5381
              (defthm drnd-near-est-lemma-2-1
 
5382
                (implies (and (rationalp x)
 
5383
                              (<= x (spn q))
 
5384
                              (equal (- x (trunc x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5385
                                     (- (away x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))) x))
 
5386
                              (> a 0)
 
5387
                              (> x 0)
 
5388
                              (integerp p)
 
5389
                              (> p 1)
 
5390
                              (integerp q)
 
5391
                              (> q 0)
 
5392
                              (drepp a p q))
 
5393
                         (>= (abs (- x a)) (abs (- x (drnd x 'near p q)))))
 
5394
                :hints (("Goal" :in-theory (enable drnd rnd)
 
5395
                         :use ((:instance near-choice (x x)
 
5396
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))))))
 
5397
 
 
5398
 
 
5399
             (local
 
5400
              (defthm drnd-near-est-lemma-2-2
 
5401
                (implies (and (rationalp x)
 
5402
                              (<= x (spn q))
 
5403
                              (not (equal (expo x) (expo a)))
 
5404
                              (<  (- x (trunc x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5405
                                  (- (away x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))) x))
 
5406
                              (> a 0)
 
5407
                              (> x 0)
 
5408
                              (integerp p)
 
5409
                              (> p 1)
 
5410
                              (integerp q)
 
5411
                              (> q 0)
 
5412
                              (drepp a p q))
 
5413
                         (>= (abs (- x a)) (abs (- x (drnd x 'near p q)))))
 
5414
                :hints (("Goal" :in-theory (enable drnd rnd)
 
5415
                         :do-not '(fertilize)
 
5416
                         :use ((:instance near1-a
 
5417
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5418
                               (:instance trunc-upper-bound
 
5419
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))))))
 
5420
 
 
5421
 
 
5422
 
 
5423
                               
 
5424
             (local
 
5425
              (defthm drnd-near-est-lemma-2-3
 
5426
                (implies (and (rationalp x)
 
5427
                              (<= x (spn q))
 
5428
                              (not (equal (expo x) (expo a)))
 
5429
                              (>  (- x (trunc x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5430
                                  (- (away x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))) x))
 
5431
                              (> a 0)
 
5432
                              (> x 0)
 
5433
                              (integerp p)
 
5434
                              (> p 1)
 
5435
                              (integerp q)
 
5436
                              (> q 0)
 
5437
                              (drepp a p q))
 
5438
                         (>= (abs (- x a)) (abs (- x (drnd x 'near p q)))))
 
5439
                :hints (("Goal" :in-theory (enable drnd rnd)
 
5440
                         :do-not '(fertilize)
 
5441
                         :use ((:instance near1-b
 
5442
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5443
                               (:instance away-lower-bound
 
5444
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))))))
 
5445
 
 
5446
 
 
5447
 
 
5448
 
 
5449
 
 
5450
             (local
 
5451
              (defthm drnd-near-est-lemma-2
 
5452
                (implies (and (rationalp x)
 
5453
                              (<= x (spn q))
 
5454
                              (not (equal (expo a) (expo x)))
 
5455
                              (> a 0)
 
5456
                              (> x 0)
 
5457
                              (integerp p)
 
5458
                              (> p 1)
 
5459
                              (integerp q)
 
5460
                              (> q 0)
 
5461
                              (drepp a p q))
 
5462
                         (>= (abs (- x a)) (abs (- x (drnd x 'near p q)))))
 
5463
                :hints (("Goal" :cases ((not (equal (- x (trunc x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5464
                                                    (- (away x (+ P (EXPO X) (* -1 (EXPO (SPN
 
5465
                                                                                          Q))))) x))))
 
5466
                         :in-theory (disable abs drnd))
 
5467
                        ("Subgoal 2" :use ((:instance drnd-near-est-lemma-2-1)))
 
5468
                        ("Subgoal 1" :cases ((not (< (- x (trunc x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5469
                                                     (- (away x (+ P (EXPO X) (* -1 (EXPO (SPN
 
5470
                                                                                           Q))))) x)))))
 
5471
                        ("Subgoal 1.2" :use ((:instance drnd-near-est-lemma-2-2)))
 
5472
                        ("Subgoal 1.1" :use ((:instance drnd-near-est-lemma-2-3))))))
 
5473
 
 
5474
 
 
5475
 
 
5476
 
 
5477
             (local
 
5478
              (defthm drnd-near-est-lemma-3
 
5479
                (implies (and (rationalp x)
 
5480
                              (<= x (spn q))
 
5481
                              (not (equal (expo a) (expo x)))
 
5482
                              (< a 0)
 
5483
                              (> x 0)
 
5484
                              (integerp p)
 
5485
                              (> p 1)
 
5486
                              (integerp q)
 
5487
                              (> q 0)
 
5488
                              (drepp a p q))
 
5489
                         (>= (abs (- x a)) (abs (- x (drnd x 'near p q)))))
 
5490
                :hints (("Goal" :use ((:instance smallest-spd (r a))
 
5491
                                      (:instance drnd-diff
 
5492
                                                 (mode 'near)))))))
 
5493
                                   
 
5494
 
 
5495
 
 
5496
             (local 
 
5497
              (defthm never-zero-drepp
 
5498
                (not (DREPP 0 P Q))
 
5499
                :hints (("Goal" :in-theory (enable drepp)))))
 
5500
 
 
5501
             (local
 
5502
              (defthm drnd-near-est-lemma
 
5503
                (implies (and (rationalp x)
 
5504
                              (<= x (spn q))
 
5505
                              (> x 0)
 
5506
                              (integerp p)
 
5507
                              (> p 1)
 
5508
                              (integerp q)
 
5509
                              (> q 0)
 
5510
                              (drepp a p q))
 
5511
                         (>= (abs (- x a)) (abs (- x (drnd x 'near p q)))))
 
5512
                :hints (("Goal" :cases ((not (equal (expo a) (expo x)))))
 
5513
                        ("Subgoal 2" :use ((:instance drnd-near-est-lemma-1)))
 
5514
                        ("Subgoal 1":cases ((not (equal a 0))))
 
5515
                        ("Subgoal 1.1":cases ((not (> a 0))))
 
5516
                        ("Subgoal 1.1.2":use ((:instance drnd-near-est-lemma-2)))
 
5517
                        ("Subgoal 1.1.1":use ((:instance drnd-near-est-lemma-3))))))
 
5518
 
 
5519
    (defthm drnd-near-est
 
5520
      (implies (and (rationalp x)
 
5521
                    (<= (abs x) (spn q))
 
5522
                    (integerp p)
 
5523
                    (> p 1)
 
5524
                    (integerp q)
 
5525
                    (> q 0)
 
5526
                    (drepp a p q))
 
5527
               (>= (abs (- x a)) (abs (- x (drnd x 'near p q)))))
 
5528
      :hints (("Goal" :cases ((not (equal x 0))))
 
5529
              ("Subgoal 2" :in-theory (enable drnd rnd))
 
5530
              ("Subgoal 1" :cases ((not (> x 0))))
 
5531
              ("Subgoal 1.2" :use ((:instance drnd-near-est-lemma)))
 
5532
              ("Subgoal 1.1" :use ((:instance drnd-near-est-lemma
 
5533
                                              (x (* -1 x))
 
5534
                                              (a (* -1 a))))
 
5535
               :in-theory (enable drnd-minus))))
 
5536
 
 
5537
             )
 
5538
 
 
5539
;----------------------------------------------------------------------
 
5540
 
 
5541
(encapsulate () 
 
5542
 
 
5543
             (local
 
5544
              (defthm drnd-near+-est-lemma-1
 
5545
                (implies (and (rationalp x)
 
5546
                              (equal (expo a) (expo x))
 
5547
                              (<= x (spn q))
 
5548
                              (> x 0)
 
5549
                              (integerp p)
 
5550
                              (> p 1)
 
5551
                              (integerp q)
 
5552
                              (> q 0)
 
5553
                              (drepp a p q))
 
5554
                         (>= (abs (- x a)) (abs (- x (drnd x 'near+ p q)))))
 
5555
                :hints (("Goal" 
 
5556
                         :in-theory (enable rnd drnd bias DREPP spn)
 
5557
                         :use ((:instance near+2
 
5558
                                          (y a)
 
5559
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))))))
 
5560
 
 
5561
 
 
5562
 
 
5563
 
 
5564
             (local
 
5565
              (defthm rationalp-drepp
 
5566
                (implies (drepp a p q)
 
5567
                         (rationalp a))
 
5568
                :hints (("Goal" :in-theory (enable drepp)))
 
5569
                :rule-classes :forward-chaining))
 
5570
 
 
5571
 
 
5572
 
 
5573
             (local
 
5574
              (defthm drnd-near+-est-lemma-2-1
 
5575
                (implies (and (rationalp x)
 
5576
                              (<= x (spn q))
 
5577
                              (equal (- x (trunc x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5578
                                     (- (away x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))) x))
 
5579
                              (> a 0)
 
5580
                              (> x 0)
 
5581
                              (integerp p)
 
5582
                              (> p 1)
 
5583
                              (integerp q)
 
5584
                              (> q 0)
 
5585
                              (drepp a p q))
 
5586
                         (>= (abs (- x a)) (abs (- x (drnd x 'near+ p q)))))
 
5587
                :hints (("Goal" :in-theory (enable drnd rnd)
 
5588
                         :use ((:instance near+-choice (x x)
 
5589
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))))))
 
5590
 
 
5591
 
 
5592
;----------------------------------------------------------------------
 
5593
 
 
5594
 
 
5595
 
 
5596
             (local
 
5597
              (defthm drnd-near+-est-lemma-2-2
 
5598
                (implies (and (rationalp x)
 
5599
                              (<= x (spn q))
 
5600
                              (not (equal (expo x) (expo a)))
 
5601
                              (<  (- x (trunc x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5602
                                  (- (away x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))) x))
 
5603
                              (> a 0)
 
5604
                              (> x 0)
 
5605
                              (integerp p)
 
5606
                              (> p 1)
 
5607
                              (integerp q)
 
5608
                              (> q 0)
 
5609
                              (drepp a p q))
 
5610
                         (>= (abs (- x a)) (abs (- x (drnd x 'near+ p q)))))
 
5611
                :hints (("Goal" :in-theory (enable drnd rnd)
 
5612
                         :do-not '(fertilize)
 
5613
                         :use ((:instance near+1-a
 
5614
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5615
                               (:instance trunc-upper-bound
 
5616
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))))))
 
5617
                               
 
5618
             (local
 
5619
              (defthm drnd-near+-est-lemma-2-3
 
5620
                (implies (and (rationalp x)
 
5621
                              (<= x (spn q))
 
5622
                              (not (equal (expo x) (expo a)))
 
5623
                              (>  (- x (trunc x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5624
                                  (- (away x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))) x))
 
5625
                              (> a 0)
 
5626
                              (> x 0)
 
5627
                              (integerp p)
 
5628
                              (> p 1)
 
5629
                              (integerp q)
 
5630
                              (> q 0)
 
5631
                              (drepp a p q))
 
5632
                         (>= (abs (- x a)) (abs (- x (drnd x 'near+ p q)))))
 
5633
                :hints (("Goal" :in-theory (enable drnd rnd)
 
5634
                         :do-not '(fertilize)
 
5635
                         :use ((:instance near+1-b
 
5636
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5637
                               (:instance away-lower-bound
 
5638
                                          (n (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))))))
 
5639
                               
 
5640
 
 
5641
             (local
 
5642
              (defthm drnd-near+-est-lemma-2
 
5643
                (implies (and (rationalp x)
 
5644
                              (<= x (spn q))
 
5645
                              (not (equal (expo a) (expo x)))
 
5646
                              (> a 0)
 
5647
                              (> x 0)
 
5648
                              (integerp p)
 
5649
                              (> p 1)
 
5650
                              (integerp q)
 
5651
                              (> q 0)
 
5652
                              (drepp a p q))
 
5653
                         (>= (abs (- x a)) (abs (- x (drnd x 'near+ p q)))))
 
5654
                :hints (("Goal" :cases ((not (equal (- x (trunc x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5655
                                                    (- (away x (+ P (EXPO X) (* -1 (EXPO (SPN
 
5656
                                                                                          Q))))) x))))
 
5657
                         :in-theory (disable abs drnd))
 
5658
                        ("Subgoal 2" :use ((:instance drnd-near+-est-lemma-2-1)))
 
5659
                        ("Subgoal 1" :cases ((not (< (- x (trunc x (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))
 
5660
                                                     (- (away x (+ P (EXPO X) (* -1 (EXPO (SPN
 
5661
                                                                                           Q))))) x)))))
 
5662
                        ("Subgoal 1.2" :use ((:instance drnd-near+-est-lemma-2-2)))
 
5663
                        ("Subgoal 1.1" :use ((:instance drnd-near+-est-lemma-2-3))))))
 
5664
 
 
5665
 
 
5666
;----------------------------------------------------------------------
 
5667
 
 
5668
             (local
 
5669
              (defthm drnd-near+-est-lemma-3
 
5670
                (implies (and (rationalp x)
 
5671
                              (<= x (spn q))
 
5672
                              (not (equal (expo a) (expo x)))
 
5673
                              (< a 0)
 
5674
                              (> x 0)
 
5675
                              (integerp p)
 
5676
                              (> p 1)
 
5677
                              (integerp q)
 
5678
                              (> q 0)
 
5679
                              (drepp a p q))
 
5680
                         (>= (abs (- x a)) (abs (- x (drnd x 'near+ p q)))))
 
5681
                :hints (("Goal" :use ((:instance smallest-spd (r a))
 
5682
                                      (:instance drnd-diff
 
5683
                                                 (mode 'near+)))))))
 
5684
                                   
 
5685
 
 
5686
             (local 
 
5687
              (defthm never-zero-drepp
 
5688
                (not (DREPP 0 P Q))
 
5689
                :hints (("Goal" :in-theory (enable drepp)))))
 
5690
 
 
5691
 
 
5692
 
 
5693
             (local
 
5694
              (defthm drnd-near+-est-lemma
 
5695
                (implies (and (rationalp x)
 
5696
                              (<= x (spn q))
 
5697
                              (> x 0)
 
5698
                              (integerp p)
 
5699
                              (> p 1)
 
5700
                              (integerp q)
 
5701
                              (> q 0)
 
5702
                              (drepp a p q))
 
5703
                         (>= (abs (- x a)) (abs (- x (drnd x 'near+ p q)))))
 
5704
                :hints (("Goal" :cases ((not (equal (expo a) (expo x)))))
 
5705
                        ("Subgoal 2" :use ((:instance drnd-near+-est-lemma-1)))
 
5706
                        ("Subgoal 1":cases ((not (equal a 0))))
 
5707
                        ("Subgoal 1.1":cases ((not (> a 0))))
 
5708
                        ("Subgoal 1.1.2":use ((:instance drnd-near+-est-lemma-2)))
 
5709
                        ("Subgoal 1.1.1":use ((:instance drnd-near+-est-lemma-3))))))
 
5710
 
 
5711
     (defthm drnd-near+-est
 
5712
       (implies (and (rationalp x)
 
5713
                     (<= (abs x) (spn q))
 
5714
                     (integerp p)
 
5715
                     (> p 1)
 
5716
                     (integerp q)
 
5717
                     (> q 0)
 
5718
                     (drepp a p q))
 
5719
                (>= (abs (- x a)) (abs (- x (drnd x 'near+ p q)))))
 
5720
       :hints (("Goal" :cases ((not (equal x 0))))
 
5721
               ("Subgoal 2" :in-theory (enable drnd rnd))
 
5722
               ("Subgoal 1" :cases ((not (> x 0))))
 
5723
               ("Subgoal 1.2" :use ((:instance drnd-near+-est-lemma)))
 
5724
               ("Subgoal 1.1" :use ((:instance drnd-near+-est-lemma
 
5725
                                               (x (* -1 x))
 
5726
                                               (a (* -1 a))))
 
5727
                :in-theory (enable drnd-minus))))
 
5728
 
 
5729
             )
 
5730
 
 
5731
;;
 
5732
;; Sat Feb  4 12:35:01 2006 finally! 
 
5733
;;
 
5734
;----------------------------------------------------------------------
 
5735
 
 
5736
 
 
5737
(encapsulate () 
 
5738
 
 
5739
 
 
5740
   (local (encapsulate () 
 
5741
 
 
5742
          (defthm fl-expt-n-minus-1-minus-1
 
5743
            (implies (and (rationalp x)
 
5744
                          (case-split (not (equal x 0)))
 
5745
                          (integerp n)
 
5746
                          (<= n 0))
 
5747
                     (equal (fl (* -1 (sig x) (expt 2 (+ -1 n))))
 
5748
                            -1))
 
5749
            :hints (("Goal" :use ((:instance fl-1/2-sig-x-is-zero-lemma-2
 
5750
                                             (y (expt 2 (+ -1 n))))
 
5751
                                  (:instance expt-weak-monotone-linear
 
5752
                                             (n (+ -1 n))
 
5753
                                             (m -1))))))
 
5754
 
 
5755
 
 
5756
         (defthm n-zero-away-reduce
 
5757
           (implies (and (rationalp x)
 
5758
                         (> x 0)
 
5759
                         (integerp n)
 
5760
                         (<= n 0))
 
5761
                    (equal (away x n)
 
5762
                           (EXPT 2 (+ 1 (EXPO X) (* -1 n)))))
 
5763
           :hints (("Goal" :in-theory (enable sgn away cg))))
 
5764
 
 
5765
 
 
5766
         (defthm drnd-lemma-trunc-small
 
5767
           (implies (and (natp p)
 
5768
                         (> x 0)
 
5769
                         (> p 1)
 
5770
                         (natp q)
 
5771
                         (> q 0)
 
5772
                         (rationalp x)
 
5773
                         (<= (+ p (expo x)) (expo (spn q))))
 
5774
                    (equal (drnd x 'trunc p q)  0))
 
5775
           :hints (("Goal" :in-theory (enable drnd rnd))))
 
5776
 
 
5777
 
 
5778
         (defthm drnd-lemma-away-small
 
5779
           (implies (and (natp p)
 
5780
                         (> x 0)
 
5781
                         (> p 1)
 
5782
                         (natp q)
 
5783
                         (> q 0)
 
5784
                         (rationalp x)
 
5785
                         (<= (+ p (expo x)) (expo (spn q))))
 
5786
                    (equal (drnd x 'away p q)  
 
5787
                           (expt 2 (+ 1 (EXPO (SPN Q)) (* -1 p)))))
 
5788
           :hints (("Goal" :in-theory (enable drnd rnd))))
 
5789
 
 
5790
 
 
5791
 
 
5792
         (defthm drnd-lemma-minf-small
 
5793
           (implies (and (natp p)
 
5794
                         (> x 0)
 
5795
                         (> p 1)
 
5796
                         (natp q)
 
5797
                         (> q 0)
 
5798
                         (rationalp x)
 
5799
                         (<= (+ p (expo x)) (expo (spn q))))
 
5800
                    (equal (drnd x 'minf p q)  0))
 
5801
           :hints (("Goal" :in-theory (enable drnd rnd))))
 
5802
 
 
5803
 
 
5804
 
 
5805
         (defthm drnd-lemma-inf-small
 
5806
           (implies (and (natp p)
 
5807
                         (> x 0)
 
5808
                         (> p 1)
 
5809
                         (natp q)
 
5810
                         (> q 0)
 
5811
                         (rationalp x)
 
5812
                         (<= (+ p (expo x)) (expo (spn q))))
 
5813
                    (equal (drnd x 'inf p q)
 
5814
                           (expt 2 (+ 1 (EXPO (SPN Q)) (* -1 p)))))
 
5815
           :hints (("Goal" :in-theory (enable drnd rnd))))
 
5816
 
 
5817
 
 
5818
 
 
5819
         (local 
 
5820
          (defthm local-expt-expand 
 
5821
            (implies (and (integerp p)
 
5822
                          (integerp q)
 
5823
                          (> q 0))
 
5824
                     (equal (EXPT 2 (+ 1 (* -1 P) (EXPO (SPN Q))))
 
5825
                            (* 2 (expt 2 (+  (* -1 p) (expo (spn q)))))))
 
5826
            :hints (("Goal" :use ((:instance a15 (i 2) (j1 1)
 
5827
                                             (j2 (+ (* -1 P) (EXPO (SPN Q))))))))))
 
5828
 
 
5829
 
 
5830
         (defthm drnd-lemma-near-small-1
 
5831
           (implies (and (natp p)
 
5832
                         (> x 0)
 
5833
                         (> p 1)
 
5834
                         (natp q)
 
5835
                         (> q 0)
 
5836
                         (rationalp x)
 
5837
                         (< x (expt 2 (+ (* -1 p) (expo (spn q)))))
 
5838
                         (<= (+ p (expo x)) (expo (spn q))))
 
5839
                    (equal (drnd x 'near p q)
 
5840
                           0))
 
5841
           :hints (("Goal" :in-theory (enable drnd rnd)
 
5842
                    :use ((:instance near1-a (n (+ p (expo x) (* -1 (expo (spn
 
5843
                                                                           q))))))))))
 
5844
 
 
5845
 
 
5846
         (defthm drnd-lemma-near-small-2
 
5847
           (implies (and (natp p)
 
5848
                         (> x 0)
 
5849
                         (> p 1)
 
5850
                         (natp q)
 
5851
                         (> q 0)
 
5852
                         (rationalp x)
 
5853
                         (> x (expt 2 (+ (* -1 p) (expo (spn q)))))
 
5854
                         (<= (+ p (expo x)) (expo (spn q))))
 
5855
                    (equal (drnd x 'near p q)
 
5856
                           (expt 2 (+ 1 (EXPO (SPN Q)) (* -1 p)))))
 
5857
           :hints (("Goal" :in-theory (enable drnd rnd)
 
5858
                    :use ((:instance near1-b (n (+ p (expo x) (* -1 (expo (spn q))))))))))
 
5859
 
 
5860
 
 
5861
 
 
5862
 
 
5863
         (defthm drnd-lemma-near+-small-1
 
5864
           (implies (and (natp p)
 
5865
                         (> x 0)
 
5866
                         (> p 1)
 
5867
                         (natp q)
 
5868
                         (> q 0)
 
5869
                         (rationalp x)
 
5870
                         (< x (expt 2 (+ (* -1 p) (expo (spn q)))))
 
5871
                         (<= (+ p (expo x)) (expo (spn q))))
 
5872
                    (equal (drnd x 'near+ p q)
 
5873
                           0))
 
5874
           :hints (("Goal" :in-theory (enable drnd rnd)
 
5875
                    :use ((:instance near+1-a (n (+ p (expo x) (* -1 (expo (spn
 
5876
                                                                            q))))))))))
 
5877
 
 
5878
 
 
5879
         (defthm drnd-lemma-near+-small-2
 
5880
           (implies (and (natp p)
 
5881
                         (> x 0)
 
5882
                         (> p 1)
 
5883
                         (natp q)
 
5884
                         (> q 0)
 
5885
                         (rationalp x)
 
5886
                         (> x (expt 2 (+ (* -1 p) (expo (spn q)))))
 
5887
                         (<= (+ p (expo x)) (expo (spn q))))
 
5888
                    (equal (drnd x 'near+ p q)
 
5889
                           (expt 2 (+ 1 (EXPO (SPN Q)) (* -1 p)))))
 
5890
           :hints (("Goal" :in-theory (enable drnd rnd)
 
5891
                    :use ((:instance near+1-b (n (+ p (expo x) (* -1 (expo (spn q))))))))))
 
5892
 
 
5893
 
 
5894
         (encapsulate ()
 
5895
                      (local 
 
5896
                       (defthm spd-/2-rewrite
 
5897
                         (implies (and (integerp p)
 
5898
                                       (integerp q)
 
5899
                                       (> q 0))
 
5900
                                  (equal (/ (spd p q) 2)
 
5901
                                         (expt 2 (+ (* -1 p) (expo (spn q))))))
 
5902
                         :hints (("Goal" :in-theory (enable spd spn)
 
5903
                                  :use ((:instance a15 (i 2) (j1 1)
 
5904
                                                   (j2 (+ 1 (* -1 P) (* -1 (BIAS Q))))))))))
 
5905
                   
 
5906
                      (local 
 
5907
                       (defthm less-than-1/2-spd-implies-expo-x-small
 
5908
                         (implies (and (< x (expt 2 (+ (* -1 p) (expo (spn q)))))
 
5909
                                       (> x 0)
 
5910
                                       (rationalp x)
 
5911
                                       (integerp p)
 
5912
                                       (integerp q)
 
5913
                                       (> q 0))
 
5914
                                  (<= (+ p (expo x)) (expo (spn q))))
 
5915
                         :hints (("Goal" :use ((:instance expo-monotone
 
5916
                                                          (x x)
 
5917
                                                          (y (expt 2 (+ (* -1 p) (expo (spn
 
5918
                                                                                        q)))))))
 
5919
                                  :in-theory (enable expo-2**n)))))
 
5920
 
 
5921
                      (defthm drnd-tiny-equal-lemma
 
5922
                        (implies (and (common-rounding-mode-p mode)
 
5923
                                      (natp p)
 
5924
                                      (> p 1)
 
5925
                                      (natp q)
 
5926
                                      (> q 0)
 
5927
                                      (rationalp x)
 
5928
                                      (< 0 x)
 
5929
                                      (< x (/ (spd p q) 2))
 
5930
                                      (rationalp y)
 
5931
                                      (< 0 y)
 
5932
                                      (< y (/ (spd p q) 2)))
 
5933
                                 (equal (drnd x mode p q)
 
5934
                                        (drnd y mode p q)))
 
5935
                        :hints (("Goal" :in-theory (enable ieee-mode-p)))
 
5936
                        :rule-classes nil))
 
5937
 
 
5938
 
 
5939
         (defthm sticky-never-increase-over-expt
 
5940
           (implies (and (< x (expt 2 k))
 
5941
                         (integerp k)
 
5942
                         (rationalp x)
 
5943
                         (> x 0)
 
5944
                         (> n 0)
 
5945
                         (integerp n))
 
5946
                    (< (sticky x n) 
 
5947
                       (expt 2 k)))
 
5948
           :hints (("Goal" :use ((:instance expo-sticky)
 
5949
                                 (:instance expo-monotone
 
5950
                                            (x (expt 2 k))
 
5951
                                            (y (sticky x n)))
 
5952
                                 (:instance expt-weak-monotone-linear
 
5953
                                            (n k)
 
5954
                                            (m (expo x)))
 
5955
                                 (:instance expo-lower-bound
 
5956
                                            (x x))))))
 
5957
 
 
5958
         (defthm sticky-preserves-inequality
 
5959
           (implies  (and (< x (expt 2 (+ (* -1 p) (expo (spn q)))))
 
5960
                          (rationalp x)
 
5961
                          (> x 0)
 
5962
                          (> n 0)
 
5963
                          (integerp n)
 
5964
                          (integerp p)
 
5965
                          (integerp q)
 
5966
                          (> p 1)
 
5967
                          (> q 0))
 
5968
                     (< (sticky x n)
 
5969
                        (expt 2 (+ (* -1 p) (expo (spn q))))))
 
5970
           :hints (("Goal"  :use ((:instance sticky-never-increase-over-expt
 
5971
                                             (k (+ (* -1 p)
 
5972
                                                   (expo (spn q)))))))))
 
5973
 
 
5974
         (defthm greater-than-1/2-spd-implies-n-no-less-than-2
 
5975
           (implies (and (> x (expt 2 (+ (* -1 p) (expo (spn q)))))
 
5976
                         (rationalp x)
 
5977
                         (> x 0)
 
5978
                         (> n 0)
 
5979
                         (integerp n)
 
5980
                         (integerp p)
 
5981
                         (integerp q)
 
5982
                         (>= n (+ p (expo x) (- (expo (spn q))) 2))
 
5983
                         (> p 1)
 
5984
                         (> q 0))
 
5985
                    (>= n 2))
 
5986
           :hints (("Goal" :use ((:instance expo-monotone
 
5987
                                            (x (expt 2 (+ (* -1 p) (expo (spn q)))))
 
5988
                                            (y x)))
 
5989
                    :in-theory (enable expo-2**n)))
 
5990
           :rule-classes nil)
 
5991
 
 
5992
         (local 
 
5993
          (defthm trunc-1-m-is-1
 
5994
            (implies (and (integerp n)
 
5995
                          (> n 0))
 
5996
                     (equal (trunc 1 n)
 
5997
                            1))
 
5998
            :hints (("Goal" :in-theory (enable trunc a15)))))
 
5999
 
 
6000
         (defthm trunc-2**n
 
6001
           (implies (and (integerp n)
 
6002
                         (integerp m)
 
6003
                         (> m 0))
 
6004
                    (equal (trunc (expt 2 n) m)
 
6005
                           (expt 2 n)))
 
6006
           :hints (("Goal" :use ((:instance trunc-shift
 
6007
                                            (x 1)
 
6008
                                            (k n)
 
6009
                                            (n m)))
 
6010
                    :in-theory (enable trunc))))
 
6011
 
 
6012
 
 
6013
         (defthm sticky-preserves-inequality-2-strong
 
6014
           (implies  (and (> x (expt 2 (+ (* -1 p) (expo (spn q)))))
 
6015
                          (rationalp x)
 
6016
                          (> x 0)
 
6017
                          (> n 0)
 
6018
                          (integerp n)
 
6019
                          (integerp p)
 
6020
                          (integerp q)
 
6021
                          (>= n (+ p (expo x) (- (expo (spn q))) 2))
 
6022
                          (> p 1)
 
6023
                          (> q 0))
 
6024
                     (> (sticky x n)
 
6025
                        (expt 2 (+ (* -1 p) (expo (spn q))))))
 
6026
           :hints (("Goal" :in-theory (enable sticky trunc-shift sgn)
 
6027
                    :use ((:instance trunc-monotone
 
6028
                                     (x (expt 2 (+ (* -1 p) (expo (spn q)))))
 
6029
                                     (y x)
 
6030
                                     (n (+ -1 n)))
 
6031
                          (:instance greater-than-1/2-spd-implies-n-no-less-than-2)))))
 
6032
 
 
6033
 
 
6034
         (defthm exactp-expt-2-1
 
6035
           (implies (and (integerp n)
 
6036
                         (integerp m)
 
6037
                         (> n 0))
 
6038
                    (exactp (expt 2 m) n))
 
6039
           :hints (("Goal" :in-theory (enable a15 sig exactp))))
 
6040
 
 
6041
 
 
6042
         (defthm equal-x-1/2-spd-sticky-n-1/2-spd
 
6043
           (implies (and (integerp p)
 
6044
                         (integerp n)
 
6045
                         (integerp q)
 
6046
                         (> p 1)
 
6047
                         (> q 0)
 
6048
                         (> n 0))
 
6049
                    (equal (sticky (expt 2 (+ (* -1 p) (expo (spn q)))) n)
 
6050
                           (expt 2 (+ (* -1 p) (expo (spn q))))))
 
6051
           :hints (("Goal" :in-theory (e/d (expo-2**n sticky)
 
6052
                                           (exactp-expt-2-1))
 
6053
                    :use ((:instance exactp-expt-2-1
 
6054
                                     (m (+ (* -1 P) (EXPO (SPN Q)))) 
 
6055
                                     (n (+ -1 n)))))))
 
6056
 
 
6057
 
 
6058
         (defthm expo-sticky-strong
 
6059
           (implies (and (rationalp x)
 
6060
                         (integerp n) (> n 0))
 
6061
                    (= (expo (sticky x n))
 
6062
                       (expo x)))
 
6063
           :hints (("Goal" :cases ((not (> x 0)))
 
6064
                    :in-theory (enable expo-minus sticky-minus))
 
6065
                   ("Subgoal 2" :use ((:instance expo-sticky)))
 
6066
                   ("Subgoal 1" :use ((:instance expo-sticky
 
6067
                                                 (x (* -1 x)))))))
 
6068
 
 
6069
 
 
6070
;----------------------------------------------------------------------
 
6071
 
 
6072
         (defthm n-equal-zero-implies-ultra-small
 
6073
           (implies (and (>= 0 (+ p (expo x) (- (expo (spn q))) 2))
 
6074
                         (natp p)
 
6075
                         (> x 0)
 
6076
                         (> p 1)
 
6077
                         (natp q)
 
6078
                         (> q 0)
 
6079
                         (rationalp x))
 
6080
                    (< x (expt 2 (+ -1 (* -1 p) (expo (spn q))))))
 
6081
           :hints (("Goal" :use ((:instance expo-upper-bound)
 
6082
                                 (:instance expt-weak-monotone-linear
 
6083
                                            (n (+ 1 (expo x)))
 
6084
                                            (m (+ -1 (* -1 p) (expo (spn q)))))))))
 
6085
 
 
6086
 
 
6087
         ;; (i-am-here) ;; Sun Oct 15 18:19:29 2006
 
6088
 
 
6089
 
 
6090
                  
 
6091
         (defthm sticky-0-reduce
 
6092
           (implies (and (> x 0)
 
6093
                         (rationalp x))
 
6094
                    (equal (sticky x 0)
 
6095
                           (EXPT 2 (1+ (EXPO X)))))
 
6096
           :hints (("Goal" :in-theory (e/d (sticky exactp sgn)
 
6097
                                           (sig-lower-bound
 
6098
                                            sig-upper-bound))
 
6099
                    :use ((:instance  sig-lower-bound)
 
6100
                          (:instance sig-upper-bound)))))
 
6101
 
 
6102
 
 
6103
 
 
6104
         (defthm small-fl-is-minus-1
 
6105
           (implies (and (rationalp x)
 
6106
                         (> x 0)
 
6107
                         (natp p)
 
6108
                         (> x 0)
 
6109
                         (> p 1)
 
6110
                         (natp q)
 
6111
                         (> q 0)
 
6112
                         (< x (expt 2 (+ -1 (* -1 p) (expo (spn q))))))
 
6113
                    (equal (FL (* -1 (SIG X)
 
6114
                                  (EXPT 2
 
6115
                                        (+ -1 P (EXPO X)
 
6116
                                           (* -1 (EXPO (SPN Q)))))))
 
6117
                           -1))
 
6118
           :hints (("Goal" :use ((:instance fl-1/2-sig-x-is-zero-2)
 
6119
                                 (:instance expo-monotone
 
6120
                                            (x x)
 
6121
                                            (y (expt 2 (+ -1 (* -1 p) (expo (spn q))))))))))
 
6122
                                   
 
6123
 
 
6124
         (defthm small-fl-is-zero-1
 
6125
           (implies (and (rationalp x)
 
6126
                         (> x 0)
 
6127
                         (natp p)
 
6128
                         (> x 0)
 
6129
                         (> p 1)
 
6130
                         (natp q)
 
6131
                         (> q 0)
 
6132
                         (< x (expt 2 (+ -1 (* -1 p) (expo (spn q))))))
 
6133
                    (equal (FL (* (SIG X)
 
6134
                                  (EXPT 2
 
6135
                                        (+ -1 P (EXPO X)
 
6136
                                           (* -1 (EXPO (SPN Q)))))))
 
6137
                           0))
 
6138
           :hints (("Goal" :use ((:instance fl-1/2-sig-x-is-zero)
 
6139
                                 (:instance expo-monotone
 
6140
                                            (x x)
 
6141
                                            (y (expt 2 (+ -1 (* -1 p) (expo (spn q))))))))))
 
6142
                                   
 
6143
 
 
6144
 
 
6145
                             
 
6146
         (defthm small-fl-is-minus-1-v2
 
6147
           (implies (and (rationalp x)
 
6148
                         (> x 0)
 
6149
                         (natp p)
 
6150
                         (> x 0)
 
6151
                         (> p 1)
 
6152
                         (natp q)
 
6153
                         (> q 0)
 
6154
                         (< x (expt 2 (+ -1 (* -1 p) (expo (spn q))))))
 
6155
                    (equal (FL (* -1 (SIG (EXPT 2 (+ 1 (EXPO X))))
 
6156
                                  (EXPT 2
 
6157
                                        (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))
 
6158
                           -1))
 
6159
           :hints (("Goal" :use ((:instance fl-1/2-sig-x-is-zero-2
 
6160
                                            (x (expt 2 (+ 1 (expo x)))))
 
6161
                                 (:instance expo-monotone
 
6162
                                            (x x)
 
6163
                                            (y (expt 2 (+ -1 (* -1 p) (expo (spn q))))))))))
 
6164
           
 
6165
  
 
6166
                             
 
6167
         (defthm small-fl-is-zero-1-v2
 
6168
           (implies (and (rationalp x)
 
6169
                         (> x 0)
 
6170
                         (natp p)
 
6171
                         (> x 0)
 
6172
                         (> p 1)
 
6173
                         (natp q)
 
6174
                         (> q 0)
 
6175
                         (< x (expt 2 (+ -1 (* -1 p) (expo (spn q))))))
 
6176
                    (equal (FL (* (SIG (EXPT 2 (+ 1 (EXPO X))))
 
6177
                                  (EXPT 2
 
6178
                                        (+ P (EXPO X) (* -1 (EXPO (SPN Q)))))))
 
6179
                           0))
 
6180
           :hints (("Goal" :use ((:instance fl-1/2-sig-x-is-zero
 
6181
                                            (x (expt 2 (+ 1 (expo x)))))
 
6182
                                 (:instance expo-monotone
 
6183
                                            (x x)
 
6184
                                            (y (expt 2 (+ -1 (* -1 p) (expo (spn q))))))))))
 
6185
           
 
6186
 
 
6187
         ;; (defthm expo-monotone-strong
 
6188
         ;;   (implies (and (< x (expt 2 n))
 
6189
         ;;                 (equal 
 
6190
         ;;             (rationalp x)
 
6191
 
 
6192
           
 
6193
         (defthm small-small-lemma
 
6194
           (implies (<= (+ 2 P (EXPO X)) (EXPO (SPN Q)))
 
6195
                    (<= (+ -1 p (expo x) (* -1 (expo (spn q))))
 
6196
                        -3)))
 
6197
 
 
6198
         (defthm small-small-lemma-2
 
6199
           (implies (<= (+ 2 P (EXPO X)) (EXPO (SPN Q)))
 
6200
                    (<= (+ p (expo x) (* -1 (expo (spn q))))
 
6201
                        -2)))
 
6202
 
 
6203
         (defthm small-is-small
 
6204
           (implies (and (>= 0 (+ p (expo x) (- (expo (spn q))) 2))
 
6205
                         (rationalp x)
 
6206
                         (> x 0)
 
6207
                         (natp p)
 
6208
                         (> x 0)
 
6209
                         (> p 1)
 
6210
                         (natp q)
 
6211
                         (> q 0))
 
6212
                    (> 1
 
6213
                       (* 2 (SIG X)
 
6214
                          (EXPT 2
 
6215
                                (+ -1 P (EXPO X)
 
6216
                                   (* -1 (EXPO (SPN q))))))))
 
6217
           :hints (("Goal" :use ((:instance sig-upper-bound)
 
6218
                                 (:instance expt-weak-monotone-linear
 
6219
                                            (n (+ -1 P (EXPO X)
 
6220
                                                  (* -1 (EXPO (SPN q)))))
 
6221
                                            (m -3)))))
 
6222
           :rule-classes :linear)
 
6223
           
 
6224
         (encapsulate () 
 
6225
                      (local      
 
6226
                       (defthm sig-expt-fact
 
6227
                         (implies (integerp n)
 
6228
                                  (equal (sig (expt 2 n)) 1))
 
6229
                         :hints (("Goal" :in-theory (enable sig a15)))))
 
6230
 
 
6231
                      (defthm small-is-small-v2
 
6232
                        (implies (and (>= 0 (+ p (expo x) (- (expo (spn q))) 2))
 
6233
                                      (rationalp x)
 
6234
                                      (> x 0)
 
6235
                                      (natp p)
 
6236
                                      (> x 0)
 
6237
                                      (> p 1)
 
6238
                                      (natp q)
 
6239
                                      (> q 0))
 
6240
                                 (> 1
 
6241
                                    (* 2 (SIG (EXPT 2 (+ 1 (EXPO X))))
 
6242
                                       (EXPT 2
 
6243
                                             (+ P (EXPO X) (* -1 (EXPO (SPN Q))))))))
 
6244
                        :hints (("Goal" :use ((:instance expt-weak-monotone-linear
 
6245
                                                         (n (+ P (EXPO X)
 
6246
                                                               (* -1 (EXPO (SPN q)))))
 
6247
                                                         (m -2)))))
 
6248
                        :rule-classes :linear))
 
6249
                
 
6250
 
 
6251
 
 
6252
 
 
6253
         (defthm extra-small-drnd-is-equal
 
6254
           (implies (and (< x (expt 2 (+ -1 (* -1 p) (expo (spn q)))))
 
6255
                         (>= 0 (+ p (expo x) (- (expo (spn q))) 2))
 
6256
                         (> x 0)
 
6257
                         (natp p)
 
6258
                         (> x 0)
 
6259
                         (> p 1)
 
6260
                         (natp q)
 
6261
                         (> q 0)
 
6262
                         (rationalp x))
 
6263
                    (equal (drnd (sticky x 0) mode p q)
 
6264
                           (drnd x mode p q)))
 
6265
           :hints (("Goal" :in-theory (enable drnd trunc sgn cg near+ near away rnd sticky))))
 
6266
 
 
6267
 
 
6268
         (defthm drnd-sticky-lemma
 
6269
           (implies (and (common-rounding-mode-p mode)
 
6270
                         (natp p)
 
6271
                         (> x 0)
 
6272
                         (> p 1)
 
6273
                         (natp q)
 
6274
                         (> q 0)
 
6275
                         (rationalp x)
 
6276
                         (<= x (spn q))
 
6277
                         (>= n 0)
 
6278
                         (integerp n)
 
6279
                         (>= n (+ p (expo x) (- (expo (spn q))) 2)))
 
6280
                    (equal (drnd (sticky x n) mode p q)
 
6281
                           (drnd x mode p q)))
 
6282
           :hints (("Goal" :cases ((not (> (+ p (expo x)) (expo (spn q))))))
 
6283
                   ("Subgoal 2" :cases ((not (equal n 0))))
 
6284
                   ("Subgoal 2.1"  :use ((:instance rnd-sticky
 
6285
                                                    (m (+ p (expo x) 
 
6286
                                                          (- (expo (spn q)))))))
 
6287
                    :in-theory (enable drnd))
 
6288
                   ("Subgoal 1" :in-theory (e/d (common-rounding-mode-p
 
6289
                                                 sticky-positive ieee-mode-p)
 
6290
                                                (drnd rnd))
 
6291
                    :cases ((not (equal x (expt 2 (+ (* -1 p)
 
6292
                                                     (expo (spn q))))))))
 
6293
                   ("Subgoal 1.1"  :cases ((not (equal n 0))))
 
6294
                   ("Subgoal 1.1.2" :use ((:instance extra-small-drnd-is-equal)
 
6295
                                          (:instance
 
6296
                                           n-equal-zero-implies-ultra-small)))
 
6297
                   ("Subgoal 1.1.1" :cases ((not (> x (expt 2 (+ (* -1 p)
 
6298
                                                                 (expo (spn q)))))))))
 
6299
           :rule-classes nil)))
 
6300
 
 
6301
 
 
6302
  (defthm drnd-sticky
 
6303
    (implies (and (common-rounding-mode-p mode)
 
6304
                  (natp p)
 
6305
                  (> p 1)
 
6306
                  (natp q)
 
6307
                  (> q 0)
 
6308
                  (rationalp x)
 
6309
                  (<= (abs x) (spn q))
 
6310
                  (natp n)
 
6311
                  (>= n (+ p (expo x) (- (expo (spn q))) 2)))
 
6312
             (equal (drnd (sticky x n) mode p q)
 
6313
                    (drnd x mode p q)))
 
6314
    :rule-classes ()
 
6315
    :hints (("Goal" :cases ((not (equal x 0)))
 
6316
             :in-theory (enable sticky-minus expo-minus
 
6317
                                drnd-minus flip))
 
6318
            ("Subgoal 1" :cases ((not (> x 0))))
 
6319
            ("Subgoal 1.2" :use ((:instance drnd-sticky-lemma)))
 
6320
            ("Subgoal 1.1" :use ((:instance drnd-sticky-lemma
 
6321
                                            (x (* -1 x))
 
6322
                                            (mode (flip mode)))))))
 
6323
 
 
6324
 
 
6325
 
 
6326
 
 
6327
  (defthm drnd-tiny-equal
 
6328
    (implies (and (common-rounding-mode-p mode)
 
6329
                  (natp p)
 
6330
                  (> p 1)
 
6331
                  (natp q)
 
6332
                  (> q 0)
 
6333
                  (rationalp x)
 
6334
                  (< 0 x)
 
6335
                  (< (abs x) (/ (spd p q) 2))
 
6336
                  (rationalp y)
 
6337
                  (< 0 y)
 
6338
                  (< (abs y) (/ (spd p q) 2)))
 
6339
             (equal (drnd x mode p q)
 
6340
                    (drnd y mode p q)))
 
6341
    :hints (("Goal" :use ((:instance drnd-tiny-equal-lemma))))
 
6342
    :rule-classes nil)
 
6343
 
 
6344
)
 
6345
 
 
6346
;----------------------------------------------------------------------
 
6347
(encapsulate ()
 
6348
 
 
6349
 (local (encapsulate () 
 
6350
 
 
6351
                     ;; (defthm plus-rnd
 
6352
                     ;;   (implies (and (rationalp x)
 
6353
                     ;;                 (>= x 0)
 
6354
                     ;;                 (rationalp y)
 
6355
                     ;;                 (>= y 0)
 
6356
                     ;;                 (integerp k)
 
6357
                     ;;                 (exactp x (+ -1 k (- (expo x) (expo y))))
 
6358
                     ;;                 (common-rounding-mode-p mode))
 
6359
                     ;;            (= (+ x (rnd y mode k))
 
6360
                     ;;               (rnd (+ x y)
 
6361
                     ;;                    mode
 
6362
                     ;;                    (+ k (- (expo (+ x y)) (expo y))))))
 
6363
                     ;;   :hints (("Goal" :use ((:instance plus-rnd---rtl-rel5-support))))
 
6364
                     ;;   :rule-classes ())
 
6365
 
 
6366
                     (defthm exactp-spn-fact
 
6367
                       (implies (and (integerp p)
 
6368
                                     (> p 1)
 
6369
                                     (integerp q)
 
6370
                                     (> q 0))
 
6371
                                (EXACTP (SPN Q) (+ -1 P)))
 
6372
                       :hints (("Goal" :in-theory (enable spn exactp-2**n))))
 
6373
 
 
6374
                     (defthm exactp-spn-fact-2
 
6375
                       (implies (and (integerp p)
 
6376
                                     (> p 1)
 
6377
                                     (integerp q)
 
6378
                                     (> q 0))
 
6379
                                (EXACTP (SPN Q) P))
 
6380
                       :hints (("Goal" :in-theory (enable spn exactp-2**n))))
 
6381
 
 
6382
                     (defthm exactp-spn-fact-3
 
6383
                       (implies (and (integerp p)
 
6384
                                     (> p 1)
 
6385
                                     (integerp q)
 
6386
                                     (> q 0))
 
6387
                                (EXACTP (* 2 (SPN Q)) P))
 
6388
                       :hints (("Goal" :in-theory (enable spn exactp-2**n)
 
6389
                                :use ((:instance a15 (i 2) (j1 1) (j2 (+ 1 (* -1 (BIAS Q)))))))))
 
6390
 
 
6391
 
 
6392
                     ;; (defthm expo-unique
 
6393
                     ;;   (implies (and (<= (expt 2 n) (abs x))
 
6394
                     ;;                 (< (abs x) (expt 2 (1+ n)))
 
6395
                     ;;                 (rationalp x)
 
6396
                     ;;                 (integerp n))
 
6397
                     ;;            (equal n (expo x)))
 
6398
                     ;;   :rule-classes ())
 
6399
 
 
6400
 
 
6401
                     (encapsulate () 
 
6402
                                  (local 
 
6403
                                   (defthm local-expt-expand 
 
6404
                                     (implies (integerp n)
 
6405
                                              (equal (EXPT 2 (+ 1 n))
 
6406
                                                     (* 2 (expt 2 n))))
 
6407
                                     :hints (("Goal" :use ((:instance a15 (i 2) (j1 1)
 
6408
                                                                      (j2 n)))))))
 
6409
 
 
6410
                                  (defthm expo-x-plus-spn-equal-expo-spn-lemma
 
6411
                                    (implies (and (rationalp x)
 
6412
                                                  (> x 0)
 
6413
                                                  (< x (expt 2 n))
 
6414
                                                  (integerp n))
 
6415
                                             (equal (expo (+ x (expt 2 n)))
 
6416
                                                    n))
 
6417
                                    :hints (("Goal" :use ((:instance expo-unique
 
6418
                                                                     (x (+ x (expt 2 n)))
 
6419
                                                                     (n n)))
 
6420
                                             :in-theory (enable expo-2**n
 
6421
                                                                spn)))
 
6422
                                    :rule-classes nil))
 
6423
 
 
6424
 
 
6425
                     (defthm expo-x-plus-spn-equal-expo-spn
 
6426
                       (implies (and (rationalp x)
 
6427
                                     (> x 0)
 
6428
                                     (< x (spn q))
 
6429
                                     (integerp q)
 
6430
                                     (> q 0))
 
6431
                                (equal (expo (+ x (spn q)))
 
6432
                                       (expo (spn q))))
 
6433
                       :hints (("Goal" :in-theory (e/d (spn expo-2**n) ())
 
6434
                                :use ((:instance expo-x-plus-spn-equal-expo-spn-lemma
 
6435
                                                 (n (expo (spn q))))))))
 
6436
 
 
6437
 
 
6438
 
 
6439
 
 
6440
                     (defthmd drnd-rewrite-lemma
 
6441
                       (implies (and (rationalp x)
 
6442
                                     (>= x 0)
 
6443
                                     (<= x (spn q))
 
6444
                                     (common-rounding-mode-p mode)
 
6445
                                     (integerp p)
 
6446
                                     (> p 1)
 
6447
                                     (integerp q)
 
6448
                                     (> q 0))
 
6449
                                (equal (drnd x mode p q)
 
6450
                                       (- (rnd (+ x (* (sgn x) (spn q))) mode p)
 
6451
                                          (* (sgn x) (spn q)))))
 
6452
                       :hints (("Goal" :cases ((not (equal x (spn q)))))
 
6453
                               ("Subgoal 2" :in-theory (e/d (drnd sgn)
 
6454
                                                            (rnd-exactp-b))
 
6455
                                :use ((:instance rnd-exactp-b (x (spn q))
 
6456
                                                 (n p))
 
6457
                                      (:instance rnd-exactp-b (x (* 2 (spn q)))
 
6458
                                                 (n p))))
 
6459
                               ("Subgoal 1" :use ((:instance
 
6460
                                                   plus-rnd
 
6461
                                                             (x (spn q))
 
6462
                                                             (y x)
 
6463
                                                             (k (+ p (expo x) (* -1 (expo (spn q)))))))
 
6464
                                :in-theory (e/d (drnd sgn bias exactp-2**n) (common-rounding-mode-p)))))
 
6465
 
 
6466
 
 
6467
                      (defthm collect-neg-specific
 
6468
                        (equal (+ (* -1 X) (* -1 (SGN X) (SPN Q)))
 
6469
                               (* -1 (+ x (* (sgn x) (spn q))))))))
 
6470
 
 
6471
        (defthmd drnd-rewrite
 
6472
          (implies (and (rationalp x)
 
6473
                        (<= (abs x) (spn q))
 
6474
                        (common-rounding-mode-p mode)
 
6475
                        (integerp p)
 
6476
                        (> p 1)
 
6477
                        (integerp q)
 
6478
                        (> q 0))
 
6479
                   (equal (drnd x mode p q)
 
6480
                          (- (rnd (+ x (* (sgn x) (spn q))) mode p)
 
6481
                             (* (sgn x) (spn q)))))
 
6482
          :hints (("Goal" :cases ((not (>= x 0))))
 
6483
                  ("Subgoal 2" :use ((:instance drnd-rewrite-lemma)))
 
6484
                  ("Subgoal 1" :use ((:instance drnd-rewrite-lemma
 
6485
                                                (x (* -1 x))
 
6486
                                                (mode (flip mode))))
 
6487
                   :in-theory (enable drnd-minus sgn-minus
 
6488
                                      rnd-minus expo-minus flip))))
 
6489
 
 
6490
        )
 
6491
 
 
6492
;----------------------------------------------------------------------