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

- moved README into demos/

Browse Source 
- updated GUI bindings

svn: r2710
This commit is contained in:
Greg Cooper 2006-04-18 23:43:59 +00:00
parent fb89fc53ef
commit 9fe113940e
11 changed files with 406 additions and 259 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/frtime/README → collects/frtime/demos/README
View File

@ -1,8 +1,9 @@
This directory contains the source code for FrTime.
This directory contains the source code for a collection of demos for
FrTime.
To run the animation/GUI demos, simply set the language level to
FrTime, open the corresponding file, and Execute. See the demo source
To run the animation/GUI demos, simply open the corresponding file,
set the language level to FrTime, and Execute. See the demo source
code for more information.
orbit-mouse.ss : A collection of balls that move in circles around

80
collects/frtime/demos/gui/aux-mixin-macros.ss Normal file
View File

@ -0,0 +1,80 @@
(module aux-mixin-macros (lib "frtime.ss" "frtime")
(require "mixin-macros.ss")
(require (lib "class.ss"))
;; consider taking out setter
; currently, get-<field-name> will return an event stream
(define-syntax behavior->callbacks
(lambda (stx)
(syntax-case stx ()
[(_ field-name update-call)
(let ([s-field-name (syntax field-name)])
(with-syntax ([the-cell-name (string->symbol
(format "~a-cell" (syntax-e s-field-name)))]
[init-beh-val (string->symbol
(format "value-now-~a-b" (syntax-e s-field-name)))])
(syntax
(lambda (default super)
(class ((events->callbacks field-name update-call)
(class super
(init init-beh-val)
(super-new (field-name init-beh-val))))
(init (field-name default))
(super-new (field-name (changes (default . until . field-name)))
(init-beh-val (value-now (default . until . field-name))))
)))))]
)))
(define-syntax (embed-processor stx)
(syntax-case stx ()
[(_ processed-name processor getter ...)
(with-syntax ([processed-getter (string->symbol
(format "get-~a" (syntax-e (syntax processed-name))))])
#'(lambda (super-class)
(class super-class
(super-new)
(inherit getter ...)
(define processed-name (processor (getter) ...))
(define/public (processed-getter) processed-name))))]))
; merges event streams created by callbacks->args-evts
(define-syntax (mixin-merge-e stx)
(syntax-case stx ()
[(_ result-name get-name ...)
#'(embed-processor result-name
(lambda args (apply merge-e args))
get-name ...)]))
; given a name for a behavior, an init-field name, and a getter method,
; produces get-<behavior-name> which is the hold of calling the getter method
; with the initial value being init-field-name
(define-syntax (mixin-hold stx)
(syntax-case stx ()
[(_ b-name init-name getter)
(with-syntax ([init-holder (string->symbol
(format "~a-holder" (syntax-e (syntax init-name))))]
[get-init (string->symbol
(format "get-~a" (syntax-e (syntax init-name))))])
#'(lambda (default-val super-class)
((embed-processor b-name (lambda (es) (hold es (send this get-init))) getter)
(class super-class
(init (init-name default-val))
(define init-holder init-name)
(define/public (get-init) init-holder)
(super-new)))))]))
; batch application of behavior->callbacks
(define-syntax add-signal-controls
(syntax-rules ()
[(_ src (field-name0 update-call0 default-val0) clause ...)
((behavior->callbacks field-name0 update-call0)
default-val0
(add-signal-controls src clause ...))]
[(_ src)
src]))
(provide (all-defined)))

3
collects/frtime/demos/gui/demo/bindec.ss
View File

