added launch-many worlds, propagate please

svn: r15499

collects/2htdp/private/launch-many-worlds.ss

@@ -0,0 +1,48 @@
+#lang scheme
+
+(require mred/mred mzlib/etc)
+
+(provide
+  launch-many-worlds
+  ;; (launch-many-worlds e1 ... e2)
+  ;; run expressions e1 through e2 in parallel,
+  ;; produce all values
+  )
+
+(define-syntax-rule 
+  (launch-many-worlds e ...) 
+  (launch-many-worlds* (lambda () e) ...))
+
+;; [Listof (-> X)] ->* X ...
+(define (launch-many-worlds* . loth)
+  (let* ([c* (make-custodian)]
+         [ch (make-channel)]
+         [pu (curry channel-put ch)]
+         [th (map (lambda (th i)
+                    (parameterize ([current-custodian c*])
+                      (rec t
+                        (thread
+                         (lambda ()
+                           (with-handlers ((exn? pu)) (pu (list i t (th)))))))))
+                  loth
+                  (build-list (length loth) (lambda (i) i)))])
+    (letrec ([L (lambda (th r*)
+                  (if (null? th)
+                      (apply values (map third (sort r* < #:key first)))
+                      (sync 
+                       (handle-evt 
+                        ch 
+                        (lambda (x)
+                          (if (exn? x)
+                              (begin
+                                (custodian-shutdown-all c*)
+                                (raise x))
+                              (L (remq (second x) th) (cons x r*))))))))])
+      (with-handlers ((exn:break? (lambda (xn) (custodian-shutdown-all c*))))
+        (L th '())))))
+
+;; some silly tests
+
+(launch-many-worlds 1 2 3)
+
+(launch-many-worlds 1 (let loop ([n 100]) (printf "~s\n" n) (sleep 1) (loop n)) 3)

collects/2htdp/universe.ss

@@ -11,12 +11,20 @@
          "private/image.ss"
          "private/world.ss"
          "private/universe.ss"
+	 "private/launch-many-worlds.ss"
          htdp/error
          (rename-in lang/prim (first-order->higher-order f2h))
          (only-in mzlib/etc evcase))
 
 (provide (all-from-out "private/image.ss"))
 
+(provide
+  launch-many-worlds
+  ;; (launch-many-worlds e1 ... e2)
+  ;; run expressions e1 through e2 in parallel,
+  ;; produce all values
+)
+
 (provide
  sexp?  ;; Any -> Boolean 
  scene? ;; Any -> Boolean