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

improve interaction between natural?, exact-positive-integer?, exact-integer?,

Browse Source 
and/c, and between/c (which implies <=/c and >=/c) so that they turn
themselves into integer-in when appropriate

for example, (contract-stronger? (integer-in 0 4) (and/c natural? (<=/c 4)))
returns #t
This commit is contained in:
Robby Findler 2017-03-07 16:23:37 -06:00
parent 87e024d55c
commit 3a639d7794
6 changed files with 114 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,7 +5,8 @@
(parameterize ([current-contract-namespace
(make-basic-contract-namespace
'racket/class
'racket/contract/combinator)])
'racket/contract/combinator
'racket/math)])
(define-syntax (test-flat-contract stx)
(syntax-case stx ()
@ -51,6 +52,12 @@
(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 '(and/c natural? (between/c -10 10)) 0 -1)
(test-flat-contract '(and/c exact-positive-integer? (between/c -10 10)) 1 0)
(test-flat-contract '(and/c exact-integer? (between/c -10 10)) 1 11)
(test-flat-contract '(and/c exact-integer? (between/c -10 10)) -1 -11)
(test-flat-contract '(and/c exact-integer? (between/c -10.5 10.5)) -10 -11)
(test-flat-contract '(and/c exact-integer? (between/c -10.5 10.5)) 10 11)
(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")

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

@ -252,6 +252,8 @@
(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 'natural? (integer-in 0 #f))
(test-name 'exact-positive-integer? (integer-in 1 #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))

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

@ -4,22 +4,43 @@
(parameterize ([current-contract-namespace
(make-basic-contract-namespace 'racket/contract
'racket/list
'racket/class)])
'racket/class
'racket/math)])
(contract-eval '(define-contract-struct couple (hd tl)))
(contract-eval '(define-contract-struct triple (a b c)))
(ctest #t contract-stronger? any/c any/c)
(ctest #t contract-stronger? integer? any/c)
(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 #f contract-stronger? (integer-in 0 4) (integer-in #f 3))
(ctest #t contract-stronger? (integer-in 0 4) (integer-in #f 4))
(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? exact-integer? (integer-in #f #f))
(ctest #t contract-stronger? (integer-in #f #f) exact-integer?)
(ctest #t contract-stronger? (integer-in 0 #f) exact-nonnegative-integer?)
(ctest #t contract-stronger? (integer-in 0 #f) natural?)
(ctest #t contract-stronger? natural? (integer-in 0 #f))
(ctest #t contract-stronger? (integer-in 1 #f) exact-positive-integer?)
(ctest #t contract-stronger? exact-positive-integer? (integer-in 1 #f))
(ctest #t contract-stronger? natural? exact-integer?) ;; this actually is `integer-in`
(ctest #t contract-stronger? (integer-in 0 5) (and/c natural? (<=/c 5)))
(ctest #t contract-stronger? (and/c natural? (<=/c 5)) (integer-in 0 5))
(ctest #t contract-stronger? (integer-in 0 5) (and/c exact-nonnegative-integer? (<=/c 5)))
(ctest #t contract-stronger? (and/c exact-nonnegative-integer? (<=/c 5)) (integer-in 0 5))
(ctest #t contract-stronger? (integer-in 5 #f) (and/c natural? (>=/c 5)))
(ctest #t contract-stronger? (and/c natural? (>=/c 5)) (integer-in 5 #f))
(ctest #t contract-stronger? (integer-in 0 #f) (and/c exact-nonnegative-integer? (>=/c -4)))
(ctest #t contract-stronger? (and/c exact-nonnegative-integer? (>=/c -4)) (integer-in 0 #f))
(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))

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

@ -4,6 +4,7 @@
"arr-util.rkt")
racket/promise
(only-in "../../private/promise.rkt" prop:force promise-forcer)
"../../private/math-predicates.rkt"
"prop.rkt"
"blame.rkt"
"guts.rkt"
@ -185,31 +186,67 @@
[(andmap flat-contract? contracts)
(define preds (map flat-contract-predicate contracts))
(cond
[(and (chaperone-of? (car preds) real?)
(pair? (cdr preds))
[(and (pair? (cdr preds))
(null? (cddr preds)))
(define second-pred (cadr preds))
(cond
[(chaperone-of? second-pred negative?)
(</c 0)]
[(chaperone-of? second-pred positive?)
(>/c 0)]
[else
(define second-contract (cadr contracts))
[(chaperone-of? (car preds) real?)
(define second-pred (cadr preds))
(cond
[(equal? (contract-name second-contract) '(not/c positive?))
(<=/c 0)]
[(equal? (contract-name second-contract) '(not/c negative?))
(>=/c 0)]
[(chaperone-of? second-pred negative?)
(</c 0)]
[(chaperone-of? second-pred positive?)
(>/c 0)]
[else
(make-first-order-and/c contracts preds)])])]
(define second-contract (cadr contracts))
(cond
[(equal? (contract-name second-contract) '(not/c positive?))
(<=/c 0)]
[(equal? (contract-name second-contract) '(not/c negative?))
(>=/c 0)]
[else
(make-first-order-and/c contracts preds)])])]
[(or (chaperone-of? (car preds) exact-nonnegative-integer?)
(chaperone-of? (car preds) natural?)
(chaperone-of? (cadr preds) exact-nonnegative-integer?)
(chaperone-of? (cadr preds) natural?))
(define other (if (procedure? (car preds)) (cadr contracts) (car contracts)))
(cond
[(between/c-s? other)
(define other-low (between/c-s-low other))
(define other-high (between/c-s-high other))
(integer-in (exact-ceiling (max 0 (if (= other-low -inf.0) 0 other-low)))
(if (= other-high +inf.0) #f (exact-floor other-high)))]
[else (make-first-order-and/c contracts preds)])]
[(or (chaperone-of? (car preds) exact-positive-integer?)
(chaperone-of? (cadr preds) exact-positive-integer?))
(define other (if (procedure? (car preds)) (cadr contracts) (car contracts)))
(cond
[(between/c-s? other)
(define other-low (between/c-s-low other))
(define other-high (between/c-s-high other))
(integer-in (exact-ceiling (max 1 (if (= other-low -inf.0) 1 other-low)))
(if (= other-high +inf.0) #f (exact-floor other-high)))]
[else (make-first-order-and/c contracts preds)])]
[(or (chaperone-of? (car preds) exact-integer?)
(chaperone-of? (cadr preds) exact-integer?))
(define other (if (procedure? (car preds)) (cadr contracts) (car contracts)))
(cond
[(between/c-s? other)
(define other-low (between/c-s-low other))
(define other-high (between/c-s-high other))
(integer-in (exact-ceiling (if (= other-low -inf.0) #f other-low))
(if (= other-high +inf.0) #f (exact-floor other-high)))]
[else (make-first-order-and/c contracts preds)])]
[else
(make-first-order-and/c contracts preds)])]
[else
(make-first-order-and/c contracts preds)])]
[(andmap chaperone-contract? contracts)
(make-chaperone-and/c contracts)]
[else (make-impersonator-and/c contracts)])))
(define (exact-floor x) (floor (inexact->exact x)))
(define (exact-ceiling x) (ceiling (inexact->exact x)))
(struct integer-in-ctc (start end)
#:property prop:flat-contract
@ -218,6 +255,8 @@
(define start (integer-in-ctc-start ctc))
(define end (integer-in-ctc-end ctc))
(cond
[(and (not end) (equal? start 0)) 'natural?]
[(and (not end) (equal? start 1)) 'exact-positive-integer?]
[(or start end)
`(integer-in ,(integer-in-ctc-start ctc)
,(integer-in-ctc-end ctc))]
@ -227,7 +266,12 @@
(define end (integer-in-ctc-end ctc))
(cond
[(and start end) (λ (x) (and (exact-integer? x) (<= start x end)))]
[start (λ (x) (and (exact-integer? x) (<= start x)))]
[start
(case start
[(0) exact-nonnegative-integer?]
[(1) exact-positive-integer?]
[else
(λ (x) (and (exact-integer? x) (<= start x)))])]
[end (λ (x) (and (exact-integer? x) (<= x end)))]
[else exact-integer?]))
#:stronger (λ (this that)
@ -274,3 +318,7 @@
(and/c start exact?)]
[else
(integer-in-ctc start end)]))
(set-some-basic-integer-in-contracts! (integer-in #f #f)
(integer-in 0 #f)
(integer-in 1 #f))

13
racket/collects/racket/contract/private/guts.rkt
View File

@ -5,6 +5,7 @@
"prop.rkt"
"rand.rkt"
"generate-base.rkt"
"../../private/math-predicates.rkt"
racket/pretty
racket/list
(for-syntax racket/base
@ -72,6 +73,7 @@
set-some-basic-list-contracts!
set-some-basic-misc-contracts!
set-some-basic-integer-in-contracts!
contract-first-order-okay-to-give-up?
contract-first-order-try-less-hard
@ -327,6 +329,13 @@
(set! between/c-s? b/c-s?)
(set! between/c-s-low b/c-s-l)
(set! between/c-s-high b/c-s-h))
(define integer-in-ff #f)
(define integer-in-0f #f)
(define integer-in-1f #f)
(define (set-some-basic-integer-in-contracts! ff 0f 1f)
(set! integer-in-ff ff)
(set! integer-in-0f 0f)
(set! integer-in-1f 1f))
(define (coerce-contract/f x [name name-default])
(cond
@ -362,6 +371,10 @@
(if (name-default? name)
between/c-inf+inf
(renamed-between/c -inf.0 +inf.0 name))]
[(chaperone-of? x exact-positive-integer?) integer-in-1f]
[(chaperone-of? x exact-nonnegative-integer?) integer-in-0f]
[(chaperone-of? x natural?) integer-in-0f]
[(chaperone-of? x exact-integer?) integer-in-ff]
[else
(make-predicate-contract (if (name-default? name)
(or (object-name x) '???)

4
racket/collects/racket/contract/private/misc.rkt
View File

@ -53,7 +53,9 @@
suggest/c
flat-contract-with-explanation)
flat-contract-with-explanation
(struct-out between/c-s))
(define-syntax (flat-murec-contract stx)
(syntax-case stx ()