From eb66b01fd542d74d19e2cfe80b805ef02dcd9492 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 6 Dec 1998 05:04:43 +0000 Subject: [PATCH] . original commit: 48242c0027982313fd6a4dd5e0fdefdf0a83f35e --- collects/tests/mred/auto.ss | 49 +++++++++++++++---------------------- collects/tests/mred/item.ss | 26 ++++++++++++++------ 2 files changed, 39 insertions(+), 36 deletions(-) diff --git a/collects/tests/mred/auto.ss b/collects/tests/mred/auto.ss index eac69e7a..5b2d205a 100644 --- a/collects/tests/mred/auto.ss +++ b/collects/tests/mred/auto.ss @@ -799,24 +799,22 @@ (stv c accept-tab-focus #f) (st #f c accept-tab-focus) - (stv c set-scrollbars 100 101 5 6 2 3 10 20 #t) + (stv c init-auto-scrollbars 500 606 .02 .033) + ; (stv c set-scrollbars 100 101 5 6 2 3 10 20 #t) (let-values ([(w h) (send c get-virtual-size)] - [(cw ch) (send c get-client-size)] - [(s1x s1y) (values 0 0)]) + [(cw ch) (send c get-client-size)]) (printf "Canvas size: Virtual: ~a x ~a Client: ~a x ~a~n" w h cw ch) (let ([check-scroll (lambda (xpos ypos) (let-values ([(x y) (send c get-view-start)]) - (test (* xpos s1x) `(canvas-view-x ,xpos ,ypos ,x ,cw) x) - (test (* ypos s1y) `(canvas-view-y ,xpos ,ypos ,y ,ch) y)))]) - (test (* 100 5) 'canvas-virt-w-size w) - (test (* 101 6) 'canvas-virt-h-size h) - - (let-values ([(x y) (send c get-view-start)]) - (printf "Canvas Init View: ~a ~a~n" x y) - (test #t 'canvas-view-x (<= (- w cw) x (+ cw (- w cw)))) - (test #t 'canvas-view-y (<= (- h ch) y (+ ch (- h ch))))) + (let ([coerce (lambda (x) (inexact->exact (floor x)))]) + (test (coerce (* xpos (- 500 cw))) `(canvas-view-x ,xpos ,ypos ,x ,cw) x) + (test (coerce (* ypos (- 606 ch))) `(canvas-view-y ,xpos ,ypos ,y ,ch) y))))]) + (test 500 'canvas-virt-w-size w) + (test 606 'canvas-virt-h-size h) + (check-scroll 0.02 0.033) + (st 0 c get-scroll-pos 'horizontal) (st 0 c get-scroll-pos 'vertical) (st 0 c get-scroll-page 'horizontal) @@ -824,19 +822,16 @@ (st 0 c get-scroll-range 'horizontal) (st 0 c get-scroll-range 'vertical) - (stv c scroll 1 1) - (let-values ([(x y) (send c get-view-start)]) - (set! s1x x) - (set! s1y y)) - (check-scroll 1 1) - (stv c scroll #f 2) - (check-scroll 1 2) - (stv c scroll 0 #f) - (check-scroll 0 2) + (stv c scroll 0.1 0.1) + (check-scroll 0.1 0.1) + (stv c scroll #f 0.2) + (check-scroll 0.1 0.2) + (stv c scroll 0.0 #f) + (check-scroll 0.0 0.2) 'done-sb)) - (stv c set-scrollbars 100 101 5 6 2 3 10 20 #f) + (stv c init-manual-scrollbars 5 6 2 3 4 5) (let-values ([(w h) (send c get-virtual-size)] [(cw ch) (send c get-client-size)]) (let ([check-scroll @@ -851,7 +846,7 @@ (test 0 'canvas-view-x x) (test 0 'canvas-view-y y)))]) - (check-scroll 5 6) + (check-scroll 4 5) (st 2 c get-scroll-page 'horizontal) (st 3 c get-scroll-page 'vertical) @@ -859,14 +854,10 @@ (st 6 c get-scroll-range 'vertical) (stv c scroll 1 1) - (check-scroll 1 1) - (stv c scroll #f 2) - (check-scroll 1 2) - (stv c scroll 0 #f) - (check-scroll 0 2) + (check-scroll 4 5) (stv c set-scroll-pos 'horizontal 1) - (check-scroll 1 2) + (check-scroll 1 5) (stv c set-scroll-pos 'vertical 0) (check-scroll 1 0) diff --git a/collects/tests/mred/item.ss b/collects/tests/mred/item.ss index f0dbafc3..93fa142d 100644 --- a/collects/tests/mred/item.ss +++ b/collects/tests/mred/item.ss @@ -200,6 +200,7 @@ [on-subwindow-char (lambda args (or (apply pre-on args) (apply super-on-subwindow-char args)))] + [on-activate (lambda (on?) (printf "active: ~a~n" on?))] [on-move (lambda (x y) (printf "moved: ~a ~a~n" x y))] [on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))]) (public [set-info @@ -531,7 +532,7 @@ [make-menu-bar (lambda () (let* ([mb (make-object menu-bar% this)] - [menu (make-object menu% "Tester" mb)] + [menu (make-object menu% "&Tester" mb)] [new (case-lambda [(l help parent) (make-object menu-item% l parent callback #f help)] [(l help) (make-object menu-item% l menu callback #f help)] @@ -762,13 +763,13 @@ (help-string-test (via apple-menu) COCONUT-ID (apple-pick #f "SUBMENU" "Submenu")) (label-test (via coconut-menu) DELETE-COCONUT (apple-pick #f "Coconut Deleter" "Delete Coconut")) ; submenu test (help-string-test (via coconut-menu) DELETE-COCONUT (apple-pick #f "CDELETER" #f)) - (top-label-test 0 (if temp-labels? "Hi" "Tester")) + (top-label-test 0 (if temp-labels? "Hi" "&Tester")) (top-label-test 1 (if apple-installed? "Apple" #f)) (tell-ok))) (make-object button% "Find Labels" lblp (lambda args - (find-test main-menu (tmp-pick "Hi" "Tester") + (find-test main-menu (tmp-pick "Hi" "&Tester") ADD-APPLE (tmp-pick "Apple Adder" "Add Apple")) (find-test apple-menu "Apple" (apple-pick -1 DELETE-APPLE DELETE-APPLE) (tmp-pick "Apple Deleter" "Delete Apple")) @@ -790,7 +791,7 @@ (send DELETE-APPLE set-help-string (tmp-pick "DELETER" "Deletes the Apple menu")) (send COCONUT-ID set-help-string (tmp-pick "SUBMENU" "Submenu")) (send DELETE-COCONUT set-help-string (tmp-pick "CDELETER" #f)) - (send (send main-menu get-item) set-label (if temp-labels? "Hi" "Tester"))))) + (send (send main-menu get-item) set-label (if temp-labels? "Hi" "&Tester"))))) (letrec ([by-bar (make-object check-box% "Via Menubar" lblp (lambda args @@ -1420,10 +1421,15 @@ [small? (send ck-s get-value)] [swap? (send ck-w get-value)]) (send c1 set-vsize 10 10) - (send c1 set-scrollbars (and h? 1) (and v? 1) 10 10 3 3 1 1 swap?) + (if swap? + (send c1 init-auto-scrollbars (and h? 10) (and v? 10) .1 .1) + (send c1 init-manual-scrollbars (and h? 10) (and v? 10) 3 3 1 1)) + ; (send c1 set-scrollbars (and h? 1) (and v? 1) 10 10 3 3 1 1 swap?) (send c2 set-vsize (if small? 50 500) (if small? 20 200)) - (send c2 set-scrollbars (and h? 25) (and v? 10) (if small? 2 20) (if small? 2 20) - 3 3 1 1 (not swap?)) + (if swap? + (send c2 init-manual-scrollbars (if small? 2 20) (if small? 2 20) 3 3 1 1) + (send c2 init-auto-scrollbars (and h? (if small? 50 500)) (and v? (if small? 20 200)) .2 .2)) + ; (send c2 set-scrollbars (and h? 25) (and v? 10) (if small? 2 20) (if small? 2 20) 3 3 1 1 (not swap?)) (if for-small? ; Specifically refresh the bottom canvas (send c2 refresh) @@ -1440,6 +1446,12 @@ (make-object button% "Get Instructions" ip (lambda (b e) (open-file "canvas-steps.txt"))) + (make-object button% + "&1/5 Scroll" ip + (lambda (b e) (send c2 scroll 0.2 0.2))) + (make-object button% + "&4/5 Scroll" ip + (lambda (b e) (send c2 scroll 0.8 0.8))) (send c1 set-vsize 10 10) (send c2 set-vsize 500 200) (send f show #t))