merge Greg's changes on the defunct v4 branch

svn: r7940

collects/frtime/demos/calculator.ss

@@ -6,7 +6,7 @@
 (define (str->num s)
   (cond
     [(string->number s)]
-    [else 0]))
+    [#t 0]))
 
 (define x
   (str->num (make-text "First number:")))

collects/frtime/demos/circles.ss

@@ -1,6 +1,6 @@
 (require (lib "animation.ss" "frtime")
          (lib "etc.ss" "frtime")
-         (lib "gui.scm" "frtime"))
+         (lib "gui.ss" "frtime"))
 
 (define radius (make-slider "Radius" 100 200 150))
 (define speed (* .02 (make-slider "Speed" 0 10 5)))

collects/frtime/demos/growing-points.ss

@@ -18,7 +18,7 @@
   (sqrt (+ (sqr (- x1 x2)) (sqr (- y1 y2)))))
 
 ;; How many growing points on one side of the grid of growing points.
-(define GRID-SIZE 8)
+(define GRID-SIZE (make-slider "Width" 1 10 8))
 
 ;; The distance between the centers of two adjacent growing points.
 (define grid-resolution (make-slider "Resolution" 2 30 20))

collects/frtime/demos/mirror-lens.ss

@@ -0,0 +1,241 @@
+(require (lib "animation.ss" "frtime")
+         (lib "gui.ss" "frtime"))
+
+;; Written by Evan Perillo
+;; never run two display-envs at the same time or the images will overlap and not look nice
+;; any relevant values can be set using the gui
+;; 4 types of optical-devices can be used, concave-mirror, convex-mirror, concave-lens, and convex-lens 
+;; An example is already written at the bottom, just click run.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;TOP LEVEL FUNCTIONS;;;;;;;;
+
+
+;creates and displays an environment with an optical device
+;display-env : slider-input -> animation
+(define (display-env)
+  (fresh-anim)
+  (fresh-anim 599 599)
+  (display-shapes (set-env (make-choice "Type of device"
+                                        (list "Concave Mirror" "Convex Lens" "Convex Mirror" "Concave Lens")) 
+                           (make-slider "Device Position" 1 599 399) 
+                           mouse-pos 
+                           (make-slider "Height" 1 100 50) 
+                           (make-slider "Focal Length" 1 110 60) 
+                           "blue")))
+
+
+(define (concave-mirror x-val)   ;; makes a concave mirror at x,  y value determined by Base-Line
+  (make-object "Concave Mirror"  ;; gives a name to the optical device
+    x-val             ;; sets it at x value indicated
+    599               ;; determines if it converges or diverges
+    (lambda (h ref-h) (make-posn (posn-x mouse-pos) ref-h)) ;; stores information regarding how the light reflects off of this object in a lambda function
+    (lambda (f d-h) (make-posn f Base-Line))
+    -1                ;; determines whether this is a mirror or a Lens, ie. whether focus is negative or positive x value 
+    ))
+
+(define (convex-lens x-val)
+  (make-object "Convex Lens" x-val 599 
+    (lambda (h ref-h) (make-posn (posn-x mouse-pos) h))
+    (lambda (f d-h) (make-posn f Base-Line))
+    1))
+
+(define (convex-mirror x-val)
+  (make-object "Convex Mirror" x-val 0 
+    (lambda (h ref-h) (make-posn (posn-x mouse-pos) ref-h))
+    (lambda (f d-h) (make-posn f d-h))
+    -1))
+
+(define (concave-lens x-val)
+  (make-object "Concave Lens" x-val 0 
+    (lambda (h ref-h) (make-posn (posn-x mouse-pos) h))
+    (lambda (f d-h) (make-posn f d-h))
+    1))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;MID LEVEL FUNCTIONS;;;;;;;;
+
+
+;set-env: number(Op-d type) number(Op-D x value) mouse-input number(object height) number(focal-length) string -> void (animation)         
+(define (set-env num x obj-pos obj-height f-length object-color)
+  (let* ([obj (get-object num x)]
+         [x-pos (posn-x obj-pos)]
+         [x-val (object-x-val obj)]
+         [y-val (object-y-val obj)]
+         [Focal-Length f-length]
+         [F (+ x-val (* (object-focus obj) Focal-Length))] 
+         [2F (- F (- x-val F))]
+         [Fl (- x-val Focal-Length)]
+         [2Fl (- Fl Focal-Length)]
+         [Object-Height obj-height]
+         [Height (- Base-Line Object-Height)]
+         [Reflected-Height (+ Base-Line Object-Height)]
+         [Double-Height (- Base-Line (* 2 Object-Height))]
+         [Object-Distance (- x-val x-pos)] 
+         [Ray1-Posn ((object-ray1 obj) Height Reflected-Height)]
+         [Ray2-Posn ((object-ray2 obj) F Double-Height)])
+    
+    (define (in-bounds proc result)
+      (if (< x-pos x-val)
+          proc
+          result)) 
+    
+    (define (create-line proc)
+      (in-bounds proc empty))
+    
+    (define (return-string proc)
+      (in-bounds proc "None"))
+    
+    
+    (define (show-info proc)
+      (if (>= x-pos x-val)
+          proc
+          ""))
+    
+    (define (get-image-type)
+      (cond
+        [(string=? (object-type obj) "Convex Mirror") (return-string "Virtual Erect Smaller")]
+        [(string=? (object-type obj) "Concave Lens") (return-string "Virtual Erect Smaller")]
+        [(string=? (object-type obj) "Concave Mirror") (get-image-type-converging 2F F)]
+        [(string=? (object-type obj) "Convex Lens") (get-image-type-converging 2Fl Fl)]))
+    
+    (define (get-image-type-converging a b)
+      (return-string
+       (cond 
+         [(< (posn-x mouse-pos) a) "Real Inverted Smaller"]
+         [(= (posn-x mouse-pos) a) "Real Inverted Equal"]
+         [(and (> (posn-x mouse-pos) a) 
+               (< (posn-x mouse-pos) b)) "Real Inverted Larger"]
+         [(= (posn-x mouse-pos) b) "None"]
+         [(and (> (posn-x mouse-pos) b)) "Virtual Erect Larger"])))
+    
+;;;;;;;;list of shapes to be drawn;
+    (append
+     (list
+      (make-line (make-posn x-val 175) (make-posn x-val 375) "black") ;optical device
+      
+      (create-line (make-line (make-posn x-pos Base-Line)             ;object
+                              (make-posn x-pos Height) object-color)) ;object
+      
+      (create-line (make-line (make-posn x-pos Height)                ;incident ray 1
+                              (make-posn x-val Base-Line) "green"))   ;incident ray 1
+      
+      (if (= x-pos x-val) null                                                                        ;reflected ray 1 
+          (create-line (make-line (make-posn x-val Base-Line)                                         ;reflected ray 1
+                                  (get-end-posn Ray1-Posn (make-posn x-val Base-Line) 599) "green"))) ;reflected ray 1
+      
+      (create-line (make-line (make-posn x-pos Height)                ;incident ray 2
+                              (make-posn x-val Height) "red"))        ;incident ray 2
+      
+      (create-line (make-line (make-posn x-val Height)                                        ;reflected ray 2
+                              (get-end-posn Ray2-Posn (make-posn x-val Height) y-val) "red")) ;reflected ray 2 
+      
+
+      
+      (make-circle (make-posn F Base-Line) 2 "black")   ;
+      (make-circle (make-posn 2F Base-Line) 2 "black")  ; Focal Points
+      (make-circle (make-posn Fl Base-Line) 2 "black")  ; 
+      (make-circle (make-posn 2Fl Base-Line) 2 "black") ;  
+      
+      (make-graph-string (make-posn 20 20)
+                         (format "Type of Image Created: ~a"
+                                 (get-image-type))
+                         "black")
+      (make-graph-string (make-posn 20 40)
+                         (format "ho: ~a    do: ~a"
+                                 (return-string Object-Height)
+                                 (return-string Object-Distance))
+                         object-color)
+      (make-graph-string (make-posn 20 60)
+                         (format "~a     ~a"
+                                 (show-info "hi: None")
+                                 (show-info "di: None"))
+                         "black")
+      (make-graph-string (make-posn 20 80)
+                         (format "~a"
+                                 (show-info "Magnification: None"))
+                         "red")
+      (make-graph-string (make-posn 450 20)
+                         (object-type obj)
+                         "black")
+      (make-graph-string (make-posn 450 40)
+                         "By: Evan Perillo"
+                         "black"))
+     
+  ;;;;;;Reflected Object;;;;;;;;;;
+        (if (>= x-pos x-val)
+          (list null)         
+           (let ((intersect  (intersection Ray2-Posn (make-posn x-val Height) Ray1-Posn (make-posn x-val Base-Line))))
+            (if (string? intersect) (create-line (list null))
+                (create-line 
+                 (list
+                  (make-line intersect (make-posn (posn-x intersect) Base-Line) "black")
+                  (make-graph-string (make-posn 20 60)
+                                     (format "hi: ~a    di: ~a"
+                                             (exact->inexact (- Base-Line (posn-y intersect))) 
+                                             (exact->inexact (- x-val (posn-x intersect))))
+                                     "black")
+                  (make-graph-string (make-posn 20 80)
+                                     (format "Magnification: ~a"
+                                             (/ (- Base-Line (posn-y intersect))
+                                                Object-Height))
+                                     "red"))))))
+        )))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BOTTOM LEVEL FUNCTIONS ;;;
+
+(define Base-Line 275)
+
+(define-struct object (type x-val y-val ray1 ray2 focus))
+
+(define (get-object num x)
+  (cond [(= 0 num) (concave-mirror x)]
+        [(= 1 num) (convex-lens x)]
+        [(= 2 num) (convex-mirror x)]
+        [(= 3 num) (concave-lens x)]))
+
+(define (solve-x m1 m2 b1 b2)
+  (if (= m1 m2)
+      "DNE"
+      (/ (- b2 b1) (- m1 m2))))
+
+(define (solve-eq x m b)
+  (if (string? x)
+      "DNE"
+      (+ (* m x) b)))
+
+(define (get-b y x m)
+  (- y (* x m)))
+
+(define (get-x y m b)
+  (/ (- y b) m))
+
+(define (get-slope a b)
+  (/ (- (posn-y b) (posn-y a))
+     (- (posn-x b) (posn-x a))))
+
+(define (get-end-posn posn-a posn-b y-val)
+  
+  (define (get-end-x posn-a posn-b)
+    (let ((slope (get-slope posn-a posn-b)))
+      (get-x y-val
+             slope
+             (get-b (posn-y posn-a) 
+                    (posn-x posn-a) 
+                    slope))))
+  (make-posn (get-end-x posn-a posn-b) y-val))
+
+  ;intersection : posn posn posn posn -> posn or "DNE"
+  (define (intersection line1a line1b line2a line2b)   
+    (let* ((m1 (get-slope line1a line1b))
+                 (m2 (get-slope line2a line2b))
+                 (b1 (get-b (posn-y line1a) (posn-x line1a) m1))
+                 (b2 (get-b (posn-y line2a) (posn-x line2a) m2))
+                 (x (solve-x m1 m2 b1 b2))
+                 (y (solve-eq x m1 b1)))
+      (if (string? x) "DNE" (make-posn x y))))
+
+;;;;;;;;;;;;;;;;Examples;;;;;;;;;;;;;;
+
+(display-env) ;creates and displays an optical device environment

