suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

allow #f as arguments to integer-in

Browse Source
This commit is contained in:
Robby Findler 2017-03-07 09:27:34 -06:00
parent 7c3412957a
commit 87e024d55c
6 changed files with 97 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -360,10 +360,32 @@ one of them.}
@defproc[(real-in [n real?] [m real?]) flat-contract?]{
An alias for @racket[between/c].}
@defproc[(integer-in [j exact-integer?] [k exact-integer?]) flat-contract?]{
@defproc[(integer-in [j (or/c exact-integer? #f)] [k (or/c exact-integer? #f)]) flat-contract?]{
Returns a @tech{flat contract} that requires the input to be an exact integer
between @racket[j] and @racket[k], inclusive.}
between @racket[j] and @racket[k], inclusive. If either @racket[j] or @racket[k]
is @racket[#f], then the range is unbounded on that end.
@examples[#:eval (contract-eval) #:once
(define/contract two-digit-number
(integer-in 10 99)
23)
(define/contract not-a-two-digit-number
(integer-in 10 99)
124)
(define/contract negative-number
(integer-in #f -1)
-4)
(define/contract not-a-negative-number
(integer-in #f -1)
4)]
@history[#:changed "6.8.0.2" @elem{Allow #@racket[j] and @racket[k] to be @racket[#f]}]
}
@defproc[(char-in [a char?] [b char?]) flat-contract?]{

17
pkgs/racket-test/tests/racket/contract/flat-contracts.rkt
View File

@ -1,24 +1,30 @@
#lang racket/base
(require "test-util.rkt")
(require "test-util.rkt"
(for-syntax racket/base))
(parameterize ([current-contract-namespace
(make-basic-contract-namespace
'racket/class
'racket/contract/combinator)])
(define (test-flat-contract contract pass fail)
(define-syntax (test-flat-contract stx)
(syntax-case stx ()
[(_ contract pass fail)
#`(test-flat-contract/proc contract pass fail #,(syntax-line stx))]))
(define (test-flat-contract/proc contract pass fail line)
(contract-eval `(,test #t flat-contract? ,contract))
(define (run-two-tests maybe-rewrite)
(let ([name (if (pair? contract)
(car contract)
contract)])
(let/ec k
(test/spec-failed (format "~a fail" name)
(test/spec-failed (format "~a fail, line ~a" name line)
(maybe-rewrite `(contract ,contract ',fail 'pos 'neg) k)
'pos))
(let/ec k
(test/spec-passed/result
(format "~a pass" name)
(format "~a pass, line ~a" name line)
(maybe-rewrite `(contract ,contract ',pass 'pos 'neg) k)
pass))))
(run-two-tests (λ (x k) x))
@ -42,6 +48,9 @@
(test-flat-contract '(integer-in 0 10) 10 3/2)
(test-flat-contract '(integer-in 0 10) 1 1.0)
(test-flat-contract '(integer-in 1 1) 1 1.0)
(test-flat-contract '(integer-in 1 #f) 1 -1)
(test-flat-contract '(integer-in #f 1) -1 2)
(test-flat-contract '(integer-in #f #f) -1 "x")
(test-flat-contract '(char-in #\a #\z) #\a #\Z)
(test-flat-contract '(char-in #\a #\z) #\z #\A)
(test-flat-contract '(char-in #\a #\z) #\b "b")

3
pkgs/racket-test/tests/racket/contract/name.rkt
View File

@ -249,6 +249,9 @@
(test-name 'real? (between/c -inf.0 +inf.0))
(test-name '5 (between/c 5 5))
(test-name '(integer-in 0 10) (integer-in 0 10))
(test-name '(integer-in 10 #f) (integer-in 10 #f))
(test-name '(integer-in #f 10) (integer-in #f 10))
(test-name 'exact-integer? (integer-in #f #f))
(test-name '(char-in #\a #\z) (char-in #\a #\z))
(test-name '(and/c 0 exact?) (integer-in 0 0))
(test-name '(real-in 1 10) (real-in 1 10))

5
pkgs/racket-test/tests/racket/contract/random-generate.rkt
View File

@ -41,10 +41,13 @@
(check-not-exn (λ () (test-contract-generation (listof boolean?))))
(check-not-exn (λ () (test-contract-generation (listof number?))))
(check-not-exn (λ () (test-contract-generation (integer-in 0 100))))
(check-not-exn (λ () (test-contract-generation exact-nonnegative-integer?)))
(check-not-exn (λ () (test-contract-generation natural?)))
(check-not-exn (λ () (test-contract-generation (integer-in 0 100))))
(check-not-exn (λ () (test-contract-generation (integer-in 0 (expt 2 1000)))))
(check-not-exn (λ () (test-contract-generation (integer-in 0 #f))))
(check-not-exn (λ () (test-contract-generation (integer-in #f 0))))
(check-not-exn (λ () (test-contract-generation (integer-in #f #f))))
(check-not-exn (λ () (test-contract-generation (char-in #\a #\z))))
(check-not-exn (λ () (test-contract-generation #\a)))
(check-not-exn (λ () (test-contract-generation (between/c 1 100))))

6
pkgs/racket-test/tests/racket/contract/stronger.rkt
View File

@ -14,6 +14,12 @@
(ctest #t contract-stronger? (integer-in 0 4) (integer-in 0 4))
(ctest #t contract-stronger? (integer-in 1 3) (integer-in 0 4))
(ctest #f contract-stronger? (integer-in 0 4) (integer-in 1 3))
(ctest #f contract-stronger? (integer-in 0 4) (integer-in 1 #f))
(ctest #t contract-stronger? (integer-in 0 4) (integer-in #f 3))
(ctest #t contract-stronger? (integer-in 0 #f) (integer-in #f #f))
(ctest #t contract-stronger? (integer-in #f 0) (integer-in #f #f))
(ctest #t contract-stronger? (integer-in 0 0) (and/c 0 exact?))
(ctest #t contract-stronger? (and/c 0 exact?) (integer-in 0 0))
(ctest #t contract-stronger? #\a (char-in #\a #\c))
(ctest #f contract-stronger? #\a (char-in #\b #\c))
(ctest #t contract-stronger? (char-in #\f #\q) (char-in #\a #\z))

63
racket/collects/racket/contract/private/and.rkt
View File

@ -214,32 +214,63 @@
(struct integer-in-ctc (start end)
#:property prop:flat-contract
(build-flat-contract-property
#:name (λ (ctc)
`(integer-in ,(integer-in-ctc-start ctc)
,(integer-in-ctc-end ctc)))
#:name (λ (ctc)
(define start (integer-in-ctc-start ctc))
(define end (integer-in-ctc-end ctc))
(cond
[(or start end)
`(integer-in ,(integer-in-ctc-start ctc)
,(integer-in-ctc-end ctc))]
[else 'exact-integer?]))
#:first-order (λ (ctc)
(define start (integer-in-ctc-start ctc))
(define end (integer-in-ctc-end ctc))
(λ (x) (and (exact-integer? x)
(<= start x end))))
(cond
[(and start end) (λ (x) (and (exact-integer? x) (<= start x end)))]
[start (λ (x) (and (exact-integer? x) (<= start x)))]
[end (λ (x) (and (exact-integer? x) (<= x end)))]
[else exact-integer?]))
#:stronger (λ (this that)
(define this-start (integer-in-ctc-start this))
(define this-end (integer-in-ctc-end that))
(define this-start (or (integer-in-ctc-start this) -inf.0))
(define this-end (or (integer-in-ctc-end this) +inf.0))
(cond
[(integer-in-ctc? that)
(define that-start (integer-in-ctc-start that))
(define that-end (integer-in-ctc-end that))
(define that-start (or (integer-in-ctc-start that) -inf.0))
(define that-end (or (integer-in-ctc-end that) +inf.0))
(<= that-start this-start this-end that-end)]
[else #f]))
#:generate (λ (ctc)
(define start (integer-in-ctc-start ctc))
(define end (integer-in-ctc-end ctc))
(λ (fuel)
(λ ()
(+ start (random (min 4294967087 (+ (- end start) 1)))))))))
(define max-random-range 4294967087)
(cond
[(or start end)
(define _start (or start (- end max-random-range)))
(define _end (or end (+ start max-random-range)))
(λ (fuel)
(λ ()
(+ _start (random (min 4294967087 (+ (- _end _start) 1))))))]
[else
(λ (fuel)
(λ ()
(cond
[(zero? (random 20)) 0]
[else
(* (if (zero? (random 2)) -1 1)
(+ (expt 2 (geo-dist 1/2))
(geo-dist 1/2)))])))]))))
(define (geo-dist p)
(let loop ([n 0])
(cond
[(< (random) p) (loop (+ n 1))]
[else n])))
(define/final-prop (integer-in start end)
(check-two-args 'integer-in start end exact-integer? exact-integer?)
(if (= start end)
(and/c start exact?)
(integer-in-ctc start end)))
(define (|(or/c #f exact-integer?)| x) (or (not x) (exact-integer? x)))
(check-two-args 'integer-in start end |(or/c #f exact-integer?)| |(or/c #f exact-integer?)|)
(cond
[(and start end (= start end))
(and/c start exact?)]
[else
(integer-in-ctc start end)]))