From 9230f66f014d873834b0b3033db23f0c68cafea1 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 10 Dec 2007 19:30:05 +0000 Subject: [PATCH] merge Greg's changes on the defunct v4 branch svn: r7940 --- collects/frtime/demos/calculator.ss | 2 +- collects/frtime/demos/circles.ss | 2 +- collects/frtime/demos/growing-points.ss | 2 +- collects/frtime/demos/mirror-lens.ss | 241 ++++++++++++++++++++++++ collects/frtime/demos/needles.ss | 5 +- collects/frtime/demos/orbit-mouse.ss | 2 +- collects/frtime/demos/pong.ss | 6 +- collects/frtime/demos/tile-game.ss | 153 +++++++++++++++ collects/frtime/frp-core.ss | 23 +-- collects/frtime/lang-ext.ss | 39 ++-- collects/frtime/mzscheme-core.ss | 47 ++--- collects/frtime/mzscheme-utils.ss | 14 +- 12 files changed, 479 insertions(+), 57 deletions(-) create mode 100644 collects/frtime/demos/mirror-lens.ss create mode 100644 collects/frtime/demos/tile-game.ss diff --git a/collects/frtime/demos/calculator.ss b/collects/frtime/demos/calculator.ss index 64c1c56d34..641930a19a 100644 --- a/collects/frtime/demos/calculator.ss +++ b/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:"))) diff --git a/collects/frtime/demos/circles.ss b/collects/frtime/demos/circles.ss index 26740f918b..6be89f4188 100644 --- a/collects/frtime/demos/circles.ss +++ b/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))) diff --git a/collects/frtime/demos/growing-points.ss b/collects/frtime/demos/growing-points.ss index ef849991ea..0d2ba8d199 100644 --- a/collects/frtime/demos/growing-points.ss +++ b/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)) diff --git a/collects/frtime/demos/mirror-lens.ss b/collects/frtime/demos/mirror-lens.ss new file mode 100644 index 0000000000..838d55ac30 --- /dev/null +++ b/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 diff --git a/collects/frtime/demos/needles.ss b/collects/frtime/demos/needles.ss index 7fc3ab7d13..432ce8571b 100644 --- a/collects/frtime/demos/needles.ss +++ b/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) diff --git a/collects/frtime/demos/orbit-mouse.ss b/collects/frtime/demos/orbit-mouse.ss index 86391446b6..cd829a4324 100644 --- a/collects/frtime/demos/orbit-mouse.ss +++ b/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)) diff --git a/collects/frtime/demos/pong.ss b/collects/frtime/demos/pong.ss index a90f9e3a53..150de09e69 100644 --- a/collects/frtime/demos/pong.ss +++ b/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 350 30) (number->string p1-score) "black") + (make-graph-string (make-posn 30 30) (number->string p2-score) + (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"))) diff --git a/collects/frtime/demos/tile-game.ss b/collects/frtime/demos/tile-game.ss new file mode 100644 index 0000000000..b8c25282cf --- /dev/null +++ b/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))))) diff --git a/collects/frtime/frp-core.ss b/collects/frtime/frp-core.ss index 52fa17ea01..795181b8fe 100644 --- a/collects/frtime/frp-core.ss +++ b/collects/frtime/frp-core.ss @@ -386,14 +386,14 @@ (define (extract k evs) - (if (mpair? evs) - (let ([ev (mcar evs)]) + (if (pair? 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)) - (k val))))))) + ;(set-mcar! evs (erest ev)) + (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 - (exn-message exn) - (compose-continuation-mark-sets2 - (signal-continuation-marks - cur-beh) - (exn-continuation-marks exn))));) + (fprintf (current-error-port) "exception while updating ~a~n" cur-beh) + (set! exn (make-exn:fail + (exn-message exn) + (compose-continuation-mark-sets2 + (signal-continuation-marks + cur-beh) + (exn-continuation-marks exn))));) ;(raise exn) (iq-enqueue (list exceptions (list exn cur-beh))) (when (behavior? cur-beh) diff --git a/collects/frtime/lang-ext.ss b/collects/frtime/lang-ext.ss index 55a1f49db2..d2b9231559 100644 --- a/collects/frtime/lang-ext.ss +++ b/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 () - (extract (lambda (the-event) + (let loop ([streams streams]) + (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 () - (extract (lambda (the-event) (proc/emit the-event) (loop)) + (let loop ([streams streams]) + (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 diff --git a/collects/frtime/mzscheme-core.ss b/collects/frtime/mzscheme-core.ss index 641952a0e0..42942501dd 100644 --- a/collects/frtime/mzscheme-core.ss +++ b/collects/frtime/mzscheme-core.ss @@ -202,27 +202,32 @@ (let ([deps (make-hash-table)]) (lambda () (begin0 - (proc (lambda (obj) - (if (behavior? obj) - (begin - (case (hash-table-get deps obj 'absent) - [(absent) (hash-table-put! deps obj 'new)] - [(old) (hash-table-put! deps obj 'alive)] - [(new) (void)]) - (value-now obj)) - obj))) - (hash-table-for-each - deps - (lambda (k v) - (case v - [(new) (hash-table-put! deps k 'old) - #;(printf "reg~n") - (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)))))) + (let/ec esc + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (proc (lambda (obj) + (if (behavior? obj) + (begin + (case (hash-table-get deps obj 'absent) + [(absent) (hash-table-put! deps obj 'new) + (register rtn obj) + (iq-enqueue rtn) + (esc #f)] + [(old) (hash-table-put! deps obj 'alive)] + [(new) (void)]) + (value-now obj)) + obj)))) + (hash-table-for-each + deps + (lambda (k v) + (case v + [(new) (hash-table-put! deps k 'old) + #;(printf "reg~n") + (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)) diff --git a/collects/frtime/mzscheme-utils.ss b/collects/frtime/mzscheme-utils.ss index 47b2ba21b3..10aa54c649 100644 --- a/collects/frtime/mzscheme-utils.ss +++ b/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