From 0940e7790d3945f173ad7dd6f02d7702490f381a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 26 Jun 2009 21:28:41 +0000 Subject: [PATCH] Converting to scheme/base svn: r15312 --- collects/frtime/lang-ext.ss | 1704 +++++++++++++++++------------------ 1 file changed, 845 insertions(+), 859 deletions(-) diff --git a/collects/frtime/lang-ext.ss b/collects/frtime/lang-ext.ss index 99103b89f0..0f1416c083 100644 --- a/collects/frtime/lang-ext.ss +++ b/collects/frtime/lang-ext.ss @@ -1,66 +1,68 @@ -(module lang-ext mzscheme - (require frtime/core/frp - mzlib/etc - mzlib/list) +#lang scheme/base +(require frtime/core/frp + scheme/bool + scheme/list + (only-in mzlib/etc + rec identity) + (for-syntax scheme/list + scheme/base)) - (require-for-syntax mzlib/list) - - (define nothing (void));(string->uninterned-symbol "nothing")) - - (define (nothing? v) (eq? v nothing)) - - (define-syntax define-reactive - (syntax-rules () - [(_ name expr) - (define name - (let ([val (parameterize ([snap? #f]) - expr)]) - (lambda () (deep-value-now val empty))))])) - - (define (deep-value-now obj table) - (cond - [(assq obj table) => second] - [(behavior? obj) - (deep-value-now (signal-value obj) (cons (list obj (signal-value obj)) table))] - [(cons? obj) - (let* ([result (cons #f #f)] - [new-table (cons (list obj result) table)] - [car-val (deep-value-now (car obj) new-table)] - [cdr-val (deep-value-now (cdr obj) new-table)]) - (if (and (eq? car-val (car obj)) - (eq? cdr-val (cdr obj))) - obj - (cons car-val cdr-val)))] - ; won't work in the presence of super structs or immutable fields - [(struct? obj) - (let*-values ([(info skipped) (struct-info obj)] - [(name init-k auto-k acc mut! immut sup skipped?) (struct-type-info info)] - [(ctor) (struct-type-make-constructor info)] - [(indices) (build-list init-k identity)] - [(result) (apply ctor (build-list init-k (lambda (i) #f)))] - [(new-table) (cons (list obj result) table)] - [(elts) (build-list init-k (lambda (i) - (deep-value-now (acc obj i) new-table)))]) - (if (andmap (lambda (i e) (eq? (acc obj i) e)) indices elts) - obj - (begin - (for-each (lambda (i e) (mut! result i e)) indices elts) - result)))] - [(vector? obj) - (let* ([len (vector-length obj)] - [indices (build-list len identity)] - [result (build-vector len (lambda (_) #f))] - [new-table (cons (list obj result) table)] - [elts (build-list len (lambda (i) - (deep-value-now (vector-ref obj i) new-table)))]) - (if (andmap (lambda (i e) (eq? (vector-ref obj i) e)) indices elts) - obj - (begin - (for-each (lambda (i e) (vector-set! result i e)) indices elts) - result)))] - [else obj])) +(define nothing (void));(string->uninterned-symbol "nothing")) - #;(define deep-value-now +(define (nothing? v) (eq? v nothing)) + +(define-syntax define-reactive + (syntax-rules () + [(_ name expr) + (define name + (let ([val (parameterize ([snap? #f]) + expr)]) + (lambda () (deep-value-now val empty))))])) + +(define (deep-value-now obj table) + (cond + [(assq obj table) => second] + [(behavior? obj) + (deep-value-now (signal-value obj) (cons (list obj (signal-value obj)) table))] + [(cons? obj) + (let* ([result (cons #f #f)] + [new-table (cons (list obj result) table)] + [car-val (deep-value-now (car obj) new-table)] + [cdr-val (deep-value-now (cdr obj) new-table)]) + (if (and (eq? car-val (car obj)) + (eq? cdr-val (cdr obj))) + obj + (cons car-val cdr-val)))] + ; won't work in the presence of super structs or immutable fields + [(struct? obj) + (let*-values ([(info skipped) (struct-info obj)] + [(name init-k auto-k acc mut! immut sup skipped?) (struct-type-info info)] + [(ctor) (struct-type-make-constructor info)] + [(indices) (build-list init-k identity)] + [(result) (apply ctor (build-list init-k (lambda (i) #f)))] + [(new-table) (cons (list obj result) table)] + [(elts) (build-list init-k (lambda (i) + (deep-value-now (acc obj i) new-table)))]) + (if (andmap (lambda (i e) (eq? (acc obj i) e)) indices elts) + obj + (begin + (for-each (lambda (i e) (mut! result i e)) indices elts) + result)))] + [(vector? obj) + (let* ([len (vector-length obj)] + [indices (build-list len identity)] + [result (build-vector len (lambda (_) #f))] + [new-table (cons (list obj result) table)] + [elts (build-list len (lambda (i) + (deep-value-now (vector-ref obj i) new-table)))]) + (if (andmap (lambda (i e) (eq? (vector-ref obj i) e)) indices elts) + obj + (begin + (for-each (lambda (i e) (vector-set! result i e)) indices elts) + result)))] + [else obj])) + +#;(define deep-value-now (case-lambda [(obj) (deep-value-now obj empty)] [(obj table) @@ -88,814 +90,798 @@ (lambda (i) (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 args)) - (with-continuation-mark - 'frtime 'lift-active - (cond - [(ormap signal? args) - (apply - proc->signal - (apply (if strict? create-strict-thunk create-thunk) fn args) - args)] - [(and strict? (ormap undefined? args)) undefined] - [else (apply fn args)])))) - - (define (lift-strict . args) - (apply lift #t args)) - - - - ; new-cell : behavior[a] -> behavior[a] (cell) - (define new-cell - (opt-lambda ([init undefined]) - (switch (event-receiver) init))) - - - (define (b1 . until . b2) - (proc->signal - (lambda () (if (undefined? (value-now b2)) - (value-now b1) - (value-now b2))) - ; deps - b1 b2)) - - (define-syntax (event-loop-help stx) - (syntax-case stx () - [(_ ([name expr] ...) - [e => body] ...) - (with-syntax ([args #'(name ...)]) - #'(accum-e - (merge-e - (e . ==> . (lambda (v) - (lambda (state) - (apply - (lambda args (body v)) - state)))) ...) - (list expr ...)))])) - - (define-syntax (event-loop stx) - - (define (add-arrow clause) - (syntax-case clause (=>) - [(e => body) #'(e => body)] - [(e body) #'(e => (lambda (_) body))])) - - (syntax-case stx () - [(_ ([name expr] ...) - clause ...) - (with-syntax ([(new-clause ...) - (map add-arrow (syntax->list #'(clause ...)))]) - #'(event-loop-help - ([name expr] ...) - new-clause ...) - )])) - - - (define undefined?/lifted (lambda (arg) (lift false undefined? arg))) - - (define (event? v) - (and (signal? v) - (if (undefined? (signal-value v)) - undefined - (event-set? (signal-value v))))) - - ; switch : event[behavior] behavior -> behavior - (define switch - (opt-lambda (e [init undefined]) - (let* ([init (box init)] - [e-b (hold e (unbox init) #t)] - [ret (proc->signal:switching - (case-lambda [() (value-now (unbox init))] - [(msg) e]) - init e-b e-b (unbox init))]) - (set-signal-thunk! - ret - (case-lambda - [() - (when (not (eq? (unbox init) (signal-value e-b))) - (unregister ret (unbox init)) - (set-box! init (value-now e-b)) - (register ret (unbox init)) - (set-signal-producers! ret (list e-b (unbox init))) - (set-signal-depth! ret (max (signal-depth ret) - (add1 (safe-signal-depth (unbox init))))) - (iq-resort)) - (value-now/no-copy (unbox init))] - [(msg) e])) - ret))) - - ; event ... -> event - (define (merge-e . args) - (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) - (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) - (lift #f (let ([first-time #t]) - (lambda (bh) - (begin0 - (make-events-now - (if first-time - empty - (list (deep-value-now bh empty)))) - (set! first-time #f)))) - b)) - - (define never-e - (changes #f)) - - - ; when-e : behavior[bool] -> event - (define (when-e b) - (let* ([last (value-now 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) - (rec ret (event-producer2 - (lambda (emit) - (lambda the-args - (cond - [(value-now b) => - (lambda (v) - (emit v) - (schedule-alarm (+ (value-now interval) (current-inexact-milliseconds)) ret))]))) - b))) - - ; ==> : event[a] (a -> b) -> event[b] - (define (e . ==> . f) - (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 -=> - (syntax-rules () - [(_ e k-e) (==> e (lambda (_) k-e))])) - - ; =#> : event[a] (a -> bool) -> event[a] - (define (e . =#> . p) - (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) - (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)) - (define (filter-e p e) - (=#> e p)) - (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) - (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) - (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) - (hold (collect-e ev init trans) init)) - - ; event[(a -> a)] a -> behavior[a] - (define (accum-b ev init) - (hold (accum-e ev init) init)) - - ; hold : a event[a] -> behavior[a] - (define hold - (opt-lambda (e [init undefined] [allow-behaviors? #f]) - (let ([val init] - [warn-about-behaviors? #t]) - (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))))) - (when (and (behavior? val) (not allow-behaviors?)) - (set! val (value-now val)) - (when warn-about-behaviors? - (thread - (lambda () - (error "hold: input event had a behavior; snapshotting to prevent nested behavior"))) - (set! warn-about-behaviors? #f))) - val)) - e)))) - - (define-syntax snapshot/sync - (syntax-rules () - [(_ (id ...) expr ...) - (let-values ([(id ...) (value-now/sync id ...)]) - expr ...)])) - - (define (synchronize) - (snapshot/sync () (void))) - - (define-syntax snapshot - (syntax-rules () - [(_ (id ...) expr ...) - (let ([id (value-now id)] ...) - expr ...)])) - - (define-syntax snapshot-all - (syntax-rules () - [(_ expr ...) - (parameterize ([snap? #t]) - expr ...)])) - - (define (snapshot-e e . bs) - (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))) - - - ;; Deprecated - (define-syntax frp:send - (syntax-rules () - [(_ obj meth arg ...) - (if (snap?) - (send obj meth (value-now arg) ...) - (send obj meth arg ...))])) +(define (lift strict? fn . args) + (if (snap?) ;; maybe fix later to handle undefined-strictness + (apply fn (map value-now args)) + (with-continuation-mark + 'frtime 'lift-active + (cond + [(ormap signal? args) + (apply + proc->signal + (apply (if strict? create-strict-thunk create-thunk) fn args) + args)] + [(and strict? (ormap undefined? args)) undefined] + [else (apply fn args)])))) + +(define (lift-strict . args) + (apply lift #t args)) + +; new-cell : behavior[a] -> behavior[a] (cell) +(define new-cell + (lambda ([init undefined]) + (switch (event-receiver) init))) + +(define (b1 . until . b2) + (proc->signal + (lambda () (if (undefined? (value-now b2)) + (value-now b1) + (value-now b2))) + ; deps + b1 b2)) + +(define-syntax (event-loop-help stx) + (syntax-case stx () + [(_ ([name expr] ...) + [e => body] ...) + (with-syntax ([args #'(name ...)]) + #'(accum-e + (merge-e + (e . ==> . (lambda (v) + (lambda (state) + (apply + (lambda args (body v)) + state)))) ...) + (list expr ...)))])) + +(define-syntax (event-loop stx) - (define (make-time-b ms) - (let ([ret (proc->signal void)]) - (set-signal-thunk! ret - (lambda () - (let ([t (current-inexact-milliseconds)]) - (schedule-alarm (+ (value-now ms) t) ret) - t))) - (set-signal-value! ret ((signal-thunk ret))) - ret)) + (define (add-arrow clause) + (syntax-case clause (=>) + [(e => body) #'(e => body)] + [(e body) #'(e => (lambda (_) body))])) - (define seconds - (let ([ret (proc->signal void)]) - (set-signal-thunk! ret - (lambda () - (let ([s (current-seconds)] - [t (current-inexact-milliseconds)]) - (schedule-alarm (* 1000 (add1 (floor (/ t 1000)))) ret) - s))) - (set-signal-value! ret ((signal-thunk ret))) - ret)) - - ; general efficiency fix for delay - ; signal[a] signal[num] -> signal[a] - (define (delay-by beh ms-b) - (letrec ([last (mcons (cons (if (zero? (value-now ms-b)) - (value-now/no-copy beh) - undefined) - (current-inexact-milliseconds)) - empty)] - [head last] - [producer (proc->signal - (lambda () - (let* ([now (and (signal? consumer) (current-inexact-milliseconds))] - [ms (value-now ms-b)]) - (let loop () - (if (or (empty? (mcdr head)) - (< now (+ ms (cdr (mcar (mcdr head)))))) - (let ([val (car (mcar head))]) - (if (event-set? val) - (make-events-now (event-set-events val)) - val)) - (begin - (set! head (mcdr head)) - (loop)))))))] - [consumer (proc->signal - (lambda () - (let* ([now (current-inexact-milliseconds)] - [new (deep-value-now beh empty)] - [ms (value-now ms-b)]) - (when (not (equal? new (car (mcar last)))) - (set-mcdr! last (mcons (cons new now) - empty)) - (set! last (mcdr last)) - (schedule-alarm (+ now ms) producer)))) - beh ms-b)]) - producer)) - - (define (inf-delay beh) - (delay-by beh 0)) - - ; fix to take arbitrary monotonically increasing number - ; (instead of milliseconds) - ; integral : signal[num] signal[num] -> signal[num] - (define integral - (opt-lambda (b [ms-b 20]) - (letrec ([accum 0] - [last-time (current-inexact-milliseconds)] - [last-val (value-now b)] - [last-alarm 0] - [producer (proc->signal (lambda () (and (signal? consumer) accum)))] - [consumer (proc->signal void b ms-b)]) - (set-signal-thunk! - consumer - (lambda () - (let ([now (current-inexact-milliseconds)]) - (if (> now (+ last-time 20)) - (begin - (when (not (number? last-val)) - (set! last-val 0)) - (set! accum (+ accum - (* last-val - (- now last-time)))) - (set! last-time now) - (set! last-val (value-now b)) - (when (value-now ms-b) - (schedule-alarm (+ last-time (value-now ms-b)) - consumer))) - (when (or (>= now last-alarm) - (and (< now 0) - (>= last-alarm 0))) - (set! last-alarm (+ now 20)) - (schedule-alarm last-alarm consumer))) - (schedule-alarm now producer)))) - ((signal-thunk consumer)) - producer))) - - ; fix for accuracy - ; derivative : signal[num] -> signal[num] - (define (derivative b) - (let* ([last-value (value-now b)] - [last-time (current-inexact-milliseconds)] - [thunk (lambda () - (let* ([new-value (value-now b)] - [new-time (current-inexact-milliseconds)] - [result (if (or (= new-value last-value) - (= new-time last-time) - (> new-time - (+ 500 last-time)) - (not (number? last-value)) - (not (number? new-value))) - 0 - (/ (- new-value last-value) - (- new-time last-time)))]) - (set! last-value new-value) - (set! last-time new-time) - result))]) - (proc->signal thunk b))) - - - - (define create-strict-thunk - (case-lambda - [(fn) fn] - [(fn arg1) (lambda () - (let ([a1 (value-now/no-copy arg1)]) - (if (undefined? a1) + (syntax-case stx () + [(_ ([name expr] ...) + clause ...) + (with-syntax ([(new-clause ...) + (map add-arrow (syntax->list #'(clause ...)))]) + #'(event-loop-help + ([name expr] ...) + new-clause ...) + )])) + +(define undefined?/lifted (lambda (arg) (lift false undefined? arg))) + +(define (event? v) + (and (signal? v) + (if (undefined? (signal-value v)) + undefined + (event-set? (signal-value v))))) + +; switch : event[behavior] behavior -> behavior +(define switch + (lambda (e [init undefined]) + (let* ([init (box init)] + [e-b (hold e (unbox init) #t)] + [ret (proc->signal:switching + (case-lambda [() (value-now (unbox init))] + [(msg) e]) + init e-b e-b (unbox init))]) + (set-signal-thunk! + ret + (case-lambda + [() + (when (not (eq? (unbox init) (signal-value e-b))) + (unregister ret (unbox init)) + (set-box! init (value-now e-b)) + (register ret (unbox init)) + (set-signal-producers! ret (list e-b (unbox init))) + (set-signal-depth! ret (max (signal-depth ret) + (add1 (safe-signal-depth (unbox init))))) + (iq-resort)) + (value-now/no-copy (unbox init))] + [(msg) e])) + ret))) + +; event ... -> event +(define (merge-e . args) + (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) + (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) + (lift #f (let ([first-time #t]) + (lambda (bh) + (begin0 + (make-events-now + (if first-time + empty + (list (deep-value-now bh empty)))) + (set! first-time #f)))) + b)) + +(define never-e + (changes #f)) + +; when-e : behavior[bool] -> event +(define (when-e b) + (let* ([last (value-now 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) + (rec ret (event-producer2 + (lambda (emit) + (lambda the-args + (cond + [(value-now b) => + (lambda (v) + (emit v) + (schedule-alarm (+ (value-now interval) (current-inexact-milliseconds)) ret))]))) + b))) + +; ==> : event[a] (a -> b) -> event[b] +(define (e . ==> . f) + (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 -=> + (syntax-rules () + [(_ e k-e) (==> e (lambda (_) k-e))])) + +; =#> : event[a] (a -> bool) -> event[a] +(define (e . =#> . p) + (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) + (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)) +(define (filter-e p e) + (=#> e p)) +(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) + (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) + (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) + (hold (collect-e ev init trans) init)) + +; event[(a -> a)] a -> behavior[a] +(define (accum-b ev init) + (hold (accum-e ev init) init)) + +; hold : a event[a] -> behavior[a] +(define hold + (lambda (e [init undefined] [allow-behaviors? #f]) + (let ([val init] + [warn-about-behaviors? #t]) + (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))))) + (when (and (behavior? val) (not allow-behaviors?)) + (set! val (value-now val)) + (when warn-about-behaviors? + (thread + (lambda () + (error "hold: input event had a behavior; snapshotting to prevent nested behavior"))) + (set! warn-about-behaviors? #f))) + val)) + e)))) + +(define-syntax snapshot/sync + (syntax-rules () + [(_ (id ...) expr ...) + (let-values ([(id ...) (value-now/sync id ...)]) + expr ...)])) + +(define (synchronize) + (snapshot/sync () (void))) + +(define-syntax snapshot + (syntax-rules () + [(_ (id ...) expr ...) + (let ([id (value-now id)] ...) + expr ...)])) + +(define-syntax snapshot-all + (syntax-rules () + [(_ expr ...) + (parameterize ([snap? #t]) + expr ...)])) + +(define (snapshot-e e . bs) + (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))) + +;; Deprecated +(define-syntax frp:send + (syntax-rules () + [(_ obj meth arg ...) + (if (snap?) + (send obj meth (value-now arg) ...) + (send obj meth arg ...))])) + +(define (make-time-b ms) + (let ([ret (proc->signal void)]) + (set-signal-thunk! ret + (lambda () + (let ([t (current-inexact-milliseconds)]) + (schedule-alarm (+ (value-now ms) t) ret) + t))) + (set-signal-value! ret ((signal-thunk ret))) + ret)) + +(define seconds + (let ([ret (proc->signal void)]) + (set-signal-thunk! ret + (lambda () + (let ([s (current-seconds)] + [t (current-inexact-milliseconds)]) + (schedule-alarm (* 1000 (add1 (floor (/ t 1000)))) ret) + s))) + (set-signal-value! ret ((signal-thunk ret))) + ret)) + +; XXX general efficiency fix for delay +; signal[a] signal[num] -> signal[a] +(define (delay-by beh ms-b) + (letrec ([last (mcons (cons (if (zero? (value-now ms-b)) + (value-now/no-copy beh) + undefined) + (current-inexact-milliseconds)) + empty)] + [head last] + [producer (proc->signal + (lambda () + (let* ([now (and (signal? consumer) (current-inexact-milliseconds))] + [ms (value-now ms-b)]) + (let loop () + (if (or (empty? (mcdr head)) + (< now (+ ms (cdr (mcar (mcdr head)))))) + (let ([val (car (mcar head))]) + (if (event-set? val) + (make-events-now (event-set-events val)) + val)) + (begin + (set! head (mcdr head)) + (loop)))))))] + [consumer (proc->signal + (lambda () + (let* ([now (current-inexact-milliseconds)] + [new (deep-value-now beh empty)] + [ms (value-now ms-b)]) + (when (not (equal? new (car (mcar last)))) + (set-mcdr! last (mcons (cons new now) + empty)) + (set! last (mcdr last)) + (schedule-alarm (+ now ms) producer)))) + beh ms-b)]) + producer)) + +(define (inf-delay beh) + (delay-by beh 0)) + +; XXX fix to take arbitrary monotonically increasing number +; (instead of milliseconds) +; integral : signal[num] signal[num] -> signal[num] +(define integral + (lambda (b [ms-b 20]) + (letrec ([accum 0] + [last-time (current-inexact-milliseconds)] + [last-val (value-now b)] + [last-alarm 0] + [producer (proc->signal (lambda () (and (signal? consumer) accum)))] + [consumer (proc->signal void b ms-b)]) + (set-signal-thunk! + consumer + (lambda () + (let ([now (current-inexact-milliseconds)]) + (if (> now (+ last-time 20)) + (begin + (when (not (number? last-val)) + (set! last-val 0)) + (set! accum (+ accum + (* last-val + (- now last-time)))) + (set! last-time now) + (set! last-val (value-now b)) + (when (value-now ms-b) + (schedule-alarm (+ last-time (value-now ms-b)) + consumer))) + (when (or (>= now last-alarm) + (and (< now 0) + (>= last-alarm 0))) + (set! last-alarm (+ now 20)) + (schedule-alarm last-alarm consumer))) + (schedule-alarm now producer)))) + ((signal-thunk consumer)) + producer))) + +; XXX fix for accuracy +; derivative : signal[num] -> signal[num] +(define (derivative b) + (let* ([last-value (value-now b)] + [last-time (current-inexact-milliseconds)] + [thunk (lambda () + (let* ([new-value (value-now b)] + [new-time (current-inexact-milliseconds)] + [result (if (or (= new-value last-value) + (= new-time last-time) + (> new-time + (+ 500 last-time)) + (not (number? last-value)) + (not (number? new-value))) + 0 + (/ (- new-value last-value) + (- new-time last-time)))]) + (set! last-value new-value) + (set! last-time new-time) + result))]) + (proc->signal thunk b))) + +(define create-strict-thunk + (case-lambda + [(fn) fn] + [(fn arg1) (lambda () + (let ([a1 (value-now/no-copy arg1)]) + (if (undefined? a1) + undefined + (fn a1))))] + [(fn arg1 arg2) (lambda () + (let ([a1 (value-now/no-copy arg1)] + [a2 (value-now/no-copy arg2)]) + (if (or (undefined? a1) + (undefined? a2)) + undefined + (fn a1 a2))))] + [(fn arg1 arg2 arg3) (lambda () + (let ([a1 (value-now/no-copy arg1)] + [a2 (value-now/no-copy arg2)] + [a3 (value-now/no-copy arg3)]) + (if (or (undefined? a1) + (undefined? a2) + (undefined? a3)) + undefined + (fn a1 a2 a3))))] + [(fn . args) (lambda () + (let ([as (map value-now/no-copy args)]) + (if (ormap undefined? as) undefined - (fn a1))))] - [(fn arg1 arg2) (lambda () - (let ([a1 (value-now/no-copy arg1)] - [a2 (value-now/no-copy arg2)]) - (if (or (undefined? a1) - (undefined? a2)) - undefined - (fn a1 a2))))] - [(fn arg1 arg2 arg3) (lambda () - (let ([a1 (value-now/no-copy arg1)] - [a2 (value-now/no-copy arg2)] - [a3 (value-now/no-copy arg3)]) - (if (or (undefined? a1) - (undefined? a2) - (undefined? a3)) - undefined - (fn a1 a2 a3))))] - [(fn . args) (lambda () - (let ([as (map value-now/no-copy args)]) - (if (ormap undefined? as) - undefined - (apply fn as))))])) - - (define create-thunk - (case-lambda - [(fn) fn] - [(fn arg1) (lambda () (fn (value-now/no-copy arg1)))] - [(fn arg1 arg2) (lambda () (fn (value-now/no-copy arg1) (value-now/no-copy arg2)))] - [(fn arg1 arg2 arg3) (lambda () (fn (value-now/no-copy arg1) - (value-now/no-copy arg2) - (value-now/no-copy arg3)))] - [(fn . args) (lambda () (apply fn (map value-now/no-copy args)))])) - - - #; - (define (general-event-processor proc . args) - ; proc : (lambda (emit suspend first-evt) ...) - (let* ([out (econs undefined undefined)] - [esc #f] - [emit (lambda (val) - (set-erest! out (econs val undefined)) - (set! out (erest out)) - val)] - [streams (map signal-value args)]) - (letrec ([suspend (lambda () - (call/cc - (lambda (k) - (set! proc-k k) - (esc (void)))))] - [proc-k (lambda (evt) (proc emit suspend evt) (set! proc-k #f))]) - (let ([thunk (lambda () - (when (ormap undefined? streams) - ;(fprintf (current-error-port) "had an undefined stream~n") - (set! streams (fix-streams streams args))) - (let loop ([streams streams]) - (extract (lambda (the-event strs) - (when proc-k - (call/cc - (lambda (k) - (set! esc k) - (proc-k the-event)))) (loop strs)) - streams)) - (set! streams (map signal-value args)) - out)]) - (apply proc->signal thunk args))))) - - (define current-emit (make-parameter #f)) - (define current-select (make-parameter #f)) - (define (emit ev) - (cond - [(current-emit) => (lambda (f) (f ev))] - [else (error 'emit "outside of general-event-processor")])) - (define (select-proc . clauses) - (cond - [(current-select) => (lambda (f) (apply f clauses))] - [else (error 'select "outside of general-event-processor")])) - - (define-syntax (select stx) - (syntax-case stx () - [(select clause ...) - (with-syntax ([((e k) ...) - (map (lambda (c) - (syntax-case c (=>) - [(e => k) #'(e k)] - [(e exp0 exp1 ...) #'(e (lambda (_) exp0 exp1 ...))])) - (syntax-e #'(clause ...)))]) - #'(select-proc (list e k) ...))])) - - (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)] - [emit (lambda (val) - (set-erest! out (econs val undefined)) - (set! out (erest out)) - val)] - [streams (make-hash-table 'weak)] - [extracted (make-hash-table 'weak)] - [top-esc #f] - [rtn (proc->signal void)] - [select (lambda e/k-list - (let/ec esc - (let loop () - (for-each (lambda (e/k) - (let* ([e (first e/k)] - [x (hash-table-get - extracted e - (lambda () empty))]) - (when (cons? x) - (hash-table-put! - extracted e (rest x)) - (esc ((second e/k) (first x)))))) - e/k-list) - (for-each (lambda (e/k) - (let* ([e (first e/k)]) - (hash-table-get - streams e - (lambda () - (register rtn e) - (hash-table-put! - streams e - (signal-value e)))))) - e/k-list) - (let/cc k - (set! proc (lambda () (k (void)))) - (top-esc (void))) - (loop))))]) - (let ([thunk (lambda () - (hash-table-for-each - streams - (lambda (k v) - ;; inefficient! appends each new event individually - (let loop ([str v]) - (when (and (econs? str) - (not (undefined? (erest str)))) - (hash-table-put! - extracted k - (append (hash-table-get extracted k (lambda () empty)) - (list (efirst (erest str))))) - (loop (erest str)))) - (hash-table-put! streams k (signal-value k)))) - (let/cc k - (set! top-esc k) - (parameterize ([current-emit emit] - [current-select select]) - (proc))) - out)]) - (set-signal-thunk! rtn thunk) - (iq-enqueue rtn) - rtn)))) - - (define (make-mutable lst) - (printf "make-mutable called on ~a~n" lst) - lst - #;(if (pair? lst) + (apply fn as))))])) + +(define create-thunk + (case-lambda + [(fn) fn] + [(fn arg1) (lambda () (fn (value-now/no-copy arg1)))] + [(fn arg1 arg2) (lambda () (fn (value-now/no-copy arg1) (value-now/no-copy arg2)))] + [(fn arg1 arg2 arg3) (lambda () (fn (value-now/no-copy arg1) + (value-now/no-copy arg2) + (value-now/no-copy arg3)))] + [(fn . args) (lambda () (apply fn (map value-now/no-copy args)))])) + +#; +(define (general-event-processor proc . args) + ; proc : (lambda (emit suspend first-evt) ...) + (let* ([out (econs undefined undefined)] + [esc #f] + [emit (lambda (val) + (set-erest! out (econs val undefined)) + (set! out (erest out)) + val)] + [streams (map signal-value args)]) + (letrec ([suspend (lambda () + (call/cc + (lambda (k) + (set! proc-k k) + (esc (void)))))] + [proc-k (lambda (evt) (proc emit suspend evt) (set! proc-k #f))]) + (let ([thunk (lambda () + (when (ormap undefined? streams) + ;(fprintf (current-error-port) "had an undefined stream~n") + (set! streams (fix-streams streams args))) + (let loop ([streams streams]) + (extract (lambda (the-event strs) + (when proc-k + (call/cc + (lambda (k) + (set! esc k) + (proc-k the-event)))) (loop strs)) + streams)) + (set! streams (map signal-value args)) + out)]) + (apply proc->signal thunk args))))) + +(define current-emit (make-parameter #f)) +(define current-select (make-parameter #f)) +(define (emit ev) + (cond + [(current-emit) => (lambda (f) (f ev))] + [else (error 'emit "outside of general-event-processor")])) +(define (select-proc . clauses) + (cond + [(current-select) => (lambda (f) (apply f clauses))] + [else (error 'select "outside of general-event-processor")])) + +(define-syntax (select stx) + (syntax-case stx () + [(select clause ...) + (with-syntax ([((e k) ...) + (map (lambda (c) + (syntax-case c (=>) + [(e => k) #'(e k)] + [(e exp0 exp1 ...) #'(e (lambda (_) exp0 exp1 ...))])) + (syntax-e #'(clause ...)))]) + #'(select-proc (list e k) ...))])) + +(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)] + [emit (lambda (val) + (set-erest! out (econs val undefined)) + (set! out (erest out)) + val)] + [streams (make-weak-hash)] + [extracted (make-weak-hash)] + [top-esc #f] + [rtn (proc->signal void)] + [select (lambda e/k-list + (let/ec esc + (let loop () + (for-each (lambda (e/k) + (let* ([e (first e/k)] + [x (hash-ref + extracted e + (lambda () empty))]) + (when (cons? x) + (hash-set! + extracted e (rest x)) + (esc ((second e/k) (first x)))))) + e/k-list) + (for-each (lambda (e/k) + (let* ([e (first e/k)]) + (hash-ref + streams e + (lambda () + (register rtn e) + (hash-set! + streams e + (signal-value e)))))) + e/k-list) + (let/cc k + (set! proc (lambda () (k (void)))) + (top-esc (void))) + (loop))))]) + (let ([thunk (lambda () + (hash-for-each + streams + (lambda (k v) + ;; inefficient! appends each new event individually + (let loop ([str v]) + (when (and (econs? str) + (not (undefined? (erest str)))) + (hash-set! + extracted k + (append (hash-ref extracted k (lambda () empty)) + (list (efirst (erest str))))) + (loop (erest str)))) + (hash-set! streams k (signal-value k)))) + (let/cc k + (set! top-esc k) + (parameterize ([current-emit emit] + [current-select select]) + (proc))) + out)]) + (set-signal-thunk! rtn thunk) + (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)) - - ;; split : event[a] (a -> b) -> (b -> event[a]) - (define (split ev fn) - (let* ([ht (make-hash-table 'weak)] - [sig (for-each-e! - ev - (lambda (e) - (let/ec k - (send-event - (hash-table-get ht (fn e) (lambda () (k (void)))) - e))) - ht)]) - (lambda (x) - sig - (hash-table-get - ht x (lambda () - (let ([rtn (event-receiver)]) - (hash-table-put! ht x rtn) - rtn)))))) + +;; split : event[a] (a -> b) -> (b -> event[a]) +(define (split ev fn) + (let* ([ht (make-weak-hash)] + [sig (for-each-e! + ev + (lambda (e) + (let/ec k + (send-event + (hash-ref ht (fn e) (lambda () (k (void)))) + e))) + ht)]) + (lambda (x) + sig + (hash-ref + ht x (lambda () + (let ([rtn (event-receiver)]) + (hash-set! ht x rtn) + rtn)))))) + +(define-syntax event-select + (syntax-rules () + [(_ [ev k] ...) + ()])) + +(define fine-timer-granularity (new-cell 20)) + +(define milliseconds (make-time-b fine-timer-granularity)) +(define time-b milliseconds) + +;;;;;;;;;;;;;;;;;;;;;; +;; Command Lambda + +(define-syntax mk-command-lambda + (syntax-rules () + [(_ (free ...) forms body ...) + (if (ormap behavior? (list free ...)) + (procs->signal:compound + (lambda x (lambda forms + (snapshot (free ...) body ...))) + (lambda (a b) void) + free ...) + (lambda forms body ...))])) + +(define-syntax (command-lambda stx) - (define-syntax event-select - (syntax-rules () - [(_ [ev k] ...) - ()])) - - (define fine-timer-granularity (new-cell 20)) - - (define milliseconds (make-time-b fine-timer-granularity)) - (define time-b milliseconds) - - ;;;;;;;;;;;;;;;;;;;;;; - ;; Command Lambda - - - (define-syntax mk-command-lambda - (syntax-rules () - [(_ (free ...) forms body ...) - (if (ormap behavior? (list free ...)) - (procs->signal:compound - (lambda x (lambda forms - (snapshot (free ...) body ...))) - (lambda (a b) void) - free ...) - (lambda forms body ...))])) - - (define-syntax (command-lambda stx) - - (define (arglist-bindings arglist-stx) - (syntax-case arglist-stx () - [var - (identifier? arglist-stx) - (list arglist-stx)] - [(var ...) + (define (arglist-bindings arglist-stx) + (syntax-case arglist-stx () + [var + (identifier? arglist-stx) + (list arglist-stx)] + [(var ...) (syntax->list arglist-stx)] - [(var . others) - (cons #'var (arglist-bindings #'others))])) - - - (define (make-snapshot-unbound insp unbound-ids) - (lambda (expr bound-ids) - (let snapshot-unbound ([expr expr] [bound-ids bound-ids]) - (syntax-recertify - (syntax-case expr (#%datum - quote - #%top - let-values - letrec-values - lambda) - [x (identifier? #'x) (if (or - (syntax-property #'x 'protected) - (ormap (lambda (id) - (bound-identifier=? id #'x)) bound-ids)) - #'x - (begin - (hash-table-put! unbound-ids #'x #t) - #'(#%app value-now x)))] - [(#%datum . val) expr] - [(quote . _) expr] - [(#%top . var) (begin - (hash-table-put! unbound-ids #'var #t) - #`(#%app value-now #,expr))] ; FIX - - [(letrec-values (((variable ...) in-e) ...) body-e ...) - (let ([new-bound-ids (append (syntax->list #'(variable ... ...)) bound-ids)]) - (with-syntax ([(new-in-e ...) (map (lambda (exp) - (snapshot-unbound exp new-bound-ids)) - (syntax->list #'(in-e ...)))] - [(new-body-e ...) (map (lambda (exp) - (snapshot-unbound exp new-bound-ids)) - (syntax->list #'(body-e ...)))]) - #'(letrec-values (((variable ...) new-in-e) ...) new-body-e ...)))] - [(let-values (((variable ...) in-e) ...) body-e ...) - (let ([new-bound-ids (append (syntax->list #'(variable ... ...)) bound-ids)]) - (with-syntax ([(new-in-e ...) (map (lambda (exp) - (snapshot-unbound exp bound-ids)) - (syntax->list #'(in-e ...)))] - [(new-body-e ...) (map (lambda (exp) - (snapshot-unbound exp new-bound-ids)) - (syntax->list #'(body-e ...)))]) - #'(let-values (((variable ...) new-in-e) ...) new-body-e ...)))] - [(lambda forms body-e ...) - (let ([new-bound-ids (append (arglist-bindings #'forms) bound-ids)]) - (with-syntax ([(new-body-e ...) (map (lambda (exp) - (snapshot-unbound exp new-bound-ids)) - (syntax->list #'(body-e ...)))]) - #'(lambda forms new-body-e ...)))] - [(tag exp ...) - (with-syntax ([(new-exp ...) (map (lambda (exp) - (snapshot-unbound exp bound-ids)) - (syntax->list #'(exp ...)))]) - #'(tag new-exp ...))] - [x (begin - (fprintf (current-error-port) "snapshot-unbound: fell through on ~a~n" #'x) - ())]) - expr insp #f)))) - - (syntax-case stx () - [(src-command-lambda (id ...) expr ...) - (let ([c-insp (current-code-inspector)]) - (parameterize ([current-code-inspector (make-inspector)]) - (syntax-case (local-expand #'(lambda (id ...) expr ...) 'expression ()) (lambda) - [(lambda (id ...) expr ...) - (let ([unbound-ids (make-hash-table)]) - (with-syntax ([(new-expr ...) (map (lambda (exp) - ((make-snapshot-unbound c-insp unbound-ids) - exp - (syntax->list #'(id ...)))) - (syntax->list #'(expr ...)))] - [(free-var ...) (hash-table-map unbound-ids - (lambda (k v) k))]) - (begin - ;(printf "~a~n" unbound-ids) - #'(if (ormap behavior? (list free-var ...)) - (procs->signal:compound (lambda _ - (lambda (id ...) - new-expr ...)) - (lambda (a b) void) - free-var ...) - (lambda (id ...) expr ...)))))])))])) + [(var . others) + (cons #'var (arglist-bindings #'others))])) - (define for-each-e! - (let ([ht (make-hash-table 'weak)]) - (opt-lambda (ev proc [ref 'dummy]) - (hash-table-put! ht ref (cons (ev . ==> . proc) (hash-table-get ht ref (lambda () empty))))))) - - (define raise-exceptions (new-cell #t)) - - (define exception-raiser - (exceptions . ==> . (lambda (p) (when (value-now raise-exceptions) - (thread - (lambda () (raise (car p)))))))) - - - - - (provide raise-exceptions - deep-value-now - nothing - nothing? - ;general-event-processor - ;general-event-processor2 - emit - select - switch - merge-e - once-e - changes - never-e - when-e - while-e - ==> - -=> - =#> - =#=> - map-e - filter-e - filter-map-e - collect-e - accum-e - collect-b - accum-b - hold - for-each-e! - snapshot/sync - synchronize - snapshot - snapshot-e - snapshot/apply - milliseconds - fine-timer-granularity - seconds - delay-by - inf-delay - integral - derivative - new-cell - lift - lift-strict - event? - command-lambda - mk-command-lambda - until - event-loop - split - define-reactive + (define (make-snapshot-unbound insp unbound-ids) + (lambda (expr bound-ids) + (let snapshot-unbound ([expr expr] [bound-ids bound-ids]) + (syntax-recertify + (syntax-case expr (#%datum + quote + #%top + let-values + letrec-values + lambda) + [x (identifier? #'x) (if (or + (syntax-property #'x 'protected) + (ormap (lambda (id) + (bound-identifier=? id #'x)) bound-ids)) + #'x + (begin + (hash-set! unbound-ids #'x #t) + #'(#%app value-now x)))] + [(#%datum . val) expr] + [(quote . _) expr] + [(#%top . var) (begin + (hash-set! unbound-ids #'var #t) + #`(#%app value-now #,expr))] ; FIX - ;; from core/frp - event-receiver - send-event - send-synchronous-event - send-synchronous-events - set-cell! - undefined - (rename undefined?/lifted undefined?) - (rename undefined? frp:undefined?) - behavior? - value-now - value-now/no-copy - value-now/sync - signal-count - signal? - - ) - ) + [(letrec-values (((variable ...) in-e) ...) body-e ...) + (let ([new-bound-ids (append (syntax->list #'(variable ... ...)) bound-ids)]) + (with-syntax ([(new-in-e ...) (map (lambda (exp) + (snapshot-unbound exp new-bound-ids)) + (syntax->list #'(in-e ...)))] + [(new-body-e ...) (map (lambda (exp) + (snapshot-unbound exp new-bound-ids)) + (syntax->list #'(body-e ...)))]) + #'(letrec-values (((variable ...) new-in-e) ...) new-body-e ...)))] + [(let-values (((variable ...) in-e) ...) body-e ...) + (let ([new-bound-ids (append (syntax->list #'(variable ... ...)) bound-ids)]) + (with-syntax ([(new-in-e ...) (map (lambda (exp) + (snapshot-unbound exp bound-ids)) + (syntax->list #'(in-e ...)))] + [(new-body-e ...) (map (lambda (exp) + (snapshot-unbound exp new-bound-ids)) + (syntax->list #'(body-e ...)))]) + #'(let-values (((variable ...) new-in-e) ...) new-body-e ...)))] + [(lambda forms body-e ...) + (let ([new-bound-ids (append (arglist-bindings #'forms) bound-ids)]) + (with-syntax ([(new-body-e ...) (map (lambda (exp) + (snapshot-unbound exp new-bound-ids)) + (syntax->list #'(body-e ...)))]) + #'(lambda forms new-body-e ...)))] + [(tag exp ...) + (with-syntax ([(new-exp ...) (map (lambda (exp) + (snapshot-unbound exp bound-ids)) + (syntax->list #'(exp ...)))]) + #'(tag new-exp ...))] + [x (begin + (fprintf (current-error-port) "snapshot-unbound: fell through on ~a~n" #'x) + '())]) + expr insp #f)))) + + (syntax-case stx () + [(src-command-lambda (id ...) expr ...) + (let ([c-insp (current-code-inspector)]) + (parameterize ([current-code-inspector (make-inspector)]) + (syntax-case (local-expand #'(lambda (id ...) expr ...) 'expression '()) (lambda) + [(lambda (id ...) expr ...) + (let ([unbound-ids (make-hash)]) + (with-syntax ([(new-expr ...) (map (lambda (exp) + ((make-snapshot-unbound c-insp unbound-ids) + exp + (syntax->list #'(id ...)))) + (syntax->list #'(expr ...)))] + [(free-var ...) (hash-map unbound-ids + (lambda (k v) k))]) + (begin + ;(printf "~a~n" unbound-ids) + #'(if (ormap behavior? (list free-var ...)) + (procs->signal:compound (lambda _ + (lambda (id ...) + new-expr ...)) + (lambda (a b) void) + free-var ...) + (lambda (id ...) expr ...)))))])))])) + + +(define for-each-e! + (let ([ht (make-weak-hash)]) + (lambda (ev proc [ref 'dummy]) + (hash-set! ht ref (cons (ev . ==> . proc) (hash-ref ht ref (lambda () empty))))))) + +(define raise-exceptions (new-cell #t)) + +(define exception-raiser + (exceptions . ==> . (lambda (p) (when (value-now raise-exceptions) + (thread + (lambda () (raise (car p)))))))) + +(provide raise-exceptions + deep-value-now + nothing + nothing? + ;general-event-processor + ;general-event-processor2 + emit + select + switch + merge-e + once-e + changes + never-e + when-e + while-e + ==> + -=> + =#> + =#=> + map-e + filter-e + filter-map-e + collect-e + accum-e + collect-b + accum-b + hold + for-each-e! + snapshot/sync + synchronize + snapshot + snapshot-e + snapshot/apply + milliseconds + fine-timer-granularity + seconds + delay-by + inf-delay + integral + derivative + new-cell + lift + lift-strict + event? + command-lambda + mk-command-lambda + until + event-loop + split + define-reactive + + ;; from core/frp + event-receiver + send-event + send-synchronous-event + send-synchronous-events + set-cell! + undefined + (rename-out [undefined?/lifted undefined?]) + (rename-out [undefined? frp:undefined?]) + behavior? + value-now + value-now/no-copy + value-now/sync + signal-count + signal? + + )