fix and set svn:eol-style
svn: r1801
This commit is contained in:
Eli Barzilay
parent
f10e1e5b29
commit
49dc4350a4
|
|
@ -1,104 +1,104 @@
|
|||
(require (lib "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 ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; create a mixin using the macro
|
||||
(define label-lifter
|
||||
(behavior->callbacks label ; name of the init field
|
||||
set-label ; callback to invoke
|
||||
))
|
||||
|
||||
; apply the mixin to a class (and a default value).
|
||||
; whenever the "label" argument of a fr-label-frame changes,
|
||||
; set-label will be invoked with the current value of the
|
||||
; supplied label behavior
|
||||
(define fr-label-frame% (label-lifter "" frame%))
|
||||
|
||||
; each second, the label will be changed to the current value of
|
||||
; seconds
|
||||
(define my-frame
|
||||
(new fr-label-frame% (label (number->string seconds))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; events->callbacks ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; create a mixin using the macro
|
||||
(define set-value-lifter
|
||||
(events->callbacks value-set-e ; name of the init field
|
||||
set-value ; callback to invoke
|
||||
))
|
||||
|
||||
; apply the mixin
|
||||
; fr-value-text-field%s will set their value to the value of
|
||||
; the event occurances supplied in the initialization argument
|
||||
; value-set-e
|
||||
(define fr-value-text-field% (set-value-lifter text-field%))
|
||||
|
||||
; every 10 seconds, the my-text will set its value to be that
|
||||
; of seconds
|
||||
(define my-text
|
||||
(new fr-value-text-field%
|
||||
(label "")
|
||||
(value-set-e
|
||||
(map-e number->string
|
||||
(filter-e (lambda (evt) (zero? (modulo evt 10)))
|
||||
(changes seconds))))
|
||||
(parent my-frame)))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; callbacks->args-evts ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; 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%))
|
||||
|
||||
; 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")))
|
||||
|
||||
; 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")))
|
||||
|
||||
; 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")))
|
||||
|
||||
; get the streams from the check boxes
|
||||
(send my-cb1 get-focus-events)
|
||||
(send my-cb2 get-focus-events)
|
||||
(send my-cb3 get-focus-events)
|
||||
|
||||
|
||||
;; SHOW THE FRAME
|
||||
(require (lib "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 ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; create a mixin using the macro
|
||||
(define label-lifter
|
||||
(behavior->callbacks label ; name of the init field
|
||||
set-label ; callback to invoke
|
||||
))
|
||||
|
||||
; apply the mixin to a class (and a default value).
|
||||
; whenever the "label" argument of a fr-label-frame changes,
|
||||
; set-label will be invoked with the current value of the
|
||||
; supplied label behavior
|
||||
(define fr-label-frame% (label-lifter "" frame%))
|
||||
|
||||
; each second, the label will be changed to the current value of
|
||||
; seconds
|
||||
(define my-frame
|
||||
(new fr-label-frame% (label (number->string seconds))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; events->callbacks ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; create a mixin using the macro
|
||||
(define set-value-lifter
|
||||
(events->callbacks value-set-e ; name of the init field
|
||||
set-value ; callback to invoke
|
||||
))
|
||||
|
||||
; apply the mixin
|
||||
; fr-value-text-field%s will set their value to the value of
|
||||
; the event occurances supplied in the initialization argument
|
||||
; value-set-e
|
||||
(define fr-value-text-field% (set-value-lifter text-field%))
|
||||
|
||||
; every 10 seconds, the my-text will set its value to be that
|
||||
; of seconds
|
||||
(define my-text
|
||||
(new fr-value-text-field%
|
||||
(label "")
|
||||
(value-set-e
|
||||
(map-e number->string
|
||||
(filter-e (lambda (evt) (zero? (modulo evt 10)))
|
||||
(changes seconds))))
|
||||
(parent my-frame)))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; callbacks->args-evts ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; 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%))
|
||||
|
||||
; 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")))
|
||||
|
||||
; 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")))
|
||||
|
||||
; 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")))
|
||||
|
||||
; get the streams from the check boxes
|
||||
(send my-cb1 get-focus-events)
|
||||
(send my-cb2 get-focus-events)
|
||||
(send my-cb3 get-focus-events)
|
||||
|
||||
|
||||
;; SHOW THE FRAME
|
||||
(send my-frame show #t)
|
||||
|
|
@ -1,111 +1,111 @@
|
|||
> FtA (Forte GUI library)
|
||||
|
||||
MACROS
|
||||
-------
|
||||
To get the 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->args-evts stream-name callback (args-to-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.
|
||||
|
||||
FtA provides event-is-val, split-mouse-events/type, and
|
||||
split-key-events/type for use as initialization arguments.
|
||||
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).
|
||||
|
||||
|
||||
MIXINS
|
||||
------
|
||||
Some common mixins have already been defined and applied.
|
||||
To get these:
|
||||
(require "fred.ss" "frtime" "demos" "gui")
|
||||
|
||||
> (add-mouse-access super-class)
|
||||
Derived from callbacks->args-evts.
|
||||
stream-name: mouse-events
|
||||
|
||||
> (add-focus-access super-class)
|
||||
Derived from callbacks->args-evts
|
||||
stream-name: focus-events
|
||||
|
||||
> (add-keypress-split super-class)
|
||||
Derived from callbacks->args-evts.
|
||||
stream-name: key-events
|
||||
|
||||
> (add-callback-access value-extractor default-value super-class)
|
||||
value-extractor is a method of two arguments (a widget
|
||||
and a control event) that gets a value for the widget.
|
||||
default-value is the default value for the widget. Adds
|
||||
(get-value-e) and (get-value-b) to super-class, where
|
||||
get-value-e returns an event stream representing the
|
||||
value of the widget, and get-value-b returns a behavior
|
||||
representing the value of the widget.
|
||||
|
||||
> (add-callback-access/loop value-extractor default-value super-class)
|
||||
does the work of add-callback-access, but also adds
|
||||
an initialization argument value-set, which is an
|
||||
event stream that sets the value of the widget at
|
||||
each event.
|
||||
|
||||
> (add-focus-on-event super-class)
|
||||
Derived from events->callbacks.
|
||||
field-name: focus-when
|
||||
|
||||
|
||||
UTILITY
|
||||
-------
|
||||
|
||||
> (standard-lift widget value-method value-default)
|
||||
standard-lift applys a common set of mixins to the
|
||||
widget. It applies add-mouse-access, add-focus-access,
|
||||
and it applys the result of behavior->callback for
|
||||
label and enable. It also applies add-callback-access
|
||||
with value-method as the value-extractor, and
|
||||
value-default as the default-value.
|
||||
Widgets that have been standard-lift'ed:
|
||||
ft-button%
|
||||
ft-radio-box%
|
||||
ft-choice%
|
||||
ft-list-box%
|
||||
|
||||
|
||||
> (standard-lift/loop widget value-method value-default)
|
||||
standard-lift/loop is the same as standard-lift,
|
||||
except thatit applies add-callback-access/loop
|
||||
instead of add-callback-access.
|
||||
Widgets that have been standard-lift/loop'ed:
|
||||
ft-check-box%
|
||||
ft-slider%
|
||||
ft-text-field%
|
||||
|
||||
|
||||
simple.ss
|
||||
---------
|
||||
|
||||
Many useful utilities have been put in
|
||||
(require "simple.ss" "frtime" "demos" "gui")
|
||||
feel free to look around and use the ones you think are
|
||||
useful.
|
||||
|
||||
> FtA (Forte GUI library)
|
||||
|
||||
MACROS
|
||||
-------
|
||||
To get the 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->args-evts stream-name callback (args-to-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.
|
||||
|
||||
FtA provides event-is-val, split-mouse-events/type, and
|
||||
split-key-events/type for use as initialization arguments.
|
||||
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).
|
||||
|
||||
|
||||
MIXINS
|
||||
------
|
||||
Some common mixins have already been defined and applied.
|
||||
To get these:
|
||||
(require "fred.ss" "frtime" "demos" "gui")
|
||||
|
||||
> (add-mouse-access super-class)
|
||||
Derived from callbacks->args-evts.
|
||||
stream-name: mouse-events
|
||||
|
||||
> (add-focus-access super-class)
|
||||
Derived from callbacks->args-evts
|
||||
stream-name: focus-events
|
||||
|
||||
> (add-keypress-split super-class)
|
||||
Derived from callbacks->args-evts.
|
||||
stream-name: key-events
|
||||
|
||||
> (add-callback-access value-extractor default-value super-class)
|
||||
value-extractor is a method of two arguments (a widget
|
||||
and a control event) that gets a value for the widget.
|
||||
default-value is the default value for the widget. Adds
|
||||
(get-value-e) and (get-value-b) to super-class, where
|
||||
get-value-e returns an event stream representing the
|
||||
value of the widget, and get-value-b returns a behavior
|
||||
representing the value of the widget.
|
||||
|
||||
> (add-callback-access/loop value-extractor default-value super-class)
|
||||
does the work of add-callback-access, but also adds
|
||||
an initialization argument value-set, which is an
|
||||
event stream that sets the value of the widget at
|
||||
each event.
|
||||
|
||||
> (add-focus-on-event super-class)
|
||||
Derived from events->callbacks.
|
||||
field-name: focus-when
|
||||
|
||||
|
||||
UTILITY
|
||||
-------
|
||||
|
||||
> (standard-lift widget value-method value-default)
|
||||
standard-lift applys a common set of mixins to the
|
||||
widget. It applies add-mouse-access, add-focus-access,
|
||||
and it applys the result of behavior->callback for
|
||||
label and enable. It also applies add-callback-access
|
||||
with value-method as the value-extractor, and
|
||||
value-default as the default-value.
|
||||
Widgets that have been standard-lift'ed:
|
||||
ft-button%
|
||||
ft-radio-box%
|
||||
ft-choice%
|
||||
ft-list-box%
|
||||
|
||||
|
||||
> (standard-lift/loop widget value-method value-default)
|
||||
standard-lift/loop is the same as standard-lift,
|
||||
except thatit applies add-callback-access/loop
|
||||
instead of add-callback-access.
|
||||
Widgets that have been standard-lift/loop'ed:
|
||||
ft-check-box%
|
||||
ft-slider%
|
||||
ft-text-field%
|
||||
|
||||
|
||||
simple.ss
|
||||
---------
|
||||
|
||||
Many useful utilities have been put in
|
||||
(require "simple.ss" "frtime" "demos" "gui")
|
||||
feel free to look around and use the ones you think are
|
||||
useful.
|
||||
|
||||
|
|
|
|||
|
|
@ -1,256 +1,256 @@
|
|||
(module fred (lib "frtime.ss" "frtime")
|
||||
(require "mixin-macros.ss"
|
||||
;"r-label.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
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; 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))))))
|
||||
|
||||
|
||||
;; *-event-processor init-argument values
|
||||
(define event-is-val
|
||||
(lambda (es)
|
||||
(map-e car es)))
|
||||
|
||||
; (send x get-mouse-events) returns a split procedure over the event-type
|
||||
(define split-mouse-events/type
|
||||
(lambda (evt-src)
|
||||
(split (map-e cadr evt-src) (lambda (evt) (send evt get-event-type)))))
|
||||
|
||||
; (send x get-key-events) returns a split procedure over the key code
|
||||
(define split-key-events/type
|
||||
(lambda (evt-src)
|
||||
(split (map-e cadr evt-src) (lambda (evt) (send evt get-key-code)))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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
|
||||
)
|
||||
super-class))
|
||||
|
||||
|
||||
(define (add-focus-access super-class)
|
||||
((callbacks->args-evts focus-events on-focus (is-focused?))
|
||||
super-class))
|
||||
|
||||
(define (add-keypress-split super-class)
|
||||
((callbacks->args-evts key-events on-subwindow-char (w e))
|
||||
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)
|
||||
))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; using events to drive object interaction
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (add-callback-access/loop val-ext super-class)
|
||||
((events->callbacks value-set set-value)
|
||||
(add-callback-access val-ext super-class)))
|
||||
|
||||
|
||||
(define (add-focus-on-event super-class)
|
||||
((events->callbacks focus-when focus-now)
|
||||
(add-focus-now super-class)))
|
||||
|
||||
|
||||
|
||||
;; Special case widgets
|
||||
(define (in-string itm)
|
||||
(if (undefined? itm)
|
||||
""
|
||||
(if (string? itm)
|
||||
itm
|
||||
(expr->string itm))))
|
||||
|
||||
|
||||
|
||||
(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)
|
||||
))
|
||||
|
||||
|
||||
|
||||
|
||||
(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)))
|
||||
|
||||
(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)))))
|
||||
|
||||
(define ft-menu-item%
|
||||
(add-callback-access
|
||||
list
|
||||
(add-void-set-value
|
||||
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
|
||||
(all-from (lib "class.ss"))
|
||||
(all-from "mixin-macros.ss")))
|
||||
|
||||
|
||||
|
||||
(module fred (lib "frtime.ss" "frtime")
|
||||
(require "mixin-macros.ss"
|
||||
;"r-label.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
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; 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))))))
|
||||
|
||||
|
||||
;; *-event-processor init-argument values
|
||||
(define event-is-val
|
||||
(lambda (es)
|
||||
(map-e car es)))
|
||||
|
||||
; (send x get-mouse-events) returns a split procedure over the event-type
|
||||
(define split-mouse-events/type
|
||||
(lambda (evt-src)
|
||||
(split (map-e cadr evt-src) (lambda (evt) (send evt get-event-type)))))
|
||||
|
||||
; (send x get-key-events) returns a split procedure over the key code
|
||||
(define split-key-events/type
|
||||
(lambda (evt-src)
|
||||
(split (map-e cadr evt-src) (lambda (evt) (send evt get-key-code)))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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
|
||||
)
|
||||
super-class))
|
||||
|
||||
|
||||
(define (add-focus-access super-class)
|
||||
((callbacks->args-evts focus-events on-focus (is-focused?))
|
||||
super-class))
|
||||
|
||||
(define (add-keypress-split super-class)
|
||||
((callbacks->args-evts key-events on-subwindow-char (w e))
|
||||
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)
|
||||
))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; using events to drive object interaction
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (add-callback-access/loop val-ext super-class)
|
||||
((events->callbacks value-set set-value)
|
||||
(add-callback-access val-ext super-class)))
|
||||
|
||||
|
||||
(define (add-focus-on-event super-class)
|
||||
((events->callbacks focus-when focus-now)
|
||||
(add-focus-now super-class)))
|
||||
|
||||
|
||||
|
||||
;; Special case widgets
|
||||
(define (in-string itm)
|
||||
(if (undefined? itm)
|
||||
""
|
||||
(if (string? itm)
|
||||
itm
|
||||
(expr->string itm))))
|
||||
|
||||
|
||||
|
||||
(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)
|
||||
))
|
||||
|
||||
|
||||
|
||||
|
||||
(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)))
|
||||
|
||||
(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)))))
|
||||
|
||||
(define ft-menu-item%
|
||||
(add-callback-access
|
||||
list
|
||||
(add-void-set-value
|
||||
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
|
||||
(all-from (lib "class.ss"))
|
||||
(all-from "mixin-macros.ss")))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,80 +1,80 @@
|
|||
(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 ()
|
||||
[(_ 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-e" (syntax-e s-field-name)))])
|
||||
(syntax
|
||||
(lambda (super)
|
||||
(class super
|
||||
(init (field-name (event-receiver)))
|
||||
(super-new)
|
||||
(inherit update-call)
|
||||
(define the-cell-name field-name)
|
||||
|
||||
(for-each-e! the-cell-name
|
||||
(lambda (evt) (update-call 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 ...))
|
||||
(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)
|
||||
(class super-class
|
||||
(init (processor (lambda (x) x)))
|
||||
(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 ...)))
|
||||
|
||||
(define/public (g-name) processed-events))))])))
|
||||
|
||||
|
||||
|
||||
|
||||
(provide behavior->callbacks
|
||||
events->callbacks
|
||||
(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 ()
|
||||
[(_ 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-e" (syntax-e s-field-name)))])
|
||||
(syntax
|
||||
(lambda (super)
|
||||
(class super
|
||||
(init (field-name (event-receiver)))
|
||||
(super-new)
|
||||
(inherit update-call)
|
||||
(define the-cell-name field-name)
|
||||
|
||||
(for-each-e! the-cell-name
|
||||
(lambda (evt) (update-call 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 ...))
|
||||
(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)
|
||||
(class super-class
|
||||
(init (processor (lambda (x) x)))
|
||||
(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 ...)))
|
||||
|
||||
(define/public (g-name) processed-events))))])))
|
||||
|
||||
|
||||
|
||||
|
||||
(provide behavior->callbacks
|
||||
events->callbacks
|
||||
callbacks->args-evts))
|
||||
|
|
@ -1,57 +1,57 @@
|
|||
(module simple (lib "frtime.ss" "frtime")
|
||||
|
||||
(require "fred.ss"
|
||||
(lib "class.ss")
|
||||
(rename (lib "mred.ss" "mred") frame% frame%))
|
||||
|
||||
(define widget (lambda (x) x))
|
||||
(define value-b (lambda (x) (send x get-value-b)))
|
||||
(define value-e (lambda (x) (send x get-value-e)))
|
||||
|
||||
(define default-parent
|
||||
(let ([fr #f])
|
||||
(lambda ()
|
||||
(unless fr
|
||||
(set! fr (new ft-frame%)))
|
||||
fr)))
|
||||
|
||||
(define creation-filter (make-parameter value-b
|
||||
(lambda (f) (if (and (procedure? f) (procedure-arity-includes? f 1))
|
||||
f
|
||||
(error 'creation-filter
|
||||
"expected a procedure of arity 1")))))
|
||||
|
||||
(define current-widget-parent (make-parameter #f))
|
||||
|
||||
(define-syntax add-widget
|
||||
(syntax-rules ()
|
||||
[(_ type arg ...)
|
||||
((creation-filter) (new type (parent (current-widget-parent)) arg ...))]))
|
||||
|
||||
|
||||
(define (filter-widget w)
|
||||
((creation-filter) w))
|
||||
|
||||
(define-syntax mode
|
||||
(syntax-rules ()
|
||||
[(_ proc type arg ...) (parameterize ([creation-filter proc])
|
||||
(add-widget type arg ...))]))
|
||||
|
||||
(define-syntax define-values-rec
|
||||
(syntax-rules ()
|
||||
[(_ [id0 exp0] [id exp] ...)
|
||||
(define-values (id0 id ...)
|
||||
(letrec ([id0 exp0]
|
||||
[id exp] ...)
|
||||
(values id0 id ...)))]))
|
||||
|
||||
|
||||
|
||||
|
||||
(provide (all-defined)
|
||||
(all-from "fred.ss")
|
||||
(all-from (lib "class.ss"))))
|
||||
|
||||
|
||||
|
||||
(module simple (lib "frtime.ss" "frtime")
|
||||
|
||||
(require "fred.ss"
|
||||
(lib "class.ss")
|
||||
(rename (lib "mred.ss" "mred") frame% frame%))
|
||||
|
||||
(define widget (lambda (x) x))
|
||||
(define value-b (lambda (x) (send x get-value-b)))
|
||||
(define value-e (lambda (x) (send x get-value-e)))
|
||||
|
||||
(define default-parent
|
||||
(let ([fr #f])
|
||||
(lambda ()
|
||||
(unless fr
|
||||
(set! fr (new ft-frame%)))
|
||||
fr)))
|
||||
|
||||
(define creation-filter (make-parameter value-b
|
||||
(lambda (f) (if (and (procedure? f) (procedure-arity-includes? f 1))
|
||||
f
|
||||
(error 'creation-filter
|
||||
"expected a procedure of arity 1")))))
|
||||
|
||||
(define current-widget-parent (make-parameter #f))
|
||||
|
||||
(define-syntax add-widget
|
||||
(syntax-rules ()
|
||||
[(_ type arg ...)
|
||||
((creation-filter) (new type (parent (current-widget-parent)) arg ...))]))
|
||||
|
||||
|
||||
(define (filter-widget w)
|
||||
((creation-filter) w))
|
||||
|
||||
(define-syntax mode
|
||||
(syntax-rules ()
|
||||
[(_ proc type arg ...) (parameterize ([creation-filter proc])
|
||||
(add-widget type arg ...))]))
|
||||
|
||||
(define-syntax define-values-rec
|
||||
(syntax-rules ()
|
||||
[(_ [id0 exp0] [id exp] ...)
|
||||
(define-values (id0 id ...)
|
||||
(letrec ([id0 exp0]
|
||||
[id exp] ...)
|
||||
(values id0 id ...)))]))
|
||||
|
||||
|
||||
|
||||
|
||||
(provide (all-defined)
|
||||
(all-from "fred.ss")
|
||||
(all-from (lib "class.ss"))))
|
||||
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user