diff --git a/collects/tests/framework/README b/collects/tests/framework/README index 591d3f2857..81ad4ef746 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -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 #| diff --git a/collects/tests/framework/panel-single.rkt b/collects/tests/framework/panel-single.rkt new file mode 100644 index 0000000000..899df78fb5 --- /dev/null +++ b/collects/tests/framework/panel-single.rkt @@ -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)) diff --git a/collects/tests/framework/panel.rkt b/collects/tests/framework/panel.rkt index b982a30d2c..cdca9c6bef 100644 --- a/collects/tests/framework/panel.rkt +++ b/collects/tests/framework/panel.rkt @@ -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))