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

under 3m, letrec doesn't seem to work the way I want for signal structures, so

Browse Source 
I've switched to manual set!

also, cleaned up the push-pull-ball demo

svn: r4803
This commit is contained in:
Greg Cooper 2006-11-07 22:14:40 +00:00
parent 4ef5d8acd5
commit f89d241e6b
2 changed files with 25 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/frtime/demos/push-pull-ball.ss
View File

@ -6,28 +6,26 @@
(define pos1 (define pos1
(rec pos (rec pos
(until (make-posn 200 200) (until (make-posn 200 200)
(delay-by (inf-delay
(let ([brnch (posn+ pos (let ([brnch (posn+ pos
(posn* (normalize (posn- mouse-pos pos)) (posn* (normalize (posn- mouse-pos pos))
(- (posn-diff pos mouse-pos) (sub1 radius))))]) (- (posn-diff pos mouse-pos) (sub1 radius))))])
(if (> (posn-diff pos mouse-pos) radius) (if (> (posn-diff pos mouse-pos) radius)
brnch brnch
pos)) pos))))))
0))))
(define pos2 (define pos2
(rec pos (rec pos
(until (make-posn 100 100) (until (make-posn 100 100)
(delay-by (inf-delay
(let ([brnch (posn+ pos (let ([brnch (posn+ pos
(posn* (normalize (posn- pos1 pos)) (posn* (normalize (posn- pos1 pos))
(- (posn-diff pos pos1) (add1 (* 2 radius)))))]) (- (posn-diff pos pos1) (add1 (* 2 radius)))))])
(if (< (posn-diff pos pos1) (* 2 radius)) (if (< (posn-diff pos pos1) (* 2 radius))
brnch brnch
pos)) pos))))))
0))))
(display-shapes (display-shapes
(list (list
(make-circle pos1 radius "blue") (make-circle pos1 radius "blue")
(make-circle pos2 radius "blue"))) (make-circle pos2 radius "gray")))

18
collects/frtime/lang-ext.ss
View File

@ -82,24 +82,26 @@
(define switch (define switch
(opt-lambda (e [init undefined]) (opt-lambda (e [init undefined])
(let* ([init (box init)] (let* ([init (box init)]
[e-b (hold e (unbox init))]) [e-b (hold e (unbox init))]
(rec ret [ret (proc->signal:switching
(proc->signal:switching (case-lambda [() undefined]
[(msg) e])
init e-b e-b (unbox init))])
(set-signal-thunk!
ret
(case-lambda (case-lambda
[() [()
(when (not (eq? (unbox init) (signal-value e-b))) (when (not (eq? (unbox init) (signal-value e-b)))
(unregister ret (unbox init)) (unregister ret (unbox init))
(set-box! init (value-now/no-copy e-b)) (set-box! init (value-now e-b))
(register ret (unbox init)) (register ret (unbox init))
(set-signal-producers! ret (list e-b (unbox init))) (set-signal-producers! ret (list e-b (unbox init)))
(set-signal-depth! ret (max (signal-depth ret) (set-signal-depth! ret (max (signal-depth ret)
(add1 (safe-signal-depth (unbox init))))) (add1 (safe-signal-depth (unbox init)))))
(iq-resort)) (iq-resort))
(value-now/no-copy (unbox init))] (value-now/no-copy (unbox init))]
[(msg) e]) [(msg) e]))
init ret)))
e-b
e-b (unbox init))))))
; event ... -> event ; event ... -> event
(define (merge-e . args) (define (merge-e . args)