a little more progress (got ellipses bounding boxes right!)

svn: r16307

collects/2htdp/private/image-core.ss

@@ -113,7 +113,10 @@ and they all have good sample contracts. (It is amazing what we can do with kids
 (define (image-right image) (bb-right (image-bb image)))
 (define (image-bottom image) (bb-bottom (image-bb image)))
 (define (image-baseline image) (bb-baseline (image-bb image)))
-(define (image? p) (is-a? p image%))
+(define (image? p) 
+  (or (is-a? p image%)
+      (is-a? p image-snip%)
+      (is-a? p bitmap%)))
 
 
 ;; a bb is  (bounding box)
@@ -149,9 +152,9 @@ and they all have good sample contracts. (It is amazing what we can do with kids
 ;;    NOTE: font can't be the raw mred font or else copy & paste won't work
 (define-struct/reg-mk text (string angle font) #:omit-define-syntaxes #:transparent)
 ;;
-;;  - (make-bitmap (is-a?/c bitmap%) angle)
+;;  - (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 (bitmap angle) #:omit-define-syntaxes #:transparent)
+(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle scale rendered-bitmap) #:omit-define-syntaxes #:transparent)
 
 ;; a polygon is:
 ;;
@@ -252,7 +255,8 @@ and they all have good sample contracts. (It is amazing what we can do with kids
         (set-box/f! rspace 0)))
 
     (define/override (write f) 
-      (send f put (string->bytes/utf-8 (format "~s" (list shape bb)))))
+      (let ([bytes (string->bytes/utf-8 (format "~s" (list shape bb)))])
+        (send f put (bytes-length bytes) bytes)))
     
     (super-new)
     
@@ -264,11 +268,18 @@ and they all have good sample contracts. (It is amazing what we can do with kids
 (define image-snipclass% 
   (class snip-class%
     (define/override (read f)
-      (let* ([str (bytes->string/utf-8 (send f get-unterminated-bytes))]
+      (let* ([bytes (send f get-unterminated-bytes)]
-             [lst (parse 
+             [str 
+              (and bytes
+                   (with-handlers ((exn:fail? (λ (x) #f)))
+                     (bytes->string/utf-8 bytes)))]
+             [lst 
+              (and str
+                   (with-handlers ((exn:fail:read? (λ (x) #f)))
+                     (parse 
                       (scheme/base:read
                        (open-input-string
-                     str)))])
+                        str)))))])
         (if lst
             (make-image (list-ref lst 0)
                         (list-ref lst 1)
@@ -280,7 +291,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
 
 (provide snip-class) 
 (define snip-class (new image-snipclass%))
-(send snip-class set-classname (format "~s" '(lib "image-core.ss" "2htdp/private")))
+(send snip-class set-classname (format "~s" '(lib "image-core.ss" "2htdp" "private")))
 (send snip-class set-version 1)
 (send (get-the-snip-class-list) add snip-class)
 
@@ -371,8 +382,16 @@ and they all have good sample contracts. (It is amazing what we can do with kids
                    (ellipse-angle shape)
                    (ellipse-mode shape)
                    (ellipse-color shape))]
-    [(text? shape) (error 'scaling-text)]
+    [(text? shape) 
-    [(bitmap? shape) (error 'scaling-a-bitmap)]))
+     (unless (and (= 1 x-scale)
+                  (= 1 y-scale))
+       (fprintf (current-error-port) "scaling text, ignoring\n"))
+     shape]
+    [(bitmap? shape) 
+     (unless (and (= 1 x-scale)
+                  (= 1 y-scale))
+       (fprintf (current-error-port) "scaling a bitmap, ignoring\n"))
+     shape]))
 
 
 ;                                                                
@@ -425,43 +444,50 @@ and they all have good sample contracts. (It is amazing what we can do with kids
        (cond
          [(ellipse? atomic-shape)
           (let* ([path (new dc-path%)]
-                 [w (ellipse-width atomic-shape)]
+                 [ew (ellipse-width atomic-shape)]
-                 [h (ellipse-height atomic-shape)]
+                 [eh (ellipse-height atomic-shape)]
-                 [θ (degrees->radians (ellipse-angle atomic-shape))]
+                 [θ (ellipse-angle atomic-shape)])
-                 [cos2 (sqr (cos θ))]
+            (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)])
-                 [sin2 (sqr (sin θ))]
+              (send path ellipse 0 0 ew eh)
-                 [rotated-width (+ (* w cos2) (* h sin2))]
+              (send path translate (- (/ ew 2)) (- (/ eh 2)))
-                 [rotated-height (+ (* w sin2) (* h cos2))])
-            
-            (send path ellipse 0 0 w h)
-            (send path translate (- (/ w 2)) (- (/ h 2)))
               (send path rotate θ)
               (send path translate (/ rotated-width 2) (/ rotated-height 2))
               (send dc set-pen (mode-color->pen (ellipse-mode atomic-shape) (ellipse-color atomic-shape)))
               (send dc set-brush (mode-color->brush (ellipse-mode atomic-shape) (ellipse-color atomic-shape)))
-            (send dc draw-path path dx dy))]
+              (send dc draw-path path dx dy)))]
-         
+         [(bitmap? atomic-shape)
+          (send dc draw-bitmap 
+                (bitmap-raw-bitmap atomic-shape)
+                dx dy
+                'solid
+                (send the-color-database find-color "black")
+                (bitmap-raw-mask atomic-shape))]
          [(text? atomic-shape)
           (let ([θ (degrees->radians (text-angle atomic-shape))])
             (send dc set-font (text-font atomic-shape))
             (send dc draw-text (text-string atomic-shape) dx dy #f 0 angle))]))]))
 
+(define (ellipse-rotated-size ew eh θ)
+  (let* ([t1 (atan (/ eh ew (exact->inexact (tan θ))))]
+         ; a*cos(t1),b*sin(t1) is the point on *original* ellipse which gets rotated to top.
+         [t2 (atan (/ (* (- eh) (tan θ)) ew))] ; the original point rotated to right side.
+         [rotated-height (+ (* ew (sin θ) (cos t1)) (* eh (cos θ) (sin t1)))]
+         [rotated-width  (- (* ew (cos θ) (cos t2)) (* eh (sin θ) (sin t2)))])
+    (values (abs rotated-width)
+            (abs rotated-height))))
+
 (define (degrees->radians θ)
   (* θ 2 pi (/ 360)))
 
-
 (define (mode-color->pen mode color)
-  (send the-pen-list find-or-create-pen color 1 
   (case mode
-          [(outline) 'solid]
+    [(outline) (send the-pen-list find-or-create-pen color 1 'solid)]
-          [(solid) 'transparent])))
+    [(solid) (send the-pen-list find-or-create-pen color 1 'solid)]))
 
 (define (mode-color->brush mode color)
-  (send the-brush-list find-or-create-brush color 
   (case mode
-          [(outline) 'transparent]
+    [(outline) (send the-brush-list find-or-create-brush "black" 'transparent)]
-          [(solid) 'solid])))
+    [(solid) (send the-brush-list find-or-create-brush color 'solid)]))
-
 
 (provide make-image image-shape
          
@@ -473,10 +499,11 @@ and they all have good sample contracts. (It is amazing what we can do with kids
          make-ellipse ellipse? ellipse-width ellipse-height ellipse-angle ellipse-mode ellipse-color
          make-text text? text-string text-angle text-font
          make-polygon polygon? polygon-points polygon-mode polygon-color
-         make-bitmap bitmap? bitmap-bitmap bitmap-angle
+         make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-scale bitmap-rendered-bitmap
           
          degrees->radians
          normalize-shape
+         ellipse-rotated-size
          
          image?
          image-right

collects/2htdp/private/image-more.ss

@@ -24,6 +24,9 @@
          show-image
          bring-between
          
+         image-snip->image
+         bitmap->image
+         
          scale
          scale/xy
          
@@ -152,7 +155,10 @@
                 'image
                 i
                 arg)
-     arg]
+     (cond
+       [(is-a? arg image-snip%) (image-snip->image arg)]
+       [(is-a? arg bitmap%) (bitmap->image arg)]
+       [else arg])]
     [(mode)
      (check-arg fn-name
                 (mode? arg)
@@ -181,7 +187,9 @@
                 (angle? arg)
                 'angle\ in\ degrees
                 i arg)
-     arg]
+     (if (< arg 0)
+         (+ arg 360)
+         arg)]
     [(color)
      (check-color fn-name i arg)
      (let ([color-str 
@@ -206,9 +214,19 @@
 (define (angle? arg)
   (and (number? arg)
        (real? arg)
-       (<= 0 arg)
+       (< -360 arg 360)))
-       (< arg 360)))
 
+(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
+  (make-image (make-bitmap bm mask-bm 0 1 #f)
+              (make-bb (send bm get-width)
+                       (send bm get-height)
+                       (send bm get-height))
+              #f))
+
+(define (image-snip->image is)
+  (bitmap->image (send is get-bitmap)
+                 (or (send is get-bitmap-mask)
+                     (send (send is get-bitmap) get-loaded-mask))))
 
 ;                                              
 ;                                              
@@ -430,35 +448,18 @@
                    (cdr points))
          (values left top right bottom)))]
     [else
-#|
->>  (rotate theta (ellipse w h _ _))
->> is
->>  (let* {[cos2 (sqr (cos theta))]
->>         [sin2 (sqr (sin theta))]
->>         }
->>    (make-bbox (+ (* w cos2) (* h sin2))
->>               (+ (* w sin2) (* h cos2)))
->>               ... ;; baseline is same as y, for non-text, right?
->>               )
->>
-|#
-     
      (let ([dx (translate-dx simple-shape)]
            [dy (translate-dy simple-shape)]
            [atomic-shape (translate-shape simple-shape)])
        (cond
          [(ellipse? atomic-shape)
-          (let* ([theta (degrees->radians (ellipse-angle atomic-shape))]
+          (let-values ([(w h) (ellipse-rotated-size (ellipse-width atomic-shape)
-                 [w (ellipse-width atomic-shape)]
+                                                    (ellipse-height atomic-shape)
-                 [h (ellipse-height atomic-shape)]
+                                                    (ellipse-angle atomic-shape))])
-                 [cos2 (sqr (cos theta))]
+            (values dx
-                 [sin2 (sqr (sin theta))]
+                    dy
-                 [new-w (+ (* w cos2) (* h sin2))]
+                    (+ dx w)
-                 [new-h (+ (* w sin2) (* h cos2))])
+                    (+ dy h)))]
-            (values (+ dx (/ (- new-w w) 2))
-                    (+ dy (/ (- new-h h) 2))
-                    (+ dx new-w (/ (- new-w w) 2))
-                    (+ dy new-h (/ (- new-h h) 2))))]
          [else
           (fprintf (current-error-port) "BAD BOUNDING BOX\n")
           (values 0 0 100 100)]))]))
@@ -510,8 +511,11 @@
                 (bring-between (+ θ (text-angle atomic-shape)) 360)
                 (text-font atomic-shape))]
     [(bitmap? atomic-shape)
-     (make-bitmap (bitmap-bitmap atomic-shape)
+     (make-bitmap (bitmap-raw-bitmap atomic-shape)
-                  (bring-between (+ θ (bitmap-angle atomic-shape)) 360))]))
+                  (bitmap-raw-mask atomic-shape)
+                  (bring-between (+ θ (bitmap-angle atomic-shape)) 360)
+                  (bitmap-scale atomic-shape)
+                  #f)]))
 
 ;; rotate-point : x,y angle -> x,y
 (define (rotate-point x y θ)

collects/teachpack/2htdp/scribblings/image.scrbl

@@ -1,7 +1,8 @@
 #lang scribble/doc
 
 @(require (for-label (except-in 2htdp/image image?)
-                     lang/htdp-beginner)
+                     lang/htdp-beginner
+                     scheme/gui/base)
           "shared.ss"
           scribble/manual)
 
@@ -10,9 +11,10 @@
 @defmodule[#:require-form beginner-require 2htdp/image]
 
 The image teachpack provides a number of basic image construction functions, along with
-combinators for building more complex images out of existing images. It includes
+combinators for building more complex images out of existing images. Basic images include
-support for various polygons, ellipses and circles, and text, as well as supporting bitmaps.
+various polygons, ellipses and circles, and text, as well as bitmaps (typically bitmaps 
-Images can be rotated, scaled, and overlaid on top of each other, as described below.
+come about via the @onscreen{Insert Image...} menu item in DrScheme.
+Existing images can be rotated, scaled, and overlaid on top of each other.
 
 @emph{This library is currently a work in progress. 
       I don't expect the existing primitives to change, but more will be added
@@ -102,7 +104,10 @@ This section lists predicates for the basic structures provided by the image lib
  Determines if @scheme[x] is an image. Images are returned by functions
  like @scheme[ellipse] and @scheme[rectangle] and
  accepted by functions like @scheme[overlay] and @scheme[beside].
-}
+
+ Additionally, images inserted into a DrScheme window are treated as
+ bitmap images, as are instances of @scheme[image-snip%] and @scheme[bitmap%].
+ }
 
 @defproc[(mode? [x any/c]) boolean?]{
  Determines if @scheme[x] is a mode suitable for

collects/tests/2htdp/test-image.ss

@@ -10,7 +10,7 @@
 
 ;; test case: (beside (text "a"...) (text "b" ...)) vs (text "ab")
 
-(show-image (frame (rotate 30 (ellipse 200 400 'solid 'purple))))
+;(show-image (frame (rotate 210 (ellipse 200 400 'solid 'purple))))
 
 #;
 (show-image
@@ -318,6 +318,10 @@
       =>
       (normalize-shape (image-shape (rotate 45 (ellipse 12 10 'solid 'red)))))
 
+(test (rotate -90 (ellipse 200 400 'solid 'purple))
+      =>
+      (rotate 90 (ellipse 200 400 'solid 'purple)))
+
 (require (only-in lang/htdp-advanced equal~?))
 
 (test (equal~? (rectangle 100 10 'solid 'red)
@@ -384,3 +388,37 @@
       (rectangle 100 10 "solid" "blue"))
 
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  bitmap tests
+;;
+
+(define (fill-bitmap b color)
+  (let ([bdc (make-object bitmap-dc% b)])
+    (send bdc set-brush color 'solid)
+    (send bdc set-pen color 1 'solid)
+    (send bdc draw-rectangle 0 0 (send b get-width) (send b get-height))
+    (send bdc set-bitmap #f)))
+
+(define blue-10x20-bitmap (make-object bitmap% 10 20))
+(fill-bitmap blue-10x20-bitmap "blue")
+(define blue-20x10-bitmap (make-object bitmap% 20 10))
+(fill-bitmap blue-20x10-bitmap "blue")
+(define blue-20x40-bitmap (make-object bitmap% 20 40))
+(fill-bitmap blue-20x40-bitmap "blue")
+
+(test (image-right (image-snip->image (make-object image-snip% blue-10x20-bitmap)))
+      => 
+      10)
+(test (image-bottom (image-snip->image (make-object image-snip% blue-10x20-bitmap)))
+      => 
+      20)
+(test (image-baseline (image-snip->image (make-object image-snip% blue-10x20-bitmap)))
+      => 
+      20)
+(test (scale 2 (make-object image-snip% blue-10x20-bitmap))
+      =>
+      (image-snip->image (make-object image-snip% blue-20x40-bitmap)))
+(test (rotate 90 (make-object image-snip% blue-10x20-bitmap))
+      =>
+      (image-snip->image (make-object image-snip% blue-20x10-bitmap)))