[plt-scheme] Multithreaded MzTake Debugging
Hi everyone- I've been trying to learn multithreaded MzTake debugging, something
that is not yet fully documented...
I noticed that the todo.txt for MzTake
talked about the need for an example of graphical debugging with multiple
threads. Since none appears to exist yet, I went ahead and created one- Feel
free to use it as a basis for such an example it's useful...
The code at
the bottom of this posting performs a pretty billiard ball simulation with
each ball controlled by a separate, Erlang-style thread. It does have one
bug related to MzTake: Every once in a blue moon (maybe after 5 min) a tracepoint
will trigger an exception that I suspect is due to a thread-safety issue with
MzTake- Most likely a subtle flaw on my part caused by my limited understanding
of multithreaded MzTake vis a vis critical sections... any ideas on how to
correct it would be appreciated...
Overall, MzTake is really fun to work
with :)
-Conrad Barski, M.D.
---------------------------bouncing-mztake.scm----------------------------------
(require (lib "mztake.ss" "mztake")
(lib "animation.ss" "frtime"))
(define ball-events (trace (loc "bouncing.scm" '(sleep _)) (list n x y color)))
(define (filter-ball n)
(hold (filter-e (lambda (k)
((car k) . = . n))
ball-events)))
(define (make-box
points)
(map (lambda (pt)
(make-circle (make-posn (cadr pt) (caddr
pt)) 20 (cadddr pt)))
points))
(display-shapes (make-box (map
filter-ball '(1 2 3 4 5))))
(set-running! #t)
----------------------------bouncing.scm-------------------------------------------------------
(module bouncing mzscheme
(require (lib "erl.ss" "frtime")
(lib "math.ss")
(only (lib "list.ss") remove))
(define (calc-collision x y dx dy ox oy odx ody)
(let ((phi
(atan (y . - . oy) (x . - . ox))))
(let ((v (sqrt ((sqr dx) . + . (sqr
dy))))
(ov (sqrt ((sqr odx) . + . (sqr ody))))
(ang
(atan dy dx))
(oang (atan ody odx)))
(let ((vxr (v .
* . (cos (ang . - . phi))))
(vyr (v . * . (sin (ang . - . phi))))
(ovxr (ov . * . (cos (oang . - . phi))))
(ovyr
(ov . * . (sin (oang . - . phi)))))
(values (((cos phi) . * . ovxr)
. + . ((cos (phi . + . (pi . / . 2))) . * . vyr))
(((sin
phi) . * . ovxr) . + . ((sin (phi . + . (pi . / . 2))) . * . vyr))
(((cos phi) . * . vxr) . + . ((cos (phi . + . (pi . / . 2))) .
* . ovyr))
(((sin phi) . * . vxr) . + . ((sin (phi . +
. (pi . / . 2))) . * . ovyr)))))))
(define (empty-mailbox x y dx
dy hitting)
(receive (after 0 (values x y dx dy hitting))
(('pos tid ox oy odx ody) (if (((sqr (x . - . ox)) . + . (sqr (y . - .
oy))) . < . 1600)
(if (member
tid hitting)
(empty-mailbox
x y dx dy hitting)
(let-values
(((dx dy odx ody) (calc-collision x y dx dy ox oy odx ody)))
(! tid (list 'bounce odx ody))
(empty-mailbox x y dx dy (cons
tid hitting))))
(empty-mailbox x y
dx dy (remove tid hitting))))
(('bounce dx dy) (empty-mailbox
x y dx dy hitting))))
(define (move-ball n x y dx dy color hitting
others)
(let ((x (x . + . dx))
(y (y . + . dy)))
(let
((dx (if (or (x . < . 20) (x . > . 380))
(0 . - . dx)
dx))
(dy (if (or (y . < . 20) (y . > . 380))
(0 . - . dy)
dy)))
(begin
(map (lambda (tid)
(! tid (list 'pos (self) x y dx
dy)))
others)
(let-values (((x y dx dy
hitting) (empty-mailbox x y dx dy hitting)))
(sleep 0.04)
(move-ball n x y dx dy color hitting others))))))
(define (make-ball n color others)
(spawn (move-ball n (50 . * . n)
200 (random 10) (random 10) color '() others)))
(letrec ((loop (lambda
(n colors others)
(if (not (null? colors))
(let ((tid (make-ball n (car colors) others)))
(loop (add1 n) (cdr colors) (cons tid others)))))))
(loop
1 '("red" "green" "blue" "yellow" "black") ()))
(sleep 10000))