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

.

Browse Source 
original commit: b6176c858857ec0fb1ed02d4e1ab8426025c5252
This commit is contained in:
Matthew Flatt 2004-11-30 17:14:38 +00:00
parent 6b6142d0f6
commit a902f3f982
1 changed files with 78 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -24,7 +24,7 @@
(class canvas% (class canvas%
(inherit popup-menu get-dc get-size get-client-size min-width min-height (inherit popup-menu get-dc get-size get-client-size min-width min-height
stretchable-width stretchable-height stretchable-width stretchable-height
get-top-level-window) get-top-level-window refresh)
(define paths #f) (define paths #f)
@ -56,14 +56,15 @@
(unless (equal? label new-label) (unless (equal? label new-label)
(set! label new-label) (set! label new-label)
(update-min-sizes) (update-min-sizes)
(on-paint)))) (refresh))))
(define/override (on-event evt) (define/override (on-event evt)
(let* ([needs-update? #f] (let* ([needs-update? #f]
[do-update [do-update
(lambda () (lambda ()
(when needs-update? (when needs-update?
(on-paint)))]) (refresh)
(yield)))])
(let-values ([(max-x max-y) (get-size)]) (let-values ([(max-x max-y) (get-size)])
(let ([inside? (and (not (send evt leaving?)) (let ([inside? (and (not (send evt leaving?))
@ -74,53 +75,34 @@
(set! needs-update? #t)))) (set! needs-update? #t))))
(cond (cond
[(and paths (not (null? paths))) [(send evt button-down?)
(cond (let-values ([(width height) (get-size)])
[(send evt button-down?) (set! mouse-over? #t)
(let-values ([(width height) (get-size)]) (set! needs-update? #t)
(set! mouse-over? #t) (set! mouse-grabbed? #t)
(set! needs-update? #t) (let ([menu (make-object popup-menu% #f
(set! mouse-grabbed? #t) (lambda x
(let ([menu (make-object popup-menu% #f (set! mouse-over? #f)
(lambda x (set! mouse-grabbed? #f)
(set! mouse-over? #f) (refresh)))])
(set! mouse-grabbed? #f) (if (and paths (not (null? paths)))
(on-paint)))]) (let loop ([paths (cdr (reverse paths))])
(let loop ([paths (cdr (reverse paths))]) (cond
(cond [(null? paths) (void)]
[(null? paths) (void)] [else
[else (make-object menu-item% (car paths) menu
(make-object menu-item% (car paths) menu (lambda (evt item)
(lambda (evt item) (on-choose-directory (apply build-path (reverse paths)))))
(on-choose-directory (apply build-path (reverse paths))))) (loop (cdr paths))]))
(loop (cdr paths))])) (let ([i (make-object menu-item%
(do-update) (string-constant no-full-name-since-not-saved)
(popup-menu menu menu void)])
0 (send i enable #f)))
height)))] (do-update)
[else (do-update)])] (popup-menu menu
[else 0
(cond height)))]
[(send evt button-up? 'left) [else (do-update)])))
(set! mouse-grabbed? #f)
(set! needs-update? #t)
(cond
[mouse-over?
(set! mouse-over? #f)
(do-update)
(message-box
(string-constant drscheme)
(string-constant no-full-name-since-not-saved)
(get-top-level-window))]
[else
(do-update)])]
[(send evt button-down? 'left)
(set! mouse-grabbed? #t)
(set! mouse-over? #t)
(set! needs-update? #t)
(do-update)]
[else
(do-update)])])))
(inherit get-parent) (inherit get-parent)
(define/private (update-min-sizes) (define/private (update-min-sizes)
@ -152,13 +134,14 @@
(define button-label-inset 1) (define button-label-inset 1)
(define black-color (make-object color% "BLACK")) (define black-color (make-object color% "BLACK"))
(define unclicked-triangle (make-object bitmap% (build-path (collection-path "icons") "turn-down.png") 'unknown/mask)) (define triangle-width 10)
(define clicked-triangle (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.png") 'unknown/mask)) (define triangle-height 16)
(define triangle-width (send clicked-triangle get-width)) (define triangle-color (make-object color% 50 50 50))
(define triangle-height (send clicked-triangle get-height))
(define triangle-space 2) (define border-inset 1)
(define circle-spacer 3) (define triangle-space 0)
(define circle-spacer 4)
(define rrect-spacer 3)
(define (offset-color color offset-one) (define (offset-color color offset-one)
(make-object color% (make-object color%
@ -166,14 +149,11 @@
(offset-one (send color green)) (offset-one (send color green))
(offset-one (send color blue)))) (offset-one (send color blue))))
(define normal-background "lightgray") (define mouse-over-color (case (system-type)
(define mouse-over/grabbed-background "darkgray") [(macosx) "darkgray"]
[else (make-object color% 230 230 230)]))
(define border-color "lightgray") (define mouse-grabbed-color (make-object color% 100 100 100))
(define mouse-over-border-color "darkgray") (define grabbed-fg-color (make-object color% 220 220 220))
(define normal-text-color (send the-color-database find-color "black"))
(define mouse-over-text-color (send the-color-database find-color "black"))
(define (calc-button-min-sizes dc label) (define (calc-button-min-sizes dc label)
(send dc set-font button-label-font) (send dc set-font button-label-font)
@ -195,45 +175,46 @@
button-label-inset)]) button-label-inset)])
(values ans-w ans-h)))) (values ans-w ans-h))))
(define (draw-button-label dc label w h mouse-over? grabbed?) (define (draw-button-label dc label w h mouse-over? grabbed?)
(cond (when (or mouse-over? grabbed?)
[mouse-over? (let ([color (if grabbed?
(send dc set-pen (send the-pen-list find-or-create-pen mouse-over-border-color 1 'solid)) mouse-grabbed-color
(send dc set-brush (send the-brush-list find-or-create-brush mouse-over/grabbed-background 'solid)) mouse-over-color)]
(send dc set-text-foreground mouse-over-text-color)] [xh (- h (* 2 border-inset))])
[else (case (system-type)
(send dc set-pen (send the-pen-list find-or-create-pen border-color 1 'solid)) [(macosx)
(send dc set-brush (send the-brush-list find-or-create-brush normal-background 'solid)) (send dc set-pen (send the-pen-list find-or-create-pen color 1 'solid))
(send dc set-text-foreground black-color)]) (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))
(send dc draw-ellipse border-inset border-inset xh xh)
(send dc draw-ellipse 0 0 h h) (send dc draw-ellipse (- w xh) border-inset xh xh)
(send dc draw-ellipse (- w h) 0 h h) (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
(send dc draw-rectangle (quotient xh 2) border-inset (- w xh) xh)
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) (send dc set-pen (send the-pen-list find-or-create-pen color 1 'solid))
(send dc draw-rectangle (quotient h 2) 0 (- w h) h) (send dc draw-line (quotient xh 2) border-inset (- w (quotient xh 2)) border-inset)
(send dc draw-line (quotient xh 2) (- h 1 border-inset) (- w (quotient xh 2)) (- h 1 border-inset))]
(cond [else
[mouse-over? (send dc set-pen (send the-pen-list find-or-create-pen triangle-color 1 'solid))
(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 color 'solid))
[else (send dc draw-rounded-rectangle rrect-spacer border-inset (- w border-inset rrect-spacer) xh 2)])))
(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 (when label
(send dc set-text-foreground (if grabbed? grabbed-fg-color black-color))
(send dc set-font button-label-font) (send dc set-font button-label-font)
(let-values ([(tw th _1 _2) (send dc get-text-extent label)]) (let-values ([(tw th _1 _2) (send dc get-text-extent label)])
(send dc draw-text label (send dc draw-text label
(+ circle-spacer button-label-inset) (+ circle-spacer button-label-inset)
(- (/ h 2) (/ th 2))))) (- (/ h 2) (/ th 2)))))
(let ([bm (if grabbed? clicked-triangle unclicked-triangle)]) (send dc set-pen (send the-pen-list find-or-create-pen
(send dc draw-bitmap (if grabbed? grabbed-fg-color triangle-color)
bm 1 'solid))
(- w triangle-width circle-spacer) (let ([x (- w triangle-width circle-spacer)]
(- (/ h 2) (/ triangle-height 2)) [y (- (/ h 2) (/ triangle-height 2))])
'solid (let loop ([dx 0][dy 6])
black-color (unless (= 5 dx)
(send bm get-loaded-mask))) (send dc draw-line
(+ x 1 dx) (+ y dy)
(+ x (- triangle-width 1 dx)) (+ y dy))
(loop (+ dx 1) (+ dy 1)))))
(void))) (void)))