diff --git a/collects/frtime/frp-core.ss b/collects/frtime/frp-core.ss index 0ed79f0c23..af3bbf3fd1 100644 --- a/collects/frtime/frp-core.ss +++ b/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 diff --git a/collects/frtime/frtime.scrbl b/collects/frtime/frtime.scrbl index 0a34217840..e8615ab317 100644 --- a/collects/frtime/frtime.scrbl +++ b/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 -@scheme[accum-e], except the transformer function is fixed and is -applied to the current accumulator and the event occurrence.} +@defproc[(collect-e [ev event?] [init any/c] [proc (-> any/c any/c +any)]) event?]{is similar to @scheme[accum-e], except the transformer +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 diff --git a/collects/frtime/mzscheme-core.ss b/collects/frtime/mzscheme-core.ss index 8e5271b133..cfe3ab1919 100644 --- a/collects/frtime/mzscheme-core.ss +++ b/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 - (lambda elts + (define frp:list list + #;(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 diff --git a/collects/frtime/mzscheme-utils.ss b/collects/frtime/mzscheme-utils.ss index 9df4744059..a877eda6d8 100644 --- a/collects/frtime/mzscheme-utils.ss +++ b/collects/frtime/mzscheme-utils.ss @@ -38,19 +38,17 @@ map ormap andmap assoc member) (rename mzscheme mzscheme:if if) (rename "lang-ext.ss" lift lift) - (rename "frp-core.ss" super-lift super-lift) - (rename "frp-core.ss" behavior? behavior?) + (only "frp-core.ss" super-lift behavior? value-now) (rename "lang-ext.ss" undefined undefined) (rename "lang-ext.ss" undefined? undefined?) mzlib/class) - (require mzlib/list) + (require mzlib/list) (define-syntax (lifted-send stx) (syntax-case stx () [(_ obj meth arg ...) (with-syntax ([(obj-tmp) (generate-temporaries '(obj))] - [(arg-tmp ...) (generate-temporaries (syntax->list -#'(arg ...)))]) + [(arg-tmp ...) (generate-temporaries (syntax->list #'(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) - (super-lift (lambda (fn) (apply frp:apply/const-fn fn args)) fn) - (apply frp:apply/const-fn fn args)))) + (let* ([first-args (all-but-last args)] + [last-args (raise-list-for-apply (first (last-pair 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)]