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))
;; Draw the clock!
(display-shapes analog-clock)
(display-shapes
(list analog-clock (make-graph-string (make-posn 20 20) "Drag me around!" "black")))

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

@ -15,6 +15,11 @@
;; Globals ;;
;;;;;;;;;;;;;
;; the current logical time step
(define logical-time (box 0))
(define (current-logical-time)
(unbox logical-time))
(define frtime-inspector (make-inspector))
(print-struct #t)
@ -126,13 +131,9 @@
(define-struct multiple (values) frtime-inspector)
(define-struct event-cons (head tail))
(define econs make-event-cons)
(define efirst event-cons-head)
(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 event-set (time events))
(define (make-events-now events)
(make-event-set (current-logical-time) events))
(define-struct (signal:unchanged signal) () frtime-inspector)
(define-struct (signal:compound signal:unchanged) (content copy) frtime-inspector)
@ -169,17 +170,19 @@
(emit (first the-args)))))))
(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
(lambda (val)
(set-erest! out (econs val undefined))
(set! out (erest out))
val))])
(apply proc->signal (lambda the-args (apply proc/emit the-args) out) deps)))
(let ([old-value (signal-value result)])
(make-events-now
(if (= (current-logical-time) (event-set-time old-value))
(append (event-set-events old-value) (list val))
(list val))))))])
(set-signal-thunk! result proc/emit)
result))
(define (build-signal ctor thunk producers)
(let ([ccm (effective-continuation-marks)])
;(printf "*")
(do-in-manager
(let* ([cust (current-cust)]
[cust-sig (and cust (ft-cust-signal cust))]
@ -336,7 +339,7 @@
(define (behavior? v)
(and (signal? v) (not (event-cons? (signal-value v)))))
(and (signal? v) (not (event-set? (signal-value v)))))
(define (undef b)
(match b
@ -392,17 +395,6 @@
[('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)
;(printf "killing~n")
(for-each
@ -433,52 +425,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)
(cond
[(signal? v) (signal-depth v)]
@ -829,12 +775,6 @@
(if k (set! x (add1 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)
(let ([f+l (hash-table-get named-providers sym)])
(when (not (member tid (mcdr f+l)))
@ -890,6 +830,8 @@
(set! notifications empty)
(set! thunks-to-run empty)
(set-box! logical-time (add1 (unbox logical-time)))
(inner)))))))
(define exceptions

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

@ -56,7 +56,8 @@
[(event? bhvr) (signal-value bhvr)]
[else bhvr])])
(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>"]
[else (expr->string tmp)])))]
[(bhvr super-render-fun)
@ -139,7 +140,7 @@
[as-snip? (watch beh)]
[(undefined? (value-now beh)) "<undefined>"]
[(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]))
(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 "ft-qq.ss" "frtime"))
(require (as-is:unchecked (lib "frp-core.ss" "frtime")
event-cons? signal-value))
event-set? signal-value))
(define (value-nowable? x)
(or (not (signal? x))
(not (event-cons? (signal-value x)))))
(not (event-set? (signal-value x)))))
(define ((behaviorof pred) 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 "frp-snip.ss")
(require "ft-qq.ss")
(require (as-is:unchecked "frp-core.ss"
event-cons? signal-value))
event-set? signal-value))
(define (value-nowable? x)
(or (not (signal? x))
(not (event-cons? (signal-value x)))))
(not (event-set? (signal-value x)))))
(define ((behaviorof pred) x)
(let ([v (value-now x)])

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

@ -17,6 +17,8 @@
[(assq obj table) => second]
[(behavior? obj)
(deep-value-now (signal-value obj) (cons (list obj (signal-value obj)) table))]
[(event? obj)
(signal-value obj)]
[(cons? obj)
(let* ([result (cons #f #f)]
[new-table (cons (list obj result) table)]
@ -36,6 +38,26 @@
(deep-value-now (vector-ref obj i) table)))]
[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)
@ -90,20 +112,7 @@
(and (signal? v)
(if (undefined? (signal-value v))
undefined
(event-cons? (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 ...))))]))
(event-set? (signal-value v)))))
; switch : event[behavior] behavior -> behavior
(define switch
@ -132,30 +141,29 @@
; event ... -> event
(define (merge-e . args)
(apply event-processor
(lambda (emit)
(lambda (the-event)
(emit the-event)))
(apply lift #t (lambda args
(make-events-now
(apply append
(map event-set-events
(filter (lambda (es) (= (current-logical-time) (event-set-time es)))
args)))))
args))
(define (once-e e)
(let ([b #t])
(rec ret (event-processor
(lambda (emit)
(lambda (the-event)
(when b
(set! b false)
(unregister ret e)
(emit the-event))))
e))))
(map-e second (filter-e (lambda (p) (= 1 (first p)))
(collect-e e (list 0) (lambda (e p) (list (add1 (first p)) e))))))
; behavior[a] -> event[a]
(define (changes b)
(event-producer2
(lambda (emit)
(lambda the-args
(emit (deep-value-now b))))
b))
(lift #f (let ([first-time #t])
(lambda (bh)
(begin0
(make-events-now
(if first-time
empty
(list (deep-value-now bh))))
(set! first-time #f))))
b))
(define never-e
(changes #f))
@ -164,14 +172,15 @@
; when-e : behavior[bool] -> event
(define (when-e b)
(let* ([last (value-now b)])
(event-producer2
(lambda (emit)
(lambda the-args
(let ([current (value-now b)])
(when (and (not last) current)
(emit current))
(set! last current))))
b)))
(lift #t (lambda (bh)
(make-events-now
(let ([current bh])
(begin0
(if (and (not last) current)
(list current)
empty)
(set! last current)))))
b)))
; while-e : behavior[bool] behavior[number] -> event
(define (while-e b interval)
@ -187,20 +196,12 @@
; ==> : event[a] (a -> b) -> event[b]
(define (e . ==> . f)
(event-processor
(lambda (emit)
(lambda (the-event)
(emit ((value-now f) the-event))))
e))
#|
(define (e . =>! . f)
(event-processor
((value-now f) the-event)
(list e)))
|#
(lift #t (lambda (es)
(make-events-now
(if (= (current-logical-time) (event-set-time es))
(map f (event-set-events es))
empty)))
e))
; -=> : event[a] b -> event[b]
(define-syntax -=>
@ -209,24 +210,21 @@
; =#> : event[a] (a -> bool) -> event[a]
(define (e . =#> . p)
(event-processor
(lambda (emit)
(lambda (the-event)
(when (value-now (p the-event))
(emit the-event))))
e))
(lift #t (lambda (es)
(make-events-now
(if (= (current-logical-time) (event-set-time es))
(filter (value-now p) (map value-now (event-set-events es)))
empty)))
e))
; =#=> : event[a] (a -> b U nothing) -> event[b]
(define (e . =#=> . f)
(event-processor
(lambda (emit)
(lambda (the-event)
(let ([x (f the-event)])
(unless (or (nothing? x) (undefined? x))
(emit x)))))
e))
(lift #t (lambda (es)
(make-events-now
(if (= (current-logical-time) (event-set-time es))
(filter (compose not nothing?) (map f (event-set-events es)))
empty)))
e))
(define (map-e f e)
(==> e f))
@ -235,25 +233,38 @@
(define (filter-map-e f e)
(=#=> 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]
(define (collect-e e init trans)
(event-processor
(lambda (emit)
(lambda (the-event)
(let ([ret (trans the-event init)])
(set! init ret)
(emit ret))))
e))
(lift #t (lambda (es)
(make-events-now
(cond
[(= (current-logical-time) (event-set-time es))
(let ([all-events (scan trans init (event-set-events es))])
(when (cons? all-events)
(set! init (first (last-pair all-events))))
all-events)]
[else empty])))
e))
; event[(a -> a)] a -> event[a]
(define (accum-e e init)
(event-processor
(lambda (emit)
(lambda (the-event)
(let ([ret (the-event init)])
(set! init ret)
(emit ret))))
e))
(lift #t (lambda (es)
(make-events-now
(cond
[(= (current-logical-time) (event-set-time es))
(let ([all-events (scan (lambda (t a) (t a)) init (event-set-events es))])
(when (cons? all-events)
(set! init (first (last-pair all-events))))
all-events)]
[else empty])))
e))
; event[a] b (a b -> b) -> behavior[b]
(define (collect-b ev init trans)
@ -267,14 +278,12 @@
(define hold
(opt-lambda (e [init undefined])
(let ([val init])
(let* ([updator (event-processor
(lambda (emit)
(lambda (the-event)
(set! val the-event)
(emit the-event)))
e)]
[rtn (proc->signal (lambda () updator val) updator)])
rtn))))
(lift #t (lambda (es) (let ([events (event-set-events es)])
(when (and (= (current-logical-time) (event-set-time es))
(cons? events))
(set! val (first (last-pair (event-set-events es)))))
val))
e))))
(define-syntax snapshot/sync
(syntax-rules ()
@ -298,11 +307,14 @@
expr ...)]))
(define (snapshot-e e . bs)
(event-processor
(lambda (emit)
(lambda (the-event)
(emit (cons the-event (map value-now bs)))))
e))
(apply lift #t (lambda (es . bs)
(make-events-now
(cond
[(= (current-logical-time) (event-set-time es))
(map (lambda (the-event) (cons the-event (map value-now bs)))
(event-set-events es))]
[else empty])))
e bs))
(define (snapshot/apply fn . args)
(apply fn (map value-now args)))
@ -317,26 +329,6 @@
(send obj meth (value-now 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)
(let ([ret (proc->signal void)])
(set-signal-thunk! ret
@ -374,7 +366,10 @@
(let loop ()
(if (or (empty? (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
(set! head (mcdr head))
(loop)))))))]
@ -495,27 +490,7 @@
[(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)
; proc : (lambda (emit suspend first-evt) ...)
(let* ([out (econs undefined undefined)]
@ -572,6 +547,7 @@
(define (flush . strs)
(select-proc (map (lambda (str) (list str void)) strs)))
#;
(define (general-event-processor2 proc)
(do-in-manager
(let* ([out (econs undefined undefined)]
@ -641,26 +617,6 @@
(mcons (first lst) (make-mutable (rest 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])
(define (split ev fn)
(let* ([ht (make-hash-table 'weak)]
@ -817,11 +773,10 @@
(provide raise-exceptions
nothing
nothing?
general-event-processor
general-event-processor2
;general-event-processor
;general-event-processor2
emit
select
event-processor
switch
merge-e
once-e
@ -847,7 +802,6 @@
snapshot
snapshot-e
snapshot/apply
magic
milliseconds
fine-timer-granularity
seconds