From 1c97b4c21f978136b5c52c838f9a1cd4ac17bd1f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 10 Apr 2006 03:54:55 +0000 Subject: [PATCH] fixed PR 7999 and added one-of/c to the contract library svn: r2650 --- collects/htdp/image.ss | 11 ++++++-- collects/mzlib/private/contract.ss | 35 ++++++++++++++++++++---- collects/tests/mzscheme/contract-test.ss | 11 +++++++- collects/tests/mzscheme/htdp-image.ss | 17 ++++++++++++ 4 files changed, 65 insertions(+), 9 deletions(-) diff --git a/collects/htdp/image.ss b/collects/htdp/image.ss index c0f6d8a29a..0a7354eb7b 100644 --- a/collects/htdp/image.ss +++ b/collects/htdp/image.ss @@ -76,6 +76,7 @@ plt/collects/tests/mzscheme/image-test.ss (define (check name p? v desc arg-posn) (check-arg name (p? v) desc arg-posn v)) (define (check-coordinate name val arg-posn) (check name number? val "number" arg-posn)) + (define (check-integer-coordinate name val arg-posn) (check name integer? val "integer" arg-posn)) (define (check-size name val arg-posn) (check name posi? val "positive exact integer" arg-posn)) (define (check-size/0 name val arg-posn) (check name nnosi? val "non-negative exact integer" arg-posn)) (define (check-image name val arg-posn) (check name image? val "image" arg-posn)) @@ -192,10 +193,14 @@ plt/collects/tests/mzscheme/image-test.ss (define (overlay/xy a dx dy b) (check-image 'overlay/xy a "first") - (check-coordinate 'overlay/xy dx "second") - (check-coordinate 'overlay/xy dy "third") + (check-integer-coordinate 'overlay/xy dx "second") + (check-integer-coordinate 'overlay/xy dy "third") (check-image 'overlay/xy b "fourth") - (real-overlay/xy 'overlay/xy a dx dy b)) + (real-overlay/xy 'overlay/xy + a + (if (exact? dx) dx (inexact->exact dx)) + (if (exact? dy) dy (inexact->exact dy)) + b)) (define (real-overlay/xy name raw-a raw-delta-x raw-delta-y raw-b) (let ([a (coerce-to-cache-image-snip raw-a)] diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index bacf703ad8..db8d1d6fd7 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -24,6 +24,7 @@ add struct contracts for immutable structs? (require (lib "etc.ss") (lib "list.ss") (lib "pretty.ss") + (lib "pconvert.ss") "contract-arrow.ss" "contract-guts.ss") @@ -734,7 +735,7 @@ add struct contracts for immutable structs? string/len false/c printable/c - symbols + symbols one-of/c listof list-immutableof vectorof vector-immutableof vector/c vector-immutable/c cons-immutable/c cons/c list-immutable/c list/c @@ -935,10 +936,34 @@ add struct contracts for immutable structs? (unless (andmap symbol? ss) (error 'symbols "expected symbols as arguments, given: ~a" (apply string-append (map (lambda (x) (format "~e " x)) ss)))) - (flat-named-contract - `(symbols ,@(map (lambda (x) `',x) ss)) - (lambda (x) - (memq x ss)))) + (make-one-of/c ss)) + + (define (one-of/c . elems) (make-one-of/c elems)) + + (define-struct/prop one-of/c (elems) + ((pos-proj-prop flat-pos-proj) + (neg-proj-prop any-curried-proj) + (name-prop (λ (ctc) + (let ([elems (one-of/c-elems ctc)]) + `(,(cond + [(andmap symbol? elems) + 'symbols] + [else + 'one-of/c]) + ,@(map print-convert elems))))) + (stronger-prop + (λ (this that) + (and (one-of/c? that) + (let ([this-elems (one-of/c-elems this)] + [that-elems (one-of/c-elems that)]) + (and + (andmap (λ (this-elem) (memv this-elem that-elems)) + this-elems) + #t))))) + (flat-prop + (λ (ctc) + (let ([elems (one-of/c-elems ctc)]) + (λ (x) (memv x elems))))))) (define printable/c (flat-named-contract diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 9baed79aee..5320a2c097 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -3774,6 +3774,8 @@ (test/spec-passed 'any/c '(contract any/c 1 'pos 'neg)) (test-flat-contract 'printable/c (vector (cons 1 (box #f))) (lambda (x) x)) (test-flat-contract '(symbols 'a 'b 'c) 'a 'd) + (test-flat-contract '(one-of/c (expt 2 65)) (expt 2 65) 12) + (test-flat-contract '(one-of/c #:x #:z) #:x #:y) (let ([c% (class object% (super-new))]) (test-flat-contract (subclass?/c c%) c% object%) @@ -3969,7 +3971,8 @@ (test-name 'natural-number/c natural-number/c) (test-name 'false/c false/c) (test-name 'printable/c printable/c) - (test-name '(symbols 'a 'b 'c)(symbols 'a 'b 'c)) + (test-name '(symbols 'a 'b 'c) (symbols 'a 'b 'c)) + (test-name '(one-of/c 1 2 3) (one-of/c 1 2 3)) (let ([c% (class object% (super-new))]) (test-name '(subclass?/c class:c%) (subclass?/c c%))) @@ -4112,6 +4115,12 @@ (test #t contract-stronger? number? number?) (test #f contract-stronger? boolean? number?) + (test #t contract-stronger? (symbols 'x 'y) (symbols 'x 'y 'z)) + (test #f contract-stronger? (symbols 'x 'y 'z) (symbols 'x 'y)) + (test #t contract-stronger? (symbols 'x 'y) (symbols 'z 'x 'y)) + (test #f contract-stronger? (symbols 'z 'x 'y) (symbols 'x 'y)) + (test #t contract-stronger? (one-of/c (expt 2 100)) (one-of/c (expt 2 100) 12)) + (let () (define-contract-struct couple (hd tl)) (define (non-zero? x) (not (zero? x))) diff --git a/collects/tests/mzscheme/htdp-image.ss b/collects/tests/mzscheme/htdp-image.ss index b5d5c09d56..27a67e2634 100644 --- a/collects/tests/mzscheme/htdp-image.ss +++ b/collects/tests/mzscheme/htdp-image.ss @@ -1047,4 +1047,21 @@ snips as arguments (err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) 1 1 #f #f) "fourth") (err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) 1 1 0 #f) "fifth") +(err/rt-name-test (overlay/xy #f + 13687968/78125 ; number's floor is 175 + 10 + (circle 50 'outline 'blue)) + "first") +(err/rt-name-test (overlay/xy (rectangle 100 200 'outline 'red) + 13687968/78125 ; number's floor is 175 + 10 + (circle 50 'outline 'blue)) + "second") +(err/rt-name-test (overlay/xy (rectangle 100 200 'outline 'red) + 10 + 13687968/78125 + (circle 50 'outline 'blue)) + "third") +(err/rt-name-test (overlay/xy (rectangle 100 200 'outline 'red) 10 10 #f) "fourth") + (report-errs) \ No newline at end of file