suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r16307
This commit is contained in:
Robby Findler 2009-10-13 17:30:40 +00:00
parent a9a9274ff8
commit 339860d340
4 changed files with 149 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
collects/2htdp/private/image-core.ss
View File

@ -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
(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)))])
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)))
[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))]
(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])))
[(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])))
[(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

64
collects/2htdp/private/image-more.ss
View File

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

13
collects/teachpack/2htdp/scribblings/image.scrbl
View File

@ -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,6 +104,9 @@ 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?]{

40
collects/tests/2htdp/test-image.ss
View File

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