From 3988aabd7e40911c4130508c4329bb984c0f86ec Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 30 Oct 2023 16:34:43 -0600 Subject: [PATCH] add 'upward style for slider controls --- gui-doc/scribblings/gui/slider-class.scrbl | 12 ++++++++---- gui-lib/info.rkt | 2 +- gui-lib/mred/private/mritem.rkt | 2 +- gui-lib/mred/private/wx/cocoa/slider.rkt | 8 ++++++-- gui-lib/mred/private/wx/gtk/slider.rkt | 6 +++++- gui-lib/mred/private/wx/win32/slider.rkt | 12 +++++++++--- gui-lib/mred/private/wxlitem.rkt | 22 ++++++++++++---------- gui-test/tests/gracket/item.rkt | 18 ++++++++++++++++-- gui-test/tests/gracket/windowing.rktl | 11 ++++++++--- 9 files changed, 66 insertions(+), 27 deletions(-) diff --git a/gui-doc/scribblings/gui/slider-class.scrbl b/gui-doc/scribblings/gui/slider-class.scrbl index 693a4c2c9..9e06bd4d4 100644 --- a/gui-doc/scribblings/gui/slider-class.scrbl +++ b/gui-doc/scribblings/gui/slider-class.scrbl @@ -23,7 +23,7 @@ Whenever the user changes the value of a slider, its callback (is-a?/c panel%) (is-a?/c pane%))] [callback ((is-a?/c slider%) (is-a?/c control-event%) . -> . any) (lambda (b e) (void))] [init-value position-integer? min-value] - [style (listof (or/c 'horizontal 'vertical 'plain + [style (listof (or/c 'horizontal 'vertical 'upward 'plain 'vertical-label 'horizontal-label 'deleted)) '(horizontal)] @@ -51,14 +51,18 @@ The @racket[min-value] and @racket[max-value] arguments specify the The @racket[callback] procedure is called (with the event type @indexed-racket['slider]) when the user changes the slider's value. -The @racket[style] argument must include either @racket['vertical] for - a vertical slider, or @racket['horizontal] for a horizontal - slider. If @racket[style] includes @racket['plain], the slider does +The @racket[style] argument must include either @racket['horizontal] for a horizontal + slider going left-to-right, @racket['upward] for + a vertical slider going up, or @racket['vertical] for + a vertical slider going down (but beware that @racket['vertical] might render + with misleading colors on Mac OS, where the system toolkit supports only upward sliders). + If @racket[style] includes @racket['plain], the slider does not display numbers for its range and current value to the user. @HVLabelNote[@racket[style]]{slider} @DeletedStyleNote[@racket[style] @racket[parent]]{slider} @FontKWs[@racket[font]] @WindowKWs[@racket[enabled]] @SubareaKWs[] @AreaKWs[] +@history[#:changed "1.73" @elem{Added @racket['upward] as a possible @racket[style] element.}] } diff --git a/gui-lib/info.rkt b/gui-lib/info.rkt index 00b8ce99d..9e4535f1a 100644 --- a/gui-lib/info.rkt +++ b/gui-lib/info.rkt @@ -34,7 +34,7 @@ (define pkg-authors '(mflatt robby)) -(define version "1.72") +(define version "1.73") (define license '(Apache-2.0 OR MIT)) diff --git a/gui-lib/mred/private/mritem.rkt b/gui-lib/mred/private/mritem.rkt index 7c259f200..bfcb1b851 100644 --- a/gui-lib/mred/private/mritem.rkt +++ b/gui-lib/mred/private/mritem.rkt @@ -451,7 +451,7 @@ (check-container-parent cwho parent) (check-callback cwho callback) (check-slider-integer cwho init-value) - (check-style cwho '(vertical horizontal) '(plain vertical-label horizontal-label deleted) style) + (check-style cwho '(vertical horizontal upward) '(plain vertical-label horizontal-label deleted) style) (check-font cwho font) (unless (<= minv maxv) (raise-arguments-error (who->name cwho) diff --git a/gui-lib/mred/private/wx/cocoa/slider.rkt b/gui-lib/mred/private/wx/cocoa/slider.rkt index 5b35ac0f5..bf2c4f788 100644 --- a/gui-lib/mred/private/wx/cocoa/slider.rkt +++ b/gui-lib/mred/private/wx/cocoa/slider.rkt @@ -44,7 +44,9 @@ (inherit get-cocoa register-as-child init-font) - (define vert? (memq 'vertical style)) + (define vert? (or (memq 'vertical style) + (memq 'upward style))) + (define up? (memq 'upward style)) (define slider-lo lo) (define slider-hi hi) @@ -155,7 +157,9 @@ (define/private (flip v) (if vert? - (+ slider-lo (- slider-hi v)) + (if up? + v + (+ slider-lo (- slider-hi v))) v)) (define/public (set-value v) diff --git a/gui-lib/mred/private/wx/gtk/slider.rkt b/gui-lib/mred/private/wx/gtk/slider.rkt index 8ba67182f..1a0cfa7f9 100644 --- a/gui-lib/mred/private/wx/gtk/slider.rkt +++ b/gui-lib/mred/private/wx/gtk/slider.rkt @@ -23,6 +23,7 @@ (define-gtk gtk_range_get_value (_fun _GtkWidget -> _double)) (define-gtk gtk_scale_set_digits (_fun _GtkWidget _int -> _void)) (define-gtk gtk_scale_set_draw_value (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_range_set_inverted (_fun _GtkWidget _gboolean -> _void)) (define-signal-handler connect-changed "value-changed" (_fun _GtkWidget -> _void) @@ -42,7 +43,8 @@ (super-new [parent parent] [gtk (as-gtk-allocation - (if (memq 'vertical style) + (if (or (memq 'vertical style) + (memq 'upward style)) (gtk_vscale_new #f) (gtk_hscale_new #f)))] [callback cb] @@ -53,6 +55,8 @@ (gtk_range_set_range gtk lo hi) (gtk_range_set_increments gtk 1.0 1.0) (gtk_range_set_value gtk val) + (when (memq 'upward style) + (gtk_range_set_inverted gtk #true)) (when (memq 'plain style) (gtk_scale_set_draw_value gtk #f)) diff --git a/gui-lib/mred/private/wx/win32/slider.rkt b/gui-lib/mred/private/wx/win32/slider.rkt index 9e10b6aed..ef1a87562 100644 --- a/gui-lib/mred/private/wx/win32/slider.rkt +++ b/gui-lib/mred/private/wx/win32/slider.rkt @@ -43,7 +43,10 @@ auto-size) (define callback cb) - (define vertical? (memq 'vertical style)) + (define vertical? (or (memq 'vertical style) + (memq 'upward style))) + (define up? (memq 'upward style)) + (define upward-hi (and up? hi)) (define panel-hwnd (if (memq 'plain style) @@ -127,7 +130,7 @@ (SendMessageW slider-hwnd TBM_SETRANGEMIN 1 lo) (SendMessageW slider-hwnd TBM_SETRANGEMAX 1 hi) - (set-value val) + (set-value (if up? (- hi val) val)) (define/override (set-size x y w h) (super set-size x y w h) @@ -165,4 +168,7 @@ (SetWindowTextW value-hwnd (format "~s" val))) (define/public (get-value) - (SendMessageW slider-hwnd TBM_GETPOS 0 0))) + (define v (SendMessageW slider-hwnd TBM_GETPOS 0 0)) + (if up? + (- upward-hi v) + v))) diff --git a/gui-lib/mred/private/wxlitem.rkt b/gui-lib/mred/private/wxlitem.rkt index 78077b7ba..e17083a2f 100644 --- a/gui-lib/mred/private/wxlitem.rkt +++ b/gui-lib/mred/private/wxlitem.rkt @@ -397,17 +397,19 @@ (define c (make-object wx-internal-slider% mred proxy (get-p) func label value min-val max-val (filter-style style) font)) - - (set-c c - (memq 'horizontal style) - (memq 'vertical style)) - + + (let ([vert? (or (memq 'vertical style) + (memq 'upward style))]) + (set-c c + (not vert?) + vert?) + (let ([h? (not vert?)]) + (stretchable-in-x h?) + (stretchable-in-y (not h?)))) + (bounce c (get-value) - (set-value v)) - (let ([h? (and (memq 'horizontal style) #t)]) - (stretchable-in-x h?) - (stretchable-in-y (not h?))))) - + (set-value v)))) + ) diff --git a/gui-test/tests/gracket/item.rkt b/gui-test/tests/gracket/item.rkt index 72e681435..f6f8d221b 100644 --- a/gui-test/tests/gracket/item.rkt +++ b/gui-test/tests/gracket/item.rkt @@ -1803,17 +1803,20 @@ (instructions p "combo-steps.txt") (send f show #t)) +(define slider-frame-style 'horizontal) +(define slider-frame-max 11) + (define (slider-frame style) (define f (make-frame frame% "Slider Test")) (define p (make-object vertical-panel% f)) (define old-list null) (define commands (list 'slider)) - (define s (make-object slider% "Slide Me" -1 11 p + (define s (make-object slider% "Slide Me" -1 slider-frame-max p (lambda (sl e) (check-callback-event s sl e commands #f) (printf "slid: ~a\n" (send s get-value))) 3 - (cons 'horizontal style))) + (cons slider-frame-style style))) (define c (make-object button% "Check" p (lambda (c e) (for-each @@ -2467,6 +2470,17 @@ (make-object vertical-pane% gsp) ; filler (make-object button% "Make Slider Frame" gsp (lambda (b e) (slider-frame null))) (make-object button% "Make Plain Slider Frame" gsp (lambda (b e) (slider-frame '(plain)))) +(make-object choice% #f '("Left" "Down" "Up" "Left^" "Down^" "Up^") + gsp (lambda (c e) + (set! slider-frame-style + (case (send c get-selection) + [(0 3) 'horizontal] + [(1 4) 'vertical] + [(2 5) 'upward])) + (set! slider-frame-max + (case (send c get-selection) + [(0 1 2) 11] + [(3 4 5) 1023])))) (make-object vertical-pane% gsp) ; filler (make-object button% "Make Tab Panel" gsp (lambda (b e) (test-tab-panel #f))) (make-object button% "Make Tabs" gsp (lambda (b e) (test-tab-panel #t))) diff --git a/gui-test/tests/gracket/windowing.rktl b/gui-test/tests/gracket/windowing.rktl index 637cc472d..7f2cc5966 100644 --- a/gui-test/tests/gracket/windowing.rktl +++ b/gui-test/tests/gracket/windowing.rktl @@ -643,7 +643,12 @@ (new slider% [parent parent] [label #f] [min-value 10] [max-value 9])) (mismatch (new slider% [parent parent] [label #f] [min-value 10] [max-value 11] [init-value 12])) - (letrec ([s (make-object slider% + (letrec ([style (case (random 3) + [(0) '(horizontal)] + [(1) '(vertical)] + [(2) '(upward)])] + [horiz? (and (memq 'horizontal style) #t)] + [s (make-object slider% "&Slider" -2 8 parent @@ -653,7 +658,7 @@ (set! side-effect 'slider) 'oops) 3 - '(horizontal))]) + style)]) (label-test s "Slider") (stv s command (make-object control-event% 'slider)) (test 'slider 'slider-callback side-effect) @@ -666,7 +671,7 @@ (stv s set-value 8) (st 8 s get-value) - (containee-window-tests s #t #f parent frame 2)) + (containee-window-tests s horiz? (not horiz?) parent frame 2)) (let ([test-list-control (lambda (l choice? multi?)