(module lang-ext mzscheme (require (lib "frp-core.ss" "frtime") (lib "etc.ss") (lib "list.ss")) (require-for-syntax (lib "list.ss")) (define nothing (void));(string->uninterned-symbol "nothing")) (define (nothing? v) (eq? v nothing)) ; 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-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 ...))))])) ; switch : event[behavior] behavior -> behavior (define switch (opt-lambda (e [init undefined]) (let* ([init (box init)] [e-b (hold e (unbox init))]) (rec ret (proc->signal:switching (case-lambda [() (when (not (eq? (unbox init) (signal-value e-b))) (unregister ret (unbox init)) (set-box! init (value-now/no-copy 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]) init e-b e-b (unbox init)))))) ; event ... -> event (define (merge-e . args) (apply event-processor (lambda (emit) (lambda (the-event) (emit the-event))) 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)))) ; behavior[a] -> event[a] (define (changes b) (event-producer2 (lambda (emit) (lambda the-args (emit (value-now b)))) b)) (define never-e (changes #f)) ; 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))) ; 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-milliseconds)) ret))]))) b))) ; ==> : 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))) |# ; -=> : 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) (event-processor (lambda (emit) (lambda (the-event) (when (value-now (p the-event)) (emit the-event)))) 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)) (define (map-e f e) (==> e f)) (define (filter-e p e) (=#> e p)) (define (filter-map-e f e) (=#=> e f)) ; 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)) ; 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)) ; 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]) (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)))) (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) (event-processor (lambda (emit) (lambda (the-event) (emit (cons the-event (map value-now bs))))) e)) (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 ...))])) ;; Depricated (define (magic dtime thunk) (let* ([last-time (current-milliseconds)] [ret (let ([myself #f]) (event-producer (let ([now (current-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)) ;; Depricated (define (make-time-b ms) (let ([ret (proc->signal void)]) (set-signal-thunk! ret (lambda () (let ([t (current-milliseconds)]) (schedule-alarm (+ ms t) ret) t))) (set-signal-value! ret ((signal-thunk ret))) ret)) (define milliseconds (make-time-b 20)) (define time-b milliseconds) (define seconds (let ([ret (proc->signal void)]) (set-signal-thunk! ret (lambda () (let ([s (current-seconds)] [t (current-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 (cons (cons (if (zero? (value-now ms-b)) (value-now/no-copy beh) undefined) (current-milliseconds)) empty)] [head last] [producer (proc->signal (lambda () (let* ([now (current-milliseconds)] [ms (value-now ms-b)]) (let loop () (if (or (empty? (rest head)) (< now (+ ms (cdadr head)))) (caar head) (begin consumer ;; just to prevent GC (set! head (rest head)) (loop)))))))] [consumer (proc->signal (lambda () (let* ([now (current-milliseconds)] [new (value-now beh)] [ms (value-now ms-b)]) (when (not (equal? new (caar last))) (set-rest! last (cons (cons new now) empty)) (set! last (rest 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-milliseconds)] [last-val (value-now b)] [last-alarm 0] [producer (proc->signal (lambda () consumer ;; just to prevent GC accum))] [consumer (proc->signal void b ms-b)]) (set-signal-thunk! consumer (lambda () (let ([now (current-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-milliseconds)] [thunk (lambda () (let* ([new-value (value-now b)] [new-time (current-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 (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 (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)] [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 () (extract (lambda (the-event) (when proc-k (call/cc (lambda (k) (set! esc k) (proc-k the-event)))) (loop)) 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 (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) ;(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))) ;; split : event[a] (a -> b) -> (b -> event[a]) (define (split ev fn) (let* ([ht (make-hash-table 'weak)] [sig (map-e (lambda (e) (let/ec k (send-event (hash-table-get ht (fn e) (lambda () (k (void)))) e))) ev)]) (lambda (x) sig (hash-table-get ht x (lambda () (let ([rtn (event-receiver)]) (hash-table-put! ht x rtn) rtn)))))) (define-syntax event-select (syntax-rules () [(_ [ev k] ...) ()])) ;;;;;;;;;;;;;;;;;;;;;; ;; 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 ...) (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 ...)))))])))])) (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 nothing nothing? general-event-processor general-event-processor2 emit select event-processor 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 magic milliseconds seconds delay-by inf-delay integral derivative new-cell lift lift-strict event? command-lambda mk-command-lambda until event-loop split ;; from frp-core 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 frtime-version signal-count signal? ) )