From 04318aa689980373cff02cb344b145e3f20924f7 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 1 May 2008 23:15:06 +0000
Subject: [PATCH] reworked the buttons along the top of drscheme

svn: r9578

original commit: ee9fc4a8d7591e0270b607fc057fa6398c6b7274
---
 collects/mred/private/mrpanel.ss              |  14 +-
 collects/mred/private/wxpanel.ss              | 156 +++++++++---------
 collects/mrlib/scribblings/mrlib.scrbl        |   1 +
 collects/mrlib/switchable-button.ss           | 149 +++++++++++++++++
 collects/scribblings/gui/canvas-class.scrbl   |   2 +-
 .../scribblings/gui/editor-overview.scrbl     |   4 +-
 .../scribblings/gui/editor-snip-class.scrbl   |   2 +-
 .../gui/horizontal-panel-class.scrbl          |  14 +-
 .../scribblings/gui/radio-box-class.scrbl     |   2 +-
 collects/scribblings/gui/snip-class.scrbl     |   2 +-
 collects/scribblings/gui/timer-class.scrbl    |   2 +-
 .../gui/vertical-panel-class.scrbl            |  14 +-
 collects/tests/mred/windowing.ss              |   4 +-
 13 files changed, 277 insertions(+), 89 deletions(-)
 create mode 100644 collects/mrlib/switchable-button.ss

diff --git a/collects/mred/private/mrpanel.ss b/collects/mred/private/mrpanel.ss
index 0de38cea..e78fe881 100644
--- a/collects/mred/private/mrpanel.ss
+++ b/collects/mred/private/mrpanel.ss
@@ -94,8 +94,18 @@
 	       (send (send wx area-parent) add-child wx))))
 	  (send parent after-new-child this)))))
 
-  (define vertical-panel% (class100*/kw panel% () [(parent [style null]) panel%-keywords] (sequence (super-init parent style))))
-  (define horizontal-panel% (class100*/kw panel% () [(parent [style null]) panel%-keywords] (sequence (super-init parent style))))
+  (define vertical-panel% 
+    (class100*/kw panel% () 
+                  [(parent [style null]) panel%-keywords] 
+                  (sequence (super-init parent style))
+                  (public [set-orientation (λ (x) (send (mred->wx this) set-orientation x))]
+                          [get-orientation (λ () (send (mred->wx this) get-orientation))])))
+  (define horizontal-panel% 
+    (class100*/kw panel% () 
+                  [(parent [style null]) panel%-keywords] 
+                  (sequence (super-init parent style))
+                  (public [set-orientation (λ (x) (send (mred->wx this) set-orientation x))]
+                          [get-orientation (λ () (send (mred->wx this) get-orientation))])))
 
   (define list-append append)
 
diff --git a/collects/mred/private/wxpanel.ss b/collects/mred/private/wxpanel.ss
index 2eaa512b..bbdc91f3 100644
--- a/collects/mred/private/wxpanel.ss
+++ b/collects/mred/private/wxpanel.ss
@@ -637,89 +637,95 @@
       
       (sequence (apply super-init args))))
 
