...

original commit: 8d05b920dd46487073cdc8cbe544a154f99eaeeb

collects/framework/frameworks.ss

@@ -23,6 +23,7 @@
   (single-mixin
    single<%>
    single%
+   single-pane%
    
    editor-mixin
    editor<%>

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

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)

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 #|
+	
 |#)

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