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

added bug logging

Browse Source 
svn: r11528

original commit: aaccfbb42feae363450250338d5c15606eaca7b6
This commit is contained in:
Robby Findler 2008-09-02 21:34:56 +00:00
parent 7e6032052d
commit 7749ed115e
2 changed files with 52 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/mrlib/scribblings/switchable-button.scrbl
View File

@ -16,8 +16,8 @@ label and the icon side-by-side.
@defconstructor/auto-super[([label string?]
[callback (-> (is-a?/c switchable-button%) any/c)]
[bitmap (is-a?/c bitmap%)]
[alternate-bitmap (is-a?/c bitmap%) bitmap]
)]{
[alternate-bitmap (is-a?/c bitmap%) bitmap]
[vertical-tight? boolean? #f])]{
The @scheme[callback] is called when the button
is pressed. The @scheme[string] and @scheme[bitmap] are
used as discussed above.
@ -25,6 +25,9 @@ used as discussed above.
If @scheme[alternate-bitmap] is supplied, then it is used
when the button is switched to the view that just shows the bitmap.
If it is not supplied, both modes show the same bitmap.
If the @scheme[vertical-tight?] argument is @scheme[#t], then the button takes up
as little as possible vertical space.
}
@defmethod[(set-label-visible [visible? boolean?]) void?]{

91
collects/mrlib/switchable-button.ss
View File

@ -53,7 +53,8 @@
(init-field label
bitmap
callback
[alternate-bitmap bitmap])
[alternate-bitmap bitmap]
[vertical-tight? #f])
(define/override (get-label) label)
@ -70,7 +71,7 @@
(define down? #f)
(define in? #f)
(define disabled? #f)
(define with-label? #t)
(define with-label? (string? label))
(define/override (enable e?)
(unless (equal? disabled? (not e?))
@ -122,47 +123,48 @@
(define timer-running? #f)
(define/private (update-float new-value?)
(cond
[with-label?
(when float-window
(send float-window show #f))]
[else
(unless (and float-window
(equal? new-value? (send float-window is-shown?)))
(cond
[in?
(unless float-window
(set! float-window (new frame%
[label ""]
[style '(no-caption no-resize-border float)]
[stretchable-width #f]
[stretchable-height #f]))
(new yellow-message% [parent float-window] [label label]))
(send float-window reflow-container)
;; position the floating window
(let-values ([(dw dh) (get-display-size)]
[(x y) (client->screen (floor (get-width))
(floor
(- (/ (get-height) 2)
(/ (send float-window get-height) 2))))]
[(dx dy) (get-display-left-top-inset)])
(let ([rhs-x (- x dx)]
[rhs-y (- y dy)])
(cond
[(< (+ rhs-x (send float-window get-width)) dw)
(send float-window move rhs-x rhs-y)]
[else
(send float-window move
(- rhs-x (send float-window get-width) (get-width))
rhs-y)])))
(unless timer-running?
(set! timer-running? #t)
(send timer start 500 #t))]
[else
(when float-window
(send float-window show #f))]))]))
(when label
(cond
[with-label?
(when float-window
(send float-window show #f))]
[else
(unless (and float-window
(equal? new-value? (send float-window is-shown?)))
(cond
[in?
(unless float-window
(set! float-window (new frame%
[label ""]
[style '(no-caption no-resize-border float)]
[stretchable-width #f]
[stretchable-height #f]))
(new yellow-message% [parent float-window] [label (or label "")]))
(send float-window reflow-container)
;; position the floating window
(let-values ([(dw dh) (get-display-size)]
[(x y) (client->screen (floor (get-width))
(floor
(- (/ (get-height) 2)
(/ (send float-window get-height) 2))))]
[(dx dy) (get-display-left-top-inset)])
(let ([rhs-x (- x dx)]
[rhs-y (- y dy)])
(cond
[(< (+ rhs-x (send float-window get-width)) dw)
(send float-window move rhs-x rhs-y)]
[else
(send float-window move
(- rhs-x (send float-window get-width) (get-width))
rhs-y)])))
(unless timer-running?
(set! timer-running? #t)
(send timer start 500 #t))]
[else
(when float-window
(send float-window show #f))]))])))
(define/private (update-in evt)
(let-values ([(cw ch) (get-client-size)])
@ -260,7 +262,8 @@
(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))))
(min-height (+ h h-circle-space margin margin
(if vertical-tight? -6 0)))))
(super-new [style '(transparent no-focus)])
(send (get-dc) set-smoothing 'aligned)