33ec3576cc
* fix a bug in initialization of FrTime widgets * fix a bug in the pong demo * allow needles and growing points to have larger grids * purge the old GUI wrapper implementation * fix a couple of bugs in the debugger * add bitmap support to the animation library svn: r9647
61 lines
2.5 KiB
Scheme
61 lines
2.5 KiB
Scheme
(module mixin-macros frtime
|
|
(require mzlib/class)
|
|
|
|
|
|
(define-syntax events->callbacks
|
|
(lambda (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)))]
|
|
[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 (renamed-update update-call))
|
|
(define the-cell-name field-name)
|
|
(for-each-e! the-cell-name
|
|
(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)
|
|
(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 (default-proc super-class)
|
|
(class super-class
|
|
(init (processor default-proc))
|
|
(define name-e (event-receiver))
|
|
(define processed-events (processor name-e))
|
|
(super-new)
|
|
;what about when the super call returns an error?
|
|
(define/override method-name
|
|
(lambda args
|
|
(send-event name-e args)
|
|
(super method-name . args)))
|
|
(define/public (g-name) processed-events))))])))
|
|
|
|
|
|
|
|
(provide events->callbacks
|
|
callbacks->args-evts))
|