From 4fccb8a90197a5e9b3f6f05e257e94d33a47cca1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 7 Jan 1999 21:32:20 +0000 Subject: [PATCH] ... original commit: 8d05b920dd46487073cdc8cbe544a154f99eaeeb --- collects/framework/frameworks.ss | 1 + collects/framework/panel.ss | 48 ++++++++++++- collects/framework/prefs.ss | 5 +- collects/tests/framework/README | 12 ++-- collects/tests/framework/panel.ss | 114 +++++++++++++++++++++++++++++- 5 files changed, 168 insertions(+), 12 deletions(-) diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index a36bd528..ab74bbf7 100644 --- a/collects/framework/frameworks.ss +++ b/collects/framework/frameworks.ss @@ -23,6 +23,7 @@ (single-mixin single<%> single% + single-pane% editor-mixin editor<%> diff --git a/collects/framework/panel.ss b/collects/framework/panel.ss index 46253fef..f60e4a2c 100644 --- a/collects/framework/panel.ss +++ b/collects/framework/panel.ss @@ -4,12 +4,54 @@ (rename [-editor<%> editor<%>]) - (define single<%> (interface (panel<%>))) + (define single<%> (interface (area-container<%>))) (define single-mixin - (mixin (panel<%>) (single<%>) args + (mixin (area-container<%>) (single<%>) args + (inherit get-alignment) + (override + [container-size + (lambda (l) + (values (apply max (map car l)) (apply max (map cadr l))))] + [place-children + (lambda (l width height) + (printf "place children~n") + (let-values ([(h-align-spec v-align-spec) (get-alignment)]) + (let ([align + (lambda (total-size spec item-size) + (floor + (case spec + [(center) (- (/ total-size 2) (/ item-size 2))] + [(left top) 0] + [(right bottom) (- total-size item-size)] + [else (error 'place-children "alignment spec is unknown ~a~n" spec)])))]) + (map (lambda (l) + (let*-values ([(min-width min-height v-stretch? h-stretch?) (apply values l)] + [(x this-width) (if h-stretch? + (values 0 width) + (values (align width h-align-spec min-width) min-width))] + [(y this-height) (if v-stretch? + (values 0 height) + (values (align height v-align-spec min-height) min-height))]) + (list x y this-width this-height))) + l))))]) + + (inherit get-children) + (private [current-active-child #f]) + (public + [active-child + (case-lambda + [() current-active-child] + [(x) + (unless (eq? x current-active-child) + (for-each (lambda (x) (send x show #f)) + (get-children)) + (set! current-active-child x) + (send current-active-child show #t))])]) (sequence (apply super-init args)))) - (define single% (single-mixin vertical-panel%)) + + (define single% (single-mixin panel%)) + (define single-pane% (single-mixin pane%)) (define -editor<%> (interface () diff --git a/collects/framework/prefs.ss b/collects/framework/prefs.ss index 1e413a2e..b9be2fbd 100644 --- a/collects/framework/prefs.ss +++ b/collects/framework/prefs.ss @@ -369,8 +369,9 @@ (make-check 'framework:menu-bindings "Enable keybindings in menus" id id) (unless (eq? (system-type) 'unix) (make-check 'framework:print-output-mode "Automatically print to postscript file" - (lambda (b) (if b 1 0)) - (lambda (n) (= n 1)))) + (lambda (b) + (if b 'postscript 'standard)) + (lambda (n) (eq? 'postscript n)))) (make-check 'framework:display-line-numbers "Display line numbers in buffer; not character offsets" id id) diff --git a/collects/tests/framework/README b/collects/tests/framework/README index b24aecb8..c0e58c88 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -100,15 +100,15 @@ tests. | these tests perform santiy checks to ensure that the docs are up to | date with the code and the mred web browser isn't horribly broken - - web browers: browse.ss - - | Checks a couple of pages from the documentation. Only checks for - | safety violations while opening them. Further tests here will be - | post-poned until the implementation itself is cleaned up. - - inheritance: inheritance.ss | make sure that the super-class relationships in the docs match | the code. +- interactive tests + + | these tests require intervention by people. Clicking and whatnot + + - panel:single |# panel.ss #| + |#) \ No newline at end of file diff --git a/collects/tests/framework/panel.ss b/collects/tests/framework/panel.ss index 4514185d..50f19f34 100644 --- a/collects/tests/framework/panel.ss +++ b/collects/tests/framework/panel.ss @@ -1,4 +1,116 @@ (test 'single-panel (lambda (x) (eq? x 'passed)) - `passed) + `(let* ([semaphore (make-semaphore 0)] + [semaphore-frame% + (class frame% args + (override + [on-close (lambda () (semaphore-post semaphore))]) + (sequence + (apply super-init args)))] + [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% (lines parent label) + (inherit get-dc get-client-size) + (override + [on-paint + (lambda () + (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))])))))]) + (inherit set-label stretchable-width stretchable-height) + (sequence + (super-init parent) + (stretchable-width #t) + (stretchable-height #t) + (set-label label)))] + + [border-panel (make-object horizontal-panel% f '(border))] + [single-panel (make-object panel:single% border-panel)] + [children (list (make-object button% "Button" single-panel void) + (make-object message% "Message" single-panel) + (make-object grid-canvas% 3 single-panel "9 squares") + (make-object grid-canvas% 5 single-panel "25 squares"))] + [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 callback)]) + radio))] + [radio + (make-radio + "Active Child" + (map (lambda (x) (send x get-label)) children) + (lambda (radio evt) + (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) + (printf "set alignment~n") + (send single-panel reflow-container) + (printf "reflowed container~n"))] + [horiz + (make-radio + "Horizontal Alignment" + (list "left" "center" "right") + (lambda (radio evt) + (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 evt) + (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 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))