[plt-scheme] Multithreaded MzTake Debugging

From: cbarski.47124901 at bloglines.com (cbarski.47124901 at bloglines.com)
Date: Sat Mar 3 13:28:59 EST 2007

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



Posted on the users mailing list.