From c4ecab7d137c57af59f8b880791b550be52e7dac Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 15 Jul 1998 16:10:10 +0000
Subject: [PATCH] .

original commit: 35a23f954428e5e483363e3e1f3736af1fcaaad5
---
 collects/tests/mred/item.ss          | 47 ++++++++++++++++++++++++++++
 collects/tests/mred/slider-steps.txt | 21 +++++++++++++
 2 files changed, 68 insertions(+)
 create mode 100644 collects/tests/mred/slider-steps.txt

diff --git a/collects/tests/mred/item.ss b/collects/tests/mred/item.ss
index 6a2f2593..29b2b5fd 100644
--- a/collects/tests/mred/item.ss
+++ b/collects/tests/mred/item.ss
@@ -1225,6 +1225,53 @@
   (instructions p "choice-list-steps.txt")
   (send f show #t))
 
+(define (slider-frame)
+  (define f (make-object mred:frame% null "Slider Test"))
+  (define p (make-object mred:vertical-panel% f))
+  (define old-list null)
+  (define commands (list wx:const-event-type-slider-command))
+  (define s (make-object mred:slider% p
+			 (lambda (sl e)
+			   (unless (= (send s get-value) (send e get-selection))
+			     (error "slider value mismatch"))
+			   (check-callback-event s sl e commands #f))
+			 "Slide Me"
+			 3 -1 11 -1))
+  (define c (make-object mred:button% p
+			 (lambda (c e)
+			   (for-each
+			    (lambda (e)
+			      (check-callback-event s s e commands #t))
+			    old-list)
+			   (printf "All Ok~n"))
+			 "Check"))
+  (define (simulate v)
+    (let ([e (make-object wx:command-event% wx:const-event-type-slider-command)])
+      (send e set-command-int v)
+      (send e set-event-object s)
+      (send s command e)))
+  (define p2 (make-object mred:horizontal-panel% p))
+  (define p3 (make-object mred:horizontal-panel% p))
+  (send p3 stretchable-in-y #f)
+  (make-object mred:button% p2
+	       (lambda (c e)
+		 (send s set-value (add1 (send s get-value))))
+	       "Up")
+  (make-object mred:button% p2
+	       (lambda (c e)
+		 (send s set-value (sub1 (send s get-value))))
+	       "Down")
+  (make-object mred:button% p2
+	       (lambda (c e)
+		 (simulate (add1 (send s get-value))))
+	       "Simulate Up")
+  (make-object mred:button% p2
+	       (lambda (c e)
+		 (simulate (sub1 (send s get-value))))
+	       "Simulate Down")
+  (instructions p "slider-steps.txt")
+  (send f show #t))
+
 (define (gauge-frame)
   (define f (make-object mred:frame% null "Gauge Test"))
   (define p (make-object mred:vertical-panel% f))
diff --git a/collects/tests/mred/slider-steps.txt b/collects/tests/mred/slider-steps.txt
new file mode 100644
index 00000000..1a71ee0a
--- /dev/null
+++ b/collects/tests/mred/slider-steps.txt
@@ -0,0 +1,21 @@
+
+The slider's initial value should be 3. The range is -1 to 11.
+
+Change the slider value in each way allowed by the control (dragging,
+ clicking in page-up/page-down, clicking on one-step arrows). For
+ each change, the console should contain "Callback Ok". When you
+ drag, one callback may be reported for the whole drag, or
+ intermediate callbacks may be reported.
+
+Click "Up" until the slider is at the top. Clicking when the slider
+ is at its maximum value should have no effect. Click "Down" once
+ aand verify that the slider is at 11.
+
+Repeat the above step for "Down".
+
+Repeat the above two steps for "Simulate Up" and "Simulate Down". For
+ the simulates, the console should report "Callback Ok" for each click.
+ If you try to go too far up or down, the console should report an
+ error: "slider value mismatch".
+
+Click the "Check" button. The console should report "All Ok".