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

.

Browse Source 
original commit: d554bce64908cffcaf28bfd0cf9e5c63bc32ee33
This commit is contained in:
Matthew Flatt 2001-06-18 22:11:21 +00:00
parent 9814b321c6
commit cefc93e8a4
2 changed files with 27 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/mred/mred.ss
View File

@ -4232,13 +4232,14 @@
(define (strip-tab s) (car (regexp-match (format "^[^~a]*" #\tab) s))) (define (strip-tab s) (car (regexp-match (format "^[^~a]*" #\tab) s)))
(define basic-labelled-menu-item% (define basic-labelled-menu-item%
(class100* mred% (labelled-menu-item<%>) (prnt lbl help-str wx-sub chkble? keymap set-wx) (class100* mred% (labelled-menu-item<%>) (prnt lbl help-str wx-sub chkble? keymap set-wx demand-callback)
(private-field (private-field
[parent prnt] [parent prnt]
[label lbl] [label lbl]
[help-string help-str] [help-string help-str]
[wx-submenu wx-sub] [wx-submenu wx-sub]
[checkable? chkble?] [checkable? chkble?]
[callback demand-callback]
[wx #f] [wx #f]
[wx-parent #f] [wx-parent #f]
[plain-label (string->immutable-string (wx:label->plain-label label))] [plain-label (string->immutable-string (wx:label->plain-label label))]
@ -4253,7 +4254,7 @@
(send wx-parent enable-top (send wx-parent position-of this) on?))) (send wx-parent enable-top (send wx-parent position-of this) on?)))
(set! enabled? (and on? #t)))]) (set! enabled? (and on? #t)))])
(public (public
[on-demand (lambda () (void))] [on-demand (lambda () (callback))]
[get-parent (lambda () parent)] [get-parent (lambda () parent)]
[get-label (lambda () label)] [get-label (lambda () label)]
[set-label (entry-point [set-label (entry-point
@ -4325,7 +4326,7 @@
[else c])) [else c]))
(define basic-selectable-menu-item% (define basic-selectable-menu-item%
(class100* basic-labelled-menu-item% (selectable-menu-item<%>) (lbl checkable? mnu cb shrtcut help-string set-wx) (class100* basic-labelled-menu-item% (selectable-menu-item<%>) (lbl checkable? mnu cb shrtcut help-string set-wx demand-callback)
(rename [super-restore restore] [super-set-label set-label] (rename [super-restore restore] [super-set-label set-label]
[super-is-deleted? is-deleted?] [super-is-deleted? is-deleted?]
[super-is-enabled? is-enabled?] [super-is-enabled? is-enabled?]
@ -4410,7 +4411,7 @@
(sequence (sequence
(set! label (string->immutable-string label)) (set! label (string->immutable-string label))
(let-values ([(new-label keymap) (calc-labels label)]) (let-values ([(new-label keymap) (calc-labels label)])
(super-init menu new-label help-string #f checkable? keymap (lambda (x) (set! wx x) (set-wx x))))))) (super-init menu new-label help-string #f checkable? keymap (lambda (x) (set! wx x) (set-wx x)) demand-callback)))))
(define (check-shortcut-args who label menu callback shortcut help-string) (define (check-shortcut-args who label menu callback shortcut help-string)
(let ([cwho `(constructor ,who)]) (let ([cwho `(constructor ,who)])
@ -4421,13 +4422,13 @@
(check-string/false cwho help-string))) (check-string/false cwho help-string)))
(define menu-item% (define menu-item%
(class100 basic-selectable-menu-item% (label menu callback [shortcut #f] [help-string #f]) (class100 basic-selectable-menu-item% (label menu callback [shortcut #f] [help-string #f] [demand-callback void])
(sequence (sequence
(check-shortcut-args 'menu-item label menu callback shortcut help-string) (check-shortcut-args 'menu-item label menu callback shortcut help-string)
(super-init label #f menu callback shortcut help-string (lambda (x) x))))) (super-init label #f menu callback shortcut help-string (lambda (x) x) demand-callback))))
(define checkable-menu-item% (define checkable-menu-item%
(class100 basic-selectable-menu-item% (label menu callback [shortcut #f] [help-string #f]) (class100 basic-selectable-menu-item% (label menu callback [shortcut #f] [help-string #f] [demand-callback void])
(sequence (sequence
(check-shortcut-args 'checkable-menu-item label menu callback shortcut help-string)) (check-shortcut-args 'checkable-menu-item label menu callback shortcut help-string))
(private-field (private-field
@ -4437,13 +4438,15 @@
[check (entry-point (lambda (on?) (send (send (mred->wx mnu) get-container) check (send wx id) on?)))] [check (entry-point (lambda (on?) (send (send (mred->wx mnu) get-container) check (send wx id) on?)))]
[is-checked? (entry-point (lambda () (send (send (mred->wx mnu) get-container) checked? (send wx id))))]) [is-checked? (entry-point (lambda () (send (send (mred->wx mnu) get-container) checked? (send wx id))))])
(sequence (sequence
(super-init label #t mnu callback shortcut help-string (lambda (x) (set! wx x) x))))) (super-init label #t mnu callback shortcut help-string (lambda (x) (set! wx x) x) demand-callback))))
(define menu-item-container<%> (interface () get-items on-demand)) (define menu-item-container<%> (interface () get-items on-demand))
(define internal-menu<%> (interface ())) (define internal-menu<%> (interface ()))
(define menu% (define menu%
(class100* basic-labelled-menu-item% (menu-item-container<%> internal-menu<%>) (label parent [help-string #f]) (class100* basic-labelled-menu-item% (menu-item-container<%> internal-menu<%>) (label parent [help-string #f] [demand-callback void])
(private-field
[callback demand-callback])
(sequence (sequence
(check-string '(constructor menu) label) (check-string '(constructor menu) label)
(menu-or-bar-parent 'menu parent) (menu-or-bar-parent 'menu parent)
@ -4452,6 +4455,7 @@
[get-items (entry-point (lambda () (send wx-menu get-items)))]) [get-items (entry-point (lambda () (send wx-menu get-items)))])
(override (override
[on-demand (lambda () [on-demand (lambda ()
(callback)
(for-each (for-each
(lambda (i) (lambda (i)
(when (is-a? i labelled-menu-item<%>) (when (is-a? i labelled-menu-item<%>)
@ -4463,19 +4467,22 @@
(as-entry (as-entry
(lambda () (lambda ()
(set! wx-menu (make-object wx-menu% this #f void)) (set! wx-menu (make-object wx-menu% this #f void))
(super-init parent label help-string wx-menu #f (send wx-menu get-keymap) (lambda (x) x)) (super-init parent label help-string wx-menu #f (send wx-menu get-keymap) (lambda (x) x) void)
(let ([wx-item (mred->wx this)]) (let ([wx-item (mred->wx this)])
(set-cdr! (send wx-item get-menu-data) wx-menu) ; for meta-shortcuts (set-cdr! (send wx-item get-menu-data) wx-menu) ; for meta-shortcuts
(send wx-item set-wx-menu wx-menu))))))) (send wx-item set-wx-menu wx-menu)))))))
(define popup-menu% (define popup-menu%
(class100* mred% (menu-item-container<%> internal-menu<%>) ([title #f][popdown-callback void]) (class100* mred% (menu-item-container<%> internal-menu<%>) ([title #f][popdown-callback void][demand-callback void])
(private-field
[callback demand-callback])
(public (public
[get-popup-target [get-popup-target
(lambda () (lambda ()
(send wx get-popup-grabber))] (send wx get-popup-grabber))]
[get-items (entry-point (lambda () (send wx get-items)))] [get-items (entry-point (lambda () (send wx get-items)))]
[on-demand (lambda () [on-demand (lambda ()
(callback)
(for-each (for-each
(lambda (i) (lambda (i)
(when (is-a? i labelled-menu-item<%>) (when (is-a? i labelled-menu-item<%>)
@ -4504,9 +4511,10 @@
(super-init wx)))))) (super-init wx))))))
(define menu-bar% (define menu-bar%
(class100* mred% (menu-item-container<%>) (parent) (class100* mred% (menu-item-container<%>) (parent [demand-callback void])
(sequence (barless-frame-parent parent)) (sequence (barless-frame-parent parent))
(private-field (private-field
[callback demand-callback]
[prnt parent] [prnt parent]
[wx #f] [wx #f]
[wx-parent #f] [wx-parent #f]
@ -4517,6 +4525,7 @@
[enable (entry-point (lambda (on?) (send wx enable-all on?)))] [enable (entry-point (lambda (on?) (send wx enable-all on?)))]
[is-enabled? (entry-point (lambda () (send wx all-enabled?)))] [is-enabled? (entry-point (lambda () (send wx all-enabled?)))]
[on-demand (lambda () [on-demand (lambda ()
(callback)
(for-each (for-each
(lambda (i) (send i on-demand)) (lambda (i) (send i on-demand))
(send wx get-items)))]) (send wx get-items)))])

12
collects/mred/private/kernel.ss
View File

@ -405,23 +405,23 @@
get-pixel) get-pixel)
(define-class post-script-dc% dc% ([interactive? #t] [parent #f])) (define-class post-script-dc% dc% ([interactive? #t] [parent #f]))
(define-class printer-dc% dc% ([parent #f])) (define-class printer-dc% dc% ([parent #f]))
(define-class event% object% () (define-class event% object% ([time-stamp 0])
get-time-stamp get-time-stamp
set-time-stamp) set-time-stamp)
(define-class control-event% event% (event-type) (define-class control-event% event% (event-type [time-stamp 0])
get-event-type get-event-type
set-event-type) set-event-type)
(define-class popup-event% control-event% () (define-class popup-event% control-event% ([menu-id 0] [time-stamp 0])
get-menu-id get-menu-id
set-menu-id) set-menu-id)
(define-class scroll-event% event% () (define-class scroll-event% event% ([event-type 'thumb] [direction 'vertical] [position 0] [time-stamp 0])
get-event-type get-event-type
set-event-type set-event-type
get-direction get-direction
set-direction set-direction
get-position get-position
set-position) set-position)
(define-class key-event% event% () (define-class key-event% event% ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0.0] [y 0.0] [time-stamp 0])
get-key-code get-key-code
set-key-code set-key-code
get-shift-down get-shift-down
@ -436,7 +436,7 @@
set-x set-x
get-y get-y
set-y) set-y)
(define-class mouse-event% event% (event-type) (define-class mouse-event% event% (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0.0] [y 0.0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0])
moving? moving?
leaving? leaving?
entering? entering?