+  
+  (define (wx-make-horizontal/vertical-panel% wx-linear-panel% init-horizontal?)
+    (class100 wx-linear-panel% args
+      (inherit major-align minor-align do-align do-get-alignment major-offset minor-offset
+	       spacing border do-graphical-size place-linear-children check-place-children
+               force-redraw)
+      (private-field [horizontal? init-horizontal?])
+      (public [get-orientation (λ () horizontal?)]
+              [set-orientation (λ (h?) 
+                                 (unless (equal? h? horizontal?)
+                                   (set! horizontal? h?)
+                                   (force-redraw)))])
+      (override
+	[alignment (lambda (h v) 
+                     (if horizontal?
+                         (do-align h v 
+                                   (lambda (x) (major-align x)) 
+                                   (lambda (x) (minor-align x)))
+                         (do-align h v 
+                                   (lambda (x) (minor-align x)) 
+                                   (lambda (x) (major-align x)))))]
+	[get-alignment (λ () (do-get-alignment (if horizontal? (λ (x y) x) (λ (x y) y))))]
+        
+	[do-get-graphical-min-size
+	 (lambda ()
+           (if horizontal?
+               (do-graphical-size 
+                (lambda (x-accum kid-info hidden?)
+                  (+ x-accum (child-info-x-min (car kid-info))
+                     (if (or hidden? (null? (cdr kid-info)))
+                         0
+                         (spacing))))
+                (lambda (y-accum kid-info hidden?)
+                  (max y-accum
+                       (+ (child-info-y-min (car kid-info))
+                          (* 2 (border))))))
+               (do-graphical-size
+                (lambda (x-accum kid-info hidden?)
+                  (max x-accum
+                       (+ (child-info-x-min (car kid-info))
+                          (* 2 (border)))))
+                (lambda (y-accum kid-info hidden?)
+                  (+ y-accum (child-info-y-min (car kid-info))
+                     (if (or (null? (cdr kid-info)) hidden?)
+                         0
+                         (spacing)))))))]
+ 
+	[do-place-children
+         (lambda (l w h)
+           (cond
+             [horizontal?
+              (check-place-children l w h)
+              (place-linear-children l w h
+                                     car    ; child-info-x-min
+                                     caddr  ; child-info-x-stretch
+                                     (lambda (s) (major-offset s))
+                                     cadr   ; child-info-y-min
+                                     cadddr ; child-info-y-stretch
+                                     (lambda (s t) (minor-offset s t))
+                                     (lambda (width height) width)
+                                     (lambda (width height) height)
+                                     (lambda (major minor) major)
+                                     (lambda (major minor) minor))]
+             [else
+              (check-place-children l w h)
+              (place-linear-children l w h
+                                     cadr   ; child-info-y-min
+                                     cadddr ; child-info-y-stretch
+                                     (lambda (s) (major-offset s))
+                                     car    ; child-info-x-min
+                                     caddr  ; child-info-x-stretch
+                                     (lambda (s t) (minor-offset s t))
+                                     (lambda (width height) height)
+                                     (lambda (width height) width)
+                                     (lambda (major minor) minor)
+                                     (lambda (major minor) major))]))])
+      (sequence (apply super-init args))))
+  
+  
   ;; horizontal-panel%: a panel which arranges its children in an evenly
   ;; spaced horizontal row.  Items are vertically centered (or stretched
   ;; to fit the dialog box if they are stretchable).  The items are evenly
   ;; spaced horizontally, with any extra space divided evenly among the
   ;; stretchable items. 
