suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 48242c0027982313fd6a4dd5e0fdefdf0a83f35e
This commit is contained in:
Matthew Flatt 1998-12-06 05:04:43 +00:00
parent ccd198d735
commit eb66b01fd5
2 changed files with 39 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/tests/mred/auto.ss
View File

@ -799,23 +799,21 @@
(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 ([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)
(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)))))
(check-scroll 0.02 0.033)
(st 0 c get-scroll-pos 'horizontal)
(st 0 c get-scroll-pos 'vertical)
@ -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)

26
collects/tests/mred/item.ss
View File

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