collects/frtime/demos/needles.ss

@@ -9,10 +9,11 @@
 ;; Require the animation library and the library
 ;; containing the build-list function.
 (require (lib "animation.ss" "frtime")
-         (lib "etc.ss" "frtime"))
+         (lib "etc.ss" "frtime")
+         (lib "gui.ss" "frtime"))
 
 ;; How many needles on one side of the grid of needles
-(define GRID-SIZE 8)
+(define GRID-SIZE (make-slider "Grid size:" 1 10 8))
 
 ;; The length of a needle in pixels
 (define NEEDLE-LENGTH 10)

collects/frtime/demos/orbit-mouse.ss

@@ -1,7 +1,7 @@
 (require (lib "animation.ss" "frtime")
          (lib "gui.ss" "frtime"))
 
-(define radius 25)
+(define radius (make-slider "Radius" 25 200 100))
 (define speed (* .1 (make-slider "Speed" -15 15 6)))
 (define phase (wave speed))
 (define n (make-slider "# Balls" 1 6 3))

collects/frtime/demos/pong.ss

@@ -104,8 +104,10 @@
   ;(make-circle (delay-by ball-pos 200) 8 "lightblue")
   (make-circle paddle1-pos paddle-radius "black")
   (make-circle paddle2-pos paddle-radius "black")
