constructors no longer lifted

- improves performance 
  - allows letrec to build cyclic structures (lists & vectors at least...)

value display in REPL finally respects language preferences, use of snips by underlying renderer (e.g., 
TexPict)

GUI bindings are compiled as separate sub-collection (reduces load time)

svn: r6840

collects/frtime/animation.ss

@@ -7,7 +7,10 @@
            (lib "class.ss")
            (lib "list.ss" "frtime")
            (lib "etc.ss" "frtime")
-           (lib "math.ss" "frtime"))
+           (lib "math.ss" "frtime")
+           (rename mzscheme mz:define-struct define-struct))
+  
+  (require-for-syntax (lib "etc.ss"))
   
   (open-graphics)
   
@@ -66,6 +69,24 @@
   (define middle-releases ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-up? 'middle))))
   (define right-releases ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-up? 'right))))
   
+  (define-syntax (define-shape-struct stx)
+    (syntax-case stx ()
+      [(_ name (field ...))
+       (with-syntax
+           ([ctor-name (datum->syntax-object stx (string->symbol (format "make-~a" (syntax-e #'name))))]
+            [(accessor-name ...)
+             (map (lambda (fd)
+                    (string->symbol (format "~a-~a" (syntax-e #'name) (syntax-e fd))))
+                  (syntax-e #'(field ...)))]
+            [(index ...)
+             (build-list (length (syntax-e #'(field ...))) identity)])
+         #'(begin
+             (define (ctor-name field ...)
+               (vector 'name field ...))
+             (define (accessor-name obj)
+               (vector-ref obj index))
+             ...))]))
+  
   (define-struct ring (center radius color))
   (define-struct solid-ellipse (ul w h color))
   (define-struct graph-string (pos text color))
@@ -87,38 +108,72 @@
     (set-cell! l x))
   
   (define (top-level-draw-list a-los)
-    ((clear-viewport pixmap))
-    (draw-list a-los)
-    (copy-viewport pixmap window))
+    (compound-lift
+     (lambda (vn)
+       ((clear-viewport pixmap))
+       (draw-list a-los vn)
+       (copy-viewport pixmap window))))
   
-  (define (draw-list a-los)
-    (for-each
-     (match-lambda
-       [(? undefined?) (void)]
-       [($ ring center radius color)
-        ((draw-ellipse pixmap)
-         (make-posn (- (posn-x center) radius)
-                    (- (posn-y center) radius))
-         (max 2 (* 2 radius))
-         (max 2 (* 2 radius))
-         color)]
-       [($ solid-ellipse ul w h color)
-        ((draw-solid-ellipse pixmap) ul w h color)]
-       [($ graph-string pos text color) ((draw-string pixmap) pos text color)]
-       [($ line p1 p2 color) ((draw-line pixmap) p1 p2 color)]
-       [($ rect ul w h color)
-        (cond
-          [(and (>= w 0) (>= h 0)) ((draw-solid-rectangle pixmap) ul w h color)]
-          [(>= h 0) ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (posn-y ul)) (- w) h color)]
-          [(>= w 0) ((draw-solid-rectangle pixmap) (make-posn (posn-x ul) (+ (posn-y ul) h)) w (- h) color)]
-          [else ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (+ (posn-y ul) h)) (- w) (- h) color)])]
-       [($ polygon pts offset color) ((draw-polygon pixmap) pts offset color)]
-       [($ solid-polygon pts offset color) ((draw-solid-polygon pixmap) pts offset color)]
-       [(? list? x) (draw-list x)]
-       [(? void?) (void)])
-     a-los))
+  (define (my-for-each proc lst v-n)
+    (let ([lst (v-n lst)])
+      (if (empty? lst)
+          (void)
+          (begin
+            (proc (v-n (first lst)))
+            (my-for-each proc (rest lst) v-n)))))
   
-  (define d (lift #t top-level-draw-list l))
+  (define (draw-list a-los v-n)
+    (let loop ([a-los a-los])
+      (my-for-each
+       (lambda (v)
+         (match (v-n v)
+           [(? undefined?) (void)]
+           [($ ring center radius color)
+            (let ([center (v-n center)]
+                  [radius (v-n radius)]
+                  [color (v-n color)])
+              (unless (or (undefined? center)
+                          (undefined? radius))
+                ((draw-ellipse pixmap)
+                 (make-posn (- (v-n (posn-x center)) radius)
+                            (- (v-n (posn-y center)) radius))
+                 (* 2 radius)
+                 (* 2 radius)
+                 (if (undefined? color) "black" color))))]
+           [($ solid-ellipse ul w h color)
+            (let ([ul (v-n ul)]
+                  [w (v-n w)]
+                  [h (v-n h)]
+                  [color (v-n color)])
+              (unless (or (undefined? ul)
+                          (undefined? w)
+                          (undefined? h))
+                ((draw-solid-ellipse pixmap) ul w h (if (undefined? color) "black" color))))]
+           [($ graph-string pos text color) ((draw-string pixmap) (v-n pos) (v-n text) (v-n color))]
+           [($ line p1 p2 color)
+            (let ([p1 (v-n p1)]
+                  [p2 (v-n p2)]
+                  [color (v-n color)])
+              (unless (or (undefined? p1)
+                          (undefined? p2))
+                ((draw-line pixmap) p1 p2 (if (undefined? color) "black" color))))]
+           [($ rect ul w h color)
+            (let ([ul (v-n ul)]
+                  [w (v-n w)]
+                  [h (v-n h)]
+                  [color (v-n color)])
+            (cond
+              [(and (>= w 0) (>= h 0)) ((draw-solid-rectangle pixmap) ul w h color)]
+              [(>= h 0) ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (posn-y ul)) (- w) h color)]
+              [(>= w 0) ((draw-solid-rectangle pixmap) (make-posn (posn-x ul) (+ (posn-y ul) h)) w (- h) color)]
+              [else ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (+ (posn-y ul) h)) (- w) (- h) color)]))]
+           [($ polygon pts offset color) ((draw-polygon pixmap) pts offset color)]
+           [($ solid-polygon pts offset color) ((draw-solid-polygon pixmap) pts offset color)]
+           [(? list? x) (loop (v-n x))]
+           [(? void?) (void)]))
+       a-los v-n)))
+  
+  (define d (top-level-draw-list l))
   
   (define-struct graph-color (fn xmin xmax ymin ymax))
   

collects/frtime/demos/gui/info.ss

@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "frtime gui wrapper")
+  (define doc.txt "doc.txt"))

collects/frtime/frp-core.ss

@@ -21,14 +21,15 @@
   
   (define named-dependents (make-hash-table))
   
-  (define frtime-version "0.3b -- Tue Nov 9 13:39:45 2004")
+  (define frtime-version "0.4b -- Tue Jun 26 17:39:45 2007")
   
   (define (compose-continuation-mark-sets2 s1 s2)
-    (append s1 s2))
+    s2)
   
   
   (define (my-ccm)
-    (continuation-mark-set->list (current-continuation-marks) 'drscheme-debug-continuation-mark-key))
+    (current-continuation-marks)
+    #;(continuation-mark-set->list (current-continuation-marks) 'drscheme-debug-continuation-mark-key))
   
   ;;;;;;;;;;;;;;;;
   ;; Structures ;;
@@ -152,8 +153,9 @@
           #;(thread (lambda () (raise (make-exn:fail
                                      "extra marks present!" (extra-cont-marks)))))
           (compose-continuation-mark-sets2
+           (my-ccm)
            (extra-cont-marks)
-           (my-ccm)))
+           ))
         (my-ccm)))
   
   ;; Simple Structure Combinators
@@ -483,8 +485,8 @@
   ; If there is a cycle, then 'inf' has (and retains) a lower depth than 'sup' (?), which
   ; indicates the cycle.  Importantly, 'propagate' uses the external message queue whenever
   ; a dependency crosses an inversion of depth.
-  (define (fix-depths inf sup)
-    (let help ([inf inf] [sup sup] [mem empty])
+  (define fix-depths
+    (opt-lambda (inf sup [mem empty])
       (if (memq sup mem)
           (send-event exceptions (list (make-exn:fail "tight cycle in dataflow graph" (signal-continuation-marks sup))
                                        sup))
@@ -492,7 +494,7 @@
                     (safe-signal-depth sup))
             (set-signal-depth! inf (add1 (safe-signal-depth sup)))
             (for-each
-             (lambda (dep) (help dep inf (cons sup mem)))
+             (lambda (dep) (fix-depths dep inf (cons sup mem)))
              (foldl (lambda (wb acc)
                       (match (weak-box-value wb)
                         [(and sig (? signal?)) (cons sig acc)]
@@ -623,7 +625,10 @@
                         (effective-continuation-marks)])
           (do-in-manager
            (let* ([cust (make-ft-cust (void) empty empty)]
-                  [_ (when (current-cust) (set-ft-cust-children! (current-cust) (cons cust (ft-cust-children (current-cust)))))]
+                  [_ (cond
+                       [(current-cust)
+                        => (lambda (c) (set-ft-cust-children! c (cons cust (ft-cust-children c))))]
+                       [else (void)])]
                   [pfun (lambda (b)
                           (parameterize ([current-cust cust])
                             (fun b)))]
@@ -770,7 +775,7 @@
                                 (undef cur-beh)
                                 #;(kill-signal cur-beh)))
                             (outer))])
-           ;; (set! exn-handler (current-exception-handler)) <-- FIXME!
+           (set! exn-handler (uncaught-exception-handler))
            (let inner ()
              
              ;; process external messages until there is an internal update

collects/frtime/frp-snip.ss

@@ -2,11 +2,13 @@
   (require (lib "class.ss")
            (lib "string.ss")
            (lib "list.ss")
+           (lib "port.ss")
            
            ;; FRP requires
            
            (lib "frp-core.ss" "frtime")
            (all-except (lib "lang-ext.ss" "frtime") undefined?)
+           (only (lib "mzscheme-core.ss" "frtime") any-nested-reactivity? raise-reactivity)
 ;           (rename (lib "frp-core.ss" "frtime") behavior? behavior?)
 ;           (rename (lib "lang-ext.ss" "frtime") event? event?)
 ;           (rename (lib "frp-core.ss" "frtime") signal? signal?)
@@ -45,16 +47,20 @@
         (send current draw dc x y left top right bottom dx dy draw-caret))
       (super-instantiate (" "))))
   
-  (define (make-snip bhvr)
-    (make-object string-snip%
-      (let ([tmp (cond
-                   [(behavior? bhvr) (value-now bhvr)]
-                   [(event? bhvr) (signal-value bhvr)]
-                   [else bhvr])])
-        (cond
-          [(econs? tmp) (format "#<event (last: ~a)>" (efirst tmp))]
-          [(undefined? tmp) "<undefined>"]
-          [else (expr->string tmp)]))))
+  (define make-snip
+    (case-lambda
+      [(bhvr)
+       (make-object string-snip%
+         (let ([tmp (cond
+                      [(behavior? bhvr) (value-now bhvr)]
+                      [(event? bhvr) (signal-value bhvr)]
+                      [else bhvr])])
+           (cond
+             [(econs? tmp) (format "#<event (last: ~a)>" (efirst tmp))]
+             [(undefined? tmp) "<undefined>"]
+             [else (expr->string tmp)])))]
+      [(bhvr super-render-fun)
+       (get-rendering (value-now bhvr) super-render-fun)]))
   
   (define value-snip%
     (class string-snip%
@@ -74,6 +80,60 @@
       
       (super-instantiate (" "))))
   
+  (define dynamic-snip-copy%
+    (class snip%
+      (init-field current parent)
+      (inherit get-admin)
+      (define/public (set-current c)
+        (parameterize ([current-eventspace drs-eventspace])
+          (queue-callback
+           (lambda ()
+             (set! current c)
+             (let ([admin (get-admin)])
+               (when admin
+                 (send admin resized this #t)
+                 #;(send admin needs-update this 0 0 2000 100)))))))
+      #;(define/override (resize w h)
+        (super resize w h)
+        (send (get-admin) resized this #t)
+        #t)
+      (define/override (size-cache-invalid)
+        (send current size-cache-invalid))
+              
+      (define/override (get-extent dc x y w h descent space lspace rspace)
+        (send current get-extent dc x y w h descent space lspace rspace))
+
+      (define/override (draw dc x y left top right bottom dx dy draw-caret)
+        (send current draw dc x y left top right bottom dx dy draw-caret))
+      (super-new)))
+    
+  (define dynamic-snip%
+    (class snip%
+      (init-field bhvr super-render-fun)
+  
+      (field [copies empty]
+             [loc-bhvr (proc->signal (lambda () (update)) bhvr)]
+             [current (make-snip bhvr super-render-fun)])
+      
+      (define/override (copy)
+        (let ([ret (make-object value-snip-copy% current this)])
+          (set! copies (cons ret copies))
+          ret))
+      
+      (define/public (update)
+        (set! current (make-snip bhvr super-render-fun))
+        (for-each (lambda (copy) (send copy set-current current)) copies))
+      
+      (define/override (size-cache-invalid)
+        (for-each
+         (lambda (s) (send s size-cache-invalid))
+         copies))
+              
+      (define/override (get-extent dc x y w h descent space lspace rspace)
+        (send current get-extent dc x y w h descent space lspace rspace))
+
+      (super-new)))
+
   (define (render beh as-snip?)
     (cond
       [as-snip? (watch beh)]
@@ -82,17 +142,27 @@
       [(event? beh) (format "#<event (last: ~a)>" (efirst (signal-value beh)))]
       [else beh]))
   
-  #;(define (get-rendering val super-render-fun)
+  (define (render/dynamic-snip val super-render-fun)
+    (if (behavior? val)
+        ; interesting case:
+        ; create a snip
+        ; each time val changes, recompute its rendering via super-render-fun
+        (make-object dynamic-snip% val super-render-fun)
+        ; easy case
+        (super-render-fun val)))
+  
+  (define (get-rendering val super-render-fun)
     (let-values ([(in out) (make-pipe-with-specials)])
-      (thread (lambda () (super-render-fun val out) (flush-output out) (close-output-port out)))
+      (thread (lambda () (super-render-fun val out) (close-output-port out)))
       (let loop ([chars empty])
         (let ([c (read-char-or-special in)])
+          ;(fprintf (current-error-port) "read ~a~n" c)
           (cond
-            [(eof-object? c) (list->string (reverse chars))]
+            [(eof-object? c) (make-object string-snip% (list->string (reverse (rest chars))))]
             [(char? c) (loop (cons c chars))]
             [else c])))))
   
-  (define (watch beh)
+  (define (watch beh super-render-fun)
     (cond
       [(undefined? beh)
        (begin
@@ -100,7 +170,13 @@
          (make-object string-snip% "<undefined>")
          )
          ]
-      [(signal? beh) (make-object value-snip% beh)]
+      [(or (behavior? beh) (any-nested-reactivity? beh))
+       (make-object dynamic-snip% (raise-reactivity beh) super-render-fun)]
+      [(signal? beh)
+       (make-object dynamic-snip% beh super-render-fun)]
+       #;(let ([pb (new pasteboard%)])
+         (send pb insert (make-object dynamic-snip% beh super-render-fun))
+         (new editor-snip% [editor (new pasteboard%)]))
       [else beh]))
   
   (provide (all-defined))

collects/frtime/frtime-tool.ss

@@ -14,25 +14,6 @@
     (unit 
       (import drscheme:tool^)
       (export drscheme:tool-exports^)
-      #;(define basic-frtime-language%
-	(class* object% (drscheme:language:simple-module-based-language<%>)
-	  (define/public (get-language-numbers)
-	    '(1000 -400 1))
-	  (define/public (get-language-position)
-	    (list (string-constant experimental-languages) "FrTime" "Minimal"))
-          (define/public (get-langauge-id) "plt:frtime")
-	  (define/public (get-module)
-	    '(lib "frtime.ss" "frtime"))
-	  (define/public (get-one-line-summary)
-	    "FrTime without libraries")
-          (define/public (get-language-url) #f)
-	  (define/public (get-reader)
-	    (lambda (name port)
-	      (let ([v (read-syntax name port)])
-		(if (eof-object? v)
-		    v
-		    (namespace-syntax-introduce v)))))
-	  (super-instantiate ())))
 
       (define big-frtime-language%
 	(class* object% (drscheme:language:simple-module-based-language<%>)
@@ -63,12 +44,12 @@
                     [else false])
                   (loop (rest lis)))))))
             
-      (define (watch watch-list value)
+      (define (watch watch-list value super-render-fun)
         (foldl
          (lambda (wb acc)
            (cond
              [(weak-box-value wb)
-              => (lambda (f) (f acc #t))]
+              => (lambda (f) (f acc super-render-fun))]
              [else acc]))
          value
          watch-list))
@@ -86,7 +67,7 @@
               (super on-execute settings run-in-user-thread)
               (run-in-user-thread
                (lambda ()
-                 (let ([new-watch (namespace-variable-value 'render)]
+                 (let ([new-watch (namespace-variable-value 'watch)]
                        [set-evspc (namespace-variable-value 'set-eventspace)])
                    (set-evspc drs-eventspace)
                    (set! watch-list
@@ -95,19 +76,19 @@
                               (lambda (r) (cons (make-weak-box new-watch) r)))
                           (filter weak-box-value watch-list))))))))
 
+          ;; pass (lambda (v) (super render-value(/format) v settings width port))
+          ;; to watcher
           (override render-value/format render-value)
           (define (render-value/format value settings port width)
-            (super render-value/format (watch watch-list value)
-                                       settings port width))
+            (super render-value/format (watch watch-list value (lambda (v prt) (render-value/format v settings prt width)))
+                   settings port width))
           (define (render-value value settings port)
-            (super render-value (watch watch-list value)
-                                settings port))
+            (super render-value (watch watch-list value (lambda (v prt) (render-value settings prt)))
+                   settings port))
 	  (define/override (use-namespace-require/copy?) #t)
 	  (super-instantiate ())))
 
       (define (phase1) (void))
       (define (phase2)
-	#;(drscheme:language-configuration:add-language 
-	 (make-object ((drscheme:language:get-default-mixin) (make-frtime-language basic-frtime-language%))))
         (drscheme:language-configuration:add-language 
 	 (make-object ((drscheme:language:get-default-mixin) (make-frtime-language big-frtime-language%))))))))

collects/frtime/info.ss

@@ -2,7 +2,7 @@
   (define name "frtime")
   (define doc.txt "doc.txt")
   
+  (define compile-subcollections (list (list "frtime" "demos" "gui")))
   (define tools (list "frtime-tool.ss"))
   (define tool-icons (list '("clock.png" "frtime")))
   (define tool-names (list "FrTime Languages")))
-

collects/frtime/lang-ext.ss

@@ -9,6 +9,35 @@
   
   (define (nothing? v) (eq? v nothing))
   
+  (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))]
+         [(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)])
+            (set-car! result car-val)
+            (set-cdr! result cdr-val)
+            result)]
+         [(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])]))
+      
   
   
   ; new-cell : behavior[a] -> behavior[a] (cell)
@@ -84,7 +113,7 @@
       (let* ([init (box init)]
              [e-b (hold e (unbox init))]
              [ret (proc->signal:switching
-                   (case-lambda [() undefined]
+                   (case-lambda [() (value-now (unbox init))]
                                 [(msg) e])
                    init e-b e-b (unbox init))])
         (set-signal-thunk!
@@ -127,7 +156,7 @@
     (event-producer2
      (lambda (emit)
        (lambda the-args
-         (emit (value-now b))))
+         (emit (deep-value-now b))))
      b))
   
   (define never-e
@@ -361,7 +390,7 @@
              [consumer (proc->signal
                         (lambda ()
                           (let* ([now (current-milliseconds)]
-                                 [new (value-now beh)]
+                                 [new (deep-value-now beh)]
                                  [ms (value-now ms-b)])
                             (when (not (equal? new (caar last)))
                               (set-rest! last (cons (cons new now)
@@ -485,7 +514,7 @@
             'frtime 'lift-active
           (if (ormap behavior? args)
               (begin
-                (when (ormap signal:compound? args)
+                #;(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

collects/frtime/mzscheme-core.ss

@@ -4,27 +4,22 @@
   (require-for-syntax (lib "struct.ss" "frtime") (lib "list.ss"))
   (require (lib "list.ss")
            (lib "frp-core.ss" "frtime")
-           (rename (lib "lang-ext.ss" "frtime") lift lift)
-           (rename (lib "lang-ext.ss" "frtime") new-cell new-cell))
-
-
-  
-  
-  
+           (only (lib "vector-lib.ss" "srfi" "43") vector-any)
+           (only (lib "lang-ext.ss" "frtime") lift new-cell switch ==> changes)
+           (only (lib "etc.ss") build-vector rec build-list opt-lambda identity))
   
   ;;;;;;;;;;;;;;;;;;;;;;;;
   ;; Fundamental Macros ;;
   ;;;;;;;;;;;;;;;;;;;;;;;;
     
-  
   (define-syntax frp:letrec
     (syntax-rules ()
       [(_ ([id val] ...) expr ...)
        (let ([id (new-cell)] ...)
          (let ([tmp val])
-           (if (signal? tmp)
-               (set-cell! id tmp)
-               (set! id tmp)))
+           (when (or (signal? tmp) (any-nested-reactivity? tmp))
+             (set-cell! id tmp))
+           (set! id tmp))
          ...
          expr ...)]))
   
@@ -32,8 +27,11 @@
   ;  (syntax-rules ()
   ;    [(_ expr clause ...) (lift #t (match-lambda clause ...) expr)]))
   
+  (define (->boolean x)
+    (if x #t #f))
+  
   (define (frp:->boolean x)
-    (lift #t (lambda (x) (if x #t #f)) x))
+    (lift #f ->boolean x))
   
   (define-syntax frp:if
     (syntax-rules ()
@@ -111,6 +109,124 @@
           (apply apply fn (append first-args rest-args)))))
   |#
   
+  (define any-nested-reactivity?
+    (opt-lambda (obj [mem empty])
+      (cond
+        [(memq obj mem) #f]
+        [(behavior? obj) #t]
+        [(cons? obj)
+         (let ([mem (cons obj mem)])
+           (or (any-nested-reactivity? (car obj) mem)
+               (any-nested-reactivity? (cdr obj) mem)))]
+        [(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)])
+           (ormap (lambda (i) (any-nested-reactivity? (acc obj i) (cons obj mem)))
+                  (build-list (+ auto-k init-k) (lambda (x) x))))]
+        [(vector? obj) (vector-any (lambda (o) (any-nested-reactivity? o (cons obj mem))) obj)]
+        [else #f])))
+  
+  (define (deep-value-now/update-deps obj deps table)
+    (cond
+      [(assq obj table) => second]
+      [(behavior? obj)
+       (case (hash-table-get deps obj 'absent)
+         [(absent) (hash-table-put! deps obj 'new)]
+         [(old)    (hash-table-put! deps obj 'alive)]
+         [(new)    (void)])
+       (deep-value-now/update-deps (signal-value obj) deps table)]
+      [(cons? obj)
+       (let* ([result (cons #f #f)]
+              [new-table (cons (list obj result) table)]
+              [car-val (deep-value-now/update-deps (car obj) deps new-table)]
+              [cdr-val (deep-value-now/update-deps (cdr obj) deps new-table)])
+         (if (and (eq? car-val (car obj))
+                  (eq? cdr-val (cdr obj)))
+             obj
+             (begin
+               (set-car! result car-val)
+               (set-cdr! result cdr-val)
+               result)))]
+      ; 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/update-deps (acc obj i) deps 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/update-deps (vector-ref obj i) deps 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 (raise-reactivity obj)
+    (let ([rtn (proc->signal void)])
+      (set-signal-thunk!
+       rtn
+       (let ([deps (make-hash-table)])
+         (lambda ()
+           (begin0
+             (deep-value-now/update-deps obj deps empty)
+             (hash-table-for-each
+              deps
+              (lambda (k v)
+                (case v
+                  [(new)   (hash-table-put! deps k 'old)
+                           (register rtn k)]
+                  [(alive) (hash-table-put! deps k 'old)]
+                  [(old)   (hash-table-remove! deps k)
+                           (unregister rtn k)])))
+             #;(printf "count = ~a~n" (hash-table-count deps))))))
+      (do-in-manager
+       (iq-enqueue rtn))
+      rtn))
+  
+  (define (compound-lift proc)
+    (let ([rtn (proc->signal void)])
+      (set-signal-thunk!
+       rtn
+       (let ([deps (make-hash-table)])
+         (lambda ()
+           (begin0
+             (proc (lambda (obj)
+                     (if (behavior? obj)
+                         (begin
+                           (case (hash-table-get deps obj 'absent)
+                             [(absent) (hash-table-put! deps obj 'new)]
+                             [(old)    (hash-table-put! deps obj 'alive)]
+                             [(new)    (void)])
+                           (value-now obj))
+                         obj)))
+             (hash-table-for-each
+              deps
+              (lambda (k v)
+                (case v
+                  [(new)   (hash-table-put! deps k 'old)
+                           #;(printf "reg~n")
+                           (register rtn k)]
+                  [(alive) (hash-table-put! deps k 'old)]
+                  [(old)   (hash-table-remove! deps k)
+                           #;(printf "unreg~n")
+                           (unregister rtn k)])))
+             #;(printf "count = ~a~n" (hash-table-count deps))))))
+      (iq-enqueue rtn)
+      rtn))
   
   ;;;;;;;;;;;;;;;;
   ;; Structures ;;
@@ -122,7 +238,9 @@
   
   
   (define (frp:cons f r)
-    (if (or (behavior? f) (behavior? r))
+    (cons f r)
+    #;(lift #f cons f r)
+    #;(if (or (behavior? f) (behavior? r))
         (procs->signal:compound
          cons
          (lambda (p i)
@@ -137,13 +255,15 @@
       (let loop ([v v])
         (cond
           [(signal:compound? v) (acc (signal:compound-content v))]
+          [(signal? v) #;(printf "access to ~a in ~a~n" acc
+                                 (value-now/no-copy v))
+                       #;(lift #t acc v)
+                       #;(switch ((changes v) . ==> . acc) (acc (value-now v)))
+                       (super-lift acc v)]
           [(signal:switching? v) (super-lift
                                   (lambda (_)
                                     (loop (unbox (signal:switching-current v))))
                                   (signal:switching-trigger v))]
-          [(signal? v) #;(printf "access to ~a in ~a~n" acc
-                                 (value-now/no-copy v))
-                       (lift #t acc v)]
 	  [(undefined? v) undefined]
           [else (acc v)]))))
     
@@ -164,12 +284,27 @@
   
   (define frp:empty? frp:null?)
   
+  (define (list-match lst cf ef)
+    (super-lift
+     (lambda (lst)
+       (cond
+         [(undefined? lst) undefined]
+         [(pair? lst) (cf (first lst) (rest lst))]
+         [(empty? lst) (ef)]))
+     lst))
+  
+  #;(define (frp:append . args)
+    (apply lift #t append args))
+  
   (define frp:append
     (case-lambda
       [() ()]
       [(lst) lst]
       [(lst1 lst2 . lsts)
-       (frp:if (frp:empty? lst1)
+       (list-match lst1
+                   (lambda (f r) (cons f (apply frp:append r lst2 lsts)))
+                   (lambda () (apply frp:append lst2 lsts)))                          
+       #;(frp:if (frp:empty? lst1)
                (apply frp:append lst2 lsts)
                (frp:cons (frp:car lst1)
                          (apply frp:append (frp:cdr lst1) lst2 lsts)))]))
@@ -208,7 +343,8 @@
   ;; Vector
   
   
-  (define (frp:vector . args)
+  (define frp:vector vector)
+  #;(define (frp:vector . args)
     (if (ormap behavior? args)
         (apply procs->signal:compound
                vector
@@ -220,9 +356,12 @@
   
   (define (frp:vector-ref v i)
     (cond
-      [(signal:compound? v) (vector-ref (signal:compound-content v) i)]
-      [(signal? v) (lift #t vector-ref v i)]
-      [else (vector-ref v i)]))
+      [(behavior? v) (super-lift (lambda (v) (frp:vector-ref v i)) v)
+       #;(switch ((changes v) . ==> . (lambda (vv) (vector-ref vv i)))
+                           (vector-ref (value-now v) i)) ;; rewrite as super-lift
+                           #;(lift #t vector-ref v i)]
+      #;[(signal:compound? v) (vector-ref (signal:compound-content v) i)]
+      [else (lift #t vector-ref v i)]))
   
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -235,7 +374,7 @@
                          args)])
       (values
        desc
-       (lambda fields
+       #;(lambda fields
          (if (ormap behavior? fields)
              (apply procs->signal:compound
                     ctor
@@ -244,6 +383,7 @@
                         (mut strct idx val)))
                     fields)
              (apply ctor fields)))
+         ctor
        (lambda (v) (if (signal:compound? v)
                        (pred (value-now/no-copy v))
                        (lift #t pred v)))
@@ -261,6 +401,7 @@
   (define-syntax (frp:define-struct stx)
     (syntax-case stx ()
       [(_ (s t) (field ...) insp)
+       #;(define-struct (s t) (field ...) (make-inspector insp))
        (let ([field-names (syntax->list #'(field ...))]
              [super-for-gen (if (syntax-e #'t)
                                 (string->symbol
@@ -271,7 +412,7 @@
                                 #t)])
          #`(begin
              (define-values #,(build-struct-names #'s field-names #f #f stx)
-               (parameterize ([current-inspector insp])
+               (parameterize ([current-inspector (make-inspector insp)])
                  #,(build-struct-generation #'s field-names #f #f super-for-gen)))
              (define-syntax s
                #,(build-struct-expand-info #'s field-names #f #f super-for-exp
@@ -405,6 +546,10 @@
            #%plain-module-begin
            #%module-begin
            #%top-interaction
+           raise-reactivity
+           any-nested-reactivity?
+           compound-lift
+           list-match
            (rename frp:if if)
            (rename frp:lambda lambda)
            (rename frp:case-lambda case-lambda)