(module lang-ext mzscheme
  (require frtime/frp-core
           mzlib/etc
           mzlib/list)

  (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 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
    (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 (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))
  
  ; 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)
                         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)
        (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))))))
  
  (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 ...)
       (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
           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 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
           signal-count
           signal?

           )
  )


