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

.

Browse Source 
original commit: c770f127c230f1ea39086887518a7b28f4db916c
This commit is contained in:
Matthew Flatt 1998-07-15 15:27:33 +00:00
parent 6176463f93
commit f5adb606ec
1 changed files with 90 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -893,6 +893,96 @@
(instructions p "checkbox-steps.txt")
(send f show #t))
(define (radiobox-frame)
(define f (make-object mred:frame% null "Radiobox Test"))
(define p (make-object mred:vertical-panel% f))
(define old-list null)
(define commands (list wx:const-event-type-radiobox-command))
(define hp (make-object mred:horizontal-panel% p))
(define _ (send hp stretchable-in-y #f))
(define callback (lambda (rb e)
(set! old-list (cons e old-list))
(unless (= (send rb get-selection) (send e get-selection))
(error "event selection mismatch"))
(unless (null? (send e get-string))
(error "event string mismatch"))
(check-callback-event rb rb e commands #f)))
(define rb1-l (list "Singleton"))
(define rb1 (make-object mred:radio-box% hp callback "&Left" -1 -1 -1 -1
rb1-l))
(define rb2-l (list "First" "Last"))
(define rb2 (make-object mred:radio-box% hp callback "&Center" -1 -1 -1 -1
rb2-l))
(define rb3-l (list "Top" "Middle" "Bottom"))
(define rb3 (make-object mred:radio-box% hp callback "&Right" -1 -1 -1 -1
rb3-l))
(define rbs (list rb1 rb2 rb3))
(define rbls (list rb1-l rb2-l rb3-l))
(define normal-sel (lambda (rb p) (send rb set-selection p)))
(define name-sel (lambda (rb p) (send rb set-string-selection (cond
[(= p -1) "Negative"]
[(<= 0 p (sub1 (send rb number)))
(send rb get-string p)]
[else "Too Big"]))))
(define simulate-sel (lambda (rb p)
(let ([e (make-object wx:command-event% wx:const-event-type-radiobox-command)])
(send e set-selection p)
(send e set-event-object rb)
(send rb command e))))
(define do-sel (lambda (sel n) (for-each (lambda (rb) (sel rb (n rb))) rbs)))
(define sel-minus (lambda (sel) (do-sel sel (lambda (rb) -1))))
(define sel-first (lambda (sel) (do-sel sel (lambda (rb) 0))))
(define sel-middle (lambda (sel) (do-sel sel (lambda (rb) (floor (/ (send rb number) 2))))))
(define sel-last (lambda (sel) (do-sel sel (lambda (rb) (sub1 (send rb number))))))
(define sel-N (lambda (sel) (do-sel sel (lambda (rb) (send rb number)))))
(define (make-selectors title sel)
(define hp2 (make-object mred:horizontal-panel% p))
(send hp2 stretchable-in-y #f)
(make-object mred:button% hp2 (lambda (b e) (sel-minus sel))
(format "Select -1~a" title))
(make-object mred:button% hp2 (lambda (b e) (sel-first sel))
(format "Select First~a" title))
(make-object mred:button% hp2 (lambda (b e) (sel-middle sel))
(format "Select Middle ~a" title))
(make-object mred:button% hp2 (lambda (b e) (sel-last sel))
(format "Select Last~a" title))
(make-object mred:button% hp2 (lambda (b e) (sel-N sel))
(format "Select N~a" title)))
(make-selectors "" normal-sel)
(make-selectors " by Name" name-sel)
(make-selectors " by Simulate" simulate-sel)
(make-object mred:button% p
(lambda (c e)
(for-each
(lambda (rb l)
(let loop ([n 0][l l])
(unless (null? l)
(let ([a (car l)]
[b (send rb get-string n)])
(unless (string=? a b)
(error "item name mismatch: ~s != ~s" a b)))
(unless (= n (send rb find-string (car l)))
(error "find-string failed"))
(loop (add1 n) (cdr l)))))
rbs rbls)
(for-each
(lambda (rb)
(unless (string=? (send rb get-string (send rb get-selection))
(send rb get-string-selection))
(error "get-string-selection failure")))
rbs)
(for-each
(lambda (e)
(let ([rb (send e get-event-object)])
(check-callback-event rb rb e commands #t)))
old-list)
(printf "All Ok~n"))
"Check")
(instructions p "radiobox-steps.txt")
(send f show #t))
(define (choice-or-list-frame list? list-style empty?)
(define f (make-object mred:frame% null (if list? "List Test" "Choice Test")))
(define p (make-object mred:vertical-panel% f))