From 339860d340c17b31a8275ccf33c130fc49998d92 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 13 Oct 2009 17:30:40 +0000 Subject: [PATCH] a little more progress (got ellipses bounding boxes right!) svn: r16307 --- collects/2htdp/private/image-core.ss | 105 +++++++++++------- collects/2htdp/private/image-more.ss | 64 ++++++----- .../teachpack/2htdp/scribblings/image.scrbl | 15 ++- collects/tests/2htdp/test-image.ss | 40 ++++++- 4 files changed, 149 insertions(+), 75 deletions(-) diff --git a/collects/2htdp/private/image-core.ss b/collects/2htdp/private/image-core.ss index 5fc6ef6522..0a4e1755b0 100644 --- a/collects/2htdp/private/image-core.ss +++ b/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))] - [lst (parse - (scheme/base:read - (open-input-string - str)))]) + (let* ([bytes (send f get-unterminated-bytes)] + [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)))))]) (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)] - [(bitmap? shape) (error 'scaling-a-bitmap)])) + [(text? shape) + (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)] - [h (ellipse-height atomic-shape)] - [θ (degrees->radians (ellipse-angle atomic-shape))] - [cos2 (sqr (cos θ))] - [sin2 (sqr (sin θ))] - [rotated-width (+ (* w cos2) (* h sin2))] - [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))] - + [ew (ellipse-width atomic-shape)] + [eh (ellipse-height atomic-shape)] + [θ (ellipse-angle 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))) + (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)))] + [(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] - [(solid) 'transparent]))) + (case mode + [(outline) (send the-pen-list find-or-create-pen color 1 'solid)] + [(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] - [(solid) 'solid]))) - + (case mode + [(outline) (send the-brush-list find-or-create-brush "black" 'transparent)] + [(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 diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss index e86b348490..feab38ce69 100644 --- a/collects/2htdp/private/image-more.ss +++ b/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) - (< arg 360))) + (< -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))] - [w (ellipse-width atomic-shape)] - [h (ellipse-height atomic-shape)] - [cos2 (sqr (cos theta))] - [sin2 (sqr (sin theta))] - [new-w (+ (* w cos2) (* h sin2))] - [new-h (+ (* w sin2) (* h cos2))]) - (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))))] + (let-values ([(w h) (ellipse-rotated-size (ellipse-width atomic-shape) + (ellipse-height atomic-shape) + (ellipse-angle atomic-shape))]) + (values dx + dy + (+ dx w) + (+ dy h)))] [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) - (bring-between (+ θ (bitmap-angle atomic-shape)) 360))])) + (make-bitmap (bitmap-raw-bitmap atomic-shape) + (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 θ) diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index bcc506aafa..8518b92165 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/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 -support for various polygons, ellipses and circles, and text, as well as supporting bitmaps. -Images can be rotated, scaled, and overlaid on top of each other, as described below. +combinators for building more complex images out of existing images. Basic images include +various polygons, ellipses and circles, and text, as well as bitmaps (typically bitmaps +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 diff --git a/collects/tests/2htdp/test-image.ss b/collects/tests/2htdp/test-image.ss index 3196b232ae..b3d16e2faa 100644 --- a/collects/tests/2htdp/test-image.ss +++ b/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))) \ No newline at end of file