@ -25,6 +25,7 @@
(define-values-rec
[sld (mode value-b ft-slider%
(stretchable-width #t)
(min-value 0)
(max-value (sub1 (expt 2 SIZE)))
(value-set (changes
@ -40,4 +41,4 @@
(value-set
(changes (place-num->bool i sld)))))))])
(send (current-widget-parent) show #t)
(send (current-widget-parent) show #t)

84
collects/frtime/demos/gui/demo/instr.ss
View File

@ -1,10 +1,11 @@
(require (lib "mixin-macros.ss" "frtime" "demos" "gui")) ;require the macros
(require (lib "mixin-macros.ss" "frtime" "demos" "gui"))
(require (lib "aux-mixin-macros.ss" "frtime" "demos" "gui")) ;require the macros
(require (lib "class.ss")) ; require class utilities
(require (lib "mred.ss" "mred")) ; require base mred library
;;;;;;;;;;;;;;;;;;;;;;;;;
;; behavior->callbacks ;;
;; behavior->callbacks ;; (aux-mixin-macros.ss)
;;;;;;;;;;;;;;;;;;;;;;;;;
; create a mixin using the macro
@ -26,7 +27,7 @@
;;;;;;;;;;;;;;;;;;;;;;;
;; events->callbacks ;;
;; events->callbacks ;; (mixin-macros.ss)
;;;;;;;;;;;;;;;;;;;;;;;
; create a mixin using the macro
@ -54,51 +55,100 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;
;; callbacks->args-evts ;;
;; callbacks->args-evts ;; (mixin-macros.ss)
;;;;;;;;;;;;;;;;;;;;;;;;;;
; create a mixin using the macro
(define focus-lifter
(callbacks->args-evts focus-events ; name of event stream
on-focus ; callback being watched
(is-focused?) ; argument list of callback being watched
))
; apply the mixin
; whenever on-focus is called in a fr-focus-check-box%,
; a list of the argument (is-focused?) is sent to an
; event stream
(define fr-focus-check-box% (focus-lifter check-box%))
(define fr-focus-check-box% (focus-lifter (lambda (x) x) check-box%))
; the focus-events-event-processor is applied to the
; event stream that carries events from on-focus.
(define my-cb1 (new fr-focus-check-box%
(parent my-frame)
(label "Check1")))
(parent my-frame)
(label "Check1")))
; Because these events are lists of one element (the only
; argument to on-focus), car effectively extracts the
; value indicated by the callback (is-focused?).
(define my-cb2 (new fr-focus-check-box%
(parent my-frame)
(focus-events-event-processor
(lambda (es) (map-e car es)))
(label "Check2")))
(parent my-frame)
(focus-events-event-processor
(lambda (es) (map-e car es)))
(label "Check2")))
; focus-events-event-processor is a function of one
; argument, an event stream, and can return anything
; that is convenient
(define my-cb3 (new fr-focus-check-box%
(parent my-frame)
(focus-events-event-processor
(lambda (es) (hold (map-e car es) #f)))
(label "Check3")))
(parent my-frame)
(focus-events-event-processor
(lambda (es) (hold (map-e car es) #f)))
(label "Check3")))
; get the streams from the check boxes
(printf "callbacks->args-evts:~n")
(send my-cb1 get-focus-events)
(send my-cb2 get-focus-events)
(send my-cb3 get-focus-events)
;;;;;;;;;;;;;;;;;;;
;; mixin-merge-e ;; (aux-mixin-macros.ss)
;;;;;;;;;;;;;;;;;;;
; see callbacks->args-evts
(define key-events-lifter
(callbacks->args-evts key-events on-subwindow-char))
; you can stack these mixins as long as you are
; careful about reuse of names
(define fr-focus-and-key-events-check-box%
(key-events-lifter
(lambda (evt-src) (map-e cdr evt-src))
fr-focus-check-box%))
; apply the macro to generate a mixin
(define merge-lifter
(mixin-merge-e
all-events ; name of the event stream created
get-key-events ; getter for one event stream
get-focus-events ; getter for second event stream
))
; apply the mixin
(define fr-merged-access-check-box%
(merge-lifter fr-focus-and-key-events-check-box%))
; now, there is an additional getter method.
; the two event streams for key-events and
; focus-events are still around, but now
; there is also all-events
(define my-cb4 (new fr-merged-access-check-box%
(parent my-frame)
(key-events-event-processor
(lambda (es)
(map-e (lambda (evt) (send (cadr evt) get-key-code)) es)))
(focus-events-event-processor
(lambda (es)
(map-e car es)))
(label "Check4")))
(printf "mixin-merge-e:~n")
(send my-cb4 get-focus-events) ; focus-events
(send my-cb4 get-key-events) ; key-events
(send my-cb4 get-all-events) ; (merge-e focus-events key-events)
;; SHOW THE FRAME
(send my-frame show #t)
(send my-frame show #t)

28
collects/frtime/demos/gui/demo/timer.ss
View File

@ -1,26 +1,20 @@
(require "../simple.ss")
(current-widget-parent (new ft-frame% (label "Timer") (width 400) (height 100)))
(define tenths (quotient milliseconds 100))
(current-widget-parent (new ft-frame% (width 400) (stretchable-width #t)))
(define-values-rec
[range (* 10 (mode value-b ft-slider%
(label "Range: ")
(min-value 10)
(max-value 30)
(init-value 10)))]
[gauge-value (min range (- tenths
(hold
(map-e (lambda (_) (value-now tenths))
reset)
(value-now tenths))))]
[gauge-value (min 15 (- seconds
(hold
(map-e (lambda (_) (value-now seconds))
reset)
(value-now seconds))))]
[gauge (mode widget ft-gauge%
(label "Elapsed: ")
(value gauge-value)
(range range))]
(label "Timer")
(value gauge-value)
(range 15)
(stretchable-width #t))]
[msg (mode widget ft-message%
(label (number->string (quotient gauge-value 10)))
(label (number->string gauge-value))
(stretchable-width #t))]
[reset (mode value-e ft-button% (label "Reset"))])

68
collects/frtime/demos/gui/doc.txt
View File

@ -1,31 +1,30 @@
> FtA (Forte GUI library)
> FrEd (Functional Reactive Editor library)
MACROS
-------
To get the macros:
To get the basic macros:
(require (lib "mixin-macros.ss" "frtime" "demos" "gui"))
> (behavior->callbacks field-name update-call)
Generates a mixin for allowing a behavior to control a widget.
The mixin has two arguments. The mixin's first argument is the
default value for field-name, and the seconds argument is the
class being mixed.
> (events->callbacks field-name update-call)
Generates a mixin for allowing an event stream to drive
callbacks. The one argument to the resulting mixin is the
class to be extended
callbacks. When an event stream is given as the init
value for field-name, that event stream is stored,
and whenever an event occurs on that stream,
update-call is invoked on the value of the event. The
one argument to the resulting mixin is the class being
extended
> (callbacks->args-evts stream-name callback (args-to-callback ...))
> (callbacks->args-evts stream-name callback)
Generates a mixin that sends an event on stream-name when
callback is called. The class has an init field called
[stream-name]-event-processor, which is a function. The
function is applied to an event stream that has an
occurence every time callback is called, and the value
of the events is a list of the arguments to the callback.
The public method (get-[stream-name]) is a public method
of the resulting class that gets the result of applying
[stream-name]-event-processor to the stream of args-evts.
[stream-name]-event-processor, whose value is a function.
The public method (get-[stream-name]) of the resulting class
gets the result of applying [stream-name]-event-processor
to the stream of args-evts. The events on the stream are
lists of the arguments to the callback. The default value
for [stream-name]-event-processor is given as the first
argument to the mixin, and the class being extended is
the second argument to the mixin.
FtA provides event-is-val, split-mouse-events/type, and
split-key-events/type for use as initialization arguments.
@ -33,8 +32,39 @@ event-is-val can be used for [stream-name]-event-processor
when the event should just be the value of the first
argument of the callback. split-*-events/type sets up an
appropriate split (see FrTime docs for split information,
MrEd docs for key-event codes and mouse-event types).
MrEd docs for key-event codes and mouse-event types) over
the type of event occurence.
events->callbacks and callbacks->args-evts are the backbone
of the transition between an object-oriented library and
an event-stream based library. Some common utility macros
are provided from:
(lib "aux-mixin-macros.ss" "frtime" "demo" "gui")
> (behavior->callbacks field-name update-call)
Generates a mixin for allowing a behavior to control a widget.
The mixin has two arguments. The mixin's first argument is the
default value for field-name, and the seconds argument is the
class being mixed. Whenever a behavior is supplied as the value
for field-name, the value-now of that behavior is used as the
super-new argument for filed-name, and whenever there is a
change in that behavior, update-call is invoked with the
current value of the behavior.
> (mixin-merge-e new-stream-name stream-getter1 stream-getter2)
Generates a mixin that provides access to the merge-e
of two event streams. The first argument is the name
of the merged stream. The merged stream can be accessed
by the public method (get-[new-stream-name]). The
method stream-getter1 and stream-getter2 are assumed to
be inherited public methods that return event streams.
For examples of how to use these macros, look at the file
"instr.ss" in collects/frtime/demos/gui/demo.
MIXINS
------

317
collects/frtime/demos/gui/fred.ss
View File

@ -1,43 +1,45 @@
(module fred (lib "frtime.ss" "frtime")
(require "mixin-macros.ss"
;"r-label.ss"
"aux-mixin-macros.ss"
(lib "class.ss")
(lib "string.ss")
(all-except (lib "mred.ss" "mred") send-event)
(lib "framework.ss" "framework"))
(define-syntax add-signal-controls
(syntax-rules ()
[(_ src (field-name0 update-call0 default-val0) clause ...)
((behavior->callbacks field-name0 update-call0)
default-val0
(add-signal-controls src clause ...))]
[(_ src)
src]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helpers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (in-string itm)
(if (undefined? itm)
""
(if (string? itm)
itm
(expr->string itm))))
;; adding assumed methods
(define (add-void-set-value super-class)
(class super-class
(define/public (set-value v) (void))
(super-new)))
(define (add-focus-now super-class)
(class super-class
(super-new)
(inherit focus)
(define/public (focus-now _) (focus))))
(define (callback->pub-meth super-class)
(class super-class
(define/public (callback-method w e) (void))
(super-new (callback (lambda (w e) (callback-method w e))))))
(define (add-shown super-class)
(class super-class
(init (shown #f))
(define shown-val shown)
(super-new)
(inherit show)
(show shown-val)))
;; *-event-processor init-argument values
(define event-is-val
@ -55,54 +57,84 @@
(split (map-e cadr evt-src) (lambda (evt) (send evt get-key-code)))))
(define (send-for-value w e)
(send w get-value))
(define (send-for-selection w e)
(send w get-selection))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; make state available as eventstreams
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (add-mouse-access super-class)
((callbacks->args-evts mouse-events ; Name of event stream
on-subwindow-event ; proc overriding
(window evt) ; arguments for on-subwindow-event. Caused by super being a macro
)
on-subwindow-event ; proc overriding
)
split-mouse-events/type
super-class))
(define (add-focus-access super-class)
((callbacks->args-evts focus-events on-focus (is-focused?))
((callbacks->args-evts focus-events on-focus)
event-is-val
super-class))
(define (add-keypress-split super-class)
((callbacks->args-evts key-events on-subwindow-char (w e))
((callbacks->args-evts key-events on-subwindow-char)
split-key-events/type
super-class))
(define (add-size-access super-class)
((callbacks->args-evts size-events on-size)
(lambda (x) x)
super-class))
(define (add-size-b super-class)
((mixin-hold size-b init-size-b get-size-events)
'(0 0)
(add-size-access super-class)))
(define (add-position-access super-class)
((callbacks->args-evts position-events on-move)
(lambda (x) x)
super-class))
(define (add-position-b super-class)
((mixin-hold position-b init-position-b get-position-events)
'(0 0)
(add-position-access super-class)))
(define (monitor-set-value super-class)
((callbacks->args-evts set-value-events set-value)
event-is-val
super-class))
(define (monitor-callback-method super-class)
((callbacks->args-evts callback-events callback-method)
(lambda (x) x)
super-class))
#|
(define (add-value-b super-class default)
(class super-class
(super-new)
(inherit get-value-e)
(define/public (get-value-b) (hold (get-value-e) default))))
|#
(define (add-callback-access val-ext super-class)
(class ((callbacks->args-evts set-value-events
set-value
(v))
((callbacks->args-evts callback-events
callback-method
(w e))
(callback->pub-meth super-class)))
(super-new (set-value-events-event-processor event-is-val)
(callback-events-event-processor (lambda (es)
(map-e (lambda (e) (apply val-ext e)) es))))
(inherit get-set-value-events get-callback-events)
(define value-e (merge-e (get-set-value-events)
(get-callback-events)))
(define value-b (hold value-e (val-ext this #f)))
(define/public (get-value-e) value-e)
(define/public (get-value-b) value-b)
))
((mixin-merge-e
value-e
get-set-value-events
get-callback-events)
(class (monitor-set-value
(monitor-callback-method
(callback->pub-meth super-class)))
(super-new (callback-events-event-processor
(lambda (es) (map-e (lambda (e) (apply val-ext e)) es)))))))
(define add-value-b (mixin-hold value-b initial-value get-value-e))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -115,142 +147,109 @@
(define (add-focus-on-event super-class)
((events->callbacks focus-when focus-now)
(add-focus-now super-class)))
(class ((events->callbacks focus-when carries-args-for focus)
super-class)
(init (focus-when (event-receiver)))
(define focus-map (map-e (lambda (_) '()) focus-when))
(super-new (focus-when focus-map))))
;; Special case widgets
(define (in-string itm)
(if (undefined? itm)
""
(if (string? itm)
itm
(expr->string itm))))
;; Standard mixin combinations
(define (standard-lift widget)
(add-size-b
(add-position-b
(add-keypress-split
(add-focus-on-event
(add-mouse-access
(add-focus-access
(add-signal-controls
widget
(label set-label "")
(enabled enable #t)
(min-width min-width 0)
(min-height min-height 0)
(stretchable-width stretchable-width #f)
(stretchable-height stretchable-height #f)
))))))))
(define (standard-input-lift accessor default val-ext)
(lambda (super-class)
(add-value-b
default
(accessor val-ext super-class))))
(define ft-frame%
(class ((callbacks->args-evts resize-events on-size (w h))
(add-mouse-access
(add-keypress-split
(add-signal-controls frame%
(label set-label "")))))
(super-new)
))
((behavior->callbacks shown show)
#f
(add-shown
(standard-lift frame%))))
(define ft-message%
(standard-lift message%))
(define ft-button%
(add-callback-access (lambda (w e) e) (add-void-set-value (standard-lift button%))))
(define ft-check-box%
((standard-input-lift add-callback-access/loop #f send-for-value)
(standard-lift check-box%)))
(define ft-slider%
((standard-input-lift add-callback-access/loop 0 send-for-value)
(standard-lift slider%))) ;ideally the default should be the minimum value
(define ft-text-field%
((standard-input-lift add-callback-access/loop "" send-for-value)
(standard-lift text-field%)))
(define ft-radio-box%
((standard-input-lift add-callback-access 0 send-for-selection)
(add-void-set-value (standard-lift radio-box%))))
(define ft-choice%
((standard-input-lift add-callback-access 0 send-for-selection)
(add-void-set-value (standard-lift choice%))))
(define ft-list-box%
((standard-input-lift add-callback-access 0 send-for-selection)
(add-void-set-value (standard-lift list-box%))))
;; Special case widgets
(define ft-message%
(add-mouse-access
(add-focus-access
(add-signal-controls message% (label set-label "") (enabled enable #t)))))
#;(define ft-autoresize-label%
(add-mouse-access
(add-focus-access
(add-signal-controls autoresize-label% (text set-label-text "") (enabled enable #t)))))
(define specialized-gauge%
(class gauge%
(init value)
(super-new)
(inherit set-value)
#;(set-value value)))
(add-signal-controls
(class gauge%
(init value)
(super-new))
(value set-value 0)
(range set-range 1)))
(define ft-gauge%
(add-mouse-access
(add-focus-access
(add-signal-controls specialized-gauge%
(label set-label "")
(enabled enable #t)
(value set-value 0)
(range set-range 1)))))
(standard-lift specialized-gauge%))
(define ft-menu-item%
(add-callback-access
list
(add-void-set-value
menu-item%)))
menu-item%)))
(define (send-for-value w e)
(send w get-value))
(define (send-for-selection w e)
(send w get-selection))
;; Standard mixin combinations
(define (standard-lift widget value-method)
(add-mouse-access
(add-focus-access
(add-callback-access
value-method
(add-signal-controls (add-void-set-value widget) (label set-label "") (enabled enable #t))))))
(define (standard-lift/loop widget value-method)
(add-mouse-access
(add-focus-access
(add-callback-access/loop
value-method
(add-signal-controls widget (label set-label "") (enabled enable #t))))))
(define ft-button%
(standard-lift button% (lambda (w e) e)))
(define ft-check-box%
(standard-lift/loop check-box% send-for-value))
(define ft-radio-box%
(standard-lift radio-box% send-for-selection))
(define ft-choice%
(standard-lift choice% send-for-selection))
(define ft-slider%
(standard-lift/loop slider% send-for-value))
(define ft-list-box%
(standard-lift list-box% send-for-selection))
(define ft-text-field%
(add-keypress-split
(add-focus-on-event
(standard-lift/loop text-field% send-for-value))))
(provide ft-frame%
ft-message%
;ft-autoresize-label%
ft-gauge%
ft-button%
ft-check-box%
ft-radio-box%
ft-choice%
ft-slider%
ft-list-box%
ft-text-field%
ft-menu-item%
menu%
menu-bar%
finder:get-file
finder:put-file
split-mouse-events/type
split-key-events/type
(provide (all-defined)
(all-from (lib "class.ss"))
(all-from "mixin-macros.ss")))
(all-from "mixin-macros.ss")
(all-from "aux-mixin-macros.ss")))

64
collects/frtime/demos/gui/mixin-macros.ss
View File

@ -1,80 +1,60 @@
(module mixin-macros (lib "frtime.ss" "frtime")
(require (lib "class.ss"))
;; consider taking out setter
(define-syntax behavior->callbacks
(lambda (stx)
(syntax-case stx ()
[(_ field-name update-call)
(let ([s-field-name (syntax field-name)])
(with-syntax ([the-cell-name (string->symbol
(format "~a-cell" (syntax-e s-field-name)))]
[getting-name (string->symbol
(format "get-~a-b" (syntax-e s-field-name)))])
(syntax
(lambda (default super)
(class super
(init (field-name default))
(super-new (field-name (value-now field-name)))
(inherit update-call)
(define the-cell-name field-name)
(for-each-e! (changes the-cell-name)
(lambda (evt) (update-call evt))
this)
(define/public (getting-name) the-cell-name))))))])))
(define-syntax events->callbacks
(lambda (stx)
(syntax-case stx ()
(syntax-case stx (carries-args-for)
[(_ field-name update-call)
#'(lambda (super-class)
(class ((events->callbacks field-name carries-args-for update-call)
super-class)
(init (field-name (event-receiver)))
(super-new (field-name (map-e list field-name)))))]
[(_ field-name carries-args-for update-call)
(let ([s-field-name (syntax field-name)])
(with-syntax ([the-cell-name (string->symbol
(format "~a-cell" (syntax-e s-field-name)))]
[getting-name (string->symbol
(format "get-~a-e" (syntax-e s-field-name)))])
(format "get-~a-e" (syntax-e s-field-name)))]
[renamed-update (string->symbol
(format "renamed-~a" (syntax-e (syntax update-call))))])
(syntax
(lambda (super)
(class super
(init (field-name (event-receiver)))
(super-new)
(inherit update-call)
(inherit (renamed-update update-call))
(define the-cell-name field-name)
(for-each-e! the-cell-name
(lambda (evt) (update-call evt))
(lambda (evt) (renamed-update . evt))
this)
(define/public (getting-name) the-cell-name))))))])))
;; overridden method can have >1 form
(define-syntax callbacks->args-evts
(lambda (stx)
(syntax-case stx ()
[(_ ev-name method-name (arg ...))
[(_ ev-name method-name)
(with-syntax ([name-e (string->symbol (format "~a-e" (syntax-e #'ev-name)))]
[g-name (string->symbol (format "get-~a" (syntax-e #'ev-name)))]
[processor (string->symbol (format "~a-event-processor" (syntax-e #'ev-name)))])
#'(lambda (super-class)
#'(lambda (default-proc super-class)
(class super-class
(init (processor (lambda (x) x)))
(init (processor default-proc))
(super-new)
(define name-e (event-receiver))
(define processed-events (processor name-e))
;what about when the super call returns an error?
(define/override method-name
(lambda (arg ...)
(send-event name-e (list arg ...))
(super method-name arg ...)))
(lambda args
(send-event name-e args)
(super method-name . args)))
(define/public (g-name) processed-events))))])))
(provide behavior->callbacks
events->callbacks
callbacks->args-evts))
(provide events->callbacks
callbacks->args-evts))

1
collects/frtime/demos/gui/simple.ss
View File

@ -54,3 +54,4 @@

10
collects/frtime/frp-snip.ss
View File

@ -82,6 +82,16 @@
[(event? beh) (format "#<event (last: ~a)>" (efirst (signal-value beh)))]
[else beh]))
#;(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)))
(let loop ([chars empty])
(let ([c (read-char-or-special in)])
(cond
[(eof-object? c) (list->string (reverse chars))]
[(char? c) (loop (cons c chars))]
[else c])))))
(define (watch beh)
(cond
[(undefined? beh)

3
collects/frtime/frtime-tool.ss
View File

@ -86,7 +86,8 @@
(run-in-user-thread
(lambda ()
(let ([new-watch (namespace-variable-value 'render)]
[set-evspc (namespace-variable-value 'set-eventspace)])
[set-evspc (namespace-variable-value 'set-eventspace)]
[get-rendering (namespace-variable-value 'get-rendering)])
(set-evspc drs-eventspace)
(set! watch-list
((if (weak-member new-watch watch-list)