From 09b8eb0be41f7f0fbf96cc070efdc25f6fa09e60 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 | 8 +++++--- 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 | 20 +++++++++++--------- gui-test/tests/gracket/windowing.rktl | 11 ++++++++--- 7 files changed, 45 insertions(+), 22 deletions(-) diff --git a/gui-doc/scribblings/gui/slider-class.scrbl b/gui-doc/scribblings/gui/slider-class.scrbl index a851d8123..e40631ece 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)] @@ -52,13 +52,15 @@ 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 + a vertical slider going down, @racket['upward] for + a vertical slider going up, or @racket['horizontal] for a horizontal + slider going left-to-right. 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.72" @elem{Added @racket['upward] as a possible @racket[style] element.}] } 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..d02ca1e36 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/windowing.rktl b/gui-test/tests/gracket/windowing.rktl index 637cc472d..449de49d1 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?)