fix 'apply' (for real this time)

document the order of arguments to collect-e's transformer

svn: r8845

collects/frtime/frp-core.ss

@@ -719,7 +719,7 @@
                                        #;(not (undefined? (signal-value cur-beh))))
                               ;(when (empty? (continuation-mark-set->list
                                ;              (exn-continuation-marks exn) 'frtime))
-                              (fprintf (current-error-port) "exception while updating ~a~n" cur-beh)
+                              ;(fprintf (current-error-port) "exception while updating ~a~n" cur-beh)
                               (set! exn (make-exn:fail
                                          (exn-message exn)
                                          (compose-continuation-mark-sets2

collects/frtime/frtime.scrbl

@@ -123,9 +123,10 @@ from @scheme[accum-e] and @scheme[hold] to construct a behavior.
 @scheme[(accum-b ev init)] is equivalent to @scheme[(hold init
 (accum-e ev init))].}
 
-@defproc[(collect-e [ev event?] [init any/c] [proc (-> any/c any/c any)]) event?]{is similar to
+@defproc[(collect-e [ev event?] [init any/c] [proc (-> any/c any/c
-@scheme[accum-e], except the transformer function is fixed and is
+any)]) event?]{is similar to @scheme[accum-e], except the transformer
-applied to the current accumulator and the event occurrence.}
+function is fixed and is applied to the event occurrence and the
+current accumulator (in that order).}
 
 @defproc[(collect-b [ev event?] [init any/c] [proc (-> any/c any/c any)]) behavior?]{is similar to
 @scheme[collect-e] in the same way as @scheme[accum-b] is similar to

collects/frtime/mzscheme-core.ss

@@ -178,6 +178,96 @@
                result)))]
       [else obj]))
   
+  (define (deep-value-now obj table)
+    (cond
+      [(assq obj table) => second]
+      [(behavior? obj)
+       (deep-value-now (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 any-spinal-reactivity?
+    (opt-lambda (lst [mem empty])
+      (cond
+        [(memq lst mem) #f]
+        [(behavior? lst) #t]
+        [(cons? lst) (any-spinal-reactivity? (cdr lst) (cons lst mem))]
+        [else #f])))
+  
+  (define (deep-cdr-value-now/update-deps obj deps table)
+    (cond
+      [(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-cdr-value-now/update-deps (signal-value obj) deps table)]
+      [(cons? obj)
+       (let* ([cdr-val (deep-cdr-value-now/update-deps (cdr obj) deps table)])
+         (cons (car obj) cdr-val))]
+      [else obj]))
+  
+  (define (raise-list-for-apply obj)
+    (if (any-spinal-reactivity? obj)
+        (let ([rtn (proc->signal void)])
+          (set-signal-thunk!
+           rtn
+           (let ([deps (make-hash-table)])
+             (lambda ()
+               (begin0
+                 (deep-cdr-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)
+                               (do-in-manager
+                                (iq-enqueue rtn))]
+                      [(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)
+        obj))
+  
   (define (raise-reactivity obj)
     (let ([rtn (proc->signal void)])
       (set-signal-thunk!
@@ -298,7 +388,8 @@
        (cond
          [(undefined? lst) undefined]
          [(pair? lst) (cf (first lst) (rest lst))]
-         [(empty? lst) (ef)]))
+         [(empty? lst) (ef)]
+         [else (error "list-match: expected a list, got ~a" lst)]))
      lst))
   
   #;(define (frp:append . args)
@@ -317,8 +408,8 @@
                (frp:cons (frp:car lst1)
                          (apply frp:append (frp:cdr lst1) lst2 lsts)))]))
   
-  (define frp:list
+  (define frp:list list
-    (lambda elts
+    #;(lambda elts
      (frp:if (frp:empty? elts)
               '()
               (frp:cons (frp:car elts)
@@ -555,6 +646,8 @@
            #%module-begin
            #%top-interaction
            raise-reactivity
+           raise-list-for-apply
+           deep-value-now
            any-nested-reactivity?
            compound-lift
            list-match

collects/frtime/mzscheme-utils.ss

@@ -38,8 +38,7 @@
                        map ormap andmap assoc member)
            (rename mzscheme mzscheme:if if)
            (rename "lang-ext.ss" lift lift)
-           (rename "frp-core.ss" super-lift super-lift)
+           (only "frp-core.ss" super-lift behavior? value-now)
-           (rename "frp-core.ss" behavior? behavior?)
            (rename "lang-ext.ss" undefined undefined)
            (rename "lang-ext.ss" undefined? undefined?)
 	   mzlib/class)
@@ -49,8 +48,7 @@
     (syntax-case stx ()
       [(_ obj meth arg ...)
        (with-syntax ([(obj-tmp) (generate-temporaries '(obj))]
-                     [(arg-tmp ...) (generate-temporaries (syntax->list
+                     [(arg-tmp ...) (generate-temporaries (syntax->list #'(arg ...)))])
-#'(arg ...)))])
          #'(lift #t 
                  (lambda (obj-tmp arg-tmp ...)
                    (send obj-tmp meth arg-tmp ...))
@@ -178,6 +176,7 @@
       [(_ expr clause ...)
        (super-lift (lambda (v) (case v clause ...)) expr)]))
   |#
+  
   (define (split-list acc lst)
     (if (null? (cdr lst))
         (values acc (car lst))
@@ -188,22 +187,14 @@
         '()
         (cons (car lst) (all-but-last (cdr lst)))))
   
-  (define frp:apply/const-fn
-    (lambda (fn . args)
-      (let ([first-args (all-but-last args)]
-            [last-args (first (last-pair args))])
-        (if (behavior? last-args)
-            (super-lift
-             (lambda (last-args)
-               (apply apply fn (append first-args (list last-args))))
-             last-args)
-            (apply apply fn args)))))
-  
   (define frp:apply
     (lambda (fn . args)
-      (if (behavior? fn)
+      (let* ([first-args (all-but-last args)]
-          (super-lift (lambda (fn) (apply frp:apply/const-fn fn args)) fn)
+             [last-args (raise-list-for-apply (first (last-pair args)))])
-          (apply frp:apply/const-fn fn args))))
+        (super-lift
+         (lambda (last-args)
+           (apply apply fn (append first-args (cons last-args empty))))
+         last-args))))
   
   #|
   ;; taken from startup.ss
@@ -263,9 +254,13 @@
   
   (define map
     (case-lambda
-      [(f l) (if (pair? l)
+      [(f l) #;(if (pair? l)
                  (cons (f (car l)) (map f (cdr l)))
-                 null)]
+                 null)
+             (list-match
+              l
+              (lambda (a d) (cons (f a) (map f d)))
+              (lambda () null))]
       [(f l1 l2) (if (and (pair? l1) (pair? l2))
                      (cons (f (car l1) (car l2)) (map f (cdr l1) (cdr l2)))
                      null)]