add 'upward style for slider controls

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.}]
 
 }
 

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))

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)

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)

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))

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)))

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))))
+
 )

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)))

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?)