suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added launch-many worlds, propagate please

Browse Source 
svn: r15499
This commit is contained in:
Matthias Felleisen 2009-07-20 19:04:37 +00:00
parent ba378b0a63
commit 7b10ba8321
2 changed files with 56 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/2htdp/private/launch-many-worlds.ss Normal file
View File

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

8
collects/2htdp/universe.ss
View File

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