fixed PR 7999 and added one-of/c to the contract library

svn: r2650

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)]

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

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)))

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)