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

- parameters work with signals now

Browse Source 
- ufo demo wraps around screen

svn: r570
This commit is contained in:
Greg Cooper 2005-08-09 03:58:49 +00:00
parent 04264c3f8f
commit 2863c91763
2 changed files with 61 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/frtime/demos/ufo.ss
View File

@ -1,13 +1,16 @@
(require (lib "animation.ss" "frtime")) (require (lib "animation.ss" "frtime"))
(define ufo-x (define ufo-x
(+ 200 ; center of window (modulo
(integral ; integrate over time (+ 200 ; center of window
(* .04 ; scale speed to appropriate # of pixels/ms (floor
(- 3 ; start off stationary (integral ; integrate over time
; use left and right arrows to accelerate (* .04 ; scale speed to appropriate # of pixels/ms
; (up to 3 in either direction) (- 3 ; start off stationary
(range-control (key 'left) (key 'right) 6 3)))))) ; use left and right arrows to accelerate
; (up to 3 in either direction)
(range-control (key 'left) (key 'right) 6 3))))))
450))
(define ufo-y ; bob up and down 5 pixels around center of window (define ufo-y ; bob up and down 5 pixels around center of window
(+ 200 (* 5 (sin (/ milliseconds 200))))) (+ 200 (* 5 (sin (/ milliseconds 200)))))
(define ufo-bright ; flash light and dark (define ufo-bright ; flash light and dark

87
collects/frtime/frp-core.ss
View File

@ -45,7 +45,7 @@
signal-thunk signal-thunk
signal-depth signal-depth
signal-continuation-marks signal-continuation-marks
signal-custodians signal-parameterization
signal-producers signal-producers
set-signal-value! set-signal-value!
set-signal-dependents! set-signal-dependents!
@ -53,11 +53,11 @@
set-signal-thunk! set-signal-thunk!
set-signal-depth! set-signal-depth!
set-signal-continuation-marks! set-signal-continuation-marks!
set-signal-custodians! set-signal-parameterization!
set-signal-producers!) set-signal-producers!)
(let*-values ([(field-name-symbols) (let*-values ([(field-name-symbols)
(list 'value 'dependents 'stale? 'thunk (list 'value 'dependents 'stale? 'thunk
'depth 'continuation-marks 'guards 'producers)] 'depth 'continuation-marks 'parameterization 'producers)]
[(desc make-signal signal? acc mut) [(desc make-signal signal? acc mut)
(make-struct-type (make-struct-type
'signal #f (length field-name-symbols) 0 #f null frtime-inspector 'signal #f (length field-name-symbols) 0 #f null frtime-inspector
@ -83,7 +83,8 @@
(define-syntax signal (define-syntax signal
(let ([field-name-symbols (list 'value 'dependents 'stale? 'thunk (let ([field-name-symbols (list 'value 'dependents 'stale? 'thunk
'depth 'continuation-marks 'guards 'producers)]) 'depth 'continuation-marks 'parameterization
'producers)])
(list-immutable (list-immutable
((syntax-local-certifier) #'struct:signal) ((syntax-local-certifier) #'struct:signal)
((syntax-local-certifier) #'make-signal) ((syntax-local-certifier) #'make-signal)
@ -104,6 +105,11 @@
(reverse field-name-symbols))) (reverse field-name-symbols)))
#t))) #t)))
(define (signal-custodians sig)
(call-with-parameterization
(signal-parameterization sig)
current-custs))
(define-struct ft-cust (signal constructed-sigs)) (define-struct ft-cust (signal constructed-sigs))
;(define-struct non-scheduled (signal)) ;(define-struct non-scheduled (signal))
(define make-non-scheduled identity) (define make-non-scheduled identity)
@ -165,7 +171,9 @@
(add1 (apply max 0 (append (map safe-signal-depth producers) (add1 (apply max 0 (append (map safe-signal-depth producers)
(map safe-signal-depth cust-sigs)))) (map safe-signal-depth cust-sigs))))
ccm ccm
custs (parameterize ([current-exception-handler
(lambda (exn) (exn-handler exn))])
(current-parameterization))
(append cust-sigs producers))]) (append cust-sigs producers))])
;(printf "~a custodians~n" (length custs)) ;(printf "~a custodians~n" (length custs))
(when (cons? producers) (when (cons? producers)
@ -188,7 +196,9 @@
(add1 (apply max 0 (append (map safe-signal-depth producers) (add1 (apply max 0 (append (map safe-signal-depth producers)
(map safe-signal-depth cust-sigs)))) (map safe-signal-depth cust-sigs))))
ccm ccm
custs (parameterize ([current-exception-handler
(lambda (exn) (exn-handler exn))])
(current-parameterization))
(append cust-sigs producers) (append cust-sigs producers)
current-box current-box
trigger)]) trigger)])
@ -229,19 +239,25 @@
acc)) acc))
empty args (build-list (length args) identity))] empty args (build-list (length args) identity))]
[sig (make-signal:compound [sig (make-signal:compound
value undefined
empty empty
#f #f
(lambda () ;mutators (lambda () ;mutators
(let loop ([i 0] [args args]) (let loop ([i 0] [args args] [val value])
(when (cons? args) (if (cons? args)
((mutate! value i) (value-now/no-copy (car args))) (let ([fd (value-now/no-copy (car args))])
(loop (add1 i) (cdr args)))) ((mutate! value i) fd)
value) (loop (add1 i) (cdr args)
(if (undefined? fd)
undefined
val)))
val)))
(add1 (apply max 0 (append (map safe-signal-depth args) (add1 (apply max 0 (append (map safe-signal-depth args)
(map safe-signal-depth cust-sigs)))) (map safe-signal-depth cust-sigs))))
(current-continuation-marks) (current-continuation-marks)
custs (parameterize ([current-exception-handler
(lambda (exn) (exn-handler exn))])
(current-parameterization))
(append cust-sigs args) (append cust-sigs args)
(apply ctor args) (apply ctor args)
(lambda () (apply ctor (map value-now args))))]) (lambda () (apply ctor (map value-now args))))])
@ -253,6 +269,7 @@
(for-each (lambda (g) (set-ft-cust-constructed-sigs! (for-each (lambda (g) (set-ft-cust-constructed-sigs!
g (cons (make-weak-box sig) (ft-cust-constructed-sigs g)))) g (cons (make-weak-box sig) (ft-cust-constructed-sigs g))))
custs) custs)
(iq-enqueue sig)
;(printf "~n*made a compound [~a]*~n~n" (value-now/no-copy sig)) ;(printf "~n*made a compound [~a]*~n~n" (value-now/no-copy sig))
sig))) sig)))
@ -527,10 +544,12 @@
(if (man?) (if (man?)
(begin expr ...) (begin expr ...)
(begin (begin
(! man (list 'run-thunk (self) (let ([custs (current-custs)]) (! man (list 'run-thunk (self)
(lambda () (let ([params (current-parameterization)])
(parameterize ([current-custs custs]) (lambda ()
expr ...))))) (call-with-parameterization
params
(lambda () expr ...))))))
(receive [('vals . vs) (apply values vs)] (receive [('vals . vs) (apply values vs)]
[('exn e) (raise e)])))])) [('exn e) (raise e)])))]))
@ -541,10 +560,11 @@
(begin expr ...) (begin expr ...)
(begin (begin
(! man (list 'run-thunk/stabilized (self) (! man (list 'run-thunk/stabilized (self)
(let ([custs (current-custs)]) (let ([params (current-parameterization)])
(lambda () (lambda ()
(parameterize ([current-custs custs]) (call-with-parameterization
expr ...))))) params
(lambda () expr ...))))))
(receive [('vals . vs) (apply values vs)] (receive [('vals . vs) (apply values vs)]
[('exn e) (raise e)])))])) [('exn e) (raise e)])))]))
@ -587,7 +607,9 @@
(letrec ([custodian-signal (letrec ([custodian-signal
(proc->signal:unchanged (proc->signal:unchanged
(lambda () (lambda ()
(for-each kill-signal (filter identity (map weak-box-value (ft-cust-constructed-sigs cust)))) (for-each kill-signal
(filter identity
(map weak-box-value (ft-cust-constructed-sigs cust))))
(unregister rtn (unbox current)) (unregister rtn (unbox current))
(set-box! current (pfun (value-now/no-copy bhvr))) (set-box! current (pfun (value-now/no-copy bhvr)))
(register rtn (unbox current)) (register rtn (unbox current))
@ -633,10 +655,11 @@
[(and (? signal?) [(and (? signal?)
(= signal-value value) (= signal-value value)
(= signal-thunk thunk) (= signal-thunk thunk)
(= signal-custodians custs)) (= signal-parameterization params))
(set-signal-stale?! b #f) (set-signal-stale?! b #f)
(let ([new-value (parameterize ([current-custs custs]) (let ([new-value (call-with-parameterization
(thunk))]) params
thunk)])
(if (or (signal:unchanged? b) (not (eq? value new-value))) (if (or (signal:unchanged? b) (not (eq? value new-value)))
(begin (begin
#;(if (signal? new-value) #;(if (signal? new-value)
@ -667,19 +690,17 @@
(propagate b)))] (propagate b)))]
[_ (void)])) [_ (void)]))
(define (signal-count) (define (signal-count)
(! man `(stat ,(self))) (! man `(stat ,(self)))
(receive [n n])) (receive [n n]))
(define exn-handler (lambda (exn) (raise exn)))
;;;;;;;;;;;;; ;;;;;;;;;;;;;
;; Manager ;; ;; Manager ;;
;;;;;;;;;;;;; ;;;;;;;;;;;;;
;; the manager of all signals and event streams ;; the manager of all signals
(define man (define man
(spawn/name (spawn/name
'frtime-heart 'frtime-heart
@ -704,7 +725,7 @@
(lambda (exn) (lambda (exn)
(when (and cur-beh (when (and cur-beh
#;(not (undefined? (signal-value cur-beh)))) #;(not (undefined? (signal-value cur-beh))))
#(when (empty? (continuation-mark-set->list #;(when (empty? (continuation-mark-set->list
(exn-continuation-marks exn) 'frtime)) (exn-continuation-marks exn) 'frtime))
(set! exn (make-exn:fail (exn-message exn) (set! exn (make-exn:fail (exn-message exn)
(signal-continuation-marks (signal-continuation-marks
@ -715,6 +736,7 @@
(undef cur-beh) (undef cur-beh)
#;(kill-signal cur-beh))) #;(kill-signal cur-beh)))
(outer))]) (outer))])
(set! exn-handler (current-exception-handler))
(let inner () (let inner ()
;; process external messages until there is an internal update ;; process external messages until there is an internal update
@ -738,13 +760,6 @@
[('run-thunk rtn-pid thunk) [('run-thunk rtn-pid thunk)
(begin (begin
(do-and-queue rtn-pid thunk) (do-and-queue rtn-pid thunk)
; (with-handlers
; ([exn:fail? (lambda (exn)
; (set! notifications
; (cons (list rtn-pid 'exn exn)
; notifications)))])
; (set! notifications (cons (list rtn-pid 'val (thunk))
; notifications)))
(loop))] (loop))]