-  (define (wx-make-horizontal-panel% wx-linear-panel%)
-    (class100 wx-linear-panel% args
-      (inherit major-align minor-align do-align do-get-alignment major-offset minor-offset
-	       spacing border do-graphical-size place-linear-children check-place-children)
-      (override
-	[alignment (lambda (h v) (do-align h v 
-					   (lambda (x) (major-align x)) 
-					   (lambda (x) (minor-align x))))]
-	[get-alignment (lambda () (do-get-alignment (lambda (x y) x)))]
-	
-	[do-get-graphical-min-size
-	 (lambda ()
-	   (do-graphical-size 
-	    (lambda (x-accum kid-info hidden?)
-	      (+ x-accum (child-info-x-min (car kid-info))
-		 (if (or hidden? (null? (cdr kid-info)))
-		     0
-		     (spacing))))
-	    (lambda (y-accum kid-info hidden?)
-	      (max y-accum
-		   (+ (child-info-y-min (car kid-info))
-		      (* 2 (border)))))))]
-	[do-place-children
-	 (lambda (l w h)
-	   (check-place-children l w h)
-	   (place-linear-children l w h
-				  car    ; child-info-x-min
-				  caddr  ; child-info-x-stretch
-				  (lambda (s) (major-offset s))
-				  cadr   ; child-info-y-min
-				  cadddr ; child-info-y-stretch
-				  (lambda (s t) (minor-offset s t))
-				  (lambda (width height) width)
-				  (lambda (width height) height)
-				  (lambda (major minor) major)
-				  (lambda (major minor) minor)))])
-      (sequence (apply super-init args))))
+  (define (wx-make-horizontal-panel% wx-linear-panel%) (wx-make-horizontal/vertical-panel% wx-linear-panel% #t))
 
   ;; vertical-panel%.  See horizontal-panel%, but reverse
   ;; "horizontal" and "vertical."
-  (define (wx-make-vertical-panel% wx-linear-panel%)
-    (class100 wx-linear-panel% args
-      (inherit major-align minor-align do-align do-get-alignment major-offset minor-offset
-	       spacing border do-graphical-size place-linear-children check-place-children)
-      (override
-	[alignment (lambda (h v) (do-align h v 
-					   (lambda (x) (minor-align x)) 
-					   (lambda (x) (major-align x))))]
-	[get-alignment (lambda () (do-get-alignment (lambda (x y) y)))]
-
-	[do-get-graphical-min-size
-	 (lambda ()
-	   (do-graphical-size
-	    (lambda (x-accum kid-info hidden?)
-	      (max x-accum
-		   (+ (child-info-x-min (car kid-info))
-		      (* 2 (border)))))
-	    (lambda (y-accum kid-info hidden?)
-	      (+ y-accum (child-info-y-min (car kid-info))
-		 (if (or (null? (cdr kid-info)) hidden?)
-		     0
-		     (spacing))))))]
-	
-	[do-place-children
-	 (lambda (l w h)
-	   (check-place-children l w h)
-	   (place-linear-children l w h
-				  cadr   ; child-info-y-min
-				  cadddr ; child-info-y-stretch
-				  (lambda (s) (major-offset s))
-				  car    ; child-info-x-min
-				  caddr  ; child-info-x-stretch
-				  (lambda (s t) (minor-offset s t))
-				  (lambda (width height) height)
-				  (lambda (width height) width)
-				  (lambda (major minor) minor)
-				  (lambda (major minor) major)))])
-      (sequence (apply super-init args))))
+  (define (wx-make-vertical-panel% wx-linear-panel%) (wx-make-horizontal/vertical-panel% wx-linear-panel% #f))
 
   (define wx-panel% (wx-make-panel% wx:panel%))
   (define wx-linear-panel% (wx-make-linear-panel% wx-panel%))
diff --git a/collects/mrlib/scribblings/mrlib.scrbl b/collects/mrlib/scribblings/mrlib.scrbl
index 6fb5e155..fa9d797a 100644
--- a/collects/mrlib/scribblings/mrlib.scrbl
+++ b/collects/mrlib/scribblings/mrlib.scrbl
@@ -16,6 +16,7 @@
 @include-section["name-message.scrbl"]
 @include-section["path-dialog.scrbl"]
 @include-section["plot.scrbl"]
+@include-section["switchable-button.scrbl"]
 
 @section{Acknowledgments}
 
diff --git a/collects/mrlib/switchable-button.ss b/collects/mrlib/switchable-button.ss
new file mode 100644
index 00000000..72e360b1
--- /dev/null
+++ b/collects/mrlib/switchable-button.ss
@@ -0,0 +1,149 @@
+#lang scheme/base
+(require scheme/gui/base
+         scheme/class)
+
+(require string-constants/string-constant)
+(provide switchable-button%)
+(define gap 2)
+(define margin 2)
+(define w-circle-space 6)
+(define h-circle-space 6)
+
+(define switchable-button%
+  (class canvas%
+    (init-field label bitmap callback)
+    
+    (inherit get-dc min-width min-height get-client-size refresh)
+    
+    (define down? #f)
+    (define in? #f)
+    (define/override (on-event evt)
+      (cond
+        [(send evt button-down? 'left)
+         (set! down? #t)
+         (set! in? #t)
+         (refresh)]
+        [(send evt button-up? 'left)
+         (set! down? #f)
+         (update-in evt)
+         (refresh)
+         (when in?
+           (callback this))]
+        [(send evt entering?)
+         (set! in? #t)
+         (refresh)]
+        [(send evt leaving?)
+         (set! in? #f)
+         (refresh)]
+        [(send evt moving?)
+         (update-in evt)]))
+    
+    (define/private (update-in evt)
+      (let-values ([(cw ch) (get-client-size)])
+        (let ([new-in?
+               (and (<= 0 (send evt get-x) cw)
+                    (<= 0 (send evt get-y) ch))])
+          (unless (equal? new-in? in?)
+            (set! in? new-in?)
+            (refresh)))))
+    
+    (define horizontal? #t)
+    (define/override (on-paint)
+      (let ([dc (get-dc)])
+        (let-values ([(cw ch) (get-client-size)])
+          (let ([alpha (send dc get-alpha)]
+                [pen (send dc get-pen)]
+                [brush (send dc get-brush)])
+            
+            (send dc set-alpha 
+                  (cond
+                    [in? (if down?
+                             .5
+                             .2)]
+                    [else 0]))
+            (send dc set-pen "black" 1 'transparent)
+            (send dc set-brush "black" 'solid)
+            (send dc draw-rounded-rectangle 
+                  margin
+                  margin 
+                  (- cw margin margin)
+                  (- ch margin margin))
+            (send dc set-alpha alpha)
+            
+            (cond
+              [horizontal? 
+               (let-values ([(tw th _1 _2) (send dc get-text-extent label)])
+                 (let ([text-start (+ (/ cw 2) (- (/ tw 2)) (- (/ (send bitmap get-width) 2)))])
+                   (send dc draw-text label text-start (- (/ ch 2) (/ th 2)))
+                   (draw-the-bitmap (+ text-start tw gap) (- (/ ch 2) (/ (send bitmap get-height) 2)))))]
+              [else
+               (draw-the-bitmap (- (/ cw 2) (/ (send bitmap get-width) 2))
+                                (- (/ ch 2) (/ (send bitmap get-height) 2)))])
+            (send dc set-pen pen)
+            (send dc set-alpha alpha)
+            (send dc set-brush brush)))))
+    
+    (define/private (draw-the-bitmap x y)
+      (send (get-dc)
+            draw-bitmap
+            bitmap
+            x y
+            'solid
+            (send the-color-database find-color "black")
+            (send bitmap get-loaded-mask)))
+    
+    (define/public (set-label-visible h?) 
+      (unless (equal? horizontal? h?)
+        (set! horizontal? h?)
+        (update-sizes)
+        (refresh)))
+    
+    (define/private (update-sizes)
+      (let ([dc (get-dc)])
+        (cond
+          [horizontal?
+           (let-values ([(w h _1 _2) (send dc get-text-extent label)])
+             (do-w/h (+ w gap (send bitmap get-width))
+                     (max h (send bitmap get-height))))]
+          [else
+           (do-w/h (send bitmap get-width)
+                   (send bitmap get-height))])))
+    
+    (define/private (do-w/h w h)
+      (let ([w (floor (inexact->exact w))]
+            [h (floor (inexact->exact h))])
+        (min-width (+ w w-circle-space margin margin))
+        (min-height (+ h h-circle-space margin margin))))
+    
+    (super-new [style '(transparent)])
+    (send (get-dc) set-smoothing 'aligned)
+    
+    (inherit stretchable-width stretchable-height)
+    (stretchable-width #f)
+    (stretchable-height #f)
+    (inherit get-graphical-min-size)
+    (update-sizes)))
+
+#;
+(begin
+  (define f (new frame% [label ""]))
+  (define p (new horizontal-panel% [parent f] [alignment '(right top)]))
+  
+  (define label (string-constant execute-button-label))
+  (define bitmap (make-object bitmap% (build-path (collection-path "icons") "run.png") 'png/mask))
+
+  (define b1 (new switchable-button% [parent p] [label label] [bitmap bitmap] [callback void]))
+  (define b2 (new switchable-button% [parent p] [label label] [bitmap bitmap] [callback void]))
+  (new button% [parent p] [stretchable-width #t] [label "b"])
+  (define swap-button
+    (new button% 
+         [parent f] 
+         [label "swap"]
+         [callback
+          (let ([state #t])
+            (λ (a b)
+              (set! state (not state))
+              (send b1 set-orientation state)
+              (send b2 set-orientation state)
+              '(send p set-orientation state)))]))
+  (send f show #t)) 
\ No newline at end of file
diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl
index 92bd895a..505aac33 100644
--- a/collects/scribblings/gui/canvas-class.scrbl
+++ b/collects/scribblings/gui/canvas-class.scrbl
@@ -45,7 +45,7 @@ The @scheme[style] argument indicates one or more of the following styles:
  @item{@scheme['resize-corner] --- leaves room for a resize control at the canvas's
                                   bottom right when only one scrollbar is visible}
 
- @item{@scheme['gl] --- {\em obsolete} (every canvas is an OpenGL context where supported)}
+ @item{@scheme['gl] --- @italic{obsolete} (every canvas is an OpenGL context where supported)}
 
  @item{@scheme['no-autoclear] --- prevents automatic erasing of the
  canvas before calls to
diff --git a/collects/scribblings/gui/editor-overview.scrbl b/collects/scribblings/gui/editor-overview.scrbl
index b65ac8c2..ddcfeb7c 100644
--- a/collects/scribblings/gui/editor-overview.scrbl
+++ b/collects/scribblings/gui/editor-overview.scrbl
@@ -310,7 +310,7 @@ Each new style is defined in one of two ways:
  @item{A @deftech{join style} is defined in terms of two other styles:
  a base style and a @deftech{shift style}. The meaning of a join style
  is determined by reinterpreting the shift style; in the
- reinterpretation, the base style is used as the {\em root\/} style
+ reinterpretation, the base style is used as the @italic{root} style
  for the shift style. (This is analogous to multi-level
  styles, like the paragraph and character styles in FrameMaker. In
  this analogy, the paragraph style is the base style, and the
@@ -698,7 +698,7 @@ Instances of @scheme[editor<%>] have three levels of internal
 
 }
 
-The internal lock for an editor is {\em not\/} affected by calls to
+The internal lock for an editor is @italic{not} affected by calls to
  @method[editor<%> lock].
 
 Methods that report @techlink{location}-independent information about an
diff --git a/collects/scribblings/gui/editor-snip-class.scrbl b/collects/scribblings/gui/editor-snip-class.scrbl
index d517d0a3..e21d7fb4 100644
--- a/collects/scribblings/gui/editor-snip-class.scrbl
+++ b/collects/scribblings/gui/editor-snip-class.scrbl
@@ -231,7 +231,7 @@ See also @method[editor-snip% get-align-top-line].
 
 Sets the editor contained by the snip, releasing the old editor in the
  snip (if any). If the new editor already has an administrator, then
- the new editor is {\em not} installed into the snip.
+ the new editor is @italic{not} installed into the snip.
 
 When an @scheme[editor-snip%] object is not inserted in an editor, it
  does not have an administrator. During this time, it does not give
diff --git a/collects/scribblings/gui/horizontal-panel-class.scrbl b/collects/scribblings/gui/horizontal-panel-class.scrbl
index 2ef4e7d3..19cfdaf9 100644
--- a/collects/scribblings/gui/horizontal-panel-class.scrbl
+++ b/collects/scribblings/gui/horizontal-panel-class.scrbl
@@ -27,8 +27,18 @@ If the @scheme['border] style is specified, the window is created with
  less than its total size). @DeletedStyleNote{panel}
 
 @WindowKWs[] @SubareaKWs[] @AreaContKWs[] @AreaKWs[]
+}
 
+@defmethod[(set-orientation [horizontal? boolean?]) void?]{
+  Sets the orientation of the panel, switching it between
+  the behavior of the @scheme[vertical-panel%] and that of
+  the @scheme[horizontal-panel%].
+}
 
-
-}}
+@defmethod[(get-orientation) boolean?]{
+  Initially returns @scheme[#t], but if 
+  @method[horizontal-panel% set-orientation] is called,
+  this method returns whatever the last value passed to it was.
+}
+}
 
diff --git a/collects/scribblings/gui/radio-box-class.scrbl b/collects/scribblings/gui/radio-box-class.scrbl
index 11c59643..fbea90c5 100644
--- a/collects/scribblings/gui/radio-box-class.scrbl
+++ b/collects/scribblings/gui/radio-box-class.scrbl
@@ -143,7 +143,7 @@ box, @|MismatchExn|.
            void?]{
 
 Sets the selected radio button by position. (The control's callback
- procedure is {\em not} invoked.) Radio buttons are numbered from
+ procedure is @italic{not} invoked.) Radio buttons are numbered from
  @scheme[0]. If @scheme[n] is equal to or larger than the number of
  radio buttons in the radio box, @|MismatchExn|.
 
diff --git a/collects/scribblings/gui/snip-class.scrbl b/collects/scribblings/gui/snip-class.scrbl
index d049ac88..ad01b417 100644
--- a/collects/scribblings/gui/snip-class.scrbl
+++ b/collects/scribblings/gui/snip-class.scrbl
@@ -283,7 +283,7 @@ A drawing context is provided for the purpose of finding font sizes,
  sizing that overrides that device context's current font.
 
 The snip's left and top @techlink{location}s are provided in editor
- coordinates. In a text editor, the y-coordinate is the {\em line's}
+ coordinates. In a text editor, the y-coordinate is the @italic{line's}
  top @techlink{location}; the snip's actual top @techlink{location} is potentially
  undetermined until its height is known.
 
diff --git a/collects/scribblings/gui/timer-class.scrbl b/collects/scribblings/gui/timer-class.scrbl
index a5f0ef61..d29ca13d 100644
--- a/collects/scribblings/gui/timer-class.scrbl
+++ b/collects/scribblings/gui/timer-class.scrbl
@@ -70,7 +70,7 @@ Starts (or restarts) the timer. If the timer is already running, its
 
 The timer's alarm expires after @scheme[msec] milliseconds, at which
 point @method[timer% notify] is called (on an event boundary). If
-@scheme[just-once?]\ is @scheme[#f], the timer expires {\em every}
+@scheme[just-once?]\ is @scheme[#f], the timer expires @italic{every}
 @scheme[msec] milliseconds until the timer is explicitly
 stopped;\footnote{More precisely, the timer expires @scheme[msec]
 milliseconds after @method[timer% notify] returns each time}
diff --git a/collects/scribblings/gui/vertical-panel-class.scrbl b/collects/scribblings/gui/vertical-panel-class.scrbl
index 61dab526..9397854f 100644
--- a/collects/scribblings/gui/vertical-panel-class.scrbl
+++ b/collects/scribblings/gui/vertical-panel-class.scrbl
@@ -30,8 +30,18 @@ If the @scheme['border] style is specified, the window is created with
  less than its total size). @DeletedStyleNote{panel}
 
 @WindowKWs[] @SubareaKWs[] @AreaContKWs[] @AreaKWs[]
+}
 
+@defmethod[(set-orientation [horizontal? boolean?]) void?]{
+  Sets the orientation of the panel, switching it between
+  the behavior of the @scheme[vertical-panel%] and that of
+  the @scheme[horizontal-panel%].
+}
 
-
-}}
+@defmethod[(get-orientation) boolean?]{
+  Initially returns @scheme[#f], but if 
+  @method[vertical-panel% set-orientation] is called,
+  this method returns whatever the last value passed to it was.
+}
+}
 
diff --git a/collects/tests/mred/windowing.ss b/collects/tests/mred/windowing.ss
index 056c752e..8d202694 100644
--- a/collects/tests/mred/windowing.ss
+++ b/collects/tests/mred/windowing.ss
@@ -992,7 +992,7 @@
 (define (panel-tests frame% show?)
   (define (panel-test % win?)
     (let* ([frame (make-object frame% "Panel Test" #f 100 100)]
-	   [panel (if %
+           [panel (if %
 		      (make-object % frame)
 		      frame)])
       (let ([go
@@ -1001,6 +1001,8 @@
 	       (if win?
 		   ((if % containee-window-tests window-tests) panel #t #t (and % frame) frame 0)
 		   (area-tests panel #t #t #f))
+               (when (is-a? panel panel%)
+                 (st #t panel get-orientation (is-a? panel horizontal-panel%)))
 	       (container-tests panel win?)
 	       (send frame show #f))])
 	(when (eq? show? 'dialog)