racket-common 6.1-4 / usr / share / racket / pkgs / frtime / lang-ext.rkt

#lang racket/base
(require (for-syntax racket/base
                     (only-in racket/list first second last-pair empty empty?))
         (only-in racket/list first second cons? empty empty? rest last-pair)
         (only-in racket/function identity)
         (only-in frtime/core/frp super-lift undefined undefined? behavior? do-in-manager-after do-in-manager proc->signal set-signal-thunk! register unregister 
                  signal? signal-depth signal:switching? signal-value value-now signal:compound? signal:compound-content signal:switching-current signal:switching-trigger 
                  set-cell! snap? iq-enqueue value-now/no-copy event-receiver event-set? proc->signal:switching set-signal-producers! set-signal-depth! safe-signal-depth 
                  make-events-now iq-resort event-set-events current-logical-time event-set-time event-producer2 schedule-alarm value-now/sync set-signal-value! signal-thunk
                  send-event exceptions send-synchronous-event send-synchronous-events signal-count))

(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 deep-value-now
    (case-lambda
      [(obj) (deep-value-now obj empty)]
      [(obj table)
       (cond
         [(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)]
                 [car-val (deep-value-now (car obj) new-table)]
                 [cdr-val (deep-value-now (cdr obj) new-table)])
            (cons car-val cdr-val))]
         [(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)])
            (apply ctor (build-list (+ auto-k init-k)
                                    (lambda (i) (deep-value-now (acc obj i) table)))))]
         [(vector? obj)
          (build-vector
           (vector-length obj)
           (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
  (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 #f 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)
  (letrec ([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)])
    ret))

; ==> : 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]          
           [consumer #f]
           [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)))))))])
    (begin
      (set! 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]
             [consumer (proc->signal void b ms-b)]
             [producer (proc->signal (lambda () (and (signal? consumer) accum)))])
      (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
                         (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)
                       ;(eprintf "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-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-for-syntax code-insp (variable-reference->module-declaration-inspector
                              (#%variable-reference)))

(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-case (syntax-disarm expr code-insp) (#%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
           
           [(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
                (eprintf "snapshot-unbound: fell through on ~a\n" #'x)
                '())]))))
  
  (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?)