332 lines
9.6 KiB
Racket
332 lines
9.6 KiB
Racket
(module fred frtime
|
|
(require "mixin-macros.ss"
|
|
"aux-mixin-macros.ss"
|
|
mzlib/class
|
|
mzlib/string
|
|
texpict/mrpict
|
|
(all-except mred send-event)
|
|
framework)
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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 (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
|
|
(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)))))
|
|
|
|
|
|
(define (send-for-value w e)
|
|
(send w get-value))
|
|
|
|
(define (send-for-selection w e)
|
|
(send w get-selection))
|
|
|
|
(define (send-for-selections w e)
|
|
(send w get-selections))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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
|
|
)
|
|
split-mouse-events/type
|
|
super-class))
|
|
|
|
|
|
(define (add-focus-access super-class)
|
|
((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)
|
|
split-key-events/type
|
|
super-class))
|
|
|
|
|
|
(define (add-size-access super-class)
|
|
((callbacks->args-evts size-events on-size)
|
|
(lambda (x) x)
|
|
(class super-class
|
|
(super-new)
|
|
(define/public (get-size-as-list)
|
|
(list (send this get-width)
|
|
(send this get-height))))))
|
|
|
|
|
|
|
|
(define (add-size-b super-class)
|
|
((mixin-hold size-b get-size-as-list get-size-events)
|
|
(add-size-access super-class)))
|
|
|
|
|
|
|
|
(define (add-position-access super-class)
|
|
((callbacks->args-evts position-events on-move)
|
|
(lambda (x) x)
|
|
(class super-class
|
|
(super-new)
|
|
(define/public (get-position-as-list)
|
|
(list (send this get-x)
|
|
(send this get-y))))))
|
|
|
|
|
|
(define (add-position-b super-class)
|
|
((mixin-hold position-b
|
|
get-position-as-list
|
|
get-position-events)
|
|
(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-callback-access val-ext super-class)
|
|
((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-callback-access/selection val-ext super-class)
|
|
((mixin-merge-e
|
|
selection-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-callback-access/selections val-ext super-class)
|
|
((mixin-merge-e
|
|
selections-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 get-value get-value-e))
|
|
|
|
(define add-selection-b (mixin-hold selection-b get-selection get-selection-e))
|
|
|
|
(define add-selections-b (mixin-hold selections-b get-selections get-selections-e))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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)
|
|
(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))))
|
|
|
|
|
|
|
|
|
|
|
|
(define (control-stretchability default widget)
|
|
(add-signal-controls
|
|
widget
|
|
(stretchable-width stretchable-width default)
|
|
(stretchable-height stretchable-width default)))
|
|
|
|
;; 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)
|
|
))))))))
|
|
|
|
(define (standard-container-lift widget)
|
|
(control-stretchability
|
|
#t
|
|
(standard-lift widget)))
|
|
|
|
|
|
(define (standard-input-lift accessor val-ext)
|
|
(lambda (super-class)
|
|
(add-value-b
|
|
(accessor val-ext super-class))))
|
|
|
|
(define (selection-input-lift accessor val-ext)
|
|
(lambda (super-class)
|
|
(add-selection-b
|
|
(accessor val-ext super-class))))
|
|
|
|
(define (selections-input-lift accessor val-ext)
|
|
(lambda (super-class)
|
|
(add-selections-b
|
|
(accessor val-ext super-class))))
|
|
|
|
(define ft-frame%
|
|
((behavior->callbacks shown show)
|
|
#f
|
|
(add-shown
|
|
(standard-container-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 send-for-value)
|
|
(standard-lift check-box%)))
|
|
|
|
(define ft-slider%
|
|
((standard-input-lift add-callback-access/loop 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%
|
|
((selection-input-lift add-callback-access/selection send-for-selection)
|
|
(add-void-set-value (standard-lift radio-box%))))
|
|
|
|
(define ft-choice%
|
|
((selection-input-lift add-callback-access/selection send-for-selection)
|
|
(add-void-set-value (standard-lift choice%))))
|
|
|
|
(define ft-list-box%
|
|
(class ((selections-input-lift add-callback-access/selections send-for-selections)
|
|
(add-void-set-value (standard-lift list-box%)))
|
|
(super-new)
|
|
(define/public (get-selection-b)
|
|
(let ([selections-b (send this get-selections-b)])
|
|
(if (null? selections-b)
|
|
#f
|
|
(car selections-b))))))
|
|
|
|
(define ft-canvas%
|
|
(class (standard-lift canvas%)
|
|
(inherit get-dc refresh get-width get-height)
|
|
(init-field pict)
|
|
(define bitmap #f)
|
|
(define bitmap-dc #f)
|
|
(super-new [paint-callback (lambda (canvas dc)
|
|
(unless (and bitmap
|
|
(= (send bitmap get-width) (get-width))
|
|
(= (send bitmap get-height) (get-height)))
|
|
(set! bitmap (make-object bitmap% (get-width) (get-height)))
|
|
(set! bitmap-dc (new bitmap-dc% [bitmap bitmap])))
|
|
(unless (undefined? (value-now pict))
|
|
(send bitmap-dc clear)
|
|
(draw-pict (value-now pict) bitmap-dc 0 0)
|
|
(send dc draw-bitmap bitmap 0 0)))])
|
|
(for-each-e! (changes pict) (lambda (_) (refresh)))))
|
|
|
|
;; Special case widgets
|
|
|
|
|
|
(define specialized-gauge%
|
|
(add-signal-controls
|
|
(class gauge%
|
|
(init value)
|
|
(super-new)
|
|
(send this set-value value))
|
|
(value set-value 0)
|
|
(range set-range 1)))
|
|
|
|
|
|
(define ft-gauge%
|
|
(standard-lift specialized-gauge%))
|
|
|
|
|
|
(define ft-menu-item%
|
|
(add-callback-access
|
|
list
|
|
(add-void-set-value
|
|
menu-item%)))
|
|
|
|
|
|
(provide (all-defined)
|
|
(all-from mzlib/class)
|
|
(all-from "mixin-macros.ss")
|
|
(all-from "aux-mixin-macros.ss")))
|
|
|
|
|
|
|