diff --git a/collects/2htdp/private/launch-many-worlds.rkt b/collects/2htdp/private/launch-many-worlds.rkt index 7049734e6d..1ecbb1d032 100644 --- a/collects/2htdp/private/launch-many-worlds.rkt +++ b/collects/2htdp/private/launch-many-worlds.rkt @@ -1,18 +1,25 @@ -#lang scheme +#lang racket -(require mred/mred mzlib/etc) +(require mred/mred mzlib/etc htdp/error) (provide - launch-many-worlds - ;; (launch-many-worlds e1 ... e2) - ;; run expressions e1 through e2 in parallel, - ;; produce all values - ) + ;; (launch-many-worlds e1 ... e2) + ;; run expressions e1 through e2 in parallel, + ;; produce all values + launch-many-worlds + ;; launch-many-worlds/proc : (-> Any) *-> [Listof Any] + launch-many-worlds/proc) (define-syntax-rule (launch-many-worlds e ...) (launch-many-worlds* (lambda () e) ...)) +(define (launch-many-worlds/proc . loth) + ;; check args + (for ([th loth][i (in-naturals 1)]) + (check-proc 'launch-many-worlds/proc th 0 i "no arguments")) + (apply launch-many-worlds* loth)) + ;; [Listof (-> X)] ->* X ... (define (launch-many-worlds* . loth) (let* ([c* (make-custodian)] diff --git a/collects/2htdp/tests/lauch-many-worlds-proc.rkt b/collects/2htdp/tests/lauch-many-worlds-proc.rkt new file mode 100644 index 0000000000..ee6d0134d3 --- /dev/null +++ b/collects/2htdp/tests/lauch-many-worlds-proc.rkt @@ -0,0 +1,18 @@ +#lang racket + +;; --------------------------------------------------------------------------------------------------- +;; testing launch many worlds/proc + +(require 2htdp/universe 2htdp/image) + +(define (aworld x c) + (big-bang 10 + [to-draw (lambda (i) (text (number->string x) (+ 33 i) c))] + [on-tick sub1] + [stop-when zero?])) + +(define (main) + (apply launch-many-worlds/proc + (build-list 20 (lambda (x) (lambda () (aworld (+ 10 x) (make-color 255 255 x))))))) + +(main) \ No newline at end of file diff --git a/collects/2htdp/tests/xtest b/collects/2htdp/tests/xtest index ebe53ef107..707e5d554a 100755 --- a/collects/2htdp/tests/xtest +++ b/collects/2htdp/tests/xtest @@ -18,6 +18,7 @@ run image-too-large.rkt run image-equality-performance-htdp.rkt run image-equality-performance.rkt run mouse-evt.rkt +run lauch-many-worlds-proc.rkt run on-tick-defined.rkt run perform-robby.rkt run profile-robby.rkt diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt index 805688ba3a..719ab26d5b 100644 --- a/collects/2htdp/universe.rkt +++ b/collects/2htdp/universe.rkt @@ -22,7 +22,7 @@ "private/universe.rkt" "private/universe-image.rkt" ;; - (only-in "private/launch-many-worlds.rkt" launch-many-worlds) + (only-in "private/launch-many-worlds.rkt" launch-many-worlds launch-many-worlds/proc) (only-in "private/stop.rkt" make-stop-the-world) (only-in "private/check-aux.rkt" sexp?) htdp/error @@ -33,9 +33,11 @@ (provide stop-with) ;; World -> STOP (provide - launch-many-worlds ;; (launch-many-worlds e1 ... e2) ;; run expressions e1 through e2 in parallel, produce all values in same order + launch-many-worlds + ;; launch-many-worlds/proc : (-> Any) *-> [Listof Any] + launch-many-worlds/proc ) (provide-primitive diff --git a/collects/htdp/error.rkt b/collects/htdp/error.rkt index 4bc95bd8c7..3fa1068ddb 100644 --- a/collects/htdp/error.rkt +++ b/collects/htdp/error.rkt @@ -40,19 +40,20 @@ ;; check-proc : sym (... *->* ...) num (union sym str) (union sym str) -> void (define (check-proc name f exp-arity arg# arg-err) + (define arg#-text (if (number? arg#) (number->ord arg#) arg#)) (unless (procedure? f) - (tp-error name "expected a function as ~a argument; given ~e" arg# f)) - (let ([arity-of-f (procedure-arity f)]) - (unless (procedure-arity-includes? f exp-arity) - (tp-error name "expected function of ~a as ~a argument; given function of ~a " - arg-err arg# - (cond - [(number? arity-of-f) - (if (= arity-of-f 1) - (format "1 argument") - (format "~s arguments" arity-of-f))] - [(arity-at-least? arity-of-f) "variable number of arguments"] - [else (format "multiple arities (~s)" arity-of-f)]))))) + (tp-error name "expected a function as ~a argument; given ~e" arg#-text f)) + (define arity-of-f (procedure-arity f)) + (unless (procedure-arity-includes? f exp-arity) + (tp-error name "expected function of ~a as ~a argument; given function of ~a " + arg-err arg#-text + (cond + [(number? arity-of-f) + (if (= arity-of-f 1) + (format "1 argument") + (format "~s arguments" arity-of-f))] + [(arity-at-least? arity-of-f) "variable number of arguments"] + [else (format "multiple arities (~s)" arity-of-f)])))) ;; Symbol (_ -> Boolean) String X X *-> X (define (check-result pname pred? expected given . other-given) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index c0050dcc1e..8a9e692f56 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -1149,6 +1149,40 @@ Once you have designed a world program, add a function definition stopped, they produce the final states, here @racket[10], @racket[25], and @racket[33]. +For advanced programmers, the library also provides a programmatic +interface for launching many worlds in parallel. + +@defproc[(launch-many-worlds/proc [thunk-that-runs-a-world (-> any/c)] ...) + any]{ + invokes all given @racket[thunk-that-runs-a-world] in parallel. Typically + each argument is a function of no argument that evaluates a @racket[big-bang] + expression. When all worlds have stopped, the function expression returns + all final worlds in order.} + +It is thus possible to decide at run time how many and which worlds to run +in parallel: +@;% +@(begin +#reader scribble/comment-reader +(racketblock +> (apply launch-many-worlds/proc + (build-list (random 10) + (lambda (i) (main (number->string i))))) +0 +9 +1 +2 +3 +6 +5 +4 +8 +7 +)) +@;% + + + @; ----------------------------------------------------------------------------- @section[#:tag "universe-sample"]{A First Sample Universe}