From 7da94e301c613746b74ea9ed202e0040c9e56036 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 11 Jul 2002 13:55:59 +0000 Subject: [PATCH] .. original commit: 1db3af01e4b49175bf7ea8980fbf7c5b88a29d40 --- collects/framework/gui-utils.ss | 304 ++++++++++++++++++++++ collects/framework/private/preferences.ss | 14 +- collects/tests/framework/main.ss | 6 +- 3 files changed, 312 insertions(+), 12 deletions(-) diff --git a/collects/framework/gui-utils.ss b/collects/framework/gui-utils.ss index 867b67fc..66aa72f2 100644 --- a/collects/framework/gui-utils.ss +++ b/collects/framework/gui-utils.ss @@ -1,3 +1,4 @@ + (module gui-utils mzscheme (require (lib "class.ss") (lib "mred.ss" "mred") @@ -213,6 +214,309 @@ "@flink gui-utils:get-clicked-clickback-delta %" ".")) + (provide gui-utils:choices-canvas%) + +(define gui-utils:choices-canvas% + (class canvas% + (init-field choices callback) + + (field + ;; selection : number + [selection 0] + + ;; button-down/over : (union #f number) + [button-down/over #f]) + + (define/public (get-selection) selection) + (define/public (set-selection _selection) + (set! selection _selection) + (on-paint)) + + (inherit get-dc) + (define/override (on-paint) + (let ([dc (get-dc)]) + (let loop ([names choices] + [n 0] + [x (get-initial-x dc)]) + (cond + [(null? names) (void)] + [else (let* ([name (car names)] + [width (get-width dc name)]) + (draw-name dc name x (cond + [(and button-down/over (= n button-down/over)) + 'button-down/over] + [(= n selection) 'selected] + [else 'unselected])) + + (loop (cdr names) + (+ n 1) + (+ x + width + (- hang-over) + name-gap)))])))) + + ;; on-event : .. same as super + ;; tracks clicks and drags for new selections + (rename [super-on-event on-event]) + (define/override (on-event evt) + (let ([dc (get-dc)]) + (cond + [(send evt button-down? 'left) + (let ([number (find-item evt dc)]) + (if number + (begin (set! clicking number) + (set! last-over number) + (set! button-down/over number) + (on-paint)) + (super-on-event evt)))] + [(and clicking + (send evt button-up? 'left)) + (let ([number (find-item evt dc)]) + (when (and number + (equal? number clicking)) + (set! selection number) + (callback this number)) + (set! last-over #f) + (set! button-down/over #f) + (set! clicking #f) + (on-paint))] + [(and clicking + (send evt moving?)) + (let ([number (find-item evt dc)]) + (unless (equal? last-over number) + (set! last-over number) + (if (and number + (equal? clicking number)) + (set! button-down/over number) + (set! button-down/over #f)) + (on-paint)))] + [else (super-on-event evt)]))) + + (field + ;; clicking : (union #f number) + ;; this is the number that is currently being clicked on + ;; (and may become the new selection) or #f if nothing + ;; is being clicked on. + [clicking #f] + + ;; last-over : (union #f number) + ;; while clicking is a number, this holds the number + ;; that the mouse was last over to avoid extra redrawing + ;; during on-event. + [last-over #f]) + + ;; find-item : mouse-event dc -> (union #f number) + ;; if the mouse event's coordinates are in one of the tabs, + ;; return that tab's number, otherwise return #f + (define/private (find-item evt dc) + (let loop ([names choices] + [n 0] + [x (get-initial-x dc)]) + (cond + [(null? names) #f] + [else (let* ([name (car names)] + [width (get-width dc name)]) + (if (point-in-name? dc x name (send evt get-x) (send evt get-y)) + n + (loop (cdr names) + (+ n 1) + (+ x + width + (- hang-over) + name-gap))))]))) + + ;; point-in-name? : dc number string number number -> boolean + (define (point-in-name? dc x name px py) + (update-points dc name x) + (send region set-polygon points) + (begin0 (point-in-region? px py) + (send region set-rectangle 0 0 0 0))) + + ;; get-initial-x : dc -> number + (inherit get-client-size) + (define (get-initial-x dc) + (let-values ([(w h) (get-client-size)]) + (- (/ w 2) + (/ (get-total-width dc) 2)))) + + ;; get-width : dc string -> number + ;; returns the width of a single name's entry, + ;; not counting the hangover space + (define/private (get-width dc name) + (let-values ([(w h a d) (send dc get-text-extent name label-font)]) + (+ w hang-over hang-over))) + + ;; get-total-width : dc -> number + (define (get-total-width dc) + (let loop ([names choices]) + (cond + [(null? names) (- hang-over name-gap)] + [else + (+ (get-width dc (car names)) + name-gap + (- hang-over) + (loop (cdr names)))]))) + + ;; get-height : dc -> number + (define (get-height dc) + (let-values ([(w h a d) (send dc get-text-extent "Xy" label-font)]) + (+ h top-space bottom-space))) + + ;; draw-name : dc string number (symbols selected button-down/over unselected) -> void + ;; draws the name and the little box around it + ;; at `x' + (define (draw-name dc name x state) + (update-points dc name x) + (send region set-polygon points) + (send dc set-brush + (case state + [(selected) selected-brush] + [(button-down/over) button-down/over-brush] + [(unselected) unselected-brush] + [else (error 'draw-name "unknown state: ~s\n" state)])) + (send dc set-clipping-region region) + (send dc draw-rectangle + (bz (min (send p1 get-x) + (send p2 get-x) + (send p3 get-x) + (send p4 get-x))) + (bz (min (send p1 get-y) + (send p2 get-y) + (send p3 get-y) + (send p4 get-y))) + (bz (max (send p1 get-x) + (send p2 get-x) + (send p3 get-x) + (send p4 get-x))) + (bz (max (send p1 get-y) + (send p2 get-y) + (send p3 get-y) + (send p4 get-y)))) + (send dc set-clipping-region #f) + (send region set-polygon null) + + (send dc draw-line + (bz (send p1 get-x)) + (bz (send p1 get-y)) + (bz (send p2 get-x)) + (bz (send p2 get-y))) + (send dc draw-line + (bz (send p2 get-x)) + (bz (send p2 get-y)) + (bz (send p3 get-x)) + (bz (send p3 get-y))) + (send dc draw-line + (bz (send p3 get-x)) + (bz (send p3 get-y)) + (bz (send p4 get-x)) + (bz (send p4 get-y))) + + (let-values ([(w h a d) (send dc get-text-extent name label-font)]) + (let ([wid (get-width dc name)]) + (send dc set-text-foreground + (case state + [(selected) selected-text-color] + [(button-down/over) selected-text-color] + [(unselected) unselected-text-color])) + (send dc set-font label-font) + (send dc draw-text name + (bz (+ x (- (/ wid 2) (/ w 2)))) + (bz top-space))))) + + ;; update-points : dc name number -> void + ;; updates p1, p2, p3, and p4 with the points around + ;; the name `name', starting at `x' + (define/private (update-points dc name x) + (let-values ([(w h a d) (send dc get-text-extent name label-font)]) + (let ([wid (get-width dc name)]) + (let ([x1 x] + [y1 (+ top-space h bottom-space)] + [x2 (+ x hang-over)] + [y2 1] + [x3 (+ x hang-over w hang-over)] + [y3 1] + [x4 (+ x hang-over w)] + [y4 (+ top-space h bottom-space)]) + (send p1 set-x (bz x1)) + (send p1 set-y (bz y1)) + (send p2 set-x (bz x2)) + (send p2 set-y (bz y2)) + (send p3 set-x (bz x3)) + (send p3 set-y (bz y3)) + (send p4 set-x (bz x4)) + (send p4 set-y (bz y4)))))) + + (define/private (bz n) (max 0 n)) + + ;; point-in-region? : number number -> boolean + ;; returns #t if the point specified by `x' and `y' is + ;; in `region'. + (define (point-in-region? x y) + (send tmp-region set-rectangle x y 1 1) + (send tmp-region intersect region) + (not (send tmp-region is-empty?))) + + (super-instantiate ()) + + ;; for use with point-in-region? + (field [tmp-region (instantiate region% () (dc (get-dc)))]) + + (field [region (instantiate region% () (dc (get-dc)))] + [p1 (make-object point% 0 0)] + [p2 (make-object point% 0 0)] + [p3 (make-object point% 0 0)] + [p4 (make-object point% 0 0)] + [points (list p1 p2 p3 p4)]) + + (inherit min-height stretchable-height + min-width stretchable-width) + (stretchable-height #f) + (min-height (floor (inexact->exact (get-height (get-dc))))) + (stretchable-width #t) + (min-width (floor (inexact->exact (get-total-width (get-dc))))))) + +;; selected-text-color : color +(define selected-text-color (make-object color% "black")) + +;; unselected-text-color : color +(define unselected-text-color (make-object color% "light gray")) + +;; selected-brush : brush +(define selected-brush (send the-brush-list find-or-create-brush (get-panel-background) 'solid)) + +;; unselected-brush : brush +(define unselected-brush (send the-brush-list find-or-create-brush "white" 'solid)) + +;; button-down/over-brush : brush +(define button-down/over-brush (send the-brush-list find-or-create-brush + (make-object color% 225 225 255) + 'solid)) + +;; label-font : font +(define label-font (send the-font-list find-or-create-font + 12 + 'system 'normal + (if (eq? (system-type) 'macosx) 'bold 'normal) + #f)) + +;; name-gap : number +;; the space between each name +(define name-gap 4) + +;; hang-over : number +;; the amount of space a single entry "slants" over +(define hang-over 8) + +;; top-space : number +;; the gap at the top of the canvas, above all the choices +(define top-space 4) + +;; bottom-space : number +;; the extra space below the words +(define bottom-space 2) + +;; end choices-canvas% + (define (cancel-on-right?) (eq? (system-type) 'windows)) (define ok/cancel-buttons diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 757965c8..8c488f4b 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -704,20 +704,20 @@ (string-constant preferences))] [panel (make-object vertical-panel% frame)] [popup-callback - (lambda (choice command-event) + (lambda (choices-canvas selection) (unless (null? ppanels) (send single-panel active-child - (ppanel-panel (list-ref ppanels (send choice get-selection))))))] + (ppanel-panel (list-ref ppanels selection)))))] [make-popup-menu (lambda () - (let ([menu (make-object choice% (string-constant preferences-category) - (map ppanel-title ppanels) - panel popup-callback)]) + (let ([menu (instantiate gui-utils:choices-canvas% () + (choices (map ppanel-title ppanels)) + (parent panel) + (callback popup-callback))]) (send menu stretchable-width #f) menu))] [popup-menu (make-popup-menu)] - [single-panel (make-object panel:single% - panel '(border))] + [single-panel (make-object panel:single% panel)] [bottom-panel (make-object horizontal-panel% panel)] [ensure-constructed (lambda () diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index b5eecd60..4aa66cca 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -7,11 +7,7 @@ (define argv (current-command-line-arguments)) - (define preferences-file (build-path (find-system-path 'pref-dir) - (case (system-type) - [(macos) "MrEd Preferences"] - [(windows) "mred.pre"] - [(unix) ".mred.prefs"]))) + (define preferences-file (find-system-path 'pref-file)) (define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)]) (build-path base (string-append name ".save"))))