From 94892215a93e761979f80a9dba5623e965154421 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Nov 2004 14:23:20 +0000 Subject: [PATCH] . original commit: d939102b323abdf294263589714b23a0d984d0da --- collects/drscheme/private/syntax-browser.ss | 8 +- .../private/tests/test-case-box.ss | 4 +- collects/hierlist/hierlist-unit.ss | 8 +- collects/icons/turn-down-click.png | Bin 0 -> 125 bytes collects/icons/turn-down.png | Bin 0 -> 157 bytes collects/icons/turn-up-click.png | Bin 0 -> 126 bytes collects/icons/turn-up.png | Bin 0 -> 156 bytes collects/mrlib/name-message.ss | 189 +++++++++--------- 8 files changed, 104 insertions(+), 105 deletions(-) create mode 100644 collects/icons/turn-down-click.png create mode 100644 collects/icons/turn-down.png create mode 100644 collects/icons/turn-up-click.png create mode 100644 collects/icons/turn-up.png diff --git a/collects/drscheme/private/syntax-browser.ss b/collects/drscheme/private/syntax-browser.ss index d0e4905b..d1065fe2 100644 --- a/collects/drscheme/private/syntax-browser.ss +++ b/collects/drscheme/private/syntax-browser.ss @@ -438,10 +438,10 @@ needed to really make this work: (define (set-box/f! b v) (when (box? b) (set-box! b v))) - (define down-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down.gif"))) - (define up-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up.gif"))) - (define down-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.gif"))) - (define up-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.gif"))) + (define down-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down.png"))) + (define up-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up.png"))) + (define down-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.png"))) + (define up-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.png"))) (define arrow-snip-height (max 10 (send up-bitmap get-height) diff --git a/collects/embedded-gui/private/tests/test-case-box.ss b/collects/embedded-gui/private/tests/test-case-box.ss index 294b76a1..c5b9c156 100644 --- a/collects/embedded-gui/private/tests/test-case-box.ss +++ b/collects/embedded-gui/private/tests/test-case-box.ss @@ -129,8 +129,8 @@ (define turn-button-snip% (class toggle-button-snip% (super-new - (images-off (cons (icon "turn-down.gif") (icon "turn-down-click.gif"))) - (images-on (cons (icon "turn-up.gif") (icon "turn-up-click.gif")))))) + (images-off (cons (icon "turn-down.png") (icon "turn-down-click.png"))) + (images-on (cons (icon "turn-up.png") (icon "turn-up-click.png")))))) ;; a snip which will display a pass/fail result (define result-snip% diff --git a/collects/hierlist/hierlist-unit.ss b/collects/hierlist/hierlist-unit.ss index 42a1af03..7e239ac8 100644 --- a/collects/hierlist/hierlist-unit.ss +++ b/collects/hierlist/hierlist-unit.ss @@ -34,10 +34,10 @@ (make-object bitmap% 10 10) (make-object bitmap% 10 10)))]) (values - (make-object bitmap% (build-path (collection-path "icons") "turn-up.gif")) - (make-object bitmap% (build-path (collection-path "icons") "turn-down.gif")) - (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.gif")) - (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.gif"))))) + (make-object bitmap% (build-path (collection-path "icons") "turn-up.png")) + (make-object bitmap% (build-path (collection-path "icons") "turn-down.png")) + (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.png")) + (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.png"))))) ;; Hack for implementing auto-wrapping items: (define arrow-size 0) diff --git a/collects/icons/turn-down-click.png b/collects/icons/turn-down-click.png new file mode 100644 index 0000000000000000000000000000000000000000..2e91127976e8770f6119ae277a722a328815476c GIT binary patch literal 125 zcmeAS@N?(olHy`uVBq!ia0vp@Ak4uAB#T}@sR2?ho-U3d6?2jkBv^SspeNv$y=Ilf zM2r8IFP(c3VwpXS^Nx_4iRBupiKYpcTNVn>VKy*L{1Yp6${fu8SV4*j_O+SgjYD U`TnlZTcCLip00i_>zopr09>#rhyVZp literal 0 HcmV?d00001 diff --git a/collects/icons/turn-down.png b/collects/icons/turn-down.png new file mode 100644 index 0000000000000000000000000000000000000000..e163ec5466cb7b8c62093d7fcfd59676bbb7ca4c GIT binary patch literal 157 zcmeAS@N?(olHy`uVBq!ia0vp@Ak4uAB#T}@sR2?co-U3d6?5L6-^kmbAmQ@xxX%uz z)ep4(b8X<#KA^Rxz^u(BDWodC_-eS!AI1mgu7+QzmgjKTdhhnNg!{5-ZQuVjF-)1H zcHu;&v_gx)Y{sdRM3O}njDt0wem!I)Q6S2&foGl-!}KrK+>G;#W&rJD@O1TaS?83{ F1OOw;IF$eZ literal 0 HcmV?d00001 diff --git a/collects/icons/turn-up-click.png b/collects/icons/turn-up-click.png new file mode 100644 index 0000000000000000000000000000000000000000..df807d96483283049ec140441cac0778ccc4a2d3 GIT binary patch literal 126 zcmeAS@N?(olHy`uVBq!ia0vp@Ak4uAB#T}@sR2^1o-U3d6?4{JbmV0);BdZ}H)|PZ zV8$%$3BKEh%D5Pu|U9WSF{0^~0NZrZ)^#?}H1NPZhe(N_`e|4rm>Nr>mdKI;Vst E0IBRcZ~y=R literal 0 HcmV?d00001 diff --git a/collects/mrlib/name-message.ss b/collects/mrlib/name-message.ss index 1d13f308..14aecd73 100644 --- a/collects/mrlib/name-message.ss +++ b/collects/mrlib/name-message.ss @@ -25,16 +25,20 @@ (inherit popup-menu get-dc get-size get-client-size min-width min-height stretchable-width stretchable-height get-top-level-window) - (override on-event on-paint) - - (define/public (on-choose-directory dir) - (void)) (define paths #f) ;; label : string (define label (string-constant untitled)) + (define full-name-window #f) + + (define mouse-grabbed? #f) + (define mouse-over? #f) + + (define/public (on-choose-directory dir) + (void)) + ;; set-message : boolean (union #f path string) -> void ;; if file-name? is #t, path-name should be a path (or #f) ;; if file-name? is #f, path-name should be a string (or #f) @@ -54,10 +58,7 @@ (update-min-sizes) (on-paint)))) - (define full-name-window #f) - - (define mouse-grabbed? #f) - (define (on-event evt) + (define/override (on-event evt) (let* ([needs-update? #f] [do-update (lambda () @@ -65,23 +66,25 @@ (on-paint)))]) (let-values ([(max-x max-y) (get-size)]) - (let ([inside? (and (<= 0 (send evt get-x) max-x) + (let ([inside? (and (not (send evt leaving?)) + (<= 0 (send evt get-x) max-x) (<= 0 (send evt get-y) max-y))]) - (unless (eq? inside? inverted?) - (set! inverted? inside?) + (unless (eq? inside? mouse-over?) + (set! mouse-over? inside?) (set! needs-update? #t)))) (cond [(and paths (not (null? paths))) (cond [(send evt button-down?) - (let-values ([(width height) (get-client-size)]) - - (set! inverted? #t) + (let-values ([(width height) (get-size)]) + (set! mouse-over? #t) (set! needs-update? #t) + (set! mouse-grabbed? #t) (let ([menu (make-object popup-menu% #f (lambda x - (set! inverted? #f) + (set! mouse-over? #f) + (set! mouse-grabbed? #f) (on-paint)))]) (let loop ([paths (cdr (reverse paths))]) (cond @@ -100,10 +103,10 @@ (cond [(send evt button-up? 'left) (set! mouse-grabbed? #f) + (set! needs-update? #t) (cond - [inverted? - (set! inverted? #f) - (set! needs-update? #t) + [mouse-over? + (set! mouse-over? #f) (do-update) (message-box (string-constant drscheme) @@ -113,28 +116,26 @@ (do-update)])] [(send evt button-down? 'left) (set! mouse-grabbed? #t) - (set! inverted? #t) + (set! mouse-over? #t) (set! needs-update? #t) (do-update)] [else (do-update)])]))) (inherit get-parent) - (define (update-min-sizes) + (define/private (update-min-sizes) (let-values ([(w h) (calc-button-min-sizes (get-dc) label)]) (min-width w) (min-height h) (send (get-parent) reflow-container))) - (define inverted? #f) - - (define (on-paint) + (define/override (on-paint) (let ([dc (get-dc)]) (let-values ([(w h) (get-client-size)]) (when (and (> w 5) (> h 5)) - (draw-button-label dc label w h inverted? mouse-grabbed?))))) + (draw-button-label dc label w h mouse-over? mouse-grabbed?))))) - (super-instantiate ()) + (super-new [style '(transparent)]) (update-min-sizes) (stretchable-width #f) (stretchable-height #f))) @@ -149,30 +150,15 @@ (send the-font-list find-or-create-font 10 'decorative 'normal 'normal #f)])) (define button-label-inset 1) - (define black-color (make-object color% "BLACK")) - (define triangle-width 10) - (define triangle-height 7) - (define triangle-space 2) + (define right-triangle-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up.png") 'unknown/mask)) + (define down-triangle-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down.png") 'unknown/mask)) + (define triangle-width (send right-triangle-bitmap get-width)) + (define triangle-height (send right-triangle-bitmap get-height)) - (define (calc-button-min-sizes dc label) - (send dc set-font button-label-font) - (let-values ([(w h a d) (send dc get-text-extent label button-label-font)]) - (let ([ans-w - (+ button-label-inset - 1 ;; becuase "(define ...)" has the wrong size under windows - (max 0 (inexact->exact (ceiling w))) - triangle-space - triangle-width - button-label-inset)] - [ans-h - (+ button-label-inset - (max 0 - (inexact->exact (ceiling h)) - triangle-height) - button-label-inset)]) - (values ans-w ans-h)))) + (define triangle-space 2) + (define circle-spacer 3) (define (offset-color color offset-one) (make-object color% @@ -180,61 +166,74 @@ (offset-one (send color green)) (offset-one (send color blue)))) - (define light-button-color (offset-color (get-panel-background) - (lambda (v) (floor (+ v (/ (- 255 v) 2)))))) - (define dark-button-color (offset-color (get-panel-background) - (lambda (v) (floor (- v (/ v 2)))))) + (define normal-background "lightgray") + (define mouse-over/grabbed-background "darkgray") + + (define mouse-over-border-color "black") + (define border-color "darkgray") + + (define normal-text-color (send the-color-database find-color "black")) + (define mouse-over-text-color (send the-color-database find-color "firebrick")) + + (define (calc-button-min-sizes dc label) + (send dc set-font button-label-font) + (let-values ([(w h a d) (send dc get-text-extent label button-label-font)]) + (let ([ans-w + (+ circle-spacer + button-label-inset + 1 ;; becuase "(define ...)" has the wrong size under windows + (max 0 (inexact->exact (ceiling w))) + triangle-space + triangle-width + button-label-inset + circle-spacer)] + [ans-h + (+ button-label-inset + (max 0 + (+ 2 (inexact->exact (ceiling h))) + (+ 2 triangle-height)) + button-label-inset)]) + (values ans-w ans-h)))) - (define triangle - (list (make-object point% 0 0) - (make-object point% triangle-width 0) - (make-object point% (/ triangle-width 2) triangle-height))) (define (draw-button-label dc label w h mouse-over? grabbed?) - (define inverted? grabbed?) + (cond + [mouse-over? + (send dc set-pen (send the-pen-list find-or-create-pen mouse-over-border-color 1 'solid)) + (send dc set-brush (send the-brush-list find-or-create-brush mouse-over/grabbed-background 'solid)) + (send dc set-text-foreground mouse-over-text-color)] + [else + (send dc set-pen (send the-pen-list find-or-create-pen border-color 1 'solid)) + (send dc set-brush (send the-brush-list find-or-create-brush normal-background 'solid)) + (send dc set-text-foreground black-color)]) - (send dc set-text-foreground black-color) - (send dc set-text-background (get-panel-background)) - (send dc set-pen (send the-pen-list find-or-create-pen - (get-panel-background) 1 'solid)) - (send dc set-brush (send the-brush-list find-or-create-brush - (get-panel-background) 'solid)) + (send dc draw-ellipse 0 0 h h) + (send dc draw-ellipse (- w h) 0 h h) - (send dc draw-rectangle 0 0 w h) + (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send dc draw-rectangle (quotient h 2) 0 (- w h) h) - (send dc set-pen (send the-pen-list find-or-create-pen - "BLACK" 1 'solid)) - (send dc set-brush - (send the-brush-list find-or-create-brush - (if inverted? dark-button-color light-button-color) 'solid)) - - #; - (let ([border - (lambda (d) - (send dc draw-rectangle - d d - (- w drop-shadow-size) - (- h drop-shadow-size)))]) - (if inverted? - (let loop ([n 0]) - (cond - [(= n drop-shadow-size) (void)] - [else - (border n) - (loop (+ n 1))])) - (let loop ([n drop-shadow-size]) - (cond - [(zero? n) (void)] - [else - (border (- n 1)) - (loop (- n 1))])))) - - (send dc draw-polygon triangle - (- w triangle-width) - (- (/ h 2) (/ triangle-height 2))) + (cond + [mouse-over? + (send dc set-pen (send the-pen-list find-or-create-pen mouse-over-border-color 1 'solid))] + [else + (send dc set-pen (send the-pen-list find-or-create-pen border-color 1 'solid))]) + (send dc draw-line (quotient h 2) 0 (- w (quotient h 2)) 0) + (send dc draw-line (quotient h 2) (- h 1) (- w (quotient h 2)) (- h 1)) (when label (send dc set-font button-label-font) - - ;; 1 is for the outer drop shadow box - (send dc draw-text label button-label-inset button-label-inset)))) + (let-values ([(tw th _1 _2) (send dc get-text-extent label)]) + (send dc draw-text label + (+ circle-spacer button-label-inset) + (- (/ h 2) (/ th 2))))) + + (let ([bm (if grabbed? down-triangle-bitmap right-triangle-bitmap)]) + (send dc draw-bitmap + bm + (- w triangle-width circle-spacer) + (- (/ h 2) (/ triangle-height 2)) + 'solid + black-color + (send bm get-loaded-mask))) + (void)))