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

reworked the buttons along the top of drscheme

Browse Source 
svn: r9578

original commit: ee9fc4a8d7591e0270b607fc057fa6398c6b7274
This commit is contained in:
Robby Findler 2008-05-01 23:15:06 +00:00
parent 5cfcbb3fde
commit 04318aa689
13 changed files with 277 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/mred/private/mrpanel.ss
View File

@ -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)

156
collects/mred/private/wxpanel.ss
View File

@ -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%))

1
collects/mrlib/scribblings/mrlib.scrbl
View File

@ -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
View 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))

2
collects/scribblings/gui/canvas-class.scrbl
View File

@ -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

4
collects/scribblings/gui/editor-overview.scrbl
View File

@ -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

2
collects/scribblings/gui/editor-snip-class.scrbl
View File

@ -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

14
collects/scribblings/gui/horizontal-panel-class.scrbl
View File

@ -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.
}
}

2
collects/scribblings/gui/radio-box-class.scrbl
View File

@ -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|.

2
collects/scribblings/gui/snip-class.scrbl
View File

@ -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.

2
collects/scribblings/gui/timer-class.scrbl
View File

@ -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}

14
collects/scribblings/gui/vertical-panel-class.scrbl
View File

@ -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.
}
}

4
collects/tests/mred/windowing.ss
View File

@ -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)