diff --git a/collects/frtime/animation.ss b/collects/frtime/animation.ss index 8a29300e97..3346c4b94e 100644 --- a/collects/frtime/animation.ss +++ b/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)) diff --git a/collects/frtime/demos/gui/info.ss b/collects/frtime/demos/gui/info.ss new file mode 100644 index 0000000000..689ea1afa7 --- /dev/null +++ b/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")) diff --git a/collects/frtime/frp-core.ss b/collects/frtime/frp-core.ss index c85082a816..a904cf3944 100644 --- a/collects/frtime/frp-core.ss +++ b/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 diff --git a/collects/frtime/frp-snip.ss b/collects/frtime/frp-snip.ss index 2944f60af0..4c91b0b854 100644 --- a/collects/frtime/frp-snip.ss +++ b/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 "#" (efirst tmp))] - [(undefined? tmp) ""] - [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 "#" (efirst tmp))] + [(undefined? tmp) ""] + [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 "#" (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% "") ) ] - [(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)) diff --git a/collects/frtime/frtime-tool.ss b/collects/frtime/frtime-tool.ss index 837775b46c..d98401c7b4 100644 --- a/collects/frtime/frtime-tool.ss +++ b/collects/frtime/frtime-tool.ss @@ -11,28 +11,9 @@ (provide tool@) (define tool@ - (unit + (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%)))))))) diff --git a/collects/frtime/info.ss b/collects/frtime/info.ss index 8fb31543bf..fa40c29ce1 100644 --- a/collects/frtime/info.ss +++ b/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"))) - diff --git a/collects/frtime/lang-ext.ss b/collects/frtime/lang-ext.ss index a746b6019b..8e4e41b0ef 100644 --- a/collects/frtime/lang-ext.ss +++ b/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 diff --git a/collects/frtime/mzscheme-core.ss b/collects/frtime/mzscheme-core.ss index 3f4c1d3e7f..28427c1930 100644 --- a/collects/frtime/mzscheme-core.ss +++ b/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)