suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix 'apply' (for real this time)

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

svn: r8845
This commit is contained in:
Greg Cooper 2008-03-02 02:54:05 +00:00
parent cb157ae275
commit 6f0322d51b
4 changed files with 117 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/frtime/frp-core.ss
View File

@ -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

7
collects/frtime/frtime.scrbl
View File

@ -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

99
collects/frtime/mzscheme-core.ss
View File

@ -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

35
collects/frtime/mzscheme-utils.ss
View File

@ -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)
(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)
@ -49,8 +48,7 @@
(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)]