From ac3e0b848b360cb5d916cd29224d3ea4c71289a6 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 7 Jun 2010 20:04:29 -0400
Subject: [PATCH 01/15] fix make-gui-namespace from scheme/gui/base and
 racket/gui/base  so that the namespace starts with scheme/base or racket/base
  respectively

original commit: 1712dfb7f5710bbfba14ca537ec4317bc6afaaaa
---
 collects/mred/mred.rkt                       |  7 ++++-
 collects/racket/gui/base.rkt                 | 27 +++++++++++++++++---
 collects/scheme/gui/base.rkt                 | 27 ++++++++++++++++++--
 collects/scribblings/gui/common.rkt          | 26 +++++++++----------
 collects/scribblings/gui/miscwin-funcs.scrbl |  4 +--
 5 files changed, 70 insertions(+), 21 deletions(-)

diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt
index 3309ac05..3127506f 100644
--- a/collects/mred/mred.rkt
+++ b/collects/mred/mred.rkt
@@ -1,5 +1,5 @@
 (module mred mzscheme
-  (require (only scheme/base
+  (require (only racket/base
                  define-namespace-anchor
                  namespace-anchor->empty-namespace
                  make-base-empty-namespace)
@@ -57,6 +57,9 @@
   (wx:set-dialogs get-file put-file get-ps-setup-from-user message-box)
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; These functions are re-implemented in scheme/gui/base
+  ;; and racket/gui/base to attach those names, instead of
+  ;; just 'mred.
 
   (define-namespace-anchor anchor)
 
@@ -75,6 +78,8 @@
         (namespace-require 'scheme/class))
       ns))
 
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
   (define (make-eventspace)
     (parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)]
                    [wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)])
diff --git a/collects/racket/gui/base.rkt b/collects/racket/gui/base.rkt
index dd18b645..dcdad620 100644
--- a/collects/racket/gui/base.rkt
+++ b/collects/racket/gui/base.rkt
@@ -1,4 +1,25 @@
-#lang scheme/base
+#lang racket/base
+(require (except-in mred
+                    make-gui-namespace
+                    make-gui-empty-namespace))
 
-(require mred)
-(provide (all-from-out mred))
+(provide (all-from-out mred)
+         make-gui-namespace
+         make-gui-empty-namespace)
+
+(define-namespace-anchor anchor)
+
+(define (make-gui-empty-namespace)
+  (let ([ns (make-base-empty-namespace)])
+    (namespace-attach-module (namespace-anchor->empty-namespace anchor)
+                             'racket/gui/base
+                             ns)
+    ns))
+
+(define (make-gui-namespace)
+  (let ([ns (make-gui-empty-namespace)])
+    (parameterize ([current-namespace ns])
+      (namespace-require 'racket/base)
+      (namespace-require 'racket/gui/base)
+      (namespace-require 'racket/class))
+    ns))
diff --git a/collects/scheme/gui/base.rkt b/collects/scheme/gui/base.rkt
index 25deaa37..3a8c8977 100644
--- a/collects/scheme/gui/base.rkt
+++ b/collects/scheme/gui/base.rkt
@@ -1,2 +1,25 @@
-#lang scheme/private/provider
-racket/gui/base
+#lang scheme/base
+(require (except-in mred
+                    make-gui-namespace
+                    make-gui-empty-namespace))
+
+(provide (all-from-out mred)
+         make-gui-namespace
+         make-gui-empty-namespace)
+
+(define-namespace-anchor anchor)
+
+(define (make-gui-empty-namespace)
+  (let ([ns (make-base-empty-namespace)])
+    (namespace-attach-module (namespace-anchor->empty-namespace anchor)
+                             'scheme/gui/base
+                             ns)
+    ns))
+
+(define (make-gui-namespace)
+  (let ([ns (make-gui-empty-namespace)])
+    (parameterize ([current-namespace ns])
+      (namespace-require 'scheme/base)
+      (namespace-require 'scheme/gui/base)
+      (namespace-require 'scheme/class))
+    ns))
diff --git a/collects/scribblings/gui/common.rkt b/collects/scribblings/gui/common.rkt
index 8868619e..4ead8e06 100644
--- a/collects/scribblings/gui/common.rkt
+++ b/collects/scribblings/gui/common.rkt
@@ -1,24 +1,24 @@
 
-(module common scheme/base
+(module common racket/base
   (require scribble/manual
            scribble/basic
-           scheme/class
-           scheme/contract
+           racket/class
+           racket/contract
            "blurbs.ss"
            (only-in "../reference/mz.ss" AllUnix exnraise))
   (provide (all-from-out scribble/manual)
            (all-from-out scribble/basic)
-           (all-from-out scheme/class)
-           (all-from-out scheme/contract)
+           (all-from-out racket/class)
+           (all-from-out racket/contract)
            (all-from-out "blurbs.ss")
            (all-from-out "../reference/mz.ss"))
 
-  (require (for-label scheme/gui/base
-                      scheme/class
-                      scheme/contract
-                      scheme/base))
-  (provide (for-label (all-from-out scheme/gui/base)
-                      (all-from-out scheme/class)
-                      (all-from-out scheme/contract)
-                      (all-from-out scheme/base))))
+  (require (for-label racket/gui/base
+                      racket/class
+                      racket/contract
+                      racket/base))
+  (provide (for-label (all-from-out racket/gui/base)
+                      (all-from-out racket/class)
+                      (all-from-out racket/contract)
+                      (all-from-out racket/base))))
 
diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl
index 525620cf..c32cf3a2 100644
--- a/collects/scribblings/gui/miscwin-funcs.scrbl
+++ b/collects/scribblings/gui/miscwin-funcs.scrbl
@@ -267,12 +267,12 @@ Strips shortcut ampersands from @racket[label], removes parenthesized
 @defproc[(make-gui-empty-namespace) namespace?]{
 
 Like @racket[make-base-empty-namespace], but with
-@racket[racket/class] and @racketmodname[racket/gui/base] also
+@racketmodname[racket/class] and @racketmodname[racket/gui/base] also
 attached to the result namespace.}
 
 @defproc[(make-gui-namespace) namespace?]{
 
-Like @racket[make-base-namespace], but with @racket[racket/class] and
+Like @racket[make-base-namespace], but with @racketmodname[racket/class] and
 @racketmodname[racket/gui/base] also required into the top-level
 environment of the result namespace.}
 

From 20a8870abb5a05238a0f80cff42d70272da9bfec Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 8 Jun 2010 16:43:32 -0500
Subject: [PATCH 02/15] changed the framework's standard menus frame so that
 the quit menu is never created under mac os x (which is the right behavior to
 make quit actually work properly).

original commit: 716aacf388dadf3d557eff0073dec582664a48b6
---
 collects/framework/private/gen-standard-menus.rkt   | 10 +++++-----
 collects/framework/private/standard-menus-items.rkt |  2 +-
 2 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/collects/framework/private/gen-standard-menus.rkt b/collects/framework/private/gen-standard-menus.rkt
index 5082f28b..120799bb 100644
--- a/collects/framework/private/gen-standard-menus.rkt
+++ b/collects/framework/private/gen-standard-menus.rkt
@@ -7,7 +7,7 @@
 
 (define-runtime-path here ".")
 
-(define standard-menus.ss-filename (simplify-path (build-path here "standard-menus.ss")))
+(define standard-menus.rkt-filename (simplify-path (build-path here "standard-menus.rkt")))
 (define docs-menus.ss-filename (simplify-path (build-path here 'up 'up "scribblings" "framework" "standard-menus.scrbl")))
 
 ;; build-before-super-item-clause : an-item -> (listof clause)
@@ -121,7 +121,7 @@
               ,(generic-initializer generic)))]))
 
 (define (main)
-  (write-standard-menus.ss)
+  (write-standard-menus.rkt)
   (write-docs))
 
 (define (write-docs)
@@ -202,10 +202,10 @@
       (display docs-footer-text port))
     #:exists 'truncate))
 
-(define (write-standard-menus.ss)
-  (printf "writing to ~a~n" standard-menus.ss-filename)  
+(define (write-standard-menus.rkt)
+  (printf "writing to ~a~n" standard-menus.rkt-filename)  
 
-  (call-with-output-file standard-menus.ss-filename
+  (call-with-output-file standard-menus.rkt-filename
     (λ (port)
       (pretty-print
        `(define standard-menus<%>
diff --git a/collects/framework/private/standard-menus-items.rkt b/collects/framework/private/standard-menus-items.rkt
index 05ae0527..10b4bf55 100644
--- a/collects/framework/private/standard-menus-items.rkt
+++ b/collects/framework/private/standard-menus-items.rkt
@@ -280,7 +280,7 @@
                            (string-constant quit-menu-item-windows)
                            (string-constant quit-menu-item-others))
                       on-demand-do-nothing
-                      '(not (current-eventspace-has-standard-menus?)))
+                      '(not (eq? (system-type) 'macosx)))
         (make-after 'file-menu 'quit 'nothing)
         
         (make-an-item 'edit-menu 'undo 

From 9eeb5c84839ef12f3769ff9fb55eb8cba56aff2f Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 16 Jun 2010 11:35:40 -0500
Subject: [PATCH 03/15] a bunch of little fixes to the 2htdp/image library (and
 related) for sfp submission: - added in the htdp/image version of the
 performance test case - made gui-eval work with things other than slideshow -
 extended render-image so that it works on bitmaps and image-snips

original commit: 22bc8f6d87f12efa6b720249a194db5dd555056e
---
 collects/mrlib/image-core.rkt | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt
index 860d8914..3d9a13f2 100644
--- a/collects/mrlib/image-core.rkt
+++ b/collects/mrlib/image-core.rkt
@@ -552,7 +552,13 @@ has been moved out).
         [font (send dc get-font)]
         [fg (send dc get-text-foreground)]
         [smoothing (send dc get-smoothing)])
-    (render-normalized-shape (send image get-normalized-shape) dc dx dy)
+    (cond
+      [(is-a? image bitmap%)
+       (send dc draw-bitmap image dx dy)]
+      [(is-a? image image-snip%)
+       (send dc draw-bitmap (send image get-bitmap) dx dy)]
+      [else
+       (render-normalized-shape (send image get-normalized-shape) dc dx dy)])
     (send dc set-pen pen)
     (send dc set-brush brush)
     (send dc set-font font)

From 7614ac4819f37cd4690a4ad4246bbb0159628237 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 18 Jun 2010 16:19:22 -0500
Subject: [PATCH 04/15] added support for flipping bitmaps

original commit: 132867518c12e2c4b223305130df7938bf1aa350
---
 collects/mrlib/image-core.rkt                | 311 ++++++++++++-------
 collects/mrlib/private/image-core-bitmap.rkt |   9 +
 2 files changed, 209 insertions(+), 111 deletions(-)

diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt
index 3d9a13f2..f9517d7d 100644
--- a/collects/mrlib/image-core.rkt
+++ b/collects/mrlib/image-core.rkt
@@ -1,4 +1,10 @@
 #lang racket/base
+
+;; changed:
+;; - simple-shape
+;; - np-atomic-shape
+;; - atomic-shape
+
 #|
 
 This library is the part of the 2htdp/image 
@@ -29,7 +35,9 @@ has been moved out).
 (require racket/class
          racket/gui/base
          racket/math
+         racket/contract
          "private/image-core-bitmap.ss"
+         (prefix-in cis: "cache-image-snip.ss")
          (for-syntax racket/base))
 
 (define-for-syntax id-constructor-pairs '())
@@ -122,6 +130,7 @@ has been moved out).
 ;;  - polygon
 ;;  - line-segment
 ;;  - curve-segment
+;;  - bitmap
 ;;  - np-atomic-shape
 
 ;; a np-atomic-shape is:
@@ -135,11 +144,22 @@ has been moved out).
 (define-struct/reg-mk text (string angle y-scale color size face family style weight underline) 
   #:omit-define-syntaxes #:transparent)
 ;;
+;;  - flip
+
+;; a bitmap is:
 ;;  - (make-bitmap (is-a?/c bitmap%) angle positive-real (or/c #f (is-a?/c bitmap%)))
 ;;    NOTE: bitmap copying needs to happen in 'write' and 'read' methods
 (define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale [rendered-bitmap #:mutable] [rendered-mask #:mutable])
   #:omit-define-syntaxes #:transparent)
 
+;; a flip is:
+;;   - (make-flip boolean bitmap)
+;; * the boolean is #t if the bitmap should be flipped vertically (after applying whatever rotation is in there)
+;; * this struct is here to avoid adding a field to bitmaps, so that old save files
+;;   from when the library did not support flipping still load
+;;   (since normalization will add a flip structure if necessary)
+(define-struct/reg-mk flip (flipped? shape))
+
 ;; a polygon is:
 ;;
 ;;  - (make-polygon (listof vector) mode color)
@@ -164,7 +184,7 @@ has been moved out).
 ;;  - (make-crop (listof points) normalized-shape)
 
 ;; a simple-shape (subtype of shape) is
-;;  - (make-translate dx dy np-atomic-shape))
+;;  - (make-translate dx dy np-atomic-shape)
 ;;  - polygon
 ;;  - line-segment
 ;;  - curve-segment
@@ -213,21 +233,26 @@ has been moved out).
     (init-field shape bb normalized?)
     (define/public (equal-to? that eq-recur)
       (or (eq? this that)
-          (and (is-a? that image%)
-               (same-bb? bb (send that get-bb))
-               (or (and (not (skip-image-equality-fast-path))  ;; this is here to make testing more effective
-                        (equal? (get-normalized-shape) (send that get-normalized-shape)))
-                   (let ([w (+ 1 (round (inexact->exact (bb-right bb))))]    ;; some shapes (ie, rectangles) draw 1 outside the bounding box
-                         [h (+ 1 (round (inexact->exact (bb-bottom bb))))])  ;; so we make the bitmap slightly bigger to accomodate that.
-                     (or (zero? w)
-                         (zero? h)
-                         (let ([bm1 (make-object bitmap% w h)]
-                               [bm2 (make-object bitmap% w h)]
-                               [bytes1 (make-bytes (* w h 4) 0)]
-                               [bytes2 (make-bytes (* w h 4) 0)]
-                               [bdc (make-object bitmap-dc%)])
-                           (and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that)
-                                (check-same? bm1 bm2 bytes1 bytes2 bdc "green" that)))))))))
+          (let ([that 
+                 (cond
+                   [(is-a? that image-snip%) (image-snip->image that)]
+                   [(is-a? that bitmap%) (bitmap->image that)]
+                   [else that])])
+            (and (is-a? that image%)
+                 (same-bb? bb (send that get-bb))
+                 (or (and (not (skip-image-equality-fast-path))  ;; this is here to make testing more effective
+                          (equal? (get-normalized-shape) (send that get-normalized-shape)))
+                     (let ([w (+ 1 (round (inexact->exact (bb-right bb))))]    ;; some shapes (ie, rectangles) draw 1 outside the bounding box
+                           [h (+ 1 (round (inexact->exact (bb-bottom bb))))])  ;; so we make the bitmap slightly bigger to accomodate that.
+                       (or (zero? w)
+                           (zero? h)
+                           (let ([bm1 (make-object bitmap% w h)]
+                                 [bm2 (make-object bitmap% w h)]
+                                 [bytes1 (make-bytes (* w h 4) 0)]
+                                 [bytes2 (make-bytes (* w h 4) 0)]
+                                 [bdc (make-object bitmap-dc%)])
+                             (and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that)
+                                  (check-same? bm1 bm2 bytes1 bytes2 bdc "green" that))))))))))
     
     (define/private (check-same? bm1 bm2 bytes1 bytes2 bdc color that)
       (clear-bitmap/draw/bytes bm1 bdc bytes1 this color)
@@ -369,9 +394,51 @@ has been moved out).
 
 (define-id->constructor id->constructor)
 
+
+(define (normalized-shape? s)
+  (cond
+    [(overlay? s)
+     (and (normalized-shape? (overlay-top s))
+          (cn-or-simple-shape? (overlay-bottom s)))]
+    [else
+     (cn-or-simple-shape? s)]))
+
+(define (cn-or-simple-shape? s)
+  (cond
+    [(crop? s)
+     (normalized-shape? (crop-shape s))]
+    [else
+     (simple-shape? s)]))
+
+(define (simple-shape? shape)
+  (or (and (translate? shape)
+           (np-atomic-shape? (translate-shape shape)))
+      (polygon? shape)
+      (line-segment? shape)
+      (curve-segment? shape)))
+
+(define (atomic-shape? shape)
+  (or (polygon? shape)
+      (line-segment? shape)
+      (curve-segment? shape)
+      (bitmap? shape)
+      (np-atomic-shape? shape)))
+
+(define (np-atomic-shape? shape)
+  (or (ellipse? shape)
+      (text? shape)
+      (and (flip? shape)
+           (boolean? (flip-flipped? shape))
+           (bitmap? (flip-shape shape)))
+      (point? shape))) ;; does this belong here?
+
+
 ;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape
 ;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape.
-(define (normalize-shape shape [f values])
+(define/contract (normalize-shape shape [f values])
+  (->* (any/c) ;; should be shape?
+       ((-> any/c any/c))
+       normalized-shape?)
   (let loop ([shape shape]
              [dx 0]
              [dy 0]
@@ -443,50 +510,20 @@ has been moved out).
          (if bottom
              (make-overlay bottom (f this-one))
              (f this-one)))]
-      [(np-atomic-shape? shape)
-       (let ([this-one 
-              (make-translate dx dy (scale-np-atomic x-scale y-scale shape))])
-         (if bottom
-             (make-overlay bottom (f this-one))
-             (f this-one)))]
+      [(or (bitmap? shape) (np-atomic-shape? shape))
+       (let ([shape (if (bitmap? shape) 
+                        (make-flip #f shape)
+                        shape)])
+         (let ([this-one 
+                (make-translate dx dy (scale-np-atomic x-scale y-scale shape))])
+           (if bottom
+               (make-overlay bottom (f this-one))
+               (f this-one))))]
       [else 
        (error 'normalize-shape "unknown shape ~s\n" shape)])))
 
-(define (normalized-shape? s)
-  (cond
-    [(overlay? s)
-     (and (normalized-shape? (overlay-top s))
-          (cn-or-simple-shape? (overlay-bottom s)))]
-    [else
-     (cn-or-simple-shape? s)]))
-
-(define (cn-or-simple-shape? s)
-  (cond
-    [(crop? s)
-     (normalized-shape? (crop-shape s))]
-    [else
-     (simple-shape? s)]))
-
-(define (simple-shape? shape)
-  (or (and (translate? shape)
-           (np-atomic-shape? (translate-shape shape)))
-      (polygon? shape)
-      (line-segment? shape)
-      (curve-segment? shape)))
-
-(define (atomic-shape? shape)
-  (or (polygon? shape)
-      (line-segment? shape)
-      (curve-segment? shape)
-      (np-atomic-shape? shape)))
-
-(define (np-atomic-shape? shape)
-  (or (ellipse? shape)
-      (text? shape)
-      (bitmap? shape)
-      (point? shape)))
-
-(define (scale-np-atomic x-scale y-scale shape)
+(define/contract (scale-np-atomic x-scale y-scale shape)
+  (-> number? number? np-atomic-shape? np-atomic-shape?)
   (cond
     [(ellipse? shape)
      (make-ellipse (* x-scale (ellipse-width shape))
@@ -508,13 +545,15 @@ has been moved out).
                 (text-style shape)
                 (text-weight shape)
                 (text-underline shape))]
-    [(bitmap? shape) 
-     (make-bitmap (bitmap-raw-bitmap shape)
-                  (bitmap-raw-mask shape)
-                  (bitmap-angle shape)
-                  (* x-scale (bitmap-x-scale shape))
-                  (* y-scale (bitmap-y-scale shape))
-                  #f #f)]))
+    [(flip? shape)
+     (let ([bitmap (flip-shape shape)])
+       (make-flip (flip-flipped? shape)
+                  (make-bitmap (bitmap-raw-bitmap bitmap)
+                               (bitmap-raw-mask bitmap)
+                               (bitmap-angle bitmap)
+                               (* x-scale (bitmap-x-scale bitmap))
+                               (* y-scale (bitmap-y-scale bitmap))
+                               #f #f)))]))
 
 (define (scale-color color x-scale y-scale)
   (cond
@@ -658,15 +697,15 @@ has been moved out).
     [else
      (let ([dx (+ dx (translate-dx simple-shape))]
            [dy (+ dy (translate-dy simple-shape))]
-           [atomic-shape (translate-shape simple-shape)])
+           [np-atomic-shape (translate-shape simple-shape)])
        (cond
-         [(ellipse? atomic-shape)
+         [(ellipse? np-atomic-shape)
           (let* ([path (new dc-path%)]
-                 [ew (ellipse-width atomic-shape)]
-                 [eh (ellipse-height atomic-shape)]
-                 [θ (degrees->radians (ellipse-angle atomic-shape))]
-                 [color (ellipse-color atomic-shape)]
-                 [mode (ellipse-mode atomic-shape)])
+                 [ew (ellipse-width np-atomic-shape)]
+                 [eh (ellipse-height np-atomic-shape)]
+                 [θ (degrees->radians (ellipse-angle np-atomic-shape))]
+                 [color (ellipse-color np-atomic-shape)]
+                 [mode (ellipse-mode np-atomic-shape)])
             (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)])
               (send path ellipse 0 0 ew eh)
               (send path translate (- (/ ew 2)) (- (/ eh 2)))
@@ -675,26 +714,26 @@ has been moved out).
               (send dc set-brush (mode-color->brush mode color))
               (send dc set-smoothing (mode-color->smoothing mode color))
               (send dc draw-path path dx dy)))]
-         [(bitmap? atomic-shape)
-          (let ([bm (get-rendered-bitmap atomic-shape)]) 
+         [(flip? np-atomic-shape) 
+          (let ([bm (get-rendered-bitmap np-atomic-shape)]) 
             (send dc draw-bitmap 
                   bm
                   (- dx (/ (send bm get-width) 2))
                   (- dy (/ (send bm get-height) 2))
                   'solid
                   (send the-color-database find-color "black")
-                  (get-rendered-mask atomic-shape)))]
-         [(text? atomic-shape)
-          (let ([θ (degrees->radians (text-angle atomic-shape))]
+                  (get-rendered-mask np-atomic-shape)))]
+         [(text? np-atomic-shape)
+          (let ([θ (degrees->radians (text-angle np-atomic-shape))]
                 [font (send dc get-font)])
-            (send dc set-font (text->font atomic-shape))
+            (send dc set-font (text->font np-atomic-shape))
             (send dc set-text-foreground 
-                  (or (send the-color-database find-color (text-color atomic-shape))
+                  (or (send the-color-database find-color (text-color np-atomic-shape))
                       (send the-color-database find-color "black")))
-            (let-values ([(w h _1 _2) (send dc get-text-extent (text-string atomic-shape))])
+            (let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))])
               (let ([p (- (make-rectangular dx dy)
                           (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))])
-                (send dc draw-text (text-string atomic-shape) 
+                (send dc draw-text (text-string np-atomic-shape) 
                       (real-part p)
                       (imag-part p) 
                       #f 0 θ))))]))]))
@@ -747,43 +786,50 @@ the mask bitmap and the original bitmap are all together in a single bytes!
 |#
 
 
-(define (get-rendered-bitmap bitmap)
-  (calc-renered-bitmap bitmap)
-  (bitmap-rendered-bitmap bitmap))
+(define (get-rendered-bitmap flip-bitmap)
+  (calc-rendered-bitmap flip-bitmap)
+  (bitmap-rendered-bitmap (flip-shape flip-bitmap)))
 
-(define (get-rendered-mask bitmap)
-  (calc-renered-bitmap bitmap)
-  (bitmap-rendered-mask bitmap))
+(define (get-rendered-mask flip-bitmap)
+  (calc-rendered-bitmap flip-bitmap)
+  (bitmap-rendered-mask (flip-shape flip-bitmap)))
 
-(define (calc-renered-bitmap bitmap)
-  (unless (bitmap-rendered-bitmap bitmap)
-    ;; fill in the rendered bitmap with the raw bitmaps.
-    (set-bitmap-rendered-bitmap! bitmap (bitmap-raw-bitmap bitmap))
-    (set-bitmap-rendered-mask! bitmap (bitmap-raw-mask bitmap))
-    (cond
-      [(and (= 1 (bitmap-x-scale bitmap))
-            (= 1 (bitmap-y-scale bitmap))
-            (= 0 (bitmap-angle bitmap)))
-       ;; if there's no scaling or rotation, we can just keep that bitmap.
-       (void)]
-      [(<= (* (bitmap-x-scale bitmap) 
-              (bitmap-y-scale bitmap))
-           1)
-       ;; since we prefer to rotate big things, we rotate first
-       (do-rotate bitmap)
-       (do-scale bitmap)]
-      [else
-       ;; since we prefer to rotate big things, we scale first
-       (do-scale bitmap)
-       (do-rotate bitmap)])))
+(define (calc-rendered-bitmap flip-bitmap)
+  (let ([bitmap (flip-shape flip-bitmap)])
+    (unless (bitmap-rendered-bitmap bitmap)
+      (let ([flipped? (flip-flipped? flip-bitmap)])
+        
+        ;; fill in the rendered bitmap with the raw bitmaps.
+        (set-bitmap-rendered-bitmap! bitmap (bitmap-raw-bitmap bitmap))
+        (set-bitmap-rendered-mask! bitmap (bitmap-raw-mask bitmap))
+        (cond
+          [(and (= 1 (bitmap-x-scale bitmap))
+                (= 1 (bitmap-y-scale bitmap))
+                (= 0 (bitmap-angle bitmap))
+                (not flipped?))
+           ;; if there's no scaling, rotation or flipping, we can just keep that bitmap.
+           (void)]
+          [(<= (* (bitmap-x-scale bitmap) 
+                  (bitmap-y-scale bitmap))
+               1)
+           ;; since we prefer to rotate big things, we rotate first
+           (do-rotate bitmap flipped?)
+           (do-scale bitmap)]
+          [else
+           ;; since we prefer to rotate big things, we scale first
+           (do-scale bitmap)
+           (do-rotate bitmap flipped?)])))))
 
-(define (do-rotate bitmap)
+(define (do-rotate bitmap flip?)
   (let ([θ (degrees->radians (bitmap-angle bitmap))])
     (let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap) 
                                              (bitmap-rendered-mask bitmap))])
       (let-values ([(rotated-bytes rotated-w rotated-h)
                     (rotate-bytes bytes w h θ)])
-        (let* ([bm (bytes->bitmap rotated-bytes rotated-w rotated-h)]
+        (let* ([flipped-bytes (if flip?
+                                  (flip-bytes rotated-bytes w h)
+                                  rotated-bytes)]
+               [bm (bytes->bitmap flipped-bytes rotated-w rotated-h)]
                [mask (send bm get-loaded-mask)])
           (set-bitmap-rendered-bitmap! bitmap bm)
           (set-bitmap-rendered-mask! bitmap mask))))))
@@ -920,6 +966,43 @@ the mask bitmap and the original bitmap are all together in a single bytes!
     (send ans set-join (pen-join pen))
     ans))
        
+(define (to-img arg)
+  (cond
+    [(is-a? arg image-snip%) (image-snip->image arg)]
+    [(is-a? arg bitmap%) (bitmap->image arg)]
+    [else arg]))
+
+(define (image-snip->image is)
+  (let ([bm (send is get-bitmap)])
+    (cond
+      [(not bm)
+       ;; this might mean we have a cache-image-snip% 
+       ;; or it might mean we have a useless snip.
+       (let-values ([(w h) (if (is-a? is cis:cache-image-snip%)
+                               (send is get-size)
+                               (values 0 0))])
+         (make-image (make-polygon
+                      (list (make-point 0 0)
+                            (make-point w 0)
+                            (make-point w h)
+                            (make-point 0 h))
+                      'solid "black")
+                     (make-bb w h h)
+                     #f))]
+      [else
+       (bitmap->image bm
+                      (or (send is get-bitmap-mask)
+                          (send bm get-loaded-mask)))])))
+
+(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
+  (let ([w (send bm get-width)]
+        [h (send bm get-height)])
+    (make-image (make-translate (/ w 2)
+                                (/ h 2)
+                                (make-bitmap bm mask-bm 0 1 1 #f #f))
+                (make-bb w h h)
+                #f)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
@@ -945,6 +1028,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale 
          bitmap-rendered-bitmap bitmap-rendered-mask
 
+         make-flip flip? flip-flipped? flip-shape
+         
          (struct-out color)
          
          degrees->radians
@@ -960,7 +1045,11 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          
          skip-image-equality-fast-path
          
-         scale-np-atomic)
+         scale-np-atomic
+         
+         to-img
+         bitmap->image
+         image-snip->image)
 
 ;; method names
 (provide get-shape get-bb get-normalized? get-normalized-shape)
diff --git a/collects/mrlib/private/image-core-bitmap.rkt b/collects/mrlib/private/image-core-bitmap.rkt
index 9be7037f..ce1bfd19 100644
--- a/collects/mrlib/private/image-core-bitmap.rkt
+++ b/collects/mrlib/private/image-core-bitmap.rkt
@@ -4,6 +4,7 @@
 
 
 (provide rotate-bytes ;; : bytes int[width] int[height] radians[radians] -> bytes
+         flip-bytes ;; : bytes int[width] int[height] -> bytes
          bitmap->bytes
          bytes->bitmap)
 ;; rotate-bitmap : (-> bytes? natural-number/c natural-number/c real? bytes?)
@@ -76,6 +77,14 @@ instead of this scaling code, we use the dc<%>'s scaling code.
     (send bm set-loaded-mask mask)
     bm))
 
+(define (flip-bytes bmbytes w h)
+  (build-bmbytes 
+   w h 
+   (λ (x y)
+     (let ([new-x x]
+           [new-y (- h y 1)])
+       (bmbytes-ref/safe bmbytes w h new-x new-y)))))
+
 (define (rotate-bytes bmbytes w h theta)
   (let* {[theta-rotation (exp (* i theta))]
          [theta-unrotation (make-rectangular (real-part theta-rotation)

From 883413b6b27164cc9bb4d80c396c19ae3b6234dc Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 18 Jun 2010 16:19:54 -0500
Subject: [PATCH 05/15] removed a bogus case in the definition of
 np-atomic-shape predicate

original commit: 0c0009465ec61cfa09126614b3282ae69dc2b1dd
---
 collects/mrlib/image-core.rkt | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt
index f9517d7d..70ade946 100644
--- a/collects/mrlib/image-core.rkt
+++ b/collects/mrlib/image-core.rkt
@@ -429,9 +429,7 @@ has been moved out).
       (text? shape)
       (and (flip? shape)
            (boolean? (flip-flipped? shape))
-           (bitmap? (flip-shape shape)))
-      (point? shape))) ;; does this belong here?
-
+           (bitmap? (flip-shape shape)))))
 
 ;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape
 ;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape.

From b7f4103256b7a664762562f0ad3d6e707d499a6a Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 18 Jun 2010 17:38:26 -0500
Subject: [PATCH 06/15] added the ability to specify radio button labels as
 regexps, not just strings

original commit: ef438302657aed31611916cec837292d5cfb0310
---
 collects/framework/test.rkt | 50 ++++++++++++++++++++++++-------------
 1 file changed, 33 insertions(+), 17 deletions(-)

diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt
index 1fe661a3..03f49d35 100644
--- a/collects/framework/test.rkt
+++ b/collects/framework/test.rkt
@@ -1,5 +1,4 @@
-#reader scribble/reader
-#lang scheme/gui
+#lang at-exp scheme/gui
 
 (require scribble/srcdoc)
 (require/doc scheme/base scribble/manual)
@@ -355,8 +354,7 @@
                                 state in-cb
                                 (build-labels rb))]
               [else (let ([i (- total n)])
-                      (if (or (string=? state (send rb get-item-label i))
-                              (string=? state (send rb get-item-plain-label i)))
+                      (if (ith-item-matches? rb state i)
                           (if (send rb is-enabled? i)
                               (send rb set-selection i)
                               (error 'test:set-radio-box!
@@ -371,6 +369,15 @@
                     "expected a string or a number as second arg, got: ~e (other arg: ~e)"
                     state in-cb)]))))
 
+(define (ith-item-matches? rb state i)
+  (cond
+    [(string? state)
+     (or (string=? state (send rb get-item-label i))
+         (string=? state (send rb get-item-plain-label i)))]
+    [(regexp? state)
+     (or (regexp-match state (send rb get-item-label i))
+         (regexp-match state (send rb get-item-plain-label i)))]))
+
 ;; set-radio-box-item! : string -> void
 (define (set-radio-box-item! state) 
   (control-action
@@ -383,8 +390,7 @@
          (cond
            [(zero? n) (error 'test:set-radio-box-item! "internal error")]
            [else (let ([i (- total n)])
-                   (if (or (string=? state (send rb get-item-label i))
-                           (string=? state (send rb get-item-plain-label i)))
+                   (if (ith-item-matches? rb state i)
                        (if (send rb is-enabled? i)
                            (send rb set-selection i)
                            (error 'test:set-radio-box!
@@ -392,14 +398,23 @@
                                   state))
                        (loop (- n 1))))]))))))
 
-;; entry-matches : string -> radio-box -> boolean
+;; entry-matches : string | regexp -> radio-box -> boolean
 (define (entry-matches name)
   (λ (rb)
     (let loop ([n (send rb get-number)])
-      (and (not (zero? n))
-           (or (equal? name (send rb get-item-label (- n 1)))
-               (equal? name (send rb get-item-plain-label (- n 1)))
-               (loop (- n 1)))))))
+      (cond
+        [(zero? n) #f]
+        [else
+         (let ([itm (send rb get-item-label (- n 1))]
+               [pln-itm (send rb get-item-plain-label (- n 1))])
+           (or (cond
+                 [(string? name)
+                  (or (equal? name itm)
+                      (equal? name pln-itm))]
+                 [(regexp? name)
+                  (or (regexp-match name itm)
+                      (regexp-match name pln-itm))])
+               (loop (- n 1))))]))))
 
 ;;; CHOICE 
 
@@ -844,11 +859,12 @@
  
  (proc-doc/names
   test:set-radio-box!
-  (-> (or/c string? (is-a?/c radio-box%)) (or/c string? number?) void?)
+  (-> (or/c string? regexp? (is-a?/c radio-box%)) (or/c string? number?) void?)
   (radio-box state)
-  @{Sets the radio-box to @scheme[state]. If @scheme[state] is a
-         string, this function finds the choice with that label and
-         if it is a number, it uses the number as an index into the
+  @{Sets the radio-box to the label matching @scheme[state]. If @scheme[state] is a
+         string, this function finds the choice with that label. 
+         If it is a regexp, this function finds the first choice whose label matches the regexp.
+         If it is a number, it uses the number as an index into the
          state. If the number is out of range or if the label isn't
          in the radio box, an exception is raised.
 
@@ -858,9 +874,9 @@
  
  (proc-doc/names
   test:set-radio-box-item!
-  (-> string? void?)
+  (-> (or/c string? regexp?) void?)
   (entry)
-  @{Finds a @scheme[radio-box%] that has a label @scheme[entry]
+  @{Finds a @scheme[radio-box%] that has a label matching @scheme[entry]
           and sets the radio-box to @scheme[entry].})
  
  (proc-doc/names

From 66ad2795fd19c05546076033222fc0faf2d59b73 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sun, 20 Jun 2010 14:13:16 -0500
Subject: [PATCH 07/15] Refactored the rotation code to support an arbitrary
 linear transformation

original commit: 2e67f8bb9fc0dda3cf411e33017301436bce2fd1
---
 collects/mrlib/private/image-core-bitmap.rkt | 89 +++++++++++++++++++-
 1 file changed, 87 insertions(+), 2 deletions(-)

diff --git a/collects/mrlib/private/image-core-bitmap.rkt b/collects/mrlib/private/image-core-bitmap.rkt
index ce1bfd19..eba26aaf 100644
--- a/collects/mrlib/private/image-core-bitmap.rkt
+++ b/collects/mrlib/private/image-core-bitmap.rkt
@@ -6,7 +6,8 @@
 (provide rotate-bytes ;; : bytes int[width] int[height] radians[radians] -> bytes
          flip-bytes ;; : bytes int[width] int[height] -> bytes
          bitmap->bytes
-         bytes->bitmap)
+         bytes->bitmap
+         linear-transform)
 ;; rotate-bitmap : (-> bytes? natural-number/c natural-number/c real? bytes?)
 ;; avoid a dependency on scheme/contract, which pulls in too much
 
@@ -85,6 +86,7 @@ instead of this scaling code, we use the dc<%>'s scaling code.
            [new-y (- h y 1)])
        (bmbytes-ref/safe bmbytes w h new-x new-y)))))
 
+#;
 (define (rotate-bytes bmbytes w h theta)
   (let* {[theta-rotation (exp (* i theta))]
          [theta-unrotation (make-rectangular (real-part theta-rotation)
@@ -113,7 +115,90 @@ instead of this scaling code, we use the dc<%>'s scaling code.
                                             (real-part pre-image)
                                             (- (imag-part pre-image))))))
             new-w
-            new-h)))                               
+            new-h)))
+
+;; linear transform: bytes width height <matrix coodinates> -> (values bytes width height)
+;; The matrix is read like this:
+;;  +-   -+
+;;  | a b |
+;;  | c d |
+;;  +-   -+
+;; The ai, bi, ci, and di are the coordinates of the inverse matrix
+(define (linear-transform bmbytes w h a b c d)
+  (let-values ([(ai bi ci di)
+                (let ([k (/ (- (* a d) (* b c)))])
+                  (values (* k d) (* k (- b))
+                          (* k (- c)) (* k a)))])
+    ;; mapp : <matrix> complex -> complex
+    ;; applies the matrix represented by abcd(as in the picture above) to p
+    (define (mapp a b c d p)
+      (let ([x (real-part p)]
+            [y (imag-part p)])
+        (make-rectangular (+ (* a x) (* b y))
+                          (+ (* c x) (* d y)))))
+    (let* {[f-rotation (λ (p) (mapp a b c d p))]
+           [f-unrotation (λ (p) (mapp ai bi ci di p))]
+           [ne (f-rotation w)]
+           [sw (f-rotation (* i (- h)))]
+           [se (f-rotation (make-rectangular w (- h)))]
+           [nw 0]
+           [pts (list ne sw se nw)]
+           [longitudes (map real-part pts)]
+           [latitudes  (map imag-part pts)]
+           [east (apply max longitudes)]
+           [west (apply min longitudes)]
+           [nrth (apply max latitudes)]
+           [sth  (apply min latitudes)]
+           [new-w (round/e (- east west))]
+           [new-h (round/e (- nrth sth))]}
+      (values (build-bmbytes new-w
+                             new-h
+                             (λ (x y)
+                               (let* {[pre-image (f-unrotation (make-rectangular (+ west x 1/2) (- nrth y 1/2)))]}
+                                 (interpolate bmbytes w h
+                                              (real-part pre-image)
+                                              (- (imag-part pre-image))))))
+              new-w
+              new-h))))
+
+(define (rotate-bytes bmbytes w h theta)
+  (let* ([theta-rotation (exp (* i theta))]
+         [x (real-part theta-rotation)]
+         [y (imag-part theta-rotation)])
+    (linear-transform 
+     bmbytes w h 
+     x (- y) y x)))
+
+#;
+(define (rotate-bytes bmbytes w h theta)
+  (let* {[theta-rotation (exp (* i theta))]
+         [theta-unrotation (make-rectangular (real-part theta-rotation)
+                                             (- (imag-part theta-rotation)))]
+         [f-rotation (λ (p) (* theta-rotation p))]
+         [f-unrotation (λ (p) (* theta-unrotation p))]
+         [ne (f-rotation w)]
+         [sw (f-rotation (* i (- h)))]
+         [se (f-rotation (make-rectangular w (- h)))]
+         [nw 0]
+         [pts (list ne sw se nw)]
+         [longitudes (map real-part pts)]
+         [latitudes  (map imag-part pts)]
+         [east (apply max longitudes)]
+         [west (apply min longitudes)]
+         [nrth (apply max latitudes)]
+         [sth  (apply min latitudes)]
+         [new-w (round/e (- east west))]
+         [new-h (round/e (- nrth sth))]}
+    (values (build-bmbytes new-w
+                           new-h
+                           (λ (x y)
+                             (let* {[pre-image (f-unrotation (make-rectangular (+ west x 1/2) (- nrth y 1/2)))]}
+                               (interpolate bmbytes w h
+                                            (real-part pre-image)
+                                            (- (imag-part pre-image))))))
+            new-w
+            new-h)))
+
 ;; Why the offsets of 1/2 in `rotate-bytes` and `interpolate`?
 ;; We consider a pixel's RGB as a point-sample taken from the 'true' image,
 ;; where the RGB is the sample at the *center* of the square covered by the pixel.

From f39e86aad386de7add03d7b0a6973eae4d3250d3 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sun, 20 Jun 2010 21:59:30 -0500
Subject: [PATCH 08/15] added local

original commit: 4504678bd78a0175ad003ec892cc27885ca75b90
---
 collects/framework/private/main.rkt | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt
index 2ab8893e..893c5de6 100644
--- a/collects/framework/private/main.rkt
+++ b/collects/framework/private/main.rkt
@@ -208,7 +208,7 @@
 (let ([hash-table (make-hasheq)])
   (for-each (λ (x) 
               (hash-set! hash-table x 'define))
-            '(local))
+            '(struct local))
   (for-each (λ (x) 
               (hash-set! hash-table x 'begin))
             '(case-lambda

From b4ccdd66b57889685373bb240df43fb48fce238a Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 22 Jun 2010 11:55:06 -0500
Subject: [PATCH 09/15] added docs and minor cleanups in mrlib/name-message

original commit: c5b0c73111e7e6e6752616856a8a4c54d3749a95
---
 collects/mrlib/name-message.rkt               |  9 ++++----
 collects/mrlib/scribblings/name-message.scrbl | 21 +++++++++++++++----
 2 files changed, 22 insertions(+), 8 deletions(-)

diff --git a/collects/mrlib/name-message.rkt b/collects/mrlib/name-message.rkt
index 823e1239..aefc4cd4 100644
--- a/collects/mrlib/name-message.rkt
+++ b/collects/mrlib/name-message.rkt
@@ -7,7 +7,8 @@
 
 (provide/contract
  [get-left-side-padding (-> number?)]
- [pad-xywh (number? number? (>=/c 0) (>=/c 0) . -> . (values number? number? (>=/c 0) (>=/c 0)))]
+ [pad-xywh (-> number? number? (>=/c 0) (>=/c 0)
+               (values number? number? (>=/c 0) (>=/c 0)))]
  [draw-button-label
   (->d ([dc (is-a?/c dc<%>)]
         [label (or/c false/c string?)]
@@ -23,8 +24,8 @@
        [result void?])]
  
  [calc-button-min-sizes
-  (->* ((is-a?/c dc<%>) string? (is-a?/c font%))
-       ()
+  (->* ((is-a?/c dc<%>) string?)
+       ((is-a?/c font%))
        (values number? number?))])
 
 (provide name-message%)
@@ -241,7 +242,7 @@
 (define mouse-grabbed-color (make-object color% 100 100 100))
 (define grabbed-fg-color (make-object color% 220 220 220))
 
-(define (calc-button-min-sizes dc label button-label-font)
+(define (calc-button-min-sizes dc label [button-label-font (send dc get-font)])
   (let-values ([(w h a d) (send dc get-text-extent label button-label-font)])
     (let-values ([(px py pw ph) (pad-xywh 0 0 w h)])
       (values pw ph))))
diff --git a/collects/mrlib/scribblings/name-message.scrbl b/collects/mrlib/scribblings/name-message.scrbl
index c9a38114..1209211f 100644
--- a/collects/mrlib/scribblings/name-message.scrbl
+++ b/collects/mrlib/scribblings/name-message.scrbl
@@ -72,7 +72,7 @@ saying that there is no file name until the file is saved.}
   the @method[name-message% set-message].
 }
                  
-@defmethod[(get-background-color) (or/c false/c (is-a/c color%) string?)]{
+@defmethod[(get-background-color) (or/c #f (is-a/c color%) string?)]{
 
 The result of this method is used for the background color
 when redrawing the name message. If it is @scheme[#f], the
@@ -80,7 +80,7 @@ OS's default panel background is used.
 
 }
 
-@defmethod[(set-allow-shrinking [width (or/c false/c number?)]) void?]{
+@defmethod[(set-allow-shrinking [width (or/c #f number?)]) void?]{
 
 When this method receives a number, the name-message will
 then shrink (the number indicates the minimum width the name
@@ -99,7 +99,8 @@ Defaultly, the name-message does not allow shrinking.
 
 
 @defproc[(calc-button-min-sizes [dc (is-a?/c dc<%>)]
-                                [str string?]) 
+                                [str string?]
+                                [font (or/c #f (is-a?/c font%)) #f])
          (values real? real?)]{
 
 Calculates the minimum width and height of a button label (when drawn
@@ -116,7 +117,7 @@ and height. The @scheme[dc] argument is used for sizing.}
                             [mouse-over? boolean?]
                             [grabbed? boolean?]
                             [font (is-a?/c font%)]
-                            [background (or/c (is-a?/c color%) string? false/c)])
+                            [background (or/c (is-a?/c color%) string? #f)])
          void?]{
 
 Draws a button label like the one for the @onscreen{(define ...)} and
@@ -139,3 +140,15 @@ color to paint (if any).
 See @scheme[calc-button-min-sizes] for help calculating the min sizes
 of the button.}
 
+@defproc[(pad-xywh [tx number?]
+                   [ty number?]
+                   [tw (>=/c 0)]
+                   [th (>=/c 0)])
+         (values number? number? (>=/c 0) (>=/c 0))]{
+  Returns spacing information describing how
+  @racket[draw-button-label] draws. The inputs are 
+  the x and y coordinates where the text should appear
+  and the width and height of the text, and the results
+  are the x and y coordinates where the shape should be
+  drawn and the width and height of the overall shape.
+}
\ No newline at end of file

From 87a29fc514eb007d811d8e5055a130d8f2d850cd Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 22 Jun 2010 11:56:59 -0500
Subject: [PATCH 10/15] rackety mrlib/name-message

original commit: 9f5593c2224d2dc6d167ab14c6adbad35806427e
---
 collects/mrlib/name-message.rkt               |  2 +-
 collects/mrlib/scribblings/name-message.scrbl | 40 +++++++++----------
 2 files changed, 21 insertions(+), 21 deletions(-)

diff --git a/collects/mrlib/name-message.rkt b/collects/mrlib/name-message.rkt
index aefc4cd4..1d964cd3 100644
--- a/collects/mrlib/name-message.rkt
+++ b/collects/mrlib/name-message.rkt
@@ -1,4 +1,4 @@
-#lang scheme/gui
+#lang racket/gui
 
 ;; min-w, min-h : number -> contract
 ;; determines if the widths and heights are suitable
diff --git a/collects/mrlib/scribblings/name-message.scrbl b/collects/mrlib/scribblings/name-message.scrbl
index 1209211f..d8cf79d7 100644
--- a/collects/mrlib/scribblings/name-message.scrbl
+++ b/collects/mrlib/scribblings/name-message.scrbl
@@ -8,7 +8,7 @@
 
 @defclass[name-message% canvas% ()]{
 
-A @scheme[name-message%] control displays a filename that the user can
+A @racket[name-message%] control displays a filename that the user can
 click to show the filename's path and select one of the enclosing
 directories. Override the @method[name-message% on-choose-directory]
 method to handle the user's selection.
@@ -16,7 +16,7 @@ method to handle the user's selection.
 
 @defconstructor/auto-super[()]{
 
-Passes all arguments to @scheme[super-init].}
+Passes all arguments to @racket[super-init].}
 
 
 @defmethod[(on-choose-directory [dir path-string?])
@@ -42,7 +42,7 @@ Draws the control's current message.}
 
 @defmethod[(set-hidden? [hidden? any/c])
            void?]{
-Calling this method with @scheme[#f] causes the name message
+Calling this method with @racket[#f] causes the name message
 to become invisible and to stop responding to mouse movements.
 
 Calling it with a true value restores its visibility and
@@ -55,19 +55,19 @@ makes it respond to mouse movements again.}
 
 Sets the label for the control.
 
-If @scheme[file-name?] is @scheme[#t], @scheme[msg] is treated like a
+If @racket[file-name?] is @racket[#t], @racket[msg] is treated like a
  pathname, and a click on the name-message control creates a popup
  menu to open a get-file dialog.
 
-If @scheme[file-name?] is @scheme[#f], @scheme[msg] is treated as a
+If @racket[file-name?] is @racket[#f], @racket[msg] is treated as a
 label string. Clicking on the name-message control pops up a dialog
 saying that there is no file name until the file is saved.}
 
 @defmethod[(set-short-title [short-title? boolean?]) void?]{
-  Sets the @scheme[short-title?] flag. The flag defaults to @scheme[#f].
+  Sets the @racket[short-title?] flag. The flag defaults to @racket[#f].
   
-  If the flag is @scheme[#t], then
-  the label for the control is simply the string @scheme["/"]. Otherwise,
+  If the flag is @racket[#t], then
+  the label for the control is simply the string @racket["/"]. Otherwise,
   the label is determined by
   the @method[name-message% set-message].
 }
@@ -75,7 +75,7 @@ saying that there is no file name until the file is saved.}
 @defmethod[(get-background-color) (or/c #f (is-a/c color%) string?)]{
 
 The result of this method is used for the background color
-when redrawing the name message. If it is @scheme[#f], the
+when redrawing the name message. If it is @racket[#f], the
 OS's default panel background is used.
 
 }
@@ -104,8 +104,8 @@ Defaultly, the name-message does not allow shrinking.
          (values real? real?)]{
 
 Calculates the minimum width and height of a button label (when drawn
-with @scheme[draw-button-label]). Returns two values: the width
-and height. The @scheme[dc] argument is used for sizing.}
+with @racket[draw-button-label]). Returns two values: the width
+and height. The @racket[dc] argument is used for sizing.}
 
 
 @defproc[(draw-button-label [dc (is-a?/c dc<%>)]
@@ -125,19 +125,19 @@ filename buttons in the top-left corner of the DrRacket frame. Use
 this function to draw similar buttons.
 
 The basic idea is to create a canvas object whose on-paint method is
-overridden to call this function.  The @scheme[dc] argument should be
-canvas's drawing context, and @scheme[str] should be the string to
-display on the button.  The @scheme[width] and @scheme[height]
+overridden to call this function.  The @racket[dc] argument should be
+canvas's drawing context, and @racket[str] should be the string to
+display on the button.  The @racket[width] and @racket[height]
 arguments should be the width and height of the button, and the
-@scheme[dx] and @scheme[dy] arguments specify an offset into
-@scheme[dc] for the button. The @scheme[mouse-over?] argument should
-be true when the mouse is over the button, and the @scheme[grabbed?]
+@racket[dx] and @racket[dy] arguments specify an offset into
+@racket[dc] for the button. The @racket[mouse-over?] argument should
+be true when the mouse is over the button, and the @racket[grabbed?]
 argument should be true when the button has been pressed. The
-@scheme[font] and @scheme[background] arguments supply the font to use
-in drawing (possibly @scheme[normal-control-font]) and the background
+@racket[font] and @racket[background] arguments supply the font to use
+in drawing (possibly @racket[normal-control-font]) and the background
 color to paint (if any).
 
-See @scheme[calc-button-min-sizes] for help calculating the min sizes
+See @racket[calc-button-min-sizes] for help calculating the min sizes
 of the button.}
 
 @defproc[(pad-xywh [tx number?]

From e101a899782ab3d7f8d47d368fc560e295f8036d Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 26 Jun 2010 10:05:06 -0600
Subject: [PATCH 11/15] add 'handles-all-mouse-events snip% flag

original commit: dc98077ca4b1eabd8ff776dca000eca17bdb9ebf
---
 collects/mred/private/wxme/pasteboard.rkt | 59 +++++++++++++++--------
 collects/mred/private/wxme/text.rkt       | 51 +++++++++++++-------
 collects/scribblings/gui/snip-class.scrbl |  8 ++-
 3 files changed, 77 insertions(+), 41 deletions(-)

diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt
index 68cd415b..4c07fd66 100644
--- a/collects/mred/private/wxme/pasteboard.rkt
+++ b/collects/mred/private/wxme/pasteboard.rkt
@@ -158,7 +158,8 @@
   (define sequence-streak? #f)
 
   (define changed? #f)
-  
+
+  (define prev-mouse-snip #f)
 
   (super-new)
 
@@ -241,28 +242,42 @@
   (def/override (on-event [mouse-event% event])
     (when s-admin
       (let-values ([(dc x y scrollx scrolly)
-                    (if (or (send event button-down?) s-caret-snip)
-                        ;; first, find clicked-on snip:
-                        (let ([x (send event get-x)]
-                              [y (send event get-y)])
-                          (let-boxes ([scrollx 0.0]
-                                      [scrolly 0.0]
-                                      [dc #f])
-                              (set-box! dc (send s-admin get-dc scrollx scrolly))
-                            ;; FIXME: old code returned if !dc
-                            (values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))
-                        (values #f 0.0 0.0 0.0 0.0))])
-        (let ([snip (if (send event button-down?)
-                        (find-snip x y)
-                        s-caret-snip)])
-        (if (and snip
-                 (eq? snip s-caret-snip))
-            (let ([loc (snip-loc snip)])
-              (send s-caret-snip on-event
+                    ;; first, find clicked-on snip:
+                    (let ([x (send event get-x)]
+                          [y (send event get-y)])
+                      (let-boxes ([scrollx 0.0]
+                                  [scrolly 0.0]
+                                  [dc #f])
+                          (set-box! dc (send s-admin get-dc scrollx scrolly))
+                        ;; FIXME: old code returned if !dc
+                        (values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))])
+        (let ([snip (find-snip x y)])
+          (when (and prev-mouse-snip
+                     (not (eq? snip prev-mouse-snip)))
+            (let ([loc (snip-loc prev-mouse-snip)])
+              (send prev-mouse-snip on-event
                     dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly) 
                     (loc-x loc) (loc-y loc)
-                    event))
-            (on-local-event event))))))
+                    event)))
+          (set! prev-mouse-snip #f)
+          (when (and snip
+                     (has-flag? (snip->flags snip) HANDLES-ALL-MOUSE-EVENTS)
+                     (not (eq? snip s-caret-snip)))
+            (let ([loc (snip-loc snip)])
+              (set! prev-mouse-snip snip)
+              (send snip on-event
+                    dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly) 
+                    (loc-x loc) (loc-y loc)
+                    event)))
+          (if (and s-caret-snip
+                   (or (not (send event button-down?))
+                       (eq? snip s-caret-snip)))
+              (let ([loc (snip-loc s-caret-snip)])
+                (send s-caret-snip on-event
+                      dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly) 
+                      (loc-x loc) (loc-y loc)
+                      event))
+              (on-local-event event))))))
 
   (def/override (on-default-event [mouse-event% event])
     (when s-admin
@@ -729,6 +744,8 @@
   
   (define/private (-delete del-snip del)
     (when (snip-loc del-snip)
+      (when (eq? del-snip prev-mouse-snip)
+        (set! prev-mouse-snip #f))
       (set! write-locked (add1 write-locked))
       (begin-edit-sequence)
       (let ([ok? (or (can-delete? del-snip)
diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt
index 884f2304..f932224d 100644
--- a/collects/mred/private/wxme/text.rkt
+++ b/collects/mred/private/wxme/text.rkt
@@ -170,6 +170,8 @@
   (define sticky-styles? #t)
   (define overwrite-mode? #f)
 
+  (define prev-mouse-snip #f)
+
   (def/public (set-styles-sticky [bool? s?]) (set! sticky-styles? (and s? #t)))
   (def/public (get-styles-sticky) sticky-styles?)
 
@@ -441,18 +443,15 @@
                  (not (send event leaving?)))
         (end-streaks '(except-key-sequence cursor delayed)))
       (let-values ([(dc x y scrollx scrolly)
-                    (if (or (send event button-down?) s-caret-snip)
-                        ;; first, find clicked-on snip:
-                        (let ([x (send event get-x)]
-                              [y (send event get-y)])
-                          (let-boxes ([scrollx 0.0]
-                                      [scrolly 0.0]
-                                      [dc #f])
-                              (set-box! dc (send s-admin get-dc scrollx scrolly))
-                            ;; FIXME: old code returned if !dc
-                            (values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))
-                        (values #f 0.0 0.0 0.0 0.0))])
-        (when (send event button-down?)
+                    ;; first, find clicked-on snip:
+                    (let ([x (send event get-x)]
+                          [y (send event get-y)])
+                      (let-boxes ([scrollx 0.0]
+                                  [scrolly 0.0]
+                                  [dc #f])
+                          (set-box! dc (send s-admin get-dc scrollx scrolly))
+                        ;; FIXME: old code returned if !dc
+                        (values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))])
           (let ([snip
                  (let-boxes ([onit? #f]
                              [how-close 0.0]
@@ -476,12 +475,26 @@
                                  #f
                                  snip)))
                          #f)))])
-            (set-caret-owner snip)))
-        (if (and s-caret-snip (has-flag? (snip->flags s-caret-snip) HANDLES-EVENTS))
-            (let-boxes ([x 0.0] [y 0.0])
-                (get-snip-position-and-location s-caret-snip #f x y)
-              (send s-caret-snip on-event dc (- x scrollx) (- y scrolly) x y event))
-            (on-local-event event)))))
+            (when (send event button-down?)
+              (set-caret-owner snip))
+            (when (and prev-mouse-snip
+                       (not (eq? snip prev-mouse-snip)))
+              (let-boxes ([x 0.0] [y 0.0])
+                  (get-snip-position-and-location prev-mouse-snip #f x y)
+                (send prev-mouse-snip on-event dc (- x scrollx) (- y scrolly) x y event)))
+            (set! prev-mouse-snip #f)
+            (if (and s-caret-snip (has-flag? (snip->flags s-caret-snip) HANDLES-EVENTS))
+                (let-boxes ([x 0.0] [y 0.0])
+                    (get-snip-position-and-location s-caret-snip #f x y)
+                  (send s-caret-snip on-event dc (- x scrollx) (- y scrolly) x y event))
+                (begin
+                  (when (and snip
+                             (has-flag? (snip->flags snip) HANDLES-ALL-MOUSE-EVENTS))
+                    (let-boxes ([x 0.0] [y 0.0])
+                        (get-snip-position-and-location snip #f x y)
+                      (set! prev-mouse-snip snip)
+                      (send snip on-event dc (- x scrollx) (- y scrolly) x y event)))
+                  (on-local-event event)))))))
 
   (def/override (on-default-event [mouse-event% event])
     (when s-admin
@@ -4004,6 +4017,8 @@
           (set! snip-count (add1 snip-count)))))
   
   (define/private (delete-snip snip)
+    (when (eq? snip prev-mouse-snip)
+      (set! prev-mouse-snip #f))
     (cond
      [(snip->next snip)
       (splice-snip (snip->next snip) (snip->prev snip) (snip->next (snip->next snip)))]
diff --git a/collects/scribblings/gui/snip-class.scrbl b/collects/scribblings/gui/snip-class.scrbl
index 3d27c532..56e07c02 100644
--- a/collects/scribblings/gui/snip-class.scrbl
+++ b/collects/scribblings/gui/snip-class.scrbl
@@ -23,7 +23,7 @@ create a useful snip:
 
  @item{@method[snip% split] if the snip can contain more than one @techlink{item}}
 
- @item{@method[snip% size-cache-invalid] if the snip caches the result to@method[snip% get-extent]} 
+ @item{@method[snip% size-cache-invalid] if the snip caches the result to @method[snip% get-extent]} 
 
  @item{@method[snip% get-text] (not required)}
 
@@ -336,7 +336,11 @@ following symbols:
        snip; only an owning editor should set this flag}
 
  @item{@indexed-scheme['handles-events] --- this snip can handle
-       keyboard and mouse events}
+       keyboard and mouse events when it has the keyboard focus}
+
+ @item{@indexed-scheme['handles-all-mouse-events] --- this snip can handle
+       mouse events that touch the snip, even if the snip does not
+       have the keyboard focus}
 
  @item{@indexed-scheme['width-depends-on-x] --- this snip's display
        width depends on the snip's x-@techlink{location} within the

From eeddddc05fdcc6e829e242de69893c060920f4f3 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 29 Jun 2010 09:25:10 -0600
Subject: [PATCH 12/15] doc corrections and clarifications

original commit: 7a7f5450468c34b173f82b5147febf7f677daa32
---
 collects/scribblings/gui/snip-class.scrbl | 7 ++++---
 1 file changed, 4 insertions(+), 3 deletions(-)

diff --git a/collects/scribblings/gui/snip-class.scrbl b/collects/scribblings/gui/snip-class.scrbl
index 56e07c02..dd590f4a 100644
--- a/collects/scribblings/gui/snip-class.scrbl
+++ b/collects/scribblings/gui/snip-class.scrbl
@@ -338,9 +338,10 @@ following symbols:
  @item{@indexed-scheme['handles-events] --- this snip can handle
        keyboard and mouse events when it has the keyboard focus}
 
- @item{@indexed-scheme['handles-all-mouse-events] --- this snip can handle
-       mouse events that touch the snip, even if the snip does not
-       have the keyboard focus}
+ @item{@indexed-scheme['handles-all-mouse-events] --- this snip can
+       handle mouse events that touch the snip or that immediately
+       follow an event that touches the snip, even if the snip does
+       not have the keyboard focus}
 
  @item{@indexed-scheme['width-depends-on-x] --- this snip's display
        width depends on the snip's x-@techlink{location} within the

From f820cb02053ccf0f9b5fe62878dc3a9a4220706f Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 6 Jul 2010 15:23:30 -0500
Subject: [PATCH 13/15] fixed PR 10998

original commit: a5d969607b764c61930ad12f01a443bca53b5031
---
 collects/mrlib/private/image-core-bitmap.rkt | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/mrlib/private/image-core-bitmap.rkt b/collects/mrlib/private/image-core-bitmap.rkt
index eba26aaf..200429fe 100644
--- a/collects/mrlib/private/image-core-bitmap.rkt
+++ b/collects/mrlib/private/image-core-bitmap.rkt
@@ -162,7 +162,7 @@ instead of this scaling code, we use the dc<%>'s scaling code.
               new-h))))
 
 (define (rotate-bytes bmbytes w h theta)
-  (let* ([theta-rotation (exp (* i theta))]
+  (let* ([theta-rotation (exp (* i theta -1))]
          [x (real-part theta-rotation)]
          [y (imag-part theta-rotation)])
     (linear-transform 

From 06f19bc758913cff0451804c6198a91c8df6a65a Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 7 Jul 2010 13:42:40 -0500
Subject: [PATCH 14/15] fixed a bug in text's color argument, as noted in PR
 10998

original commit: 070a39d902a3ccb73a0c0e7d50c6bda0fe9ee69e
---
 collects/mrlib/image-core.rkt | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt
index 70ade946..63b21dbb 100644
--- a/collects/mrlib/image-core.rkt
+++ b/collects/mrlib/image-core.rkt
@@ -725,9 +725,13 @@ has been moved out).
           (let ([θ (degrees->radians (text-angle np-atomic-shape))]
                 [font (send dc get-font)])
             (send dc set-font (text->font np-atomic-shape))
-            (send dc set-text-foreground 
-                  (or (send the-color-database find-color (text-color np-atomic-shape))
-                      (send the-color-database find-color "black")))
+            (let ([color (get-color-arg (text-color np-atomic-shape))])
+              (send dc set-text-foreground 
+                    (cond
+                      [(string? color)
+                       (or (send the-color-database find-color color)
+                           (send the-color-database find-color "black"))]
+                      [else color])))
             (let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))])
               (let ([p (- (make-rectangular dx dy)
                           (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))])

From ca8b8c5e766301f88aba35e90263d0d05315c62e Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 10 Jul 2010 09:45:49 -0500
Subject: [PATCH 15/15] modified the draw-button-label contract so that it
 would work with a let*-style scoping for ->d

original commit: 476dd36eec345b439a97cc85047aba7f0dcf2957
---
 collects/mrlib/name-message.rkt | 12 ++++--------
 1 file changed, 4 insertions(+), 8 deletions(-)

diff --git a/collects/mrlib/name-message.rkt b/collects/mrlib/name-message.rkt
index 1d964cd3..d1ad4ccf 100644
--- a/collects/mrlib/name-message.rkt
+++ b/collects/mrlib/name-message.rkt
@@ -1,10 +1,5 @@
 #lang racket/gui
 
-;; min-w, min-h : number -> contract
-;; determines if the widths and heights are suitable
-(define (min-w h) (flat-named-contract "draw-button-label-width" (lambda (w) (w . > . (- h (* 2 border-inset))))))
-(define (min-h w) (flat-named-contract "draw-button-label-height" (lambda (h) (h . > . (* 2 border-inset)))))
-
 (provide/contract
  [get-left-side-padding (-> number?)]
  [pad-xywh (-> number? number? (>=/c 0) (>=/c 0)
@@ -14,13 +9,14 @@
         [label (or/c false/c string?)]
         [x number?]
         [y number?]
-        [w (and/c number? (min-w h))]
-        [h (and/c number? (min-h w))]
+        [w number?]
+        [h (and/c number? (>=/c (* 2 border-inset)))]
         [mouse-over? boolean?]
         [grabbed? boolean?]
         [button-label-font (is-a?/c font%)]
         [bkg-color (or/c false/c (is-a?/c color%) string?)])
-       ()
+       #:pre-cond
+       (w . > . (- h (* 2 border-inset)))
        [result void?])]
  
  [calc-button-min-sizes