From 5a6f81ed26e30006fe452c9106ff90cb9c05ceff Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 19 Nov 2007 04:01:13 +0000 Subject: [PATCH] made the bottom line of the drscheme window be half as tall svn: r7762 original commit: 753cd127a6577931c0dc24d2232078088eba348e --- collects/framework/private/frame.ss | 111 +++++----------------------- collects/framework/private/icon.ss | 4 +- collects/mrlib/name-message.ss | 60 +++++++++++++-- 3 files changed, 75 insertions(+), 100 deletions(-) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index d19023cf..3fd0da05 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -254,10 +254,7 @@ (super-new) (send (group:get-the-frame-group) insert-frame this))) - (define locked-message-line1 (string-constant read-only-line1)) - (define locked-message-line2 (string-constant read-only-line2)) - (define unlocked-message-line1 (string-constant read/write-line1)) - (define unlocked-message-line2 (string-constant read/write-line2)) + (define locked-message (string-constant read-only)) (define lock-canvas% (class canvas% @@ -272,38 +269,26 @@ (define/override (on-paint) (let* ([dc (get-dc)] [draw - (λ (str1 str2 bg-color bg-style line-color line-style) + (λ (str bg-color bg-style line-color line-style) (send dc set-font small-control-font) (let-values ([(w h) (get-client-size)] - [(tw1 th1 _1 _2) (send dc get-text-extent str1)] - [(tw2 th2 _3 _4) (send dc get-text-extent str2)]) + [(tw th _1 _2) (send dc get-text-extent str)]) (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style)) (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style)) (send dc draw-rectangle 0 0 w h) - (cond - [(string=? str2 "") - (send dc draw-text str1 - (- (/ w 2) (/ tw1 2)) - (- (* h 1/2) (/ th1 2)))] - [else - (send dc draw-text str1 - (- (/ w 2) (/ tw1 2)) - (- (* h 1/2) th1)) - (send dc draw-text str2 - (- (/ w 2) (/ tw2 2)) - (* h 1/2))])))]) + (send dc draw-text str + (- (/ w 2) (/ tw 2)) + (- (/ h 2) (/ th 2)))))]) (when locked? - (draw locked-message-line1 locked-message-line2 - "yellow" 'solid "black" 'solid)))) + (draw locked-message "yellow" 'solid "black" 'solid)))) (inherit get-parent min-width min-height stretchable-width stretchable-height) (define/private (setup-sizes) (let ([dc (get-dc)]) (if locked? - (let-values ([(wl1 hl1 _1 _2) (send dc get-text-extent locked-message-line1)] - [(wl2 hl2 _3 _4) (send dc get-text-extent locked-message-line2)]) - (min-width (inexact->exact (floor (+ 2 (max (+ wl1 2) (+ wl2 2)))))) - (min-height (inexact->exact (floor (+ 2 hl1 hl2))))) + (let-values ([(w h _1 _2) (send dc get-text-extent locked-message)]) + (min-width (inexact->exact (floor (+ w 4)))) + (min-height (inexact->exact (floor (+ h 2))))) (begin (min-width 0) (min-height 0))))) @@ -315,58 +300,6 @@ (stretchable-width #f) (stretchable-height #t))) - #; - (define lock-canvas% - (class canvas% - (field [locked? #f]) - (inherit refresh) - (define/public (set-locked l) - (set! locked? l) - (refresh)) - (inherit get-client-size get-dc) - (define/override (on-paint) - (let* ([dc (get-dc)] - [draw - (λ (str1 str2 bg-color bg-style line-color line-style) - (send dc set-font small-control-font) - (let-values ([(w h) (get-client-size)] - [(tw1 th1 _1 _2) (send dc get-text-extent str1)] - [(tw2 th2 _3 _4) (send dc get-text-extent str2)]) - (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style)) - (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style)) - (send dc draw-rectangle 0 0 w h) - (cond - [(string=? str2 "") - (send dc draw-text str1 - (- (/ w 2) (/ tw1 2)) - (- (* h 1/2) (/ th1 2)))] - [else - (send dc draw-text str1 - (- (/ w 2) (/ tw1 2)) - (- (* h 1/2) th1)) - (send dc draw-text str2 - (- (/ w 2) (/ tw2 2)) - (* h 1/2))])))]) - (if locked? - (draw locked-message-line1 locked-message-line2 - "yellow" 'solid "black" 'solid) - (draw unlocked-message-line1 unlocked-message-line2 - (get-panel-background) 'transparent (get-panel-background) 'transparent)))) - (inherit get-parent min-width min-height stretchable-width stretchable-height) - - (super-new [style '(transparent)]) - - (let ([dc (get-dc)]) - (send dc set-font small-control-font) - (let-values ([(wl1 hl1 _1 _2) (send dc get-text-extent locked-message-line1)] - [(wl2 hl2 _3 _4) (send dc get-text-extent locked-message-line2)] - [(wu1 hu1 _5 _6) (send dc get-text-extent unlocked-message-line1)] - [(wu2 hu2 _7 _8) (send dc get-text-extent unlocked-message-line2)]) - (stretchable-width #f) - (stretchable-height #t) - (min-width (inexact->exact (floor (+ 2 (max (+ wl1 2) (+ wl2 2) wu1 wu2))))) - (min-height (inexact->exact (floor (+ 2 hu1 hu2)))))))) - (define status-line<%> (interface (basic<%>) open-status-line @@ -987,34 +920,26 @@ (define-values (anchor-message overwrite-message macro-recording-message) - (let* ([text-info-messages-parent - (new vertical-panel% - [parent (get-info-panel)] - [stretchable-width #f])] - [anchor-message + (let* ([anchor-message (new message% [font small-control-font] [label (string-constant auto-extend-selection)] - [parent text-info-messages-parent])] - [hp (new horizontal-panel% - [alignment '(left center)] - [parent text-info-messages-parent] - [stretchable-height #f])] + [parent (get-info-panel)])] [overwrite-message (new message% [font small-control-font] [label (string-constant overwrite)] - [parent hp])] + [parent (get-info-panel)])] [macro-recording-message (new message% [label "c-x;("] [font small-control-font] - [parent hp])]) + [parent (get-info-panel)])] + [msgs (list anchor-message + overwrite-message + macro-recording-message)]) (send (get-info-panel) change-children - (λ (l) - (cons - text-info-messages-parent - (remq text-info-messages-parent l)))) + (λ (l) (append msgs (remq* msgs l)))) (values anchor-message overwrite-message macro-recording-message))) diff --git a/collects/framework/private/icon.ss b/collects/framework/private/icon.ss index e9fb159d..718f8e5f 100644 --- a/collects/framework/private/icon.ss +++ b/collects/framework/private/icon.ss @@ -44,8 +44,8 @@ (define get-up/down-cursor (make-get-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s)) (define get-left/right-cursor (make-get-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w)) - (define mrf-on-bitmap (delay (include-bitmap (lib "mrf.jpg" "icons")))) - (define gc-on-bitmap (delay (include-bitmap (lib "recycle.gif" "icons")))) + (define mrf-on-bitmap (delay (include-bitmap (lib "mrf.png" "icons")))) + (define gc-on-bitmap (delay (include-bitmap (lib "recycle.png" "icons")))) (define (make-off-bitmap onb) (let* ([bitmap (make-object bitmap% diff --git a/collects/mrlib/name-message.ss b/collects/mrlib/name-message.ss index 2752a2e4..36e02b0d 100644 --- a/collects/mrlib/name-message.ss +++ b/collects/mrlib/name-message.ss @@ -24,7 +24,8 @@ [h (and/c number? (min-h w))] [mouse-over? boolean?] [grabbed? boolean?] - [button-label-font (is-a?/c font%)]) + [button-label-font (is-a?/c font%)] + [bkg-color (or/c false/c (is-a?/c color%) string?)]) void?)) (calc-button-min-sizes @@ -44,6 +45,13 @@ (unless (eq? hidden? d?) (set! hidden? d?) (refresh))) + + (define allow-to-shrink #f) + (define/public (set-allow-shrinking w) + (unless (eq? w allow-to-shrink) + (set! allow-to-shrink w) + (set! to-draw-message #f) + (update-min-sizes))) (define paths #f) @@ -75,6 +83,7 @@ [else (string-constant untitled)])]) (unless (equal? label new-label) (set! label new-label) + (set! to-draw-message #f) (update-min-sizes) (refresh)))) @@ -134,13 +143,25 @@ (inherit get-parent) (define/private (update-min-sizes) (let-values ([(w h) (calc-button-min-sizes (get-dc) label font)]) - (min-width w) + (cond + [allow-to-shrink + (cond + [(< w allow-to-shrink) + (stretchable-width #f) + (min-width w)] + [else + (stretchable-width #t) + (min-width allow-to-shrink)])] + [else + (min-width w)]) (min-height h) (send (get-parent) reflow-container))) (define/override (on-paint) (when paint-sema - (semaphore-post paint-sema)) + (semaphore-post paint-sema)) + (unless to-draw-message + (compute-new-string)) (let ([dc (get-dc)]) (let-values ([(w h) (get-client-size)]) (cond @@ -154,7 +175,30 @@ (send dc set-brush brush))] [else (when (and (> w 5) (> h 5)) - (draw-button-label dc label 0 0 w h mouse-over? mouse-grabbed? font))])))) + (draw-button-label dc to-draw-message 0 0 w h mouse-over? mouse-grabbed? font (get-background-color)))])))) + + (define/public (get-background-color) #f) + + (define to-draw-message #f) + (define/private (compute-new-string) + (let-values ([(cw ch) (get-client-size)]) + (let ([width-to-use (- cw (get-left-side-padding) triangle-width circle-spacer)]) + (let loop ([c (string-length label)]) + (cond + [(= c 0) (set! to-draw-message "")] + [else + (let ([candidate (if (= c (string-length label)) + label + (string-append (substring label 0 c) "..."))]) + (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent candidate small-control-font)]) + (cond + [(tw . <= . width-to-use) (set! to-draw-message candidate)] + [else + (loop (- c 1))])))]))))) + + (define/override (on-size w h) + (compute-new-string) + (refresh)) (super-new [style '(transparent no-focus)]) (update-min-sizes) @@ -215,7 +259,13 @@ ans-w ans-h))) - (define (draw-button-label dc label dx dy w h mouse-over? grabbed? button-label-font) + (define (draw-button-label dc label dx dy w h mouse-over? grabbed? button-label-font bkg-color) + + (when bkg-color + (send dc set-pen bkg-color 1 'solid) + (send dc set-brush bkg-color 'solid) + (send dc draw-rectangle dx dy w h)) + (when (or mouse-over? grabbed?) (let ([color (if grabbed? mouse-grabbed-color