made the bottom line of the drscheme window be half as tall
svn: r7762 original commit: 753cd127a6577931c0dc24d2232078088eba348e
This commit is contained in:
Robby Findler
parent
d36b4b6015
commit
5a6f81ed26
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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%
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user