added David's check-random to test engine and teaching languages

this is somewhat experimental, but it helps with testing random functions

pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/advanced.scrbl

@@ -11,8 +11,8 @@
             local let let* letrec time begin begin0 set! delay shared recur when case match unless
              ; match
              _ cons list list* struct vector box
-            check-expect check-within check-member-of check-range check-error)
+            check-expect check-random check-within check-member-of check-range check-error)
-(check-expect check-within check-error check-member-of check-range require)
+(check-expect check-random check-within check-error check-member-of check-range require)
 [program (code:line def-or-expr ...)]
 [def-or-expr definition
              expr
@@ -301,6 +301,7 @@ level as they did in the @secref["intermediate-lam"] level.
              and 
              or
              check-expect
+             check-random
              check-within
              check-error
              check-member-of

pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/beginner-abbr.scrbl

@@ -8,8 +8,8 @@
 
 @racketgrammar*+qq[
 #:literals (define define-struct lambda cond else if and or require lib planet
-            check-expect check-within check-error)
+            check-expect check-random check-within check-error)
-(check-expect check-within check-member-of check-range check-error require)
+(check-expect check-random check-within check-member-of check-range check-error require)
 [program (code:line def-or-expr ...)]
 [def-or-expr definition
              expr
@@ -68,6 +68,7 @@ Abbreviations} level as they did in the @secref["beginner"] level.
             and 
             or
             check-expect
+            check-random
             check-within
             check-error
             check-member-of

pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/beginner.scrbl

@@ -9,8 +9,8 @@
 
 @racketgrammar*+library[
 #:literals (define define-struct lambda cond else if and or require lib planet
-            check-expect check-within check-error)
+            check-expect check-random check-within check-error)
-(check-expect check-within check-member-of check-range check-error require)
+(check-expect check-random check-within check-member-of check-range check-error require)
 [program (code:line def-or-expr ...)]
 [def-or-expr definition
              expr
@@ -64,6 +64,7 @@ A quoted @racket[name] is a symbol. A symbol is a value, just like
              and 
              or
              check-expect
+             check-random
              check-within
              check-error
              check-member-of

pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/intermediate-lambda.scrbl

@@ -8,8 +8,8 @@
 
 @racketgrammar*+qq[
 #:literals (define define-struct lambda λ cond else if and or require lib planet
-            local let let* letrec time check-expect check-within check-member-of check-range check-error)
+            local let let* letrec time check-expect check-random check-within check-member-of check-range check-error)
-(check-expect check-within check-member-of check-range check-error require)
+(check-expect check-random check-within check-member-of check-range check-error require)
 [program (code:line def-or-expr ...)]
 [def-or-expr definition
              expr
@@ -109,6 +109,7 @@ level as they did in the @secref["intermediate"] level.
              and 
              or
              check-expect
+             check-random
              check-within
              check-error
              check-member-of

pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/intermediate.scrbl

@@ -9,8 +9,8 @@
 
 @racketgrammar*+qq[
 #:literals (define define-struct lambda cond else if and or require lib planet
-            local let let* letrec time check-expect check-within check-error)
+            local let let* letrec time check-expect check-random check-within check-error)
-(check-expect check-within check-member-of check-range check-error require)
+(check-expect check-random check-within check-member-of check-range check-error require)
 [program (code:line def-or-expr ...)]
 [def-or-expr definition
              expr
@@ -84,6 +84,7 @@ did in the @secref["beginner-abbr"] level.
                      and 
                      or
                      check-expect
+                     check-random
                      check-within
                      check-error
                      check-member-of

pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/prim-ops.rkt

@@ -3,6 +3,8 @@
          scribble/decode
          scribble/struct
          scribble/racket
+         scribble/eval
+	 racket/sandbox
          racket/list
          racket/pretty
          syntax/docprovide
@@ -18,6 +20,14 @@
          prim-ops
          prim-op-defns)
 
