diff --git a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt index 080e6430ba..dcab995e13 100644 --- a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt +++ b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt @@ -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") diff --git a/pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-test/tests/racket/contract/name.rkt index 09d7505027..85b5709787 100644 --- a/pkgs/racket-test/tests/racket/contract/name.rkt +++ b/pkgs/racket-test/tests/racket/contract/name.rkt @@ -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)) diff --git a/pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-test/tests/racket/contract/stronger.rkt index 98499cef58..43076baaa4 100644 --- a/pkgs/racket-test/tests/racket/contract/stronger.rkt +++ b/pkgs/racket-test/tests/racket/contract/stronger.rkt @@ -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)) diff --git a/racket/collects/racket/contract/private/and.rkt b/racket/collects/racket/contract/private/and.rkt index d65fd0c7bc..bd760e56a9 100644 --- a/racket/collects/racket/contract/private/and.rkt +++ b/racket/collects/racket/contract/private/and.rkt @@ -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)] - [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)] [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)) \ No newline at end of file diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index 972ba734e2..795553ee23 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -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) '???) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 44cf222240..ac7b173287 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -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 ()