minor changes + fixes to demos:
svn: r818
This commit is contained in:
Greg Cooper
parent
adec0ec106
commit
8e93c75f81
|
|
@ -31,7 +31,8 @@
|
|||
(clicks-in-clock
|
||||
. -=> .
|
||||
(snapshot (mouse-pos clock-center)
|
||||
(posn- mouse-pos clock-center)))))
|
||||
(posn- mouse-pos clock-center)))
|
||||
#;(make-posn 0 0)))
|
||||
|
||||
;; Define follow-mouse which is true when the center of the clock
|
||||
;; should be at the mouse cursor; false when it is at the last
|
||||
|
|
@ -47,9 +48,9 @@
|
|||
(rec p
|
||||
(inf-delay
|
||||
(until (make-posn 200 200)
|
||||
(let ([p1 (posn- mouse-pos offset)])
|
||||
(let ([p1 0])
|
||||
(if follow-mouse?
|
||||
p1
|
||||
(posn- mouse-pos offset)
|
||||
p))))))
|
||||
|
||||
;; Define the length of the hands in terms of the radius of the clock.
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
(lib "framework.ss" "framework")
|
||||
(as-is:unchecked (lib "string.ss") expr->string)
|
||||
(as-is:unchecked (lib "etc.ss") build-vector)
|
||||
(lifted mzscheme regexp-match)
|
||||
;(lifted mzscheme regexp-match)
|
||||
(as-is:unchecked mzscheme make-hash-table hash-table-put! hash-table-get
|
||||
hash-table-remove! let*-values vector-set! make-string
|
||||
exn?
|
||||
|
|
@ -346,10 +346,10 @@
|
|||
|
||||
[scrollbar-updater
|
||||
(list
|
||||
(lift #t (lambda (pg) (set-scroll-page 'horizontal (clip 1 (- pg chars-per-cell -1) 10000))) h-chars-per-page~)
|
||||
(lift #t (lambda (pg) (set-scroll-page 'vertical (clip 1 (sub1 pg) 10000))) v-cells-per-page~)
|
||||
(lift #t (lambda (rng) (set-scroll-range 'horizontal (clip 1 rng 10000))) h-scroll-range~)
|
||||
(lift #t (lambda (rng) (set-scroll-range 'vertical (clip 1 rng 10000))) v-scroll-range~))]
|
||||
(lift-strict (lambda (pg) (set-scroll-page 'horizontal (clip 1 (- pg chars-per-cell -1) 10000))) h-chars-per-page~)
|
||||
(lift-strict (lambda (pg) (set-scroll-page 'vertical (clip 1 (sub1 pg) 10000))) v-cells-per-page~)
|
||||
(lift-strict (lambda (rng) (set-scroll-range 'horizontal (clip 1 rng 10000))) h-scroll-range~)
|
||||
(lift-strict (lambda (rng) (set-scroll-range 'vertical (clip 1 rng 10000))) v-scroll-range~))]
|
||||
|
||||
[scroller ((merge-e (changes h-scroll-pos~)
|
||||
(changes v-scroll-pos~)) . -=> . (refresh))]
|
||||
|
|
@ -409,7 +409,7 @@
|
|||
[focuser ((key-events . =#> . (lambda (ev) (eq? #\return (send ev get-key-code))))
|
||||
. -=> . (send text-field focus))]
|
||||
|
||||
[text-field-switcher (lift #t (lambda (row col)
|
||||
[text-field-switcher (lift-strict (lambda (row col)
|
||||
(unless (or (negative? row)
|
||||
(negative? col))
|
||||
(send text-field set-value (ss-get-cell-text row col))))
|
||||
|
|
|
|||
|
|
@ -142,6 +142,17 @@
|
|||
; update the given signal at the given time
|
||||
(define-struct alarm (time signal))
|
||||
|
||||
(define extra-cont-marks (make-parameter #f))
|
||||
|
||||
(define (effective-continuation-marks)
|
||||
(if (extra-cont-marks)
|
||||
(begin
|
||||
#;(thread (lambda () (raise (make-exn:fail
|
||||
"extra marks present!" (extra-cont-marks)))))
|
||||
(compose-continuation-mark-sets
|
||||
(extra-cont-marks)
|
||||
(current-continuation-marks)))
|
||||
(current-continuation-marks)))
|
||||
|
||||
;; Simple Structure Combinators
|
||||
|
||||
|
|
@ -162,7 +173,7 @@
|
|||
(apply proc->signal (lambda the-args (apply proc/emit the-args) out) deps)))
|
||||
|
||||
(define (build-signal ctor thunk producers)
|
||||
(let ([ccm (current-continuation-marks)])
|
||||
(let ([ccm (effective-continuation-marks)])
|
||||
(do-in-manager
|
||||
(let* ([custs (current-custs)]
|
||||
[cust-sigs (map ft-cust-signal custs)]
|
||||
|
|
@ -172,7 +183,8 @@
|
|||
(map safe-signal-depth cust-sigs))))
|
||||
ccm
|
||||
(parameterize ([current-exception-handler
|
||||
(lambda (exn) (exn-handler exn))])
|
||||
(lambda (exn) (exn-handler exn))]
|
||||
[extra-cont-marks ccm])
|
||||
(current-parameterization))
|
||||
(append cust-sigs producers))])
|
||||
;(printf "~a custodians~n" (length custs))
|
||||
|
|
@ -187,7 +199,7 @@
|
|||
sig))))
|
||||
|
||||
(define (proc->signal:switching thunk current-box trigger . producers)
|
||||
(let ([ccm (current-continuation-marks)])
|
||||
(let ([ccm (effective-continuation-marks)])
|
||||
(do-in-manager
|
||||
(let* ([custs (current-custs)]
|
||||
[cust-sigs (map ft-cust-signal custs)]
|
||||
|
|
@ -197,7 +209,8 @@
|
|||
(map safe-signal-depth cust-sigs))))
|
||||
ccm
|
||||
(parameterize ([current-exception-handler
|
||||
(lambda (exn) (exn-handler exn))])
|
||||
(lambda (exn) (exn-handler exn))]
|
||||
[extra-cont-marks ccm])
|
||||
(current-parameterization))
|
||||
(append cust-sigs producers)
|
||||
current-box
|
||||
|
|
@ -221,57 +234,59 @@
|
|||
|
||||
;; mutate! : compound num -> (any -> ())
|
||||
(define (procs->signal:compound ctor mutate! . args)
|
||||
(do-in-manager
|
||||
(let* ([custs (current-custs)]
|
||||
[cust-sigs (map ft-cust-signal custs)]
|
||||
[value (apply ctor (map value-now/no-copy args))]
|
||||
#;[mutators
|
||||
(foldl
|
||||
(lambda (arg idx acc)
|
||||
(if (signal? arg) ; behavior?
|
||||
(cons (proc->signal
|
||||
(let ([m (mutate! value idx)])
|
||||
(lambda ()
|
||||
(let ([v (value-now/no-copy arg)])
|
||||
(m v)
|
||||
'struct-mutator)))
|
||||
arg) acc)
|
||||
acc))
|
||||
empty args (build-list (length args) identity))]
|
||||
[sig (make-signal:compound
|
||||
undefined
|
||||
empty
|
||||
#f
|
||||
(lambda () ;mutators
|
||||
(let loop ([i 0] [args args] [val value])
|
||||
(if (cons? args)
|
||||
(let ([fd (value-now/no-copy (car args))])
|
||||
((mutate! value i) fd)
|
||||
(loop (add1 i) (cdr args)
|
||||
(if (undefined? fd)
|
||||
undefined
|
||||
val)))
|
||||
val)))
|
||||
(add1 (apply max 0 (append (map safe-signal-depth args)
|
||||
(map safe-signal-depth cust-sigs))))
|
||||
(current-continuation-marks)
|
||||
(parameterize ([current-exception-handler
|
||||
(lambda (exn) (exn-handler exn))])
|
||||
(current-parameterization))
|
||||
(append cust-sigs args)
|
||||
(apply ctor args)
|
||||
(lambda () (apply ctor (map value-now args))))])
|
||||
;(printf "mutators = ~a~n" mutators)
|
||||
(when (cons? args)
|
||||
(register sig args))
|
||||
(when (cons? cust-sigs)
|
||||
(register (make-non-scheduled sig) cust-sigs))
|
||||
(for-each (lambda (g) (set-ft-cust-constructed-sigs!
|
||||
g (cons (make-weak-box sig) (ft-cust-constructed-sigs g))))
|
||||
custs)
|
||||
(iq-enqueue sig)
|
||||
;(printf "~n*made a compound [~a]*~n~n" (value-now/no-copy sig))
|
||||
sig)))
|
||||
(let ([ccm (effective-continuation-marks)])
|
||||
(do-in-manager
|
||||
(let* ([custs (current-custs)]
|
||||
[cust-sigs (map ft-cust-signal custs)]
|
||||
[value (apply ctor (map value-now/no-copy args))]
|
||||
#;[mutators
|
||||
(foldl
|
||||
(lambda (arg idx acc)
|
||||
(if (signal? arg) ; behavior?
|
||||
(cons (proc->signal
|
||||
(let ([m (mutate! value idx)])
|
||||
(lambda ()
|
||||
(let ([v (value-now/no-copy arg)])
|
||||
(m v)
|
||||
'struct-mutator)))
|
||||
arg) acc)
|
||||
acc))
|
||||
empty args (build-list (length args) identity))]
|
||||
[sig (make-signal:compound
|
||||
undefined
|
||||
empty
|
||||
#f
|
||||
(lambda () ;mutators
|
||||
(let loop ([i 0] [args args] [val value])
|
||||
(if (cons? args)
|
||||
(let ([fd (value-now/no-copy (car args))])
|
||||
((mutate! value i) fd)
|
||||
(loop (add1 i) (cdr args)
|
||||
(if (undefined? fd)
|
||||
undefined
|
||||
val)))
|
||||
val)))
|
||||
(add1 (apply max 0 (append (map safe-signal-depth args)
|
||||
(map safe-signal-depth cust-sigs))))
|
||||
ccm
|
||||
(parameterize ([current-exception-handler
|
||||
(lambda (exn) (exn-handler exn))]
|
||||
[extra-cont-marks ccm])
|
||||
(current-parameterization))
|
||||
(append cust-sigs args)
|
||||
(apply ctor args)
|
||||
(lambda () (apply ctor (map value-now args))))])
|
||||
;(printf "mutators = ~a~n" mutators)
|
||||
(when (cons? args)
|
||||
(register sig args))
|
||||
(when (cons? cust-sigs)
|
||||
(register (make-non-scheduled sig) cust-sigs))
|
||||
(for-each (lambda (g) (set-ft-cust-constructed-sigs!
|
||||
g (cons (make-weak-box sig) (ft-cust-constructed-sigs g))))
|
||||
custs)
|
||||
(iq-enqueue sig)
|
||||
;(printf "~n*made a compound [~a]*~n~n" (value-now/no-copy sig))
|
||||
sig))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -597,32 +612,34 @@
|
|||
|
||||
(define (super-lift fun bhvr)
|
||||
(if (behavior? bhvr)
|
||||
(do-in-manager
|
||||
(let* ([cust (make-ft-cust (void) empty)]
|
||||
[custs (cons cust (current-custs))]
|
||||
[pfun (lambda (b)
|
||||
(parameterize ([current-custs custs])
|
||||
(fun b)))]
|
||||
[current (box undefined)])
|
||||
(letrec ([custodian-signal
|
||||
(proc->signal:unchanged
|
||||
(lambda ()
|
||||
(for-each kill-signal
|
||||
(filter identity
|
||||
(map weak-box-value (ft-cust-constructed-sigs cust))))
|
||||
(unregister rtn (unbox current))
|
||||
(set-box! current (pfun (value-now/no-copy bhvr)))
|
||||
(register rtn (unbox current))
|
||||
;; keep rtn's producers up-to-date
|
||||
(set-car! (signal-producers rtn) (unbox current))
|
||||
(iq-resort)
|
||||
'custodian)
|
||||
bhvr)]
|
||||
[rtn (proc->signal:switching
|
||||
(lambda () custodian-signal (value-now/no-copy (unbox current)))
|
||||
current custodian-signal undefined bhvr custodian-signal)])
|
||||
(set-ft-cust-signal! cust custodian-signal)
|
||||
rtn)))
|
||||
(parameterize ([extra-cont-marks
|
||||
(effective-continuation-marks)])
|
||||
(do-in-manager
|
||||
(let* ([cust (make-ft-cust (void) empty)]
|
||||
[custs (cons cust (current-custs))]
|
||||
[pfun (lambda (b)
|
||||
(parameterize ([current-custs custs])
|
||||
(fun b)))]
|
||||
[current (box undefined)])
|
||||
(letrec ([custodian-signal
|
||||
(proc->signal:unchanged
|
||||
(lambda ()
|
||||
(for-each kill-signal
|
||||
(filter identity
|
||||
(map weak-box-value (ft-cust-constructed-sigs cust))))
|
||||
(unregister rtn (unbox current))
|
||||
(set-box! current (pfun (value-now/no-copy bhvr)))
|
||||
(register rtn (unbox current))
|
||||
;; keep rtn's producers up-to-date
|
||||
(set-car! (signal-producers rtn) (unbox current))
|
||||
(iq-resort)
|
||||
'custodian)
|
||||
bhvr)]
|
||||
[rtn (proc->signal:switching
|
||||
(lambda () custodian-signal (value-now/no-copy (unbox current)))
|
||||
current custodian-signal undefined bhvr custodian-signal)])
|
||||
(set-ft-cust-signal! cust custodian-signal)
|
||||
rtn))))
|
||||
(fun bhvr)))
|
||||
|
||||
|
||||
|
|
@ -725,11 +742,14 @@
|
|||
(lambda (exn)
|
||||
(when (and cur-beh
|
||||
#;(not (undefined? (signal-value cur-beh))))
|
||||
#;(when (empty? (continuation-mark-set->list
|
||||
(exn-continuation-marks exn) 'frtime))
|
||||
(set! exn (make-exn:fail (exn-message exn)
|
||||
(signal-continuation-marks
|
||||
cur-beh))))
|
||||
;(when (empty? (continuation-mark-set->list
|
||||
; (exn-continuation-marks exn) 'frtime))
|
||||
(set! exn (make-exn:fail
|
||||
(exn-message exn)
|
||||
(compose-continuation-mark-sets
|
||||
(signal-continuation-marks
|
||||
cur-beh)
|
||||
(exn-continuation-marks exn))));)
|
||||
;(raise exn)
|
||||
(iq-enqueue (list exceptions (list exn cur-beh)))
|
||||
(when (behavior? cur-beh)
|
||||
|
|
|
|||
|
|
@ -526,6 +526,92 @@
|
|||
out)])
|
||||
(apply proc->signal thunk args)))))
|
||||
|
||||
(define current-emit (make-parameter #f))
|
||||
(define current-select (make-parameter #f))
|
||||
(define (emit ev)
|
||||
(cond
|
||||
[(current-emit) => (lambda (f) (f ev))]
|
||||
[else (error 'emit "outside of general-event-processor")]))
|
||||
(define (select-proc . clauses)
|
||||
(cond
|
||||
[(current-select) => (lambda (f) (apply f clauses))]
|
||||
[else (error 'select "outside of general-event-processor")]))
|
||||
|
||||
(define-syntax (select stx)
|
||||
(syntax-case stx ()
|
||||
[(select clause ...)
|
||||
(with-syntax ([((e k) ...)
|
||||
(map (lambda (c)
|
||||
(syntax-case c (=>)
|
||||
[(e => k) #'(e k)]
|
||||
[(e exp0 exp1 ...) #'(e (lambda (_) exp0 exp1 ...))]))
|
||||
(syntax-e #'(clause ...)))])
|
||||
#'(select-proc (list e k) ...))]))
|
||||
|
||||
(define (flush . strs)
|
||||
(select-proc (map (lambda (str) (list str void)) strs)))
|
||||
|
||||
(define (general-event-processor2 proc)
|
||||
(do-in-manager
|
||||
(let* ([out (econs undefined undefined)]
|
||||
[emit (lambda (val)
|
||||
(set-erest! out (econs val undefined))
|
||||
(set! out (erest out))
|
||||
val)]
|
||||
[streams (make-hash-table 'weak)]
|
||||
[extracted (make-hash-table 'weak)]
|
||||
[top-esc #f]
|
||||
[rtn (proc->signal void)]
|
||||
[select (lambda e/k-list
|
||||
(let/ec esc
|
||||
(let loop ()
|
||||
(for-each (lambda (e/k)
|
||||
(let* ([e (first e/k)]
|
||||
[x (hash-table-get
|
||||
extracted e
|
||||
(lambda () empty))])
|
||||
(when (cons? x)
|
||||
(hash-table-put!
|
||||
extracted e (rest x))
|
||||
(esc ((second e/k) (first x))))))
|
||||
e/k-list)
|
||||
(for-each (lambda (e/k)
|
||||
(let* ([e (first e/k)])
|
||||
(hash-table-get
|
||||
streams e
|
||||
(lambda ()
|
||||
(register rtn e)
|
||||
(hash-table-put!
|
||||
streams e
|
||||
(signal-value e))))))
|
||||
e/k-list)
|
||||
(let/cc k
|
||||
(set! proc (lambda () (k (void))))
|
||||
(top-esc (void)))
|
||||
(loop))))])
|
||||
(let ([thunk (lambda ()
|
||||
(hash-table-for-each
|
||||
streams
|
||||
(lambda (k v)
|
||||
;; inefficient! appends each new event individually
|
||||
(let loop ([str v])
|
||||
(when (and (econs? str)
|
||||
(not (undefined? (erest str))))
|
||||
(hash-table-put!
|
||||
extracted k
|
||||
(append (hash-table-get extracted k (lambda () empty))
|
||||
(list (efirst (erest str)))))
|
||||
(loop (erest str))))
|
||||
(hash-table-put! streams k (signal-value k))))
|
||||
(let/cc k
|
||||
(set! top-esc k)
|
||||
(parameterize ([current-emit emit]
|
||||
[current-select select])
|
||||
(proc)))
|
||||
out)])
|
||||
(set-signal-thunk! rtn thunk)
|
||||
(iq-enqueue rtn)
|
||||
rtn))))
|
||||
|
||||
(define (event-processor proc . args)
|
||||
(let* ([out (econs undefined undefined)]
|
||||
|
|
@ -546,7 +632,27 @@
|
|||
out)])
|
||||
(apply proc->signal thunk args)))
|
||||
|
||||
;; split : event[a] (a -> b) -> (b -> event[a])
|
||||
(define (split ev fn)
|
||||
(let* ([ht (make-hash-table 'weak)]
|
||||
[sig (map-e (lambda (e)
|
||||
(let/ec k
|
||||
(send-event
|
||||
(hash-table-get ht (fn e) (lambda () (k (void))))
|
||||
e)))
|
||||
ev)])
|
||||
(lambda (x)
|
||||
sig
|
||||
(hash-table-get
|
||||
ht x (lambda ()
|
||||
(let ([rtn (event-receiver)])
|
||||
(hash-table-put! ht x rtn)
|
||||
rtn))))))
|
||||
|
||||
(define-syntax event-select
|
||||
(syntax-rules ()
|
||||
[(_ [ev k] ...)
|
||||
()]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Command Lambda
|
||||
|
|
@ -678,6 +784,9 @@
|
|||
nothing
|
||||
nothing?
|
||||
general-event-processor
|
||||
general-event-processor2
|
||||
emit
|
||||
select
|
||||
event-processor
|
||||
switch
|
||||
merge-e
|
||||
|
|
@ -719,6 +828,7 @@
|
|||
mk-command-lambda
|
||||
until
|
||||
event-loop
|
||||
split
|
||||
|
||||
;; from frp-core
|
||||
event-receiver
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user