+(define-syntax-rule (mk-eval defs ...)
+  ;; ==> 
+  (let ([me (make-base-eval)])
+    (call-in-sandbox-context me (lambda () (error-print-source-location #f)))
+    (interaction-eval #:eval me defs) 
+    ...
+    me))
+
 (define (maybe-make-table l t)
   (if (paragraph? t)
       (make-paragraph
@@ -137,6 +147,7 @@
                      and 
                      or
                      check-expect
+                     check-random
                      check-within
                      check-error
                      check-member-of
@@ -152,6 +163,7 @@
                   #'or @racket[or]
                   #'and @racket[and]
                   #'check-expect @racket[check-expect]
+                  #'check-random @racket[check-random]
                   #'check-within @racket[check-within]
                   #'check-error @racket[check-error]
                   #'check-member-of @racket[check-member-of]
@@ -167,6 +179,7 @@
                         or-id or-elem
                         and-id and-elem
                         check-expect-id check-expect-elem
+                        check-random-id check-random-elem
                         check-within-id check-within-elem
                         check-error-id check-error-elem
                         check-member-of-id check-member-of-elem
@@ -297,13 +310,49 @@
 
   @; ----------------------------------------------------------------------
 
-
   @defform*[#:id [check-expect check-expect-id]
             [(check-expect expression expected-expression)]]{
 
    Checks that the first @racket[expression] evaluates to the same value as the
    @racket[expected-expression].}
 
+  @defform*[#:id [check-random check-random-id]
+            [(check-random expression expected-expression)]]{
+
+   Checks that the first @racket[expression] evaluates to the same value as the
+   @racket[expected-expression].
+
+The form supplies the same random-number generator to both parts. If both
+parts request @racket[random] numbers from the same interval in the same
+order, they receive the same random numbers. 
+
+@examples[#:eval (mk-eval (require test-engine/racket-tests))
+
+(check-random (random 10) (random 10))
+
+(check-random 
+  (begin (random 100) (random 200))
+  (begin (random 100) (random 200)))
+
+(test)
+]
+
+If the two parts call @racket[random] for different intervals, they are
+likely to fail: 
+
+@examples[#:eval (mk-eval (require test-engine/racket-tests))
+(check-random 
+  (begin (random 100) (random 200))
+  (begin (random 200) (random 100)))
+
+(test)
+]
+
+It is an error for @racket[expr] or @racket[expected-expr] to produce a function
+value or an inexact number.
+
+   }
+
 
   @defform*[#:id [check-within check-within-id]
             [(check-within expression expected-expression delta)]]{

pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/std-grammar.rkt

@@ -11,12 +11,13 @@
 
 (define-syntax-rule (racketgrammar*+library
                      #:literals lits
-                     (check-expect check-within check-member-of check-range check-error require)
+                     (check-expect check-random check-within check-member-of check-range check-error require)
                      form ...)
   (racketgrammar*
    #:literals lits
    form ...
    [test-case @#,racket[(check-expect expr expr)]
+              @#,racket[(check-random expr expr)]
               @#,racket[(check-within expr expr expr)]
               @#,racket[(check-member-of expr expr (... ...))]
               @#,racket[(check-range expr expr expr)]
@@ -31,11 +32,11 @@
 
 (define-syntax-rule (racketgrammar*+qq 
                      #:literals lits
-                     (check-expect check-within check-member-of check-range check-error require)
+                     (check-expect check-random check-within check-member-of check-range check-error require)
                      form ...)
   (racketgrammar*+library
    #:literals lits
-   (check-expect check-within check-member-of check-range check-error require)
+   (check-expect check-random check-within check-member-of check-range check-error require)
    form ...
    (...
     [quoted name

pkgs/htdp-pkgs/htdp-doc/test-engine/test-engine.scrbl

@@ -1,8 +1,15 @@
 #lang scribble/doc
-@(require scribble/manual
+
-          (for-label racket/base
+@(require (for-label racket/base test-engine/racket-tests (prefix-in gui: test-engine/racket-gui)))
-                     test-engine/racket-tests
+
-                     (prefix-in gui: test-engine/racket-gui)))
+@(require scribble/manual scribble/eval racket/sandbox)
+@(define-syntax-rule (mk-eval defs ...)
+  ;; ==> 
+  (let ([me (make-base-eval)])
+    (call-in-sandbox-context me (lambda () (error-print-source-location #f)))
+    (interaction-eval #:eval me defs) 
+    ...
+    me))
 
 @title{Test Support}
 
@@ -31,6 +38,39 @@ Checks whether the value of the @racket[expr] expression is
 It is an error for @racket[expr] or @racket[expected-expr] to produce a function
 value or an inexact number.}
 
+@defform[(check-random expr expected-expr)]{
+Checks whether the value of the @racket[expr] expression is
+@racket[equal?] to the value produced by the @racket[expected-expr].
+
+The form supplies the same random-number generator to both parts. If both
+parts request @racket[random] numbers from the same interval in the same
+order, they receive the same random numbers. 
+
+@examples[#:eval (mk-eval (require test-engine/racket-tests))
+
+(check-random (random 10) (random 10))
+
+(check-random 
+  (begin (random 100) (random 200))
+  (begin (random 100) (random 200)))
+
+(test)
+]
+
+If the two parts call @racket[random] for different intervals, they are
+likely to fail: 
+
+@examples[#:eval (mk-eval (require test-engine/racket-tests))
+(check-random 
+  (begin (random 100) (random 200))
+  (begin (random 200) (random 100)))
+
+(test)
+]
+
+It is an error for @racket[expr] or @racket[expected-expr] to produce a function
+value or an inexact number.} 
+
 @defform[(check-within expr expected-expr delta-expr)
           #:contracts ([delta-expr number?])]{
 Checks whether the value of the @racket[test] expression is structurally

pkgs/htdp-pkgs/htdp-lib/lang/htdp-advanced.rkt

@@ -56,6 +56,7 @@
           [advanced-delay delay]
           [advanced-module-begin #%module-begin])
          check-expect
+         check-random
          check-within
          check-error
          check-member-of

pkgs/htdp-pkgs/htdp-lib/lang/htdp-beginner-abbr.rkt

@@ -38,6 +38,7 @@
           [beginner-true true]
           [beginner-false false])
          check-expect
+	 check-random 
          check-within
          check-error
          check-member-of

pkgs/htdp-pkgs/htdp-lib/lang/htdp-beginner.rkt

@@ -42,6 +42,7 @@
           [beginner-false false]
           )
          check-expect
+	 check-random 
          check-within
          check-error
          check-member-of

pkgs/htdp-pkgs/htdp-lib/lang/htdp-intermediate-lambda.rkt

@@ -43,6 +43,7 @@
           [beginner-false false]
           )
          check-expect
+	 check-random 
          check-within
          check-error
          check-member-of

pkgs/htdp-pkgs/htdp-lib/lang/htdp-intermediate.rkt

@@ -44,6 +44,7 @@
           [beginner-false false]
           )
          check-expect
+	 check-random 
          check-within
          check-error
          check-member-of

pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt

@@ -14,6 +14,7 @@
 
 (provide
  check-expect ;; syntax : (check-expect <expression> <expression>)
+ check-random ;; syntax : (check-random <expression> <expression>)
  check-within ;; syntax : (check-within <expression> <expression> <expression>)
  check-member-of ;; syntax : (check-member-of <expression> <expression>)
  check-range ;; syntax : (check-range <expression> <expression> <expression>)
@@ -31,13 +32,13 @@
 (define FUNCTION-FMT
   "check-expect cannot compare functions.")
 (define CHECK-ERROR-STR-FMT
-  "check-error expects a string for the second argument, representing the expected error message. Given ~s")
+  "check-error expects a string (the expected error message) for the second argument. Given ~s")
 (define CHECK-WITHIN-INEXACT-FMT
   "check-within expects an inexact number for the range. ~a is not inexact.")
 (define CHECK-WITHIN-FUNCTION-FMT
   "check-within cannot compare functions.")
 (define LIST-FMT
-  "check-member-of expects a list for the second argument, containing the possible outcomes. Given ~s")
+  "check-member-of expects a list for the second argument (the possible outcomes). Given ~s")
 (define CHECK-MEMBER-OF-FUNCTION-FMT
   "check-member-of cannot compare functions.")
 (define RANGE-MIN-FMT
@@ -57,22 +58,21 @@
 
 ;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax?
 ;; the common part of all three test forms.
-(define-for-syntax (check-expect-maker
+(define-for-syntax (check-expect-maker stx checker-proc-stx test-expr embedded-stxes hint-tag)
-                    stx checker-proc-stx test-expr embedded-stxes hint-tag)
   (define bogus-name
     (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t))
   (define src-info
     (with-stepper-syntax-properties (['stepper-skip-completely #t])
-      #`(list #,@(list #`(quote #,(syntax-source stx))
+                                    #`(list #,@(list #`(quote #,(syntax-source stx))
-                       (syntax-line stx)
+                                                     (syntax-line stx)
-                       (syntax-column stx)
+                                                     (syntax-column stx)
-                       (syntax-position stx)
+                                                     (syntax-position stx)
-                       (syntax-span stx)))))
+                                                     (syntax-span stx)))))
   (if (eq? 'module (syntax-local-context))
       #`(define #,bogus-name
           #,(stepper-syntax-property
-             #`(let ([test-engine (namespace-variable-value
+             #`(let* ([ns (current-namespace)]
-                                   'test~object #f builder (current-namespace))])
+                      [test-engine (namespace-variable-value 'test~object #f builder ns)])
                  (when test-engine
                    (insert-test test-engine
                                 (lambda ()
@@ -109,31 +109,30 @@
                      skipto/cdr skipto/third ;; application of insert-test
                      '(syntax-e cdr cdr syntax-e car) ;; lambda
                      )))
-      #`(let ([test-engine (namespace-variable-value
+      #`(let ([test-engine (namespace-variable-value 'test~object #f builder (current-namespace))])
-                            'test~object #f builder (current-namespace))])
+          (when test-engine
-	  (when test-engine
+            (insert-test test-engine
-	    (insert-test test-engine
+                         (lambda ()
-			 (lambda ()
+                           #,(with-stepper-syntax-properties
-			   #,(with-stepper-syntax-properties
+                              (['stepper-hint hint-tag]
-			      (['stepper-hint hint-tag]
+                               ['stepper-hide-reduction #t]
-			       ['stepper-hide-reduction #t]
+                               ['stepper-use-val-as-final #t])
-			       ['stepper-use-val-as-final #t])
+                              (quasisyntax/loc stx
-			      (quasisyntax/loc stx
+                                (#,checker-proc-stx
-				(#,checker-proc-stx
+                                 #,(with-stepper-syntax-properties
-				 #,(with-stepper-syntax-properties
+                                    (['stepper-hide-reduction #t])
-				    (['stepper-hide-reduction #t])
+                                    #`(car 
-				    #`(car 
+                                       #,(with-stepper-syntax-properties
-				       #,(with-stepper-syntax-properties
+                                          (['stepper-hide-reduction #t])
-					  (['stepper-hide-reduction #t])
+                                          #`(list
-					  #`(list
+                                             (lambda () #,test-expr)
-					     (lambda () #,test-expr)
+                                             #,(syntax/loc stx (void))))))
-					     #,(syntax/loc stx (void))))))
+                                 #,@embedded-stxes
-				 #,@embedded-stxes
+                                 #,src-info
-				 #,src-info
+                                 #,(with-stepper-syntax-properties
-				 #,(with-stepper-syntax-properties
+                                    (['stepper-no-lifting-info #t]
-				    (['stepper-no-lifting-info #t]
+                                     ['stepper-hide-reduction #t])
-				     ['stepper-hide-reduction #t])
+                                    #'test-engine))))))))))
-				    #'test-engine))))))))))
 
 (define-for-syntax (check-context?)
   (let ([c (syntax-local-context)])
@@ -149,10 +148,23 @@
     (raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx))
   (syntax-case stx ()
     [(_ test actual)
-     (check-expect-maker stx #'check-values-expected #`test (list #`actual)
+     (check-expect-maker stx #'check-values-expected #`test (list #`actual) 'comes-from-check-expect)]
-                         'comes-from-check-expect)]
     [_ (raise-syntax-error 'check-expect (argcount-error-message/stx 2 stx) stx)]))
 
+;; checking random values 
+(define-syntax-rule 
+  (check-random e1 e2)
+  (begin
+    (define rng (make-pseudo-random-generator))
+    (define k (modulo (current-milliseconds) (sub1 (expt 2 31))))
+    (check-expect
+     (parameterize ((current-pseudo-random-generator rng))
+       (random-seed k)
+       e1)
+     (parameterize ((current-pseudo-random-generator rng))
+       (random-seed k)
+       e2))))
+
 ;; check-values-expected: (-> scheme-val) scheme-val src test-engine -> void
 (define (check-values-expected test actual src test-engine)
   (error-check (lambda (v) (if (number? v) (exact? v) #t))
@@ -244,7 +256,10 @@
     (raise-syntax-error 'check-member-of CHECK-EXPECT-DEFN-STR stx))
   (syntax-case stx ()
     [(_ test actual actuals ...)
-     (check-expect-maker stx #'check-member-of-values-expected #`test (list #`actual #`(list actuals ...))
+     (check-expect-maker stx
+                         #'check-member-of-values-expected
+                         #`test
+                         (list #`actual #`(list actuals ...))
                          'comes-from-check-member-of)]
     [_ (raise-syntax-error 'check-member-of (argcount-error-message/stx 2 stx #t) stx)]))
 
@@ -282,25 +297,22 @@
 ;;                (src format scheme-val scheme-val scheme-val -> check-fail)
 ;;                ( -> scheme-val) scheme-val scheme-val test-engine symbol? -> void
 (define (run-and-check check maker test expect range src test-engine kind)
-  (match-let ([(list result result-val exn)
+  (match-let 
-               (with-handlers ([exn:fail:wish?
+      ([(list result result-val exn)
-                                (lambda (e)
+        (with-handlers ([exn:fail:wish?
-                                  (let ([display (error-display-handler)])
+                         (lambda (e)
-                                    (list (unimplemented-wish src (test-format) (exn:fail:wish-name e) (exn:fail:wish-args e))
+                           (define display (error-display-handler))
-                                          'error
+                           (define name (exn:fail:wish-name e))
-                                          #f)))]
+                           (define args (exn:fail:wish-args e))
-                               [exn:fail?
+                           (list (unimplemented-wish src (test-format) name args) 'error #f))]
-                                (lambda (e)
+                        [exn:fail?
-                                  (let ([display (error-display-handler)])
+                         (lambda (e)
-                                    (list (make-unexpected-error src (test-format) expect
+                           (define display (error-display-handler))
-                                                                 (get-rewriten-error-message e)
+                           (define msg (get-rewriten-error-message e))
-                                                                 e)
+                           (list (make-unexpected-error src (test-format) expect msg e) 'error e))])
-                                          'error
+          (define test-val (test))
-                                          e)))])
+          (cond [(check expect test-val range) (list #t test-val #f)]
-                 (let ([test-val (test)])
+                [else (list (maker src (test-format) test-val expect range) test-val #f)]))])
-                   (cond [(check expect test-val range) (list #t test-val #f)]
-                         [else 
-                          (list (maker src (test-format) test-val expect range) test-val #f)])))])
     (cond [(check-fail? result)
            (send (send test-engine get-info) check-failed result (check-fail-src result) exn)
            (if exn (raise exn) #f)]
@@ -311,7 +323,7 @@
 
 (define (reset-tests)
   (let ([test-engine (namespace-variable-value
-		      'test~object #f builder (current-namespace))])
+                      'test~object #f builder (current-namespace))])
     (when test-engine
       (send test-engine reset-info))))
 
@@ -385,27 +397,27 @@
     (define/pubment (signature-failed obj signature message blame)
       
       (let* ((cms
-	      (continuation-mark-set->list (current-continuation-marks)
+              (continuation-mark-set->list (current-continuation-marks)
-					   teaching-languages-continuation-mark-key))
+                                           teaching-languages-continuation-mark-key))
-	     (srcloc
+             (srcloc
-	      (cond
+              (cond
-	       ((findf (lambda (mark)
+                ((findf (lambda (mark)
-			 (and mark
+                          (and mark
-			      (or (path? (car mark))
+                               (or (path? (car mark))
-				  (symbol? (car mark)))))
+                                   (symbol? (car mark)))))
-		       cms)
+                        cms)
-		=> (lambda (mark)
+                 => (lambda (mark)
-		     (apply (lambda (source line col pos span)
+                      (apply (lambda (source line col pos span)
-			      (make-srcloc source line col pos span))
+                               (make-srcloc source line col pos span))
-			    mark)))
+                             mark)))
-	       (else #f)))
+                (else #f)))
-	     (message
+             (message
-	      (or message
+              (or message
-		  (make-signature-got obj (test-format)))))
+                  (make-signature-got obj (test-format)))))
         
-	(set! signature-violations
+        (set! signature-violations
-	      (cons (make-signature-violation obj signature message srcloc blame)
+              (cons (make-signature-violation obj signature message srcloc blame)
-		    signature-violations)))
+                    signature-violations)))
       (report-failure)
       (inner (void) signature-failed obj signature message))
     
@@ -457,4 +469,4 @@
       (inner (void) run-test test))))
 
 (provide scheme-test-data test-format test-execute test-silence error-handler 
-	 signature-test-info% build-test-engine)
+         signature-test-info% build-test-engine)

pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt

@@ -1,6 +1,6 @@
-;; The first three lines of this file were inserted by DrScheme. They record metadata
+;; The first three lines of this file were inserted by DrRacket. They record metadata
 ;; about the language level of this file in a form that our tools can easily process.
-#reader(lib "htdp-beginner-reader.ss" "lang")((modname TestEngineTest) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
+#reader(lib "htdp-advanced-reader.ss" "lang")((modname TestEngineTest) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #t #t none #f ())))
 ;;Expect 37 checks, 17 failures
 
 (define (count f)
@@ -55,3 +55,31 @@
 (check-range 0.0 0 10.5)
 (check-range 10.5 0 10.5)
 (check-range 10.5001 0 10.5) ;fails
+
+;; ---------------------------------------------------------------------------------------------------
+;; MF: from DVH 
+
+(define (random-elt ls) (list-ref ls (random (length ls))))
+
+(check-random (random-elt (build-list 100 identity))
+              (list-ref (build-list 100 identity) (random 100)))
+
+
+(define (f _x)
+  (list (random 10) (random 20)))
+
+(define (g _x)
+  (list (random 10) (random 20)))
+
+(check-random (f 0) (list (random 10) (random 20)))
+
+(check-random (g 0)
+              (let ((x2 (random 20))
+                    (x1 (random 10)))
+                (list x1 x2)))
+
+(define (h _x) (first (list (random 50) (random 20))))
+
+(check-random (h) (begin (random 50) (random 20)))
+
+(check-random (h) (begin (random 20) (random 50))) ;; fails