reworked the buttons along the top of drscheme
svn: r9578
This commit is contained in:
Robby Findler
parent
567e438f1d
commit
ee9fc4a8d7
|
|
@ -53,6 +53,12 @@
|
|||
(finder:default-filters)))
|
||||
(application:current-app-name (string-constant drscheme))
|
||||
|
||||
(preferences:set-default 'drscheme:toolbar-state
|
||||
'(#f . horizontal)
|
||||
(λ (x) (and (pair? x)
|
||||
(boolean? (car x))
|
||||
(memq (cdr x) '(horizontal vertical)))))
|
||||
|
||||
(preferences:set-default 'drscheme:htdp:last-set-teachpacks
|
||||
'()
|
||||
(λ (x)
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ module browser threading seems wrong.
|
|||
"drsig.ss"
|
||||
"auto-language.ss"
|
||||
"insert-large-letters.ss"
|
||||
mrlib/switchable-button
|
||||
|
||||
(prefix-in drscheme:arrow: "../arrow.ss")
|
||||
|
||||
|
|
@ -275,15 +276,9 @@ module browser threading seems wrong.
|
|||
frame
|
||||
program-filename)))])))
|
||||
|
||||
(define make-execute-bitmap
|
||||
(bitmap-label-maker (string-constant execute-button-label)
|
||||
(build-path (collection-path "icons") "run.png")))
|
||||
(define make-save-bitmap
|
||||
(bitmap-label-maker (string-constant save-button-label)
|
||||
(build-path (collection-path "icons") "save.png")))
|
||||
(define make-break-bitmap
|
||||
(bitmap-label-maker (string-constant break-button-label)
|
||||
(build-path (collection-path "icons") "break.png")))
|
||||
(define execute-bitmap (make-object bitmap% (build-path (collection-path "icons") "run.png") 'png/mask))
|
||||
(define break-bitmap (make-object bitmap% (build-path (collection-path "icons") "break.png") 'png/mask))
|
||||
(define save-bitmap (make-object bitmap% (build-path (collection-path "icons") "save.png") 'png/mask))
|
||||
|
||||
(define-values (get-program-editor-mixin add-to-program-editor-mixin)
|
||||
(let* ([program-editor-mixin
|
||||
|
|
@ -1152,7 +1147,8 @@ module browser threading seems wrong.
|
|||
;; should only be called by the tab% object
|
||||
(define-local-member-name
|
||||
disable-evaluation-in-tab
|
||||
enable-evaluation-in-tab)
|
||||
enable-evaluation-in-tab
|
||||
update-toolbar-visiblity)
|
||||
|
||||
(define -frame<%>
|
||||
(interface (drscheme:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>)
|
||||
|
|
@ -1302,36 +1298,85 @@ module browser threading seems wrong.
|
|||
(parent louter-panel)
|
||||
(stretchable-height #f)))
|
||||
(set! logging-panel (make-object horizontal-panel% logging-parent-panel))
|
||||
(unless toolbar-shown?
|
||||
(unless (toolbar-shown?)
|
||||
(send logging-parent-panel change-children (λ (l) '())))
|
||||
root))
|
||||
|
||||
(inherit show-info hide-info is-info-hidden?)
|
||||
(field [toolbar-shown? (preferences:get 'drscheme:toolbar-shown)]
|
||||
[toolbar-menu-item #f])
|
||||
(field [toolbar-state (preferences:get 'drscheme:toolbar-state)]
|
||||
[toolbar-vertical-menu-item #f]
|
||||
[toolbar-horizontal-menu-item #f]
|
||||
[toolbar-hidden-menu-item #f]
|
||||
[toolbar-menu #f])
|
||||
|
||||
(define/override (on-toolbar-button-click)
|
||||
(toggle-toolbar-visiblity))
|
||||
;; returns #t if the toolbar is visible, #f otherwise
|
||||
(define/private (toolbar-shown?) (car toolbar-state))
|
||||
|
||||
(define/private (toggle-toolbar-visiblity)
|
||||
(set! toolbar-shown? (not toolbar-shown?))
|
||||
(preferences:set 'drscheme:toolbar-shown toolbar-shown?)
|
||||
(define/private (change-toolbar-state new-state)
|
||||
(set! toolbar-state new-state)
|
||||
(preferences:set 'drscheme:toolbar-state new-state)
|
||||
(update-toolbar-visiblity))
|
||||
|
||||
(define/private (update-toolbar-visiblity)
|
||||
(cond
|
||||
[toolbar-shown?
|
||||
(show-info)
|
||||
(send top-outer-panel change-children (λ (l) (list top-panel)))
|
||||
(send logging-parent-panel change-children (λ (l) (list logging-panel)))
|
||||
(send toolbar-menu-item set-label (string-constant hide-toolbar))]
|
||||
[else
|
||||
(hide-info)
|
||||
(send top-outer-panel change-children (λ (l) '()))
|
||||
(send logging-parent-panel change-children (λ (l) '()))
|
||||
(send toolbar-menu-item set-label (string-constant show-toolbar))])
|
||||
(define/override (on-toolbar-button-click) (change-toolbar-state (cons (not (car toolbar-state)) (cdr toolbar-state))))
|
||||
(define/private (set-toolbar-horizontal) (change-toolbar-state (cons #f 'horizontal)))
|
||||
(define/private (set-toolbar-vertical) (change-toolbar-state (cons #f 'vertical)))
|
||||
(define/private (set-toolbar-hidden) (change-toolbar-state (cons #t (cdr toolbar-state))))
|
||||
|
||||
(define/public (update-toolbar-visiblity)
|
||||
(let* ([hidden? (car (preferences:get 'drscheme:toolbar-state))]
|
||||
[vertical? (and (not hidden?)
|
||||
(eq? (cdr (preferences:get 'drscheme:toolbar-state))
|
||||
'vertical))]
|
||||
[horizontal? (and (not hidden?)
|
||||
(eq? (cdr (preferences:get 'drscheme:toolbar-state))
|
||||
'horizontal))])
|
||||
(send toolbar-horizontal-menu-item check horizontal?)
|
||||
(send toolbar-vertical-menu-item check vertical?)
|
||||
(send toolbar-hidden-menu-item check hidden?)
|
||||
|
||||
(cond
|
||||
[hidden?
|
||||
(hide-info)
|
||||
(send top-outer-panel change-children (λ (l) '()))
|
||||
(send logging-parent-panel change-children (λ (l) '()))]
|
||||
[vertical? (orient/show #t)]
|
||||
[horizontal? (orient/show #f)]))
|
||||
(update-defs/ints-resize-corner))
|
||||
|
||||
(define/private (orient/show vertical?)
|
||||
(begin-container-sequence)
|
||||
(show-info)
|
||||
|
||||
(let ([bpo (send button-panel get-orientation)])
|
||||
(unless (equal? bpo (not vertical?))
|
||||
(send button-panel set-orientation (not vertical?))
|
||||
|
||||
;; have to be careful to avoid reversing the list when the orientation is already proper
|
||||
(send button-panel change-children reverse)))
|
||||
|
||||
(let loop ([obj button-panel])
|
||||
(cond
|
||||
[(is-a? obj area-container<%>)
|
||||
(for-each loop (send obj get-children))]
|
||||
[(is-a? obj switchable-button%)
|
||||
(send obj set-label-visible (not vertical?))]
|
||||
[else (void)]))
|
||||
(send save-button set-label-visible (not vertical?))
|
||||
(send top-outer-panel stretchable-height vertical?)
|
||||
(send top-outer-panel stretchable-width (not vertical?))
|
||||
(send top-panel set-orientation (not vertical?))
|
||||
(send toolbar/rest-panel set-orientation vertical?)
|
||||
(send toolbar/rest-panel change-children (λ (l)
|
||||
(if vertical?
|
||||
(append (remq top-outer-panel l) (list top-outer-panel))
|
||||
(cons top-outer-panel (remq top-outer-panel l)))))
|
||||
(send top-outer-panel change-children (λ (l) (list top-panel)))
|
||||
(send logging-parent-panel change-children (λ (l) (list logging-panel)))
|
||||
(if vertical?
|
||||
(send top-panel change-children (λ (x) (remq name-panel x)))
|
||||
(send top-panel change-children (λ (x) (cons name-panel (remq name-panel x)))))
|
||||
(end-container-sequence))
|
||||
|
||||
(field [remove-show-status-line-callback
|
||||
(preferences:add-callback
|
||||
'framework:show-status-line
|
||||
|
|
@ -1342,7 +1387,7 @@ module browser threading seems wrong.
|
|||
(update-defs/ints-resize-corner/pref (preferences:get 'framework:show-status-line)))
|
||||
|
||||
(define/private (update-defs/ints-resize-corner/pref si-pref)
|
||||
(let ([bottom-material? (and toolbar-shown? si-pref)])
|
||||
(let ([bottom-material? (and (toolbar-shown?) si-pref)])
|
||||
(let loop ([cs definitions-canvases])
|
||||
(cond
|
||||
[(null? cs) (void)]
|
||||
|
|
@ -2409,7 +2454,7 @@ module browser threading seems wrong.
|
|||
(define/public (get-interactions-text) interactions-text)
|
||||
|
||||
(define/public (get-definitions/interactions-panel-parent)
|
||||
(get-area-container))
|
||||
toolbar/rest-panel)
|
||||
|
||||
(inherit delegated-text-shown? hide-delegated-text show-delegated-text)
|
||||
(define/override (add-show-menu-items show-menu)
|
||||
|
|
@ -2464,13 +2509,27 @@ module browser threading seems wrong.
|
|||
(hide-module-browser)
|
||||
(show-module-browser))))))
|
||||
|
||||
(set! toolbar-menu-item
|
||||
(new menu-item%
|
||||
(label (string-constant show-toolbar))
|
||||
(parent show-menu)
|
||||
(callback
|
||||
(λ (x y)
|
||||
(toggle-toolbar-visiblity))))))
|
||||
(set! toolbar-menu (new menu%
|
||||
[parent show-menu]
|
||||
[label "Toolbar"]))
|
||||
(set! toolbar-horizontal-menu-item
|
||||
(new checkable-menu-item%
|
||||
[label "Horizontal Toolbar"]
|
||||
[parent toolbar-menu]
|
||||
[callback (λ (x y) (set-toolbar-horizontal))]
|
||||
[checked #f]))
|
||||
(set! toolbar-vertical-menu-item
|
||||
(new checkable-menu-item%
|
||||
[label "Vertical Toolbar"]
|
||||
[parent toolbar-menu]
|
||||
[callback (λ (x y) (set-toolbar-vertical))]
|
||||
[checked #f]))
|
||||
(set! toolbar-hidden-menu-item
|
||||
(new checkable-menu-item%
|
||||
[label "Hidden Toolbar"]
|
||||
[parent toolbar-menu]
|
||||
[callback (λ (x y) (set-toolbar-hidden))]
|
||||
[checked #f])))
|
||||
|
||||
|
||||
;
|
||||
|
|
@ -3205,13 +3264,16 @@ module browser threading seems wrong.
|
|||
; ; ;
|
||||
|
||||
|
||||
(define toolbar/rest-panel (new vertical-panel% [parent (get-area-container)]))
|
||||
|
||||
;; most contain only top-panel (or nothing)
|
||||
(define top-outer-panel (new horizontal-pane%
|
||||
(parent (get-area-container))
|
||||
(stretchable-height #f)))
|
||||
(define top-outer-panel (new horizontal-panel%
|
||||
[parent toolbar/rest-panel]
|
||||
[alignment '(right top)]
|
||||
[stretchable-height #f]))
|
||||
|
||||
[define top-panel (make-object horizontal-panel% top-outer-panel)]
|
||||
[define name-panel (new vertical-pane%
|
||||
[define name-panel (new horizontal-panel%
|
||||
(parent top-panel)
|
||||
(alignment '(left center))
|
||||
(stretchable-width #f)
|
||||
|
|
@ -3259,13 +3321,13 @@ module browser threading seems wrong.
|
|||
[define get-interactions-canvas (λ () interactions-canvas)]
|
||||
|
||||
(set! save-button
|
||||
(make-object button%
|
||||
(make-save-bitmap this)
|
||||
top-panel
|
||||
(λ args
|
||||
(when definitions-text
|
||||
(save)
|
||||
(send definitions-canvas focus)))))
|
||||
(new switchable-button%
|
||||
[parent top-panel]
|
||||
[callback (λ (x) (when definitions-text
|
||||
(save)
|
||||
(send definitions-canvas focus)))]
|
||||
[bitmap save-bitmap]
|
||||
[label (string-constant save-button-label)]))
|
||||
|
||||
(set! name-message (new drs-name-message% [parent name-panel]))
|
||||
(send name-message stretchable-width #t)
|
||||
|
|
@ -3273,7 +3335,7 @@ module browser threading seems wrong.
|
|||
[define teachpack-items null]
|
||||
[define break-button (void)]
|
||||
[define execute-button (void)]
|
||||
[define button-panel (make-object horizontal-panel% top-panel)]
|
||||
[define button-panel (new horizontal-panel% [parent top-panel] [spacing 2])]
|
||||
[define/public get-execute-button (λ () execute-button)]
|
||||
[define/public get-break-button (λ () break-button)]
|
||||
[define/public get-button-panel (λ () button-panel)]
|
||||
|
|
@ -3288,16 +3350,18 @@ module browser threading seems wrong.
|
|||
(frame this))]
|
||||
|
||||
(set! execute-button
|
||||
(make-object button%
|
||||
(make-execute-bitmap this)
|
||||
button-panel
|
||||
(λ (button evt) (execute-callback))))
|
||||
(new switchable-button%
|
||||
[parent button-panel]
|
||||
[callback (λ (x) (execute-callback))]
|
||||
[bitmap execute-bitmap]
|
||||
[label (string-constant execute-button-label)]))
|
||||
|
||||
(set! break-button
|
||||
(make-object button%
|
||||
(make-break-bitmap this)
|
||||
button-panel
|
||||
(λ (x y)
|
||||
(send current-tab break-callback))))
|
||||
(new switchable-button%
|
||||
[parent button-panel]
|
||||
[callback (λ (x) (send current-tab break-callback))]
|
||||
[bitmap break-bitmap]
|
||||
[label (string-constant break-button-label)]))
|
||||
|
||||
(send button-panel stretchable-height #f)
|
||||
(send button-panel stretchable-width #f)
|
||||
|
|
@ -3347,7 +3411,6 @@ module browser threading seems wrong.
|
|||
(list p (- 1 p)))))
|
||||
|
||||
(set-label-prefix (string-constant drscheme))
|
||||
(update-toolbar-visiblity)
|
||||
(set! newest-frame this)
|
||||
(send definitions-canvas focus)))
|
||||
|
||||
|
|
@ -3699,6 +3762,7 @@ module browser threading seems wrong.
|
|||
(unless (eq? (system-type) 'macosx)
|
||||
;; mac os x has a bug where maximizing can make the window too big.
|
||||
(send frame maximize (preferences:get 'drscheme:unit-window-max?))))
|
||||
(send frame update-toolbar-visiblity)
|
||||
(send frame show #t)
|
||||
(set! first-frame? #f)
|
||||
frame))))
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
mzlib/list
|
||||
syntax/toplevel
|
||||
syntax/boundmap
|
||||
mrlib/bitmap-label
|
||||
mrlib/switchable-button
|
||||
(prefix-in drscheme:arrow: drscheme/arrow)
|
||||
(prefix-in fw: framework/framework)
|
||||
mred
|
||||
|
|
@ -890,10 +890,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
(super-new)))))
|
||||
|
||||
(define syncheck-bitmap
|
||||
(bitmap-label-maker
|
||||
(string-constant check-syntax)
|
||||
(build-path (collection-path "icons") "syncheck.png")))
|
||||
(define syncheck-bitmap (make-object bitmap% (build-path (collection-path "icons") "syncheck.png") 'png/mask))
|
||||
|
||||
(define syncheck-frame<%>
|
||||
(interface ()
|
||||
|
|
@ -1226,10 +1223,11 @@ If the namespace does not, they are colored the unbound color.
|
|||
[stretchable-width #f]
|
||||
[stretchable-height #f]))
|
||||
(define check-syntax-button
|
||||
(new button%
|
||||
(label (syncheck-bitmap this))
|
||||
(new switchable-button%
|
||||
(label (string-constant check-syntax))
|
||||
(bitmap syncheck-bitmap)
|
||||
(parent check-syntax-button-parent-panel)
|
||||
(callback (λ (button evt) (syncheck:button-callback)))))
|
||||
(callback (λ (button) (syncheck:button-callback)))))
|
||||
(define/public (syncheck:get-button) check-syntax-button)
|
||||
(send (get-button-panel) change-children
|
||||
(λ (l)
|
||||
|
|
|
|||
|
|
@ -12,7 +12,8 @@
|
|||
(lib "tool.ss" "drscheme")
|
||||
"marks.ss"
|
||||
syntax/boundmap
|
||||
(lib "bitmap-label.ss" "mrlib")
|
||||
mrlib/switchable-button
|
||||
mrlib/bitmap-label
|
||||
"annotator.ss"
|
||||
"load-sandbox.ss"
|
||||
framework
|
||||
|
|
@ -1055,6 +1056,32 @@
|
|||
|
||||
(super-new)))
|
||||
|
||||
(define debug-bitmap
|
||||
(make-object bitmap%
|
||||
(build-path (collection-path "gui-debugger" "icons") "icon-small.png")
|
||||
'png/mask))
|
||||
|
||||
(define make-pause-label
|
||||
(bitmap-label-maker
|
||||
"Pause"
|
||||
(build-path (collection-path "gui-debugger" "icons") "pause.png")))
|
||||
(define make-resume-label
|
||||
(bitmap-label-maker
|
||||
"Go"
|
||||
(build-path (collection-path "gui-debugger" "icons") "resume.png")))
|
||||
(define make-step-label
|
||||
(bitmap-label-maker
|
||||
"Step"
|
||||
(build-path (collection-path "gui-debugger" "icons") "step.png")))
|
||||
(define make-over-label
|
||||
(bitmap-label-maker
|
||||
"Over"
|
||||
(build-path (collection-path "gui-debugger" "icons") "step-over2.png")))
|
||||
(define make-out-label
|
||||
(bitmap-label-maker
|
||||
"Out"
|
||||
(build-path (collection-path "gui-debugger" "icons") "step-out2.png")))
|
||||
|
||||
(define (debug-unit-frame-mixin super%)
|
||||
(class super%
|
||||
|
||||
|
|
@ -1283,18 +1310,15 @@
|
|||
[stretchable-width #t]))
|
||||
|
||||
(define debug-button
|
||||
(make-object button%
|
||||
((bitmap-label-maker
|
||||
(string-constant debug-tool-button-name)
|
||||
(build-path (collection-path "gui-debugger" "icons") "icon-small.png")) this)
|
||||
(make-object vertical-pane% (get-button-panel))
|
||||
(lambda (button evt) (set! debug? #t) (execute-callback))))
|
||||
(new switchable-button%
|
||||
(label (string-constant debug-tool-button-name))
|
||||
(bitmap debug-bitmap)
|
||||
(parent (make-object vertical-pane% (get-button-panel)))
|
||||
(callback (λ (button) (set! debug? #t) (execute-callback)))))
|
||||
|
||||
(define pause-button
|
||||
(instantiate button% ()
|
||||
[label ((bitmap-label-maker
|
||||
"Pause"
|
||||
(build-path (collection-path "gui-debugger" "icons") "pause.png")) this)]
|
||||
[label (make-pause-label this)]
|
||||
[parent debug-panel]
|
||||
[callback (lambda (button evt)
|
||||
(if (send (get-current-tab) get-stack-frames)
|
||||
|
|
@ -1307,9 +1331,7 @@
|
|||
|
||||
(define resume-button
|
||||
(instantiate button% ()
|
||||
[label ((bitmap-label-maker
|
||||
"Go"
|
||||
(build-path (collection-path "gui-debugger" "icons") "resume.png")) this)]
|
||||
[label (make-resume-label this)]
|
||||
[parent debug-panel]
|
||||
[callback (lambda (button evt)
|
||||
(if (send (get-current-tab) get-stack-frames)
|
||||
|
|
@ -1319,9 +1341,7 @@
|
|||
|
||||
(define step-button
|
||||
(instantiate button% ()
|
||||
[label ((bitmap-label-maker
|
||||
"Step"
|
||||
(build-path (collection-path "gui-debugger" "icons") "step.png")) this)]
|
||||
[label (make-step-label this)]
|
||||
[parent debug-panel]
|
||||
[callback (lambda (btn evt)
|
||||
(if (send (get-current-tab) get-stack-frames)
|
||||
|
|
@ -1373,18 +1393,14 @@
|
|||
|
||||
(define step-over-button
|
||||
(new button%
|
||||
[label ((bitmap-label-maker
|
||||
"Over"
|
||||
(build-path (collection-path "gui-debugger" "icons") "step-over2.png")) this)]
|
||||
[label (make-over-label this)]
|
||||
[parent debug-panel]
|
||||
[callback (make-big-step-callback #f)]
|
||||
[enabled #f]))
|
||||
|
||||
(define step-out-button
|
||||
(new button%
|
||||
[label ((bitmap-label-maker
|
||||
"Out"
|
||||
(build-path (collection-path "gui-debugger" "icons") "step-out2.png")) this)]
|
||||
[label (make-out-label this)]
|
||||
[parent debug-panel]
|
||||
[callback (make-big-step-callback #t)]
|
||||
[enabled #f]))
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
scheme/gui
|
||||
framework/framework
|
||||
drscheme/tool
|
||||
mrlib/bitmap-label
|
||||
mrlib/switchable-button
|
||||
string-constants
|
||||
"model/trace.ss"
|
||||
"model/deriv.ss"
|
||||
|
|
@ -55,6 +55,11 @@
|
|||
(define-local-member-name check-language)
|
||||
(define-local-member-name get-debug-button)
|
||||
|
||||
(define macro-debugger-bitmap
|
||||
(make-object bitmap%
|
||||
(build-path (collection-path "macro-debugger") "view" "icon-small.png")
|
||||
'png/mask))
|
||||
|
||||
(define (macro-debugger-unit-frame-mixin %)
|
||||
(class %
|
||||
(super-new)
|
||||
|
|
@ -65,14 +70,11 @@
|
|||
(define macro-debug-panel
|
||||
(new vertical-pane% (parent (get-button-panel))))
|
||||
(define macro-debug-button
|
||||
(new button%
|
||||
(label (make-bitmap-label
|
||||
"Macro Stepper"
|
||||
(build-path (collection-path "macro-debugger")
|
||||
"view"
|
||||
"icon-small.png")))
|
||||
(new switchable-button%
|
||||
(label "Macro Stepper")
|
||||
(bitmap macro-debugger-bitmap)
|
||||
(parent macro-debug-panel)
|
||||
(callback (lambda (button event) (execute #t)))))
|
||||
(callback (λ (button) (execute #t)))))
|
||||
|
||||
(define/override (execute-callback)
|
||||
(execute #f))
|
||||
|
|
|
|||
|
|
@ -94,8 +94,18 @@
|
|||
(send (send wx area-parent) add-child wx))))
|
||||
(send parent after-new-child this)))))
|
||||
|
||||
(define vertical-panel% (class100*/kw panel% () [(parent [style null]) panel%-keywords] (sequence (super-init parent style))))
|
||||
(define horizontal-panel% (class100*/kw panel% () [(parent [style null]) panel%-keywords] (sequence (super-init parent style))))
|
||||
(define vertical-panel%
|
||||
(class100*/kw panel% ()
|
||||
[(parent [style null]) panel%-keywords]
|
||||
(sequence (super-init parent style))
|
||||
(public [set-orientation (λ (x) (send (mred->wx this) set-orientation x))]
|
||||
[get-orientation (λ () (send (mred->wx this) get-orientation))])))
|
||||
(define horizontal-panel%
|
||||
(class100*/kw panel% ()
|
||||
[(parent [style null]) panel%-keywords]
|
||||
(sequence (super-init parent style))
|
||||
(public [set-orientation (λ (x) (send (mred->wx this) set-orientation x))]
|
||||
[get-orientation (λ () (send (mred->wx this) get-orientation))])))
|
||||
|
||||
(define list-append append)
|
||||
|
||||
|
|
|
|||
|
|
@ -637,89 +637,95 @@
|
|||
|
||||
(sequence (apply super-init args))))
|
||||
|
||||
|
||||
(define (wx-make-horizontal/vertical-panel% wx-linear-panel% init-horizontal?)
|
||||
(class100 wx-linear-panel% args
|
||||
(inherit major-align minor-align do-align do-get-alignment major-offset minor-offset
|
||||
spacing border do-graphical-size place-linear-children check-place-children
|
||||
force-redraw)
|
||||
(private-field [horizontal? init-horizontal?])
|
||||
(public [get-orientation (λ () horizontal?)]
|
||||
[set-orientation (λ (h?)
|
||||
(unless (equal? h? horizontal?)
|
||||
(set! horizontal? h?)
|
||||
(force-redraw)))])
|
||||
(override
|
||||
[alignment (lambda (h v)
|
||||
(if horizontal?
|
||||
(do-align h v
|
||||
(lambda (x) (major-align x))
|
||||
(lambda (x) (minor-align x)))
|
||||
(do-align h v
|
||||
(lambda (x) (minor-align x))
|
||||
(lambda (x) (major-align x)))))]
|
||||
[get-alignment (λ () (do-get-alignment (if horizontal? (λ (x y) x) (λ (x y) y))))]
|
||||
|
||||
[do-get-graphical-min-size
|
||||
(lambda ()
|
||||
(if horizontal?
|
||||
(do-graphical-size
|
||||
(lambda (x-accum kid-info hidden?)
|
||||
(+ x-accum (child-info-x-min (car kid-info))
|
||||
(if (or hidden? (null? (cdr kid-info)))
|
||||
0
|
||||
(spacing))))
|
||||
(lambda (y-accum kid-info hidden?)
|
||||
(max y-accum
|
||||
(+ (child-info-y-min (car kid-info))
|
||||
(* 2 (border))))))
|
||||
(do-graphical-size
|
||||
(lambda (x-accum kid-info hidden?)
|
||||
(max x-accum
|
||||
(+ (child-info-x-min (car kid-info))
|
||||
(* 2 (border)))))
|
||||
(lambda (y-accum kid-info hidden?)
|
||||
(+ y-accum (child-info-y-min (car kid-info))
|
||||
(if (or (null? (cdr kid-info)) hidden?)
|
||||
0
|
||||
(spacing)))))))]
|
||||
|
||||
[do-place-children
|
||||
(lambda (l w h)
|
||||
(cond
|
||||
[horizontal?
|
||||
(check-place-children l w h)
|
||||
(place-linear-children l w h
|
||||
car ; child-info-x-min
|
||||
caddr ; child-info-x-stretch
|
||||
(lambda (s) (major-offset s))
|
||||
cadr ; child-info-y-min
|
||||
cadddr ; child-info-y-stretch
|
||||
(lambda (s t) (minor-offset s t))
|
||||
(lambda (width height) width)
|
||||
(lambda (width height) height)
|
||||
(lambda (major minor) major)
|
||||
(lambda (major minor) minor))]
|
||||
[else
|
||||
(check-place-children l w h)
|
||||
(place-linear-children l w h
|
||||
cadr ; child-info-y-min
|
||||
cadddr ; child-info-y-stretch
|
||||
(lambda (s) (major-offset s))
|
||||
car ; child-info-x-min
|
||||
caddr ; child-info-x-stretch
|
||||
(lambda (s t) (minor-offset s t))
|
||||
(lambda (width height) height)
|
||||
(lambda (width height) width)
|
||||
(lambda (major minor) minor)
|
||||
(lambda (major minor) major))]))])
|
||||
(sequence (apply super-init args))))
|
||||
|
||||
|
||||
;; horizontal-panel%: a panel which arranges its children in an evenly
|
||||
;; spaced horizontal row. Items are vertically centered (or stretched
|
||||
;; to fit the dialog box if they are stretchable). The items are evenly
|
||||
;; spaced horizontally, with any extra space divided evenly among the
|
||||
;; stretchable items.
|
||||
(define (wx-make-horizontal-panel% wx-linear-panel%)
|
||||
(class100 wx-linear-panel% args
|
||||
(inherit major-align minor-align do-align do-get-alignment major-offset minor-offset
|
||||
spacing border do-graphical-size place-linear-children check-place-children)
|
||||
(override
|
||||
[alignment (lambda (h v) (do-align h v
|
||||
(lambda (x) (major-align x))
|
||||
(lambda (x) (minor-align x))))]
|
||||
[get-alignment (lambda () (do-get-alignment (lambda (x y) x)))]
|
||||
|
||||
[do-get-graphical-min-size
|
||||
(lambda ()
|
||||
(do-graphical-size
|
||||
(lambda (x-accum kid-info hidden?)
|
||||
(+ x-accum (child-info-x-min (car kid-info))
|
||||
(if (or hidden? (null? (cdr kid-info)))
|
||||
0
|
||||
(spacing))))
|
||||
(lambda (y-accum kid-info hidden?)
|
||||
(max y-accum
|
||||
(+ (child-info-y-min (car kid-info))
|
||||
(* 2 (border)))))))]
|
||||
[do-place-children
|
||||
(lambda (l w h)
|
||||
(check-place-children l w h)
|
||||
(place-linear-children l w h
|
||||
car ; child-info-x-min
|
||||
caddr ; child-info-x-stretch
|
||||
(lambda (s) (major-offset s))
|
||||
cadr ; child-info-y-min
|
||||
cadddr ; child-info-y-stretch
|
||||
(lambda (s t) (minor-offset s t))
|
||||
(lambda (width height) width)
|
||||
(lambda (width height) height)
|
||||
(lambda (major minor) major)
|
||||
(lambda (major minor) minor)))])
|
||||
(sequence (apply super-init args))))
|
||||
(define (wx-make-horizontal-panel% wx-linear-panel%) (wx-make-horizontal/vertical-panel% wx-linear-panel% #t))
|
||||
|
||||
;; vertical-panel%. See horizontal-panel%, but reverse
|
||||
;; "horizontal" and "vertical."
|
||||
(define (wx-make-vertical-panel% wx-linear-panel%)
|
||||
(class100 wx-linear-panel% args
|
||||
(inherit major-align minor-align do-align do-get-alignment major-offset minor-offset
|
||||
spacing border do-graphical-size place-linear-children check-place-children)
|
||||
(override
|
||||
[alignment (lambda (h v) (do-align h v
|
||||
(lambda (x) (minor-align x))
|
||||
(lambda (x) (major-align x))))]
|
||||
[get-alignment (lambda () (do-get-alignment (lambda (x y) y)))]
|
||||
|
||||
[do-get-graphical-min-size
|
||||
(lambda ()
|
||||
(do-graphical-size
|
||||
(lambda (x-accum kid-info hidden?)
|
||||
(max x-accum
|
||||
(+ (child-info-x-min (car kid-info))
|
||||
(* 2 (border)))))
|
||||
(lambda (y-accum kid-info hidden?)
|
||||
(+ y-accum (child-info-y-min (car kid-info))
|
||||
(if (or (null? (cdr kid-info)) hidden?)
|
||||
0
|
||||
(spacing))))))]
|
||||
|
||||
[do-place-children
|
||||
(lambda (l w h)
|
||||
(check-place-children l w h)
|
||||
(place-linear-children l w h
|
||||
cadr ; child-info-y-min
|
||||
cadddr ; child-info-y-stretch
|
||||
(lambda (s) (major-offset s))
|
||||
car ; child-info-x-min
|
||||
caddr ; child-info-x-stretch
|
||||
(lambda (s t) (minor-offset s t))
|
||||
(lambda (width height) height)
|
||||
(lambda (width height) width)
|
||||
(lambda (major minor) minor)
|
||||
(lambda (major minor) major)))])
|
||||
(sequence (apply super-init args))))
|
||||
(define (wx-make-vertical-panel% wx-linear-panel%) (wx-make-horizontal/vertical-panel% wx-linear-panel% #f))
|
||||
|
||||
(define wx-panel% (wx-make-panel% wx:panel%))
|
||||
(define wx-linear-panel% (wx-make-linear-panel% wx-panel%))
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@
|
|||
@include-section["name-message.scrbl"]
|
||||
@include-section["path-dialog.scrbl"]
|
||||
@include-section["plot.scrbl"]
|
||||
@include-section["switchable-button.scrbl"]
|
||||
|
||||
@section{Acknowledgments}
|
||||
|
||||
|
|
|
|||
149
collects/mrlib/switchable-button.ss
Normal file
149
collects/mrlib/switchable-button.ss
Normal file
|
|
@ -0,0 +1,149 @@
|
|||
#lang scheme/base
|
||||
(require scheme/gui/base
|
||||
scheme/class)
|
||||
|
||||
(require string-constants/string-constant)
|
||||
(provide switchable-button%)
|
||||
(define gap 2)
|
||||
(define margin 2)
|
||||
(define w-circle-space 6)
|
||||
(define h-circle-space 6)
|
||||
|
||||
(define switchable-button%
|
||||
(class canvas%
|
||||
(init-field label bitmap callback)
|
||||
|
||||
(inherit get-dc min-width min-height get-client-size refresh)
|
||||
|
||||
(define down? #f)
|
||||
(define in? #f)
|
||||
(define/override (on-event evt)
|
||||
(cond
|
||||
[(send evt button-down? 'left)
|
||||
(set! down? #t)
|
||||
(set! in? #t)
|
||||
(refresh)]
|
||||
[(send evt button-up? 'left)
|
||||
(set! down? #f)
|
||||
(update-in evt)
|
||||
(refresh)
|
||||
(when in?
|
||||
(callback this))]
|
||||
[(send evt entering?)
|
||||
(set! in? #t)
|
||||
(refresh)]
|
||||
[(send evt leaving?)
|
||||
(set! in? #f)
|
||||
(refresh)]
|
||||
[(send evt moving?)
|
||||
(update-in evt)]))
|
||||
|
||||
(define/private (update-in evt)
|
||||
(let-values ([(cw ch) (get-client-size)])
|
||||
(let ([new-in?
|
||||
(and (<= 0 (send evt get-x) cw)
|
||||
(<= 0 (send evt get-y) ch))])
|
||||
(unless (equal? new-in? in?)
|
||||
(set! in? new-in?)
|
||||
(refresh)))))
|
||||
|
||||
(define horizontal? #t)
|
||||
(define/override (on-paint)
|
||||
(let ([dc (get-dc)])
|
||||
(let-values ([(cw ch) (get-client-size)])
|
||||
(let ([alpha (send dc get-alpha)]
|
||||
[pen (send dc get-pen)]
|
||||
[brush (send dc get-brush)])
|
||||
|
||||
(send dc set-alpha
|
||||
(cond
|
||||
[in? (if down?
|
||||
.5
|
||||
.2)]
|
||||
[else 0]))
|
||||
(send dc set-pen "black" 1 'transparent)
|
||||
(send dc set-brush "black" 'solid)
|
||||
(send dc draw-rounded-rectangle
|
||||
margin
|
||||
margin
|
||||
(- cw margin margin)
|
||||
(- ch margin margin))
|
||||
(send dc set-alpha alpha)
|
||||
|
||||
(cond
|
||||
[horizontal?
|
||||
(let-values ([(tw th _1 _2) (send dc get-text-extent label)])
|
||||
(let ([text-start (+ (/ cw 2) (- (/ tw 2)) (- (/ (send bitmap get-width) 2)))])
|
||||
(send dc draw-text label text-start (- (/ ch 2) (/ th 2)))
|
||||
(draw-the-bitmap (+ text-start tw gap) (- (/ ch 2) (/ (send bitmap get-height) 2)))))]
|
||||
[else
|
||||
(draw-the-bitmap (- (/ cw 2) (/ (send bitmap get-width) 2))
|
||||
(- (/ ch 2) (/ (send bitmap get-height) 2)))])
|
||||
(send dc set-pen pen)
|
||||
(send dc set-alpha alpha)
|
||||
(send dc set-brush brush)))))
|
||||
|
||||
(define/private (draw-the-bitmap x y)
|
||||
(send (get-dc)
|
||||
draw-bitmap
|
||||
bitmap
|
||||
x y
|
||||
'solid
|
||||
(send the-color-database find-color "black")
|
||||
(send bitmap get-loaded-mask)))
|
||||
|
||||
(define/public (set-label-visible h?)
|
||||
(unless (equal? horizontal? h?)
|
||||
(set! horizontal? h?)
|
||||
(update-sizes)
|
||||
(refresh)))
|
||||
|
||||
(define/private (update-sizes)
|
||||
(let ([dc (get-dc)])
|
||||
(cond
|
||||
[horizontal?
|
||||
(let-values ([(w h _1 _2) (send dc get-text-extent label)])
|
||||
(do-w/h (+ w gap (send bitmap get-width))
|
||||
(max h (send bitmap get-height))))]
|
||||
[else
|
||||
(do-w/h (send bitmap get-width)
|
||||
(send bitmap get-height))])))
|
||||
|
||||
(define/private (do-w/h w h)
|
||||
(let ([w (floor (inexact->exact w))]
|
||||
[h (floor (inexact->exact h))])
|
||||
(min-width (+ w w-circle-space margin margin))
|
||||
(min-height (+ h h-circle-space margin margin))))
|
||||
|
||||
(super-new [style '(transparent)])
|
||||
(send (get-dc) set-smoothing 'aligned)
|
||||
|
||||
(inherit stretchable-width stretchable-height)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f)
|
||||
(inherit get-graphical-min-size)
|
||||
(update-sizes)))
|
||||
|
||||
#;
|
||||
(begin
|
||||
(define f (new frame% [label ""]))
|
||||
(define p (new horizontal-panel% [parent f] [alignment '(right top)]))
|
||||
|
||||
(define label (string-constant execute-button-label))
|
||||
(define bitmap (make-object bitmap% (build-path (collection-path "icons") "run.png") 'png/mask))
|
||||
|
||||
(define b1 (new switchable-button% [parent p] [label label] [bitmap bitmap] [callback void]))
|
||||
(define b2 (new switchable-button% [parent p] [label label] [bitmap bitmap] [callback void]))
|
||||
(new button% [parent p] [stretchable-width #t] [label "b"])
|
||||
(define swap-button
|
||||
(new button%
|
||||
[parent f]
|
||||
[label "swap"]
|
||||
[callback
|
||||
(let ([state #t])
|
||||
(λ (a b)
|
||||
(set! state (not state))
|
||||
(send b1 set-orientation state)
|
||||
(send b2 set-orientation state)
|
||||
'(send p set-orientation state)))]))
|
||||
(send f show #t))
|
||||
BIN
collects/scribblings/drscheme/example.png
Normal file
BIN
collects/scribblings/drscheme/example.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 42 KiB |
7
collects/scribblings/drscheme/example.ss
Normal file
7
collects/scribblings/drscheme/example.ss
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
#lang scheme
|
||||
|
||||
;; square : number -> number
|
||||
;; to produce the square of x
|
||||
(define (square x)
|
||||
(* x x))
|
||||
|
||||
|
|
@ -16,7 +16,7 @@
|
|||
The DrScheme window has three parts: a row of buttons at the top, two
|
||||
editing panels in the middle, and a status line at the bottom.
|
||||
|
||||
@image["screen-shot.png"]
|
||||
@image["example.png"]
|
||||
|
||||
The top editing panel, called the @deftech{definitions window}, is for
|
||||
defining programs. The above figure shows a program that defines the
|
||||
|
|
|
|||
Binary file not shown.
|
Before Width: | Height: | Size: 36 KiB After Width: | Height: | Size: 32 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 44 KiB |
|
|
@ -45,7 +45,7 @@ The @scheme[style] argument indicates one or more of the following styles:
|
|||
@item{@scheme['resize-corner] --- leaves room for a resize control at the canvas's
|
||||
bottom right when only one scrollbar is visible}
|
||||
|
||||
@item{@scheme['gl] --- {\em obsolete} (every canvas is an OpenGL context where supported)}
|
||||
@item{@scheme['gl] --- @italic{obsolete} (every canvas is an OpenGL context where supported)}
|
||||
|
||||
@item{@scheme['no-autoclear] --- prevents automatic erasing of the
|
||||
canvas before calls to
|
||||
|
|
|
|||
|
|
@ -310,7 +310,7 @@ Each new style is defined in one of two ways:
|
|||
@item{A @deftech{join style} is defined in terms of two other styles:
|
||||
a base style and a @deftech{shift style}. The meaning of a join style
|
||||
is determined by reinterpreting the shift style; in the
|
||||
reinterpretation, the base style is used as the {\em root\/} style
|
||||
reinterpretation, the base style is used as the @italic{root} style
|
||||
for the shift style. (This is analogous to multi-level
|
||||
styles, like the paragraph and character styles in FrameMaker. In
|
||||
this analogy, the paragraph style is the base style, and the
|
||||
|
|
@ -698,7 +698,7 @@ Instances of @scheme[editor<%>] have three levels of internal
|
|||
|
||||
}
|
||||
|
||||
The internal lock for an editor is {\em not\/} affected by calls to
|
||||
The internal lock for an editor is @italic{not} affected by calls to
|
||||
@method[editor<%> lock].
|
||||
|
||||
Methods that report @techlink{location}-independent information about an
|
||||
|
|
|
|||
|
|
@ -231,7 +231,7 @@ See also @method[editor-snip% get-align-top-line].
|
|||
|
||||
Sets the editor contained by the snip, releasing the old editor in the
|
||||
snip (if any). If the new editor already has an administrator, then
|
||||
the new editor is {\em not} installed into the snip.
|
||||
the new editor is @italic{not} installed into the snip.
|
||||
|
||||
When an @scheme[editor-snip%] object is not inserted in an editor, it
|
||||
does not have an administrator. During this time, it does not give
|
||||
|
|
|
|||
|
|
@ -27,8 +27,18 @@ If the @scheme['border] style is specified, the window is created with
|
|||
less than its total size). @DeletedStyleNote{panel}
|
||||
|
||||
@WindowKWs[] @SubareaKWs[] @AreaContKWs[] @AreaKWs[]
|
||||
}
|
||||
|
||||
@defmethod[(set-orientation [horizontal? boolean?]) void?]{
|
||||
Sets the orientation of the panel, switching it between
|
||||
the behavior of the @scheme[vertical-panel%] and that of
|
||||
the @scheme[horizontal-panel%].
|
||||
}
|
||||
|
||||
|
||||
}}
|
||||
@defmethod[(get-orientation) boolean?]{
|
||||
Initially returns @scheme[#t], but if
|
||||
@method[horizontal-panel% set-orientation] is called,
|
||||
this method returns whatever the last value passed to it was.
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -143,7 +143,7 @@ box, @|MismatchExn|.
|
|||
void?]{
|
||||
|
||||
Sets the selected radio button by position. (The control's callback
|
||||
procedure is {\em not} invoked.) Radio buttons are numbered from
|
||||
procedure is @italic{not} invoked.) Radio buttons are numbered from
|
||||
@scheme[0]. If @scheme[n] is equal to or larger than the number of
|
||||
radio buttons in the radio box, @|MismatchExn|.
|
||||
|
||||
|
|
|
|||
|
|
@ -283,7 +283,7 @@ A drawing context is provided for the purpose of finding font sizes,
|
|||
sizing that overrides that device context's current font.
|
||||
|
||||
The snip's left and top @techlink{location}s are provided in editor
|
||||
coordinates. In a text editor, the y-coordinate is the {\em line's}
|
||||
coordinates. In a text editor, the y-coordinate is the @italic{line's}
|
||||
top @techlink{location}; the snip's actual top @techlink{location} is potentially
|
||||
undetermined until its height is known.
|
||||
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ Starts (or restarts) the timer. If the timer is already running, its
|
|||
|
||||
The timer's alarm expires after @scheme[msec] milliseconds, at which
|
||||
point @method[timer% notify] is called (on an event boundary). If
|
||||
@scheme[just-once?]\ is @scheme[#f], the timer expires {\em every}
|
||||
@scheme[just-once?]\ is @scheme[#f], the timer expires @italic{every}
|
||||
@scheme[msec] milliseconds until the timer is explicitly
|
||||
stopped;\footnote{More precisely, the timer expires @scheme[msec]
|
||||
milliseconds after @method[timer% notify] returns each time}
|
||||
|
|
|
|||
|
|
@ -30,8 +30,18 @@ If the @scheme['border] style is specified, the window is created with
|
|||
less than its total size). @DeletedStyleNote{panel}
|
||||
|
||||
@WindowKWs[] @SubareaKWs[] @AreaContKWs[] @AreaKWs[]
|
||||
}
|
||||
|
||||
@defmethod[(set-orientation [horizontal? boolean?]) void?]{
|
||||
Sets the orientation of the panel, switching it between
|
||||
the behavior of the @scheme[vertical-panel%] and that of
|
||||
the @scheme[horizontal-panel%].
|
||||
}
|
||||
|
||||
|
||||
}}
|
||||
@defmethod[(get-orientation) boolean?]{
|
||||
Initially returns @scheme[#f], but if
|
||||
@method[vertical-panel% set-orientation] is called,
|
||||
this method returns whatever the last value passed to it was.
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -992,7 +992,7 @@
|
|||
(define (panel-tests frame% show?)
|
||||
(define (panel-test % win?)
|
||||
(let* ([frame (make-object frame% "Panel Test" #f 100 100)]
|
||||
[panel (if %
|
||||
[panel (if %
|
||||
(make-object % frame)
|
||||
frame)])
|
||||
(let ([go
|
||||
|
|
@ -1001,6 +1001,8 @@
|
|||
(if win?
|
||||
((if % containee-window-tests window-tests) panel #t #t (and % frame) frame 0)
|
||||
(area-tests panel #t #t #f))
|
||||
(when (is-a? panel panel%)
|
||||
(st #t panel get-orientation (is-a? panel horizontal-panel%)))
|
||||
(container-tests panel win?)
|
||||
(send frame show #f))])
|
||||
(when (eq? show? 'dialog)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user