diff --git a/collects/frtime/README b/collects/frtime/demos/README similarity index 90% rename from collects/frtime/README rename to collects/frtime/demos/README index fa1280d7c0..2f34aa47cd 100644 --- a/collects/frtime/README +++ b/collects/frtime/demos/README @@ -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 diff --git a/collects/frtime/demos/gui/aux-mixin-macros.ss b/collects/frtime/demos/gui/aux-mixin-macros.ss new file mode 100644 index 0000000000..2b7ff740d1 --- /dev/null +++ b/collects/frtime/demos/gui/aux-mixin-macros.ss @@ -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- 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- 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))) \ No newline at end of file diff --git a/collects/frtime/demos/gui/demo/bindec.ss b/collects/frtime/demos/gui/demo/bindec.ss index 8fb6df2ff3..a205651d93 100644 --- a/collects/frtime/demos/gui/demo/bindec.ss +++ b/collects/frtime/demos/gui/demo/bindec.ss @@ -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) \ No newline at end of file diff --git a/collects/frtime/demos/gui/demo/instr.ss b/collects/frtime/demos/gui/demo/instr.ss index b444c3fadf..4a76d507a3 100644 --- a/collects/frtime/demos/gui/demo/instr.ss +++ b/collects/frtime/demos/gui/demo/instr.ss @@ -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) \ No newline at end of file diff --git a/collects/frtime/demos/gui/demo/timer.ss b/collects/frtime/demos/gui/demo/timer.ss index 7131cdd865..cead671687 100644 --- a/collects/frtime/demos/gui/demo/timer.ss +++ b/collects/frtime/demos/gui/demo/timer.ss @@ -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"))]) diff --git a/collects/frtime/demos/gui/doc.txt b/collects/frtime/demos/gui/doc.txt index dc2c19f0fb..bd40ba959b 100644 --- a/collects/frtime/demos/gui/doc.txt +++ b/collects/frtime/demos/gui/doc.txt @@ -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 ------ diff --git a/collects/frtime/demos/gui/fred.ss b/collects/frtime/demos/gui/fred.ss index 69a32e9335..97c136882b 100644 --- a/collects/frtime/demos/gui/fred.ss +++ b/collects/frtime/demos/gui/fred.ss @@ -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"))) diff --git a/collects/frtime/demos/gui/mixin-macros.ss b/collects/frtime/demos/gui/mixin-macros.ss index d79ea03514..d04d215420 100644 --- a/collects/frtime/demos/gui/mixin-macros.ss +++ b/collects/frtime/demos/gui/mixin-macros.ss @@ -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)) \ No newline at end of file diff --git a/collects/frtime/demos/gui/simple.ss b/collects/frtime/demos/gui/simple.ss index 8d8efc0f11..aa745d6959 100644 --- a/collects/frtime/demos/gui/simple.ss +++ b/collects/frtime/demos/gui/simple.ss @@ -54,3 +54,4 @@ + \ No newline at end of file diff --git a/collects/frtime/frp-snip.ss b/collects/frtime/frp-snip.ss index 8b2ab76e90..2944f60af0 100644 --- a/collects/frtime/frp-snip.ss +++ b/collects/frtime/frp-snip.ss @@ -82,6 +82,16 @@ [(event? beh) (format "#" (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) diff --git a/collects/frtime/frtime-tool.ss b/collects/frtime/frtime-tool.ss index b402445a87..58760bfdc0 100644 --- a/collects/frtime/frtime-tool.ss +++ b/collects/frtime/frtime-tool.ss @@ -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)