-  (make-graph-string (make-posn 30 30) (number->string p2-score) "black")
+  (make-graph-string (make-posn 30 30) (number->string p2-score)
-  (make-graph-string (make-posn 350 30) (number->string p1-score) "black")
+                     (if (= p2-score (delay-by p2-score 600)) "black" "red"))
+  (make-graph-string (make-posn 350 30) (number->string p1-score)
+                     (if (= p1-score (delay-by p1-score 600)) "black" "red"))
   ;(make-graph-string (make-posn 120 30) (number->string (posn-len ball-vel)) "black")
   (make-line (make-posn 0 150) (make-posn 0 250) "red")
   (make-line (make-posn 399 150) (make-posn 399 250) "red")))

collects/frtime/demos/tile-game.ss

@@ -0,0 +1,153 @@
+;; tile game by Dave Tucker
+
+(require (lib "animation.ss" "frtime")
+         (lib "gui.ss" "frtime")
+         (lib "class.ss"))
+
+(define-struct tile (row col num color))
+(define-struct state (tiles blank-row blank-col))
+
+(define hue (list-ref '(0 1 4 5) (make-choice "Color: " '("Black" "Blue" "Red" "Magenta"))))
+(define reverse-keys? (make-check-box "Reverse keys? "))
+(define animate? (make-check-box "Animate? " #t))
+(define animation-speed (list-ref '(250 500 750) (make-choice "Animation speed: " '("Fast" "Medium" "Slow"))))
+(define smoothness (list-ref '(10 20 50) (make-choice "Animation smoothness: " '("Smooth" "Normal" "Coarse"))))
+
+(set-cell! fine-timer-granularity smoothness)
+
+(define ((component i) bit)
+  (if (not (zero? (bitwise-and hue bit)))
+      1
+      (/ i 16)))
+
+(define initial-tiles
+  (build-list 15
+              (lambda (i)
+                (make-tile (quotient i 4)
+                           (remainder i 4)
+                           i
+                           (apply make-rgb (map (component i) '(4 2 1)))))))
+
+(define config
+  (accum-b (merge-e
+            (left-clicks
+             . ==> .
+             (lambda (ev)
+               (lambda (st)
+                 (let* ([r (quotient (send ev get-y) 100)]
+                        [c (quotient (send ev get-x) 100)]
+                        [st1 (caar st)]
+                        [br (state-blank-row st1)]
+                        [bc (state-blank-col st1)])
+                   (cond
+                     [(and (= r br) (not (= c bc)))
+                      `((,(make-state
+                           (let ([dir (quotient (- c bc) (abs (- c bc)))])
+                             (map (lambda (t)
+                                    (if (and (= (tile-row t) r)
+                                             (or (<= (+ bc dir) (tile-col t) c)
+                                                 (<= c (tile-col t) (+ bc dir))))
+                                        (make-tile (tile-row t)
+                                                   (- (tile-col t) dir)
+                                                   (tile-num t)
+                                                   (tile-color t))
+                                        t))
+                                  (state-tiles st1)))
+                           r
+                           c)
+                         ,(value-now milliseconds))
+                        ,(first st))]
+                     [(and (not (= r br)) (= c bc))
+                      `((,(make-state
+                           (let ([dir (quotient (- r br) (abs (- r br)))])
+                             (map (lambda (t)
+                                    (if (and (= (tile-col t) c)
+                                             (or (<= (+ dir br) (tile-row t) r)
+                                                 (<= r (tile-row t) (+ dir br))))
+                                        (make-tile (- (tile-row t) dir)
+                                                   (tile-col t)
+                                                   (tile-num t)
+                                                   (tile-color t))
+                                        t))
+                                  (state-tiles st1)))
+                           r
+                           c)
+                         ,(value-now milliseconds))
+                        ,(first st))]
+                     [#t st])))))
+              (key-strokes
+               . ==> .
+               (lambda (ev)
+                 (lambda (st)
+                   (let/ec k
+                     (let*-values ([(st1) (caar st)]
+                                   [(br) (state-blank-row st1)]
+                                   [(bc) (state-blank-col st1)]
+                                   [(r c)
+                                    (let ([ev (if (value-now reverse-keys?)
+                                                  (case ev
+                                                    [(left) 'right]
+                                                    [(right) 'left]
+                                                    [(up)    'down]
+                                                    [(down)    'up])
+                                                  ev)])
+                                      (case ev
+                                        [(left) (if (< bc 3)
+                                                    (values br (add1 bc))
+                                                    (k st))]
+                                        [(right) (if (> bc 0)
+                                                     (values br (sub1 bc))
+                                                     (k st))]
+                                        [(up) (if (< br 3)
+                                                  (values (add1 br) bc)
+                                                  (k st))]
+                                        [(down) (if (> br 0)
+                                                    (values (sub1 br) bc)
+                                                    (k st))]
+                                        [else (k st)]))])
+                       `((,(make-state (map (lambda (t)
+                                              (if (and (= (tile-row t) r) (= (tile-col t) c))
+                                                  (make-tile br bc (tile-num t) (tile-color t))
+                                                  t))
+                                            (state-tiles st1))
+                                       r
+                                       c)
+                          ,(value-now milliseconds))
+                         ,(first st))))))))
+             (let ([init-state (make-state initial-tiles 3 3)]
+                   [init-time (- (value-now milliseconds) 1000)])
+               (list (list init-state init-time)
+                     (list init-state init-time)))))
+
+(define (tile->shape t)
+  (make-rect (make-posn (+ 1 (* (tile-col t) 100))
+                        (+ 1 (* (tile-row t) 100)))
+             98
+             98
+             (tile-color t)))
+
+(define (tile-pos t)
+  (make-posn (+ 1 (* (tile-col t) 100))
+             (+ 1 (* (tile-row t) 100))))
+
+(define (linear-comb x1 x2 frac)
+  (+ (* frac x1) (* (- 1 frac) x2)))
+
+(define (blend-posns p1 p2 frac)
+  (make-posn (linear-comb (posn-x p1) (posn-x p2) frac)
+             (linear-comb (posn-y p1) (posn-y p2) frac)))
+
+(define (tiles->shape t0 t1 frac)
+  (make-rect (blend-posns (tile-pos t0) (tile-pos t1) frac)
+             98
+             98
+             (tile-color t0)))
+
+(display-shapes
+ (if animate?
+     (map (lambda (t1 t2)
+            (tiles->shape t1 t2 (min 1 (/ (- milliseconds (cadar config))
+                                          animation-speed))))
+          (state-tiles (caar config))
+          (state-tiles (caadr config)))
+     (map tile->shape (state-tiles (caar config)))))

collects/frtime/frp-core.ss

@@ -386,14 +386,14 @@
   
   
   (define (extract k evs)
-    (if (mpair? evs)
+    (if (pair? evs)
-        (let ([ev (mcar evs)])
+        (let ([ev (car evs)])
           (if (or (eq? ev undefined) (undefined? (erest ev)))
-              (extract k (mcdr evs))
+              (extract k (cdr evs))
               (begin
                 (let ([val (efirst (erest ev))])
-                  (set-mcar! evs (erest ev))
+                  ;(set-mcar! evs (erest ev))
-                  (k val)))))))
+                  (k val (cons (erest ev) (rest evs)))))))))
   
   
   (define (kill-signal sig)
@@ -768,12 +768,13 @@
                                        #;(not (undefined? (signal-value cur-beh))))
                               ;(when (empty? (continuation-mark-set->list
                                ;              (exn-continuation-marks exn) 'frtime))
-                                (set! exn (make-exn:fail
+                              (fprintf (current-error-port) "exception while updating ~a~n" cur-beh)
-                                           (exn-message exn)
+                              (set! exn (make-exn:fail
-                                           (compose-continuation-mark-sets2
+                                         (exn-message exn)
-                                            (signal-continuation-marks
+                                         (compose-continuation-mark-sets2
-                                             cur-beh)
+                                          (signal-continuation-marks
-                                            (exn-continuation-marks exn))));)
+                                           cur-beh)
+                                          (exn-continuation-marks exn))));)
                               ;(raise exn)
                               (iq-enqueue (list exceptions (list exn cur-beh)))
                               (when (behavior? cur-beh)

collects/frtime/lang-ext.ss

@@ -317,7 +317,7 @@
            (send obj meth (value-now arg) ...)
            (send obj meth arg ...))]))
   
-  ;; Depricated
+  ;; Deprecated
   (define (magic dtime thunk)
     (let* ([last-time (current-milliseconds)]
            [ret (let ([myself #f])
@@ -336,22 +336,17 @@
       ret))
   
   
-  ;; Depricated
+  ;; Deprecated
   (define (make-time-b ms)
     (let ([ret (proc->signal void)])
       (set-signal-thunk! ret
                          (lambda ()
                            (let ([t (current-milliseconds)])
-                             (schedule-alarm (+ ms t) ret)
+                             (schedule-alarm (+ (value-now ms) t) ret)
                              t)))
       (set-signal-value! ret ((signal-thunk ret)))
       ret))
   
-  
-  
-  (define milliseconds (make-time-b 20))
-  (define time-b milliseconds)
-  
   (define seconds
     (let ([ret (proc->signal void)])
       (set-signal-thunk! ret
@@ -379,7 +374,7 @@
                                  [ms (value-now ms-b)])
                             (let loop ()
                               (if (or (empty? (mcdr head))
-                                      (< now (+ ms (cdar (mcdr head)))))
+                                      (< now (+ ms (cdr (mcar (mcdr head))))))
                                   (car (mcar head))
                                   (begin
                                     (set! dummy consumer) ;; just to prevent GC
@@ -545,13 +540,13 @@
                        (when (ormap undefined? streams)
                          ;(fprintf (current-error-port) "had an undefined stream~n")
                          (set! streams (fix-streams streams args)))
-                       (let loop ()
+                       (let loop ([streams streams])
-                         (extract (lambda (the-event)
+                         (extract (lambda (the-event strs)
                                     (when proc-k
                                       (call/cc
                                        (lambda (k)
                                          (set! esc k)
-                                         (proc-k the-event)))) (loop))
+                                         (proc-k the-event)))) (loop strs))
                                   streams))
                        (set! streams (map signal-value args))
                        out)])
@@ -644,6 +639,13 @@
          (iq-enqueue rtn)
          rtn))))
   
+  (define (make-mutable lst)
+    (printf "make-mutable called on ~a~n" lst)
+    lst
+    #;(if (pair? lst)
+        (mcons (first lst) (make-mutable (rest lst)))
+        lst))
+  
   (define (event-processor proc . args)
     (let* ([out (econs undefined undefined)]
            [proc/emit (proc
@@ -654,10 +656,11 @@
            [streams (map signal-value args)]
            [thunk (lambda ()
                     (when (ormap undefined? streams)
+                      (printf "some streams were undefined~n")
                       ;(fprintf (current-error-port) "had an undefined stream~n")
                       (set! streams (fix-streams streams args)))
-                    (let loop ()
+                    (let loop ([streams streams])
-                      (extract (lambda (the-event) (proc/emit the-event) (loop))
+                      (extract (lambda (the-event strs) (proc/emit the-event) (loop strs))
                                streams))
                     (set! streams (map signal-value args))
                     out)])
@@ -685,7 +688,12 @@
       [(_ [ev k] ...)
        ()]))
   
-    ;;;;;;;;;;;;;;;;;;;;;;
+  (define fine-timer-granularity (new-cell 20))
+  
+  (define milliseconds (make-time-b fine-timer-granularity))
+  (define time-b milliseconds)
+  
+  ;;;;;;;;;;;;;;;;;;;;;;
   ;; Command Lambda 
   
   
@@ -846,6 +854,7 @@
            snapshot/apply
            magic
            milliseconds
+           fine-timer-granularity
            seconds
            delay-by
            inf-delay

collects/frtime/mzscheme-core.ss

@@ -202,27 +202,32 @@
        (let ([deps (make-hash-table)])
          (lambda ()
            (begin0
-             (proc (lambda (obj)
+             (let/ec esc
-                     (if (behavior? obj)
+               (with-handlers ([exn:fail? (lambda (exn) #f)])
-                         (begin
+                 (proc (lambda (obj)
-                           (case (hash-table-get deps obj 'absent)
+                         (if (behavior? obj)
-                             [(absent) (hash-table-put! deps obj 'new)]
+                             (begin
-                             [(old)    (hash-table-put! deps obj 'alive)]
+                               (case (hash-table-get deps obj 'absent)
-                             [(new)    (void)])
+                                 [(absent) (hash-table-put! deps obj 'new)
-                           (value-now obj))
+                                           (register rtn obj)
-                         obj)))
+                                           (iq-enqueue rtn)
-             (hash-table-for-each
+                                           (esc #f)]
-              deps
+                                 [(old)    (hash-table-put! deps obj 'alive)]
-              (lambda (k v)
+                                 [(new)    (void)])
-                (case v
+                               (value-now obj))
-                  [(new)   (hash-table-put! deps k 'old)
+                             obj))))
-                           #;(printf "reg~n")
+               (hash-table-for-each
-                           (register rtn k)]
+                deps
-                  [(alive) (hash-table-put! deps k 'old)]
+                (lambda (k v)
-                  [(old)   (hash-table-remove! deps k)
+                  (case v
-                           #;(printf "unreg~n")
+                    [(new)   (hash-table-put! deps k 'old)
-                           (unregister rtn k)])))
+                             #;(printf "reg~n")
-             #;(printf "count = ~a~n" (hash-table-count deps))))))
+                             (register rtn k)]
+                    [(alive) (hash-table-put! deps k 'old)]
+                    [(old)   (hash-table-remove! deps k)
+                             #;(printf "unreg~n")
+                             (unregister rtn k)])))
+               #;(printf "count = ~a~n" (hash-table-count deps)))))))
       (iq-enqueue rtn)
       rtn))
   

collects/frtime/mzscheme-utils.ss

@@ -18,7 +18,7 @@
                        letrec
                        match
                        cons car cdr pair? null?
-                       caar cdar cadr cddr caddr cdddr cadddr cddddr
+                       caar caadr cdar cadar cadr cddr caddr cdddr cadddr cddddr
                        make-struct-type
                        make-struct-field-accessor
                        make-struct-field-mutator
@@ -34,7 +34,7 @@
                        and
                        or
                        cond when unless ;case
-                       else =>
+                       ; else =>
                        map ormap andmap assoc member)
            (rename mzscheme mzscheme:if if)
            (rename "lang-ext.ss" lift lift)
@@ -151,6 +151,12 @@
   (define (cadr v)
     (car (cdr v)))
   
+  (define (cadar v)
+    (car (cdar v)))
+  
+  (define (caadr v)
+    (car (cadr v)))
+  
   (define (cddr v)
     (cdr (cdr v)))
   
@@ -275,6 +281,7 @@
   (define (dont-optimize x) x)
 
   (provide cond 
+           else =>
            and 
            or 
            or-undef 
@@ -284,6 +291,9 @@
            ormap 
            andmap
            caar
+           caadr
+           cdar
+           cadar
            cadr
            cddr
            caddr