moved interactive panel test into its own file
This commit is contained in:
Robby Findler
parent
900d74714e
commit
3dc5bbd0eb
|
|
@ -77,11 +77,15 @@ signal failures when there aren't any.
|
|||
|
||||
|# scheme.rkt #|
|
||||
|
||||
- panel tests:
|
||||
|
||||
|# panel.rkt #|
|
||||
|
||||
- |# (interactive #| tests
|
||||
|
||||
| these tests require intervention by people. Clicking and whatnot
|
||||
|
||||
- panel:single |# panel.rkt #|
|
||||
- panel:single |# panel-single.rkt #|
|
||||
|
||||
- garbage collection: |# mem.rkt #|
|
||||
|
||||
|
|
|
|||
134
collects/tests/framework/panel-single.rkt
Normal file
134
collects/tests/framework/panel-single.rkt
Normal file
|
|
@ -0,0 +1,134 @@
|
|||
#lang mzscheme
|
||||
(require "test-suite-utils.ss")
|
||||
|
||||
(test
|
||||
'single-panel
|
||||
(lambda (x) (eq? x 'passed))
|
||||
`(let* ([semaphore (make-semaphore 0)]
|
||||
[semaphore-frame%
|
||||
(class frame%
|
||||
(define/augment (on-close) (semaphore-post semaphore))
|
||||
(super-new))]
|
||||
[f (make-object semaphore-frame% "Single Panel Test")]
|
||||
[blue-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)]
|
||||
[green-brush (send the-brush-list find-or-create-brush "FOREST GREEN" 'solid)]
|
||||
[black-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid)]
|
||||
[grid-canvas%
|
||||
(class canvas%
|
||||
(init-field lines)
|
||||
(init label)
|
||||
(inherit get-dc get-client-size)
|
||||
(override on-paint)
|
||||
(define (on-paint)
|
||||
(let-values ([(width height) (get-client-size)])
|
||||
(let ([dc (get-dc)]
|
||||
[single-width (/ width lines)]
|
||||
[single-height (/ height lines)])
|
||||
(send dc set-pen black-pen)
|
||||
(let loop ([i lines])
|
||||
(cond
|
||||
[(zero? i) (void)]
|
||||
[else
|
||||
(let loop ([j lines])
|
||||
(cond
|
||||
[(zero? j) (void)]
|
||||
[else
|
||||
(send dc set-brush
|
||||
(if (= 0 (modulo (+ i j) 2))
|
||||
blue-brush green-brush))
|
||||
(send dc draw-rectangle
|
||||
(* single-width (- i 1))
|
||||
(* single-height (- j 1))
|
||||
single-width
|
||||
single-height)
|
||||
(loop (- j 1))]))
|
||||
(loop (- i 1))])))))
|
||||
(super-instantiate ())
|
||||
|
||||
;; soon to be obsolete, hopefully.
|
||||
(inherit set-label)
|
||||
(set-label label)
|
||||
|
||||
(inherit min-width min-height)
|
||||
(min-width 50)
|
||||
(min-height 50))]
|
||||
[border-panel (make-object horizontal-panel% f '(border))]
|
||||
[single-panel (make-object panel:single% border-panel)]
|
||||
[children
|
||||
(list
|
||||
(instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f))
|
||||
(instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide") (stretchable-width #f) (stretchable-height #t))
|
||||
(instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Tall") (stretchable-width #t) (stretchable-height #f))
|
||||
(instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide and Tall") (stretchable-width #t) (stretchable-height #t)))]
|
||||
[active-child (car children)]
|
||||
[radios (make-object horizontal-panel% f)]
|
||||
[make-radio
|
||||
(lambda (label choices callback)
|
||||
(let* ([panel (make-object vertical-panel% radios '(border))]
|
||||
[message (make-object message% label panel)]
|
||||
[radio (make-object radio-box% #f choices panel (lambda (radio _) (callback radio)))]
|
||||
[button (make-object button%
|
||||
"Cycle" panel
|
||||
(lambda (_1 _2)
|
||||
(let ([before (send radio get-selection)]
|
||||
[tot (send radio get-number)])
|
||||
(let loop ([n tot])
|
||||
(unless (zero? n)
|
||||
(send radio set-selection (- tot n))
|
||||
(callback radio)
|
||||
(sleep/yield 1)
|
||||
(loop (- n 1))))
|
||||
(send radio set-selection before)
|
||||
(callback radio))))])
|
||||
radio))]
|
||||
[radio
|
||||
(make-radio
|
||||
"Active Child"
|
||||
(map (lambda (x) (send x get-label)) children)
|
||||
(lambda (radio)
|
||||
(let loop ([n (length children)]
|
||||
[cs children])
|
||||
(cond
|
||||
[(null? cs) (void)]
|
||||
[else (let ([c (car cs)])
|
||||
(if (string=? (send radio get-item-label (send radio get-selection))
|
||||
(send c get-label))
|
||||
(begin (set! active-child c)
|
||||
(send single-panel active-child active-child))
|
||||
(loop (- n 1)
|
||||
(cdr cs))))]))))]
|
||||
[vertical-alignment 'center]
|
||||
[horizontal-alignment 'center]
|
||||
[update-alignment (lambda ()
|
||||
(send single-panel set-alignment horizontal-alignment vertical-alignment))]
|
||||
[horiz
|
||||
(make-radio
|
||||
"Horizontal Alignment"
|
||||
(list "left" "center" "right")
|
||||
(lambda (radio)
|
||||
(set! horizontal-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
|
||||
(update-alignment)))]
|
||||
[vert
|
||||
(make-radio
|
||||
"Vertical Alignment"
|
||||
(list "top" "center" "bottom")
|
||||
(lambda (radio)
|
||||
(set! vertical-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
|
||||
(update-alignment)))]
|
||||
[buttons (make-object horizontal-panel% f)]
|
||||
[result 'failed]
|
||||
[failed (make-object button% "Failed" buttons (lambda (_1 _2) (semaphore-post semaphore)))]
|
||||
[passed (make-object button% "Passed" buttons (lambda (_1 _2)
|
||||
(set! result 'passed)
|
||||
(semaphore-post semaphore)))])
|
||||
(send border-panel min-width 100)
|
||||
(send border-panel min-height 100)
|
||||
(send vert set-selection 1)
|
||||
(send horiz set-selection 1)
|
||||
(send buttons stretchable-height #f)
|
||||
(send buttons set-alignment 'right 'center)
|
||||
(send radios stretchable-height #f)
|
||||
(send f show #t)
|
||||
(yield semaphore)
|
||||
(send f show #f)
|
||||
result))
|
||||
|
|
@ -114,140 +114,3 @@
|
|||
(λ (l) (equal? l '(((0 0 242 629) (247 0 243 629)) ((242 247)))))
|
||||
`(call-with-values (λ () (panel:dragable-place-children '((30 30 #t #t) (30 30 #t #t)) 490 629 '(1/2 1/2) 5 #f))
|
||||
list))
|
||||
|
||||
;(dragable-place-children infos width height percentages gap-width vertical?)
|
||||
|
||||
;; with stuff that doesn't fit....
|
||||
|
||||
#;
|
||||
(test
|
||||
'single-panel
|
||||
(lambda (x) (eq? x 'passed))
|
||||
`(let* ([semaphore (make-semaphore 0)]
|
||||
[semaphore-frame%
|
||||
(class frame%
|
||||
(define/augment (on-close) (semaphore-post semaphore))
|
||||
(super-new))]
|
||||
[f (make-object semaphore-frame% "Single Panel Test")]
|
||||
[blue-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)]
|
||||
[green-brush (send the-brush-list find-or-create-brush "FOREST GREEN" 'solid)]
|
||||
[black-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid)]
|
||||
[grid-canvas%
|
||||
(class canvas%
|
||||
(init-field lines)
|
||||
(init label)
|
||||
(inherit get-dc get-client-size)
|
||||
(override on-paint)
|
||||
(define (on-paint)
|
||||
(let-values ([(width height) (get-client-size)])
|
||||
(let ([dc (get-dc)]
|
||||
[single-width (/ width lines)]
|
||||
[single-height (/ height lines)])
|
||||
(send dc set-pen black-pen)
|
||||
(let loop ([i lines])
|
||||
(cond
|
||||
[(zero? i) (void)]
|
||||
[else
|
||||
(let loop ([j lines])
|
||||
(cond
|
||||
[(zero? j) (void)]
|
||||
[else
|
||||
(send dc set-brush
|
||||
(if (= 0 (modulo (+ i j) 2))
|
||||
blue-brush green-brush))
|
||||
(send dc draw-rectangle
|
||||
(* single-width (- i 1))
|
||||
(* single-height (- j 1))
|
||||
single-width
|
||||
single-height)
|
||||
(loop (- j 1))]))
|
||||
(loop (- i 1))])))))
|
||||
(super-instantiate ())
|
||||
|
||||
;; soon to be obsolete, hopefully.
|
||||
(inherit set-label)
|
||||
(set-label label)
|
||||
|
||||
(inherit min-width min-height)
|
||||
(min-width 50)
|
||||
(min-height 50))]
|
||||
[border-panel (make-object horizontal-panel% f '(border))]
|
||||
[single-panel (make-object panel:single% border-panel)]
|
||||
[children
|
||||
(list
|
||||
(instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f))
|
||||
(instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide") (stretchable-width #f) (stretchable-height #t))
|
||||
(instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Tall") (stretchable-width #t) (stretchable-height #f))
|
||||
(instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide and Tall") (stretchable-width #t) (stretchable-height #t)))]
|
||||
[active-child (car children)]
|
||||
[radios (make-object horizontal-panel% f)]
|
||||
[make-radio
|
||||
(lambda (label choices callback)
|
||||
(let* ([panel (make-object vertical-panel% radios '(border))]
|
||||
[message (make-object message% label panel)]
|
||||
[radio (make-object radio-box% #f choices panel (lambda (radio _) (callback radio)))]
|
||||
[button (make-object button%
|
||||
"Cycle" panel
|
||||
(lambda (_1 _2)
|
||||
(let ([before (send radio get-selection)]
|
||||
[tot (send radio get-number)])
|
||||
(let loop ([n tot])
|
||||
(unless (zero? n)
|
||||
(send radio set-selection (- tot n))
|
||||
(callback radio)
|
||||
(sleep/yield 1)
|
||||
(loop (- n 1))))
|
||||
(send radio set-selection before)
|
||||
(callback radio))))])
|
||||
radio))]
|
||||
[radio
|
||||
(make-radio
|
||||
"Active Child"
|
||||
(map (lambda (x) (send x get-label)) children)
|
||||
(lambda (radio)
|
||||
(let loop ([n (length children)]
|
||||
[cs children])
|
||||
(cond
|
||||
[(null? cs) (void)]
|
||||
[else (let ([c (car cs)])
|
||||
(if (string=? (send radio get-item-label (send radio get-selection))
|
||||
(send c get-label))
|
||||
(begin (set! active-child c)
|
||||
(send single-panel active-child active-child))
|
||||
(loop (- n 1)
|
||||
(cdr cs))))]))))]
|
||||
[vertical-alignment 'center]
|
||||
[horizontal-alignment 'center]
|
||||
[update-alignment (lambda ()
|
||||
(send single-panel set-alignment horizontal-alignment vertical-alignment))]
|
||||
[horiz
|
||||
(make-radio
|
||||
"Horizontal Alignment"
|
||||
(list "left" "center" "right")
|
||||
(lambda (radio)
|
||||
(set! horizontal-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
|
||||
(update-alignment)))]
|
||||
[vert
|
||||
(make-radio
|
||||
"Vertical Alignment"
|
||||
(list "top" "center" "bottom")
|
||||
(lambda (radio)
|
||||
(set! vertical-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
|
||||
(update-alignment)))]
|
||||
[buttons (make-object horizontal-panel% f)]
|
||||
[result 'failed]
|
||||
[failed (make-object button% "Failed" buttons (lambda (_1 _2) (semaphore-post semaphore)))]
|
||||
[passed (make-object button% "Passed" buttons (lambda (_1 _2)
|
||||
(set! result 'passed)
|
||||
(semaphore-post semaphore)))])
|
||||
(send border-panel min-width 100)
|
||||
(send border-panel min-height 100)
|
||||
(send vert set-selection 1)
|
||||
(send horiz set-selection 1)
|
||||
(send buttons stretchable-height #f)
|
||||
(send buttons set-alignment 'right 'center)
|
||||
(send radios stretchable-height #f)
|
||||
(send f show #t)
|
||||
(yield semaphore)
|
||||
(send f show #f)
|
||||
result))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user