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

fixed a bug in the drawing of name messages that affected the language level setting that shows up in the bottom right of drscheme

Browse Source 
svn: r7764

original commit: c4781b2025dc6a0294c6c9a5fbe6779330d90a4d
This commit is contained in:
Robby Findler 2007-11-19 14:29:22 +00:00
parent 5a6f81ed26
commit 3d5a3d7fd9
1 changed files with 17 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/mrlib/name-message.ss
View File

@ -259,7 +259,15 @@
ans-w ans-w
ans-h))) ans-h)))
(define (draw-button-label dc label dx dy w h mouse-over? grabbed? button-label-font bkg-color) (define (draw-button-label dc label dx dy full-w h mouse-over? grabbed? button-label-font bkg-color)
(define label-width
(if label
(let-values ([(w _1 _2 _3) (send dc get-text-extent label)])
w)
0))
(define w (+ border-inset circle-spacer button-label-inset label-width triangle-width circle-spacer border-inset))
(when bkg-color (when bkg-color
(send dc set-pen bkg-color 1 'solid) (send dc set-pen bkg-color 1 'solid)
@ -310,17 +318,17 @@
#t))) #t)))
(send dc set-pen (send the-pen-list find-or-create-pen (send dc set-pen (send the-pen-list find-or-create-pen
(if grabbed? grabbed-fg-color triangle-color) (if grabbed? grabbed-fg-color triangle-color)
1 'solid)) 1 'solid))
(let ([x (- w triangle-width circle-spacer)] (let ([x (- w triangle-width circle-spacer)]
[y (- (/ h 2) (/ triangle-height 2))]) [y (- (/ h 2) (/ triangle-height 2))])
(let loop ([x-off 0][off-y 5]) (let loop ([x-off 0][off-y 5])
(unless (= 5 x-off) (unless (= 5 x-off)
(send dc draw-line (send dc draw-line
(+ dx (+ x 1 x-off)) (+ dx (+ x 1 x-off))
(+ dy (+ y off-y)) (+ dy (+ y off-y))
(+ dx (+ x (- triangle-width 1 x-off))) (+ dx (+ x (- triangle-width 1 x-off)))
(+ dy (+ y off-y))) (+ dy (+ y off-y)))
(loop (+ x-off 1) (+ off-y 1))))) (loop (+ x-off 1) (+ off-y 1)))))
(void))) (void)))