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

cleaner model for events

Browse Source 
svn: r8691
This commit is contained in:
Greg Cooper 2008-02-17 03:20:26 +00:00
parent ea61e52e84
commit 1cbca40558
6 changed files with 152 additions and 254 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/frtime/demos/analog-clock.ss
View File

@ -134,4 +134,5 @@
(list clock-face hour-hand minute-hand second-hand)) (list clock-face hour-hand minute-hand second-hand))
;; Draw the clock! ;; Draw the clock!
(display-shapes analog-clock) (display-shapes
(list analog-clock (make-graph-string (make-posn 20 20) "Drag me around!" "black")))

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

@ -14,6 +14,11 @@
;;;;;;;;;;;;; ;;;;;;;;;;;;;
;; Globals ;; ;; Globals ;;
;;;;;;;;;;;;; ;;;;;;;;;;;;;
;; the current logical time step
(define logical-time (box 0))
(define (current-logical-time)
(unbox logical-time))
(define frtime-inspector (make-inspector)) (define frtime-inspector (make-inspector))
(print-struct #t) (print-struct #t)
@ -126,14 +131,10 @@
(define-struct multiple (values) frtime-inspector) (define-struct multiple (values) frtime-inspector)
(define-struct event-cons (head tail)) (define-struct event-set (time events))
(define econs make-event-cons) (define (make-events-now events)
(define efirst event-cons-head) (make-event-set (current-logical-time) events))
(define erest event-cons-tail)
(define econs? event-cons?)
(define set-efirst! set-event-cons-head!)
(define set-erest! set-event-cons-tail!)
(define-struct (signal:unchanged signal) () frtime-inspector) (define-struct (signal:unchanged signal) () frtime-inspector)
(define-struct (signal:compound signal:unchanged) (content copy) frtime-inspector) (define-struct (signal:compound signal:unchanged) (content copy) frtime-inspector)
(define-struct (signal:switching signal:unchanged) (current trigger) frtime-inspector) (define-struct (signal:switching signal:unchanged) (current trigger) frtime-inspector)
@ -169,17 +170,19 @@
(emit (first the-args))))))) (emit (first the-args)))))))
(define (event-producer2 proc . deps) (define (event-producer2 proc . deps)
(let* ([out (econs undefined undefined)] (let* ([result (apply proc->signal (lambda args (make-events-now empty)) deps)]
[proc/emit (proc [proc/emit (proc
(lambda (val) (lambda (val)
(set-erest! out (econs val undefined)) (let ([old-value (signal-value result)])
(set! out (erest out)) (make-events-now
val))]) (if (= (current-logical-time) (event-set-time old-value))
(apply proc->signal (lambda the-args (apply proc/emit the-args) out) deps))) (append (event-set-events old-value) (list val))
(list val))))))])
(set-signal-thunk! result proc/emit)
result))
(define (build-signal ctor thunk producers) (define (build-signal ctor thunk producers)
(let ([ccm (effective-continuation-marks)]) (let ([ccm (effective-continuation-marks)])
;(printf "*")
(do-in-manager (do-in-manager
(let* ([cust (current-cust)] (let* ([cust (current-cust)]
[cust-sig (and cust (ft-cust-signal cust))] [cust-sig (and cust (ft-cust-signal cust))]
@ -336,7 +339,7 @@
(define (behavior? v) (define (behavior? v)
(and (signal? v) (not (event-cons? (signal-value v))))) (and (signal? v) (not (event-set? (signal-value v)))))
(define (undef b) (define (undef b)
(match b (match b
@ -392,17 +395,6 @@
[('exn e) (raise e)]))])) [('exn e) (raise e)]))]))
(define (extract k evs)
(if (pair? evs)
(let ([ev (car evs)])
(if (or (eq? ev undefined) (undefined? (erest ev)))
(extract k (cdr evs))
(begin
(let ([val (efirst (erest ev))])
;(set-mcar! evs (erest ev))
(k val (cons (erest ev) (rest evs)))))))))
(define (kill-signal sig) (define (kill-signal sig)
;(printf "killing~n") ;(printf "killing~n")
(for-each (for-each
@ -432,53 +424,7 @@
;; Dataflow Graph Maintenance ;; ;; Dataflow Graph Maintenance ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (fix-streams streams args)
(if (empty? streams)
empty
(cons
(if (undefined? (first streams))
(let ([stream (signal-value (first args))])
stream
#;(if (undefined? stream)
stream
(if (equal? stream (econs undefined undefined))
stream
(econs undefined stream))))
(first streams))
(fix-streams (rest streams) (rest args)))))
(define (event-forwarder sym evt f+l)
(let ([proc (lambda (emit)
(lambda (the-event)
(for-each (lambda (tid)
(! tid (list 'remote-evt sym the-event))) (mcdr f+l))))]
[args (list evt)])
(let* ([out (econs undefined undefined)]
[proc/emit (proc
(lambda (val)
(set-erest! out (econs val undefined))
(set! out (erest out))
val))]
[streams (let loop ([args args])
(if (null? args)
null
(mcons (signal-value (car args))
(loop (cdr args)))))]
[thunk (lambda ()
(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) (proc/emit the-event) (loop))
streams))
(set! streams (map signal-value args))
out)])
(apply proc->signal thunk args))))
(define (safe-signal-depth v) (define (safe-signal-depth v)
(cond (cond
[(signal? v) (signal-depth v)] [(signal? v) (signal-depth v)]
@ -829,12 +775,6 @@
(if k (set! x (add1 x))))) (if k (set! x (add1 x)))))
(! rtn-pid x))] (! rtn-pid x))]
[('bind sym evt)
(let ([forwarder+listeners (mcons #f empty)])
(set-mcar! forwarder+listeners
(event-forwarder sym evt forwarder+listeners))
(hash-table-put! named-providers sym forwarder+listeners))
(loop)]
[('remote-reg tid sym) [('remote-reg tid sym)
(let ([f+l (hash-table-get named-providers sym)]) (let ([f+l (hash-table-get named-providers sym)])
(when (not (member tid (mcdr f+l))) (when (not (member tid (mcdr f+l)))
@ -889,6 +829,8 @@
(set! notifications empty) (set! notifications empty)
(set! thunks-to-run empty) (set! thunks-to-run empty)
(set-box! logical-time (add1 (unbox logical-time)))
(inner))))))) (inner)))))))

5
collects/frtime/frp-snip.ss
View File

@ -56,7 +56,8 @@
[(event? bhvr) (signal-value bhvr)] [(event? bhvr) (signal-value bhvr)]
[else bhvr])]) [else bhvr])])
(cond (cond
[(econs? tmp) (format "#<event (last: ~a)>" (efirst tmp))] [(event-set? tmp) (format "#<event (last: ~a@~a)>"
(event-set-events tmp) (event-set-time tmp))]
[(undefined? tmp) "<undefined>"] [(undefined? tmp) "<undefined>"]
[else (expr->string tmp)])))] [else (expr->string tmp)])))]
[(bhvr super-render-fun) [(bhvr super-render-fun)
@ -139,7 +140,7 @@
[as-snip? (watch beh)] [as-snip? (watch beh)]
[(undefined? (value-now beh)) "<undefined>"] [(undefined? (value-now beh)) "<undefined>"]
[(behavior? beh) (format "#<behavior (~a)>" (value-now beh))] [(behavior? beh) (format "#<behavior (~a)>" (value-now beh))]
[(event? beh) (format "#<event (last: ~a)>" (efirst (signal-value beh)))] [(event? beh) (format "#<event (last: ~a)>" (event-set-events (signal-value beh)))]
[else beh])) [else beh]))
(define (render/dynamic-snip val super-render-fun) (define (render/dynamic-snip val super-render-fun)

4
collects/frtime/frtime-lang-only.ss
View File

@ -2,11 +2,11 @@
(require (lib "lang-ext.ss" "frtime")) (require (lib "lang-ext.ss" "frtime"))
(require (lib "ft-qq.ss" "frtime")) (require (lib "ft-qq.ss" "frtime"))
(require (as-is:unchecked (lib "frp-core.ss" "frtime") (require (as-is:unchecked (lib "frp-core.ss" "frtime")
event-cons? signal-value)) event-set? signal-value))
(define (value-nowable? x) (define (value-nowable? x)
(or (not (signal? x)) (or (not (signal? x))
(not (event-cons? (signal-value x))))) (not (event-set? (signal-value x)))))
(define ((behaviorof pred) x) (define ((behaviorof pred) x)
(let ([v (value-now x)]) (let ([v (value-now x)])

6
collects/frtime/frtime.ss
View File

@ -1,13 +1,13 @@
(module frtime "mzscheme-utils.ss" (module frtime "mzscheme-utils.ss"
(require "lang-ext.ss") (require "lang-ext.ss")
(require "frp-snip.ss") (require "frp-snip.ss")
(require "ft-qq.ss") (require "ft-qq.ss")
(require (as-is:unchecked "frp-core.ss" (require (as-is:unchecked "frp-core.ss"
event-cons? signal-value)) event-set? signal-value))
(define (value-nowable? x) (define (value-nowable? x)
(or (not (signal? x)) (or (not (signal? x))
(not (event-cons? (signal-value x))))) (not (event-set? (signal-value x)))))
(define ((behaviorof pred) x) (define ((behaviorof pred) x)
(let ([v (value-now x)]) (let ([v (value-now x)])

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

@ -17,6 +17,8 @@
[(assq obj table) => second] [(assq obj table) => second]
[(behavior? obj) [(behavior? obj)
(deep-value-now (signal-value obj) (cons (list obj (signal-value obj)) table))] (deep-value-now (signal-value obj) (cons (list obj (signal-value obj)) table))]
[(event? obj)
(signal-value obj)]
[(cons? obj) [(cons? obj)
(let* ([result (cons #f #f)] (let* ([result (cons #f #f)]
[new-table (cons (list obj result) table)] [new-table (cons (list obj result) table)]
@ -36,6 +38,26 @@
(deep-value-now (vector-ref obj i) table)))] (deep-value-now (vector-ref obj i) table)))]
[else obj])])) [else obj])]))
(define (lift strict? fn . args)
(if (snap?) ;; maybe fix later to handle undefined-strictness
(apply fn (map value-now/no-copy args))
(with-continuation-mark
'frtime 'lift-active
(if (ormap signal? args)
(begin
#;(when (ormap signal:compound? args)
(printf "attempting to lift ~a over a signal:compound in ~a!~n" fn (map value-now args)))
(apply
proc->signal
(apply (if strict? create-strict-thunk create-thunk) fn args)
args))
(if (and strict? (ormap undefined? args))
undefined
(apply fn args))))))
(define (lift-strict . args)
(apply lift #t args))
; new-cell : behavior[a] -> behavior[a] (cell) ; new-cell : behavior[a] -> behavior[a] (cell)
@ -90,21 +112,8 @@
(and (signal? v) (and (signal? v)
(if (undefined? (signal-value v)) (if (undefined? (signal-value v))
undefined undefined
(event-cons? (signal-value v))))) (event-set? (signal-value v)))))
(define-syntax (event-producer stx)
(syntax-case stx ()
[(src-event-producer expr dep ...)
(with-syntax ([emit (datum->syntax-object (syntax src-event-producer) 'emit)]
[the-args (datum->syntax-object
(syntax src-event-producer) 'the-args)])
(syntax (let* ([out (econs undefined undefined)]
[emit (lambda (val)
(set-erest! out (econs val undefined))
(set! out (erest out)))])
(proc->signal (lambda the-args expr out) dep ...))))]))
; switch : event[behavior] behavior -> behavior ; switch : event[behavior] behavior -> behavior
(define switch (define switch
(opt-lambda (e [init undefined]) (opt-lambda (e [init undefined])
@ -132,30 +141,29 @@
; event ... -> event ; event ... -> event
(define (merge-e . args) (define (merge-e . args)
(apply event-processor (apply lift #t (lambda args
(lambda (emit) (make-events-now
(lambda (the-event) (apply append
(emit the-event))) (map event-set-events
(filter (lambda (es) (= (current-logical-time) (event-set-time es)))
args)))))
args)) args))
(define (once-e e) (define (once-e e)
(let ([b #t]) (map-e second (filter-e (lambda (p) (= 1 (first p)))
(rec ret (event-processor (collect-e e (list 0) (lambda (e p) (list (add1 (first p)) e))))))
(lambda (emit)
(lambda (the-event)
(when b
(set! b false)
(unregister ret e)
(emit the-event))))
e))))
; behavior[a] -> event[a] ; behavior[a] -> event[a]
(define (changes b) (define (changes b)
(event-producer2 (lift #f (let ([first-time #t])
(lambda (emit) (lambda (bh)
(lambda the-args (begin0
(emit (deep-value-now b)))) (make-events-now
b)) (if first-time
empty
(list (deep-value-now bh))))
(set! first-time #f))))
b))
(define never-e (define never-e
(changes #f)) (changes #f))
@ -164,14 +172,15 @@
; when-e : behavior[bool] -> event ; when-e : behavior[bool] -> event
(define (when-e b) (define (when-e b)
(let* ([last (value-now b)]) (let* ([last (value-now b)])
(event-producer2 (lift #t (lambda (bh)
(lambda (emit) (make-events-now
(lambda the-args (let ([current bh])
(let ([current (value-now b)]) (begin0
(when (and (not last) current) (if (and (not last) current)
(emit current)) (list current)
(set! last current)))) empty)
b))) (set! last current)))))
b)))
; while-e : behavior[bool] behavior[number] -> event ; while-e : behavior[bool] behavior[number] -> event
(define (while-e b interval) (define (while-e b interval)
@ -187,21 +196,13 @@
; ==> : event[a] (a -> b) -> event[b] ; ==> : event[a] (a -> b) -> event[b]
(define (e . ==> . f) (define (e . ==> . f)
(event-processor (lift #t (lambda (es)
(lambda (emit) (make-events-now
(lambda (the-event) (if (= (current-logical-time) (event-set-time es))
(emit ((value-now f) the-event)))) (map f (event-set-events es))
e)) empty)))
e))
#|
(define (e . =>! . f)
(event-processor
((value-now f) the-event)
(list e)))
|#
; -=> : event[a] b -> event[b] ; -=> : event[a] b -> event[b]
(define-syntax -=> (define-syntax -=>
(syntax-rules () (syntax-rules ()
@ -209,24 +210,21 @@
; =#> : event[a] (a -> bool) -> event[a] ; =#> : event[a] (a -> bool) -> event[a]
(define (e . =#> . p) (define (e . =#> . p)
(event-processor (lift #t (lambda (es)
(lambda (emit) (make-events-now
(lambda (the-event) (if (= (current-logical-time) (event-set-time es))
(when (value-now (p the-event)) (filter (value-now p) (map value-now (event-set-events es)))
(emit the-event)))) empty)))
e)) e))
; =#=> : event[a] (a -> b U nothing) -> event[b] ; =#=> : event[a] (a -> b U nothing) -> event[b]
(define (e . =#=> . f) (define (e . =#=> . f)
(event-processor (lift #t (lambda (es)
(lambda (emit) (make-events-now
(lambda (the-event) (if (= (current-logical-time) (event-set-time es))
(let ([x (f the-event)]) (filter (compose not nothing?) (map f (event-set-events es)))
(unless (or (nothing? x) (undefined? x)) empty)))
(emit x))))) e))
e))
(define (map-e f e) (define (map-e f e)
(==> e f)) (==> e f))
@ -235,25 +233,38 @@
(define (filter-map-e f e) (define (filter-map-e f e)
(=#=> e f)) (=#=> e f))
(define (scan trans acc lst)
(if (cons? lst)
(let ([new-acc (trans (first lst) acc)])
(cons new-acc (scan trans new-acc (rest lst))))
empty))
; event[a] b (a b -> b) -> event[b] ; event[a] b (a b -> b) -> event[b]
(define (collect-e e init trans) (define (collect-e e init trans)
(event-processor (lift #t (lambda (es)
(lambda (emit) (make-events-now
(lambda (the-event) (cond
(let ([ret (trans the-event init)]) [(= (current-logical-time) (event-set-time es))
(set! init ret) (let ([all-events (scan trans init (event-set-events es))])
(emit ret)))) (when (cons? all-events)
e)) (set! init (first (last-pair all-events))))
all-events)]
[else empty])))
e))
; event[(a -> a)] a -> event[a] ; event[(a -> a)] a -> event[a]
(define (accum-e e init) (define (accum-e e init)
(event-processor (lift #t (lambda (es)
(lambda (emit) (make-events-now
(lambda (the-event) (cond
(let ([ret (the-event init)]) [(= (current-logical-time) (event-set-time es))
(set! init ret) (let ([all-events (scan (lambda (t a) (t a)) init (event-set-events es))])
(emit ret)))) (when (cons? all-events)
e)) (set! init (first (last-pair all-events))))
all-events)]
[else empty])))
e))
; event[a] b (a b -> b) -> behavior[b] ; event[a] b (a b -> b) -> behavior[b]
(define (collect-b ev init trans) (define (collect-b ev init trans)
@ -267,14 +278,12 @@
(define hold (define hold
(opt-lambda (e [init undefined]) (opt-lambda (e [init undefined])
(let ([val init]) (let ([val init])
(let* ([updator (event-processor (lift #t (lambda (es) (let ([events (event-set-events es)])
(lambda (emit) (when (and (= (current-logical-time) (event-set-time es))
(lambda (the-event) (cons? events))
(set! val the-event) (set! val (first (last-pair (event-set-events es)))))
(emit the-event))) val))
e)] e))))
[rtn (proc->signal (lambda () updator val) updator)])
rtn))))
(define-syntax snapshot/sync (define-syntax snapshot/sync
(syntax-rules () (syntax-rules ()
@ -298,11 +307,14 @@
expr ...)])) expr ...)]))
(define (snapshot-e e . bs) (define (snapshot-e e . bs)
(event-processor (apply lift #t (lambda (es . bs)
(lambda (emit) (make-events-now
(lambda (the-event) (cond
(emit (cons the-event (map value-now bs))))) [(= (current-logical-time) (event-set-time es))
e)) (map (lambda (the-event) (cons the-event (map value-now bs)))
(event-set-events es))]
[else empty])))
e bs))
(define (snapshot/apply fn . args) (define (snapshot/apply fn . args)
(apply fn (map value-now args))) (apply fn (map value-now args)))
@ -315,28 +327,8 @@
[(_ obj meth arg ...) [(_ obj meth arg ...)
(if (snap?) (if (snap?)
(send obj meth (value-now arg) ...) (send obj meth (value-now arg) ...)
(send obj meth arg ...))])) (send obj meth arg ...))]))
;; Deprecated
(define (magic dtime thunk)
(let* ([last-time (current-inexact-milliseconds)]
[ret (let ([myself #f])
(event-producer
(let ([now (current-inexact-milliseconds)])
(snapshot (dtime)
(when (cons? the-args)
(set! myself (first the-args)))
(when (and dtime (>= now (+ last-time dtime)))
(emit (thunk))
(set! last-time now))
(when dtime
(schedule-alarm (+ last-time dtime) myself))))
dtime))])
(send-event ret ret)
ret))
;; Deprecated
(define (make-time-b ms) (define (make-time-b ms)
(let ([ret (proc->signal void)]) (let ([ret (proc->signal void)])
(set-signal-thunk! ret (set-signal-thunk! ret
@ -374,7 +366,10 @@
(let loop () (let loop ()
(if (or (empty? (mcdr head)) (if (or (empty? (mcdr head))
(< now (+ ms (cdr (mcar (mcdr head)))))) (< now (+ ms (cdr (mcar (mcdr head))))))
(car (mcar head)) (let ([val (car (mcar head))])
(if (event-set? val)
(make-events-now (event-set-events val))
val))
(begin (begin
(set! head (mcdr head)) (set! head (mcdr head))
(loop)))))))] (loop)))))))]
@ -495,27 +490,7 @@
[(fn . args) (lambda () (apply fn (map value-now/no-copy args)))])) [(fn . args) (lambda () (apply fn (map value-now/no-copy args)))]))
(define (lift strict? fn . args) #;
(if (snap?) ;; maybe fix later to handle undefined-strictness
(apply fn (map value-now/no-copy args))
(with-continuation-mark
'frtime 'lift-active
(if (ormap behavior? args)
(begin
#;(when (ormap signal:compound? args)
(printf "attempting to lift ~a over a signal:compound in ~a!~n" fn (map value-now args)))
(apply
proc->signal
(apply (if strict? create-strict-thunk create-thunk) fn args)
args))
(if (and strict? (ormap undefined? args))
undefined
(apply fn args))))))
(define (lift-strict . args)
(apply lift #t args))
(define (general-event-processor proc . args) (define (general-event-processor proc . args)
; proc : (lambda (emit suspend first-evt) ...) ; proc : (lambda (emit suspend first-evt) ...)
(let* ([out (econs undefined undefined)] (let* ([out (econs undefined undefined)]
@ -572,6 +547,7 @@
(define (flush . strs) (define (flush . strs)
(select-proc (map (lambda (str) (list str void)) strs))) (select-proc (map (lambda (str) (list str void)) strs)))
#;
(define (general-event-processor2 proc) (define (general-event-processor2 proc)
(do-in-manager (do-in-manager
(let* ([out (econs undefined undefined)] (let* ([out (econs undefined undefined)]
@ -640,27 +616,7 @@
#;(if (pair? lst) #;(if (pair? lst)
(mcons (first lst) (make-mutable (rest lst))) (mcons (first lst) (make-mutable (rest lst)))
lst)) lst))
(define (event-processor proc . args)
(let* ([out (econs undefined undefined)]
[proc/emit (proc
(lambda (val)
(set-erest! out (econs val undefined))
(set! out (erest out))
val))]
[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 ([streams streams])
(extract (lambda (the-event strs) (proc/emit the-event) (loop strs))
streams))
(set! streams (map signal-value args))
out)])
(apply proc->signal thunk args)))
;; split : event[a] (a -> b) -> (b -> event[a]) ;; split : event[a] (a -> b) -> (b -> event[a])
(define (split ev fn) (define (split ev fn)
(let* ([ht (make-hash-table 'weak)] (let* ([ht (make-hash-table 'weak)]
@ -817,11 +773,10 @@
(provide raise-exceptions (provide raise-exceptions
nothing nothing
nothing? nothing?
general-event-processor ;general-event-processor
general-event-processor2 ;general-event-processor2
emit emit
select select
event-processor
switch switch
merge-e merge-e
once-e once-e
@ -847,7 +802,6 @@
snapshot snapshot
snapshot-e snapshot-e
snapshot/apply snapshot/apply
magic
milliseconds milliseconds
fine-timer-granularity fine-timer-granularity
seconds seconds
@ -881,7 +835,7 @@
frtime-version frtime-version
signal-count signal-count
signal? signal?
) )
) )