(hopefully) sorted out polygons; added a few other polygon-based primitives
svn: r16570
This commit is contained in:
Robby Findler
parent
ccb90d4640
commit
3159a06389
|
|
@ -66,12 +66,16 @@ and they all have good sample contracts. (It is amazing what we can do with kids
|
|||
|
||||
ellipse
|
||||
rectangle
|
||||
regular-polygon
|
||||
star
|
||||
triangle
|
||||
|
||||
x-place?
|
||||
y-place?
|
||||
image?
|
||||
mode?
|
||||
angle?
|
||||
side-count?
|
||||
|
||||
image-width
|
||||
image-height)
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require mrlib/image-core
|
||||
(require "../../mrlib/image-core.ss"
|
||||
scheme/class
|
||||
scheme/gui/base
|
||||
htdp/error
|
||||
|
|
@ -34,9 +34,16 @@
|
|||
y-place?
|
||||
mode?
|
||||
angle?
|
||||
side-count?
|
||||
|
||||
image-width
|
||||
image-height)
|
||||
image-height
|
||||
|
||||
regular-polygon
|
||||
triangle
|
||||
star
|
||||
|
||||
swizzle)
|
||||
|
||||
|
||||
(define (show-image g [extra-space 0])
|
||||
|
|
@ -168,26 +175,26 @@
|
|||
'mode
|
||||
i
|
||||
arg)
|
||||
(let ([sym (if (string? arg)
|
||||
(string->symbol arg)
|
||||
arg)])
|
||||
sym
|
||||
#;
|
||||
(if (eq? sym 'outline)
|
||||
1
|
||||
sym))]
|
||||
(if (string? arg)
|
||||
(string->symbol arg)
|
||||
arg)]
|
||||
[(width height)
|
||||
(check-arg fn-name
|
||||
(and (number? arg)
|
||||
(and (real? arg)
|
||||
(not (negative? arg)))
|
||||
'non-negative-number
|
||||
'non-negative-real-number
|
||||
i arg)
|
||||
arg]
|
||||
[(dx dy factor x-factor y-factor)
|
||||
[(dx dy factor x-factor y-factor side-length)
|
||||
(check-arg fn-name
|
||||
(and (number? arg)
|
||||
(real? arg))
|
||||
'number
|
||||
(real? arg)
|
||||
'real\ number
|
||||
i arg)
|
||||
arg]
|
||||
[(side-count)
|
||||
(check-arg fn-name
|
||||
(side-count? arg)
|
||||
'side-count
|
||||
i arg)
|
||||
arg]
|
||||
[(angle)
|
||||
|
|
@ -220,9 +227,11 @@
|
|||
(define (mode? arg)
|
||||
(member arg '(solid outline "solid" "outline")))
|
||||
(define (angle? arg)
|
||||
(and (number? arg)
|
||||
(real? arg)
|
||||
(and (real? arg)
|
||||
(< -360 arg 360)))
|
||||
(define (side-count? i)
|
||||
(and (integer? i)
|
||||
(3 . <= . i)))
|
||||
|
||||
(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
|
||||
(make-image (make-bitmap bm mask-bm 0 1 #f)
|
||||
|
|
@ -464,15 +473,15 @@
|
|||
(+ r dx)
|
||||
(+ b dy))))]))
|
||||
|
||||
|
||||
(define (atomic-bb atomic-shape)
|
||||
(cond
|
||||
[(ellipse? atomic-shape)
|
||||
(let-values ([(w h) (ellipse-rotated-size (ellipse-width atomic-shape)
|
||||
(ellipse-height atomic-shape)
|
||||
(ellipse-angle atomic-shape))])
|
||||
(degrees->radians (ellipse-angle atomic-shape)))])
|
||||
(values 0 0 w h))]
|
||||
[else
|
||||
(fprintf (current-error-port) "BAD BOUNDING BOX\n")
|
||||
(values 0 0 100 100)]))
|
||||
|
||||
;; rotate-simple : angle simple-shape -> simple-shape
|
||||
|
|
@ -588,13 +597,7 @@
|
|||
(list (make-point 0 0)
|
||||
(make-point width 0)
|
||||
(make-point width height)
|
||||
(make-point 0 height))
|
||||
|
||||
#;
|
||||
(list (make-point 0 0)
|
||||
(make-point (- width 1) 0)
|
||||
(make-point (- width 1) (- height 1))
|
||||
(make-point 0 (- height 1))))
|
||||
(make-point 0 height)))
|
||||
|
||||
|
||||
;; circle
|
||||
|
|
@ -603,7 +606,48 @@
|
|||
;; line
|
||||
;; star
|
||||
;; text
|
||||
;; regular-polygon
|
||||
|
||||
(define/chk (triangle side-length mode color)
|
||||
(make-polygon/star side-length 3 mode color values))
|
||||
(define/chk (regular-polygon side-length side-count mode color)
|
||||
(make-polygon/star side-length side-count mode color values))
|
||||
(define/chk (star side-length mode color)
|
||||
(make-polygon/star side-length 5 mode color swizzle))
|
||||
|
||||
(define (make-polygon/star side-length side-count mode color adjust)
|
||||
(let ([poly (make-polygon
|
||||
(adjust (regular-polygon-points side-length side-count))
|
||||
mode
|
||||
color)])
|
||||
(let-values ([(l t r b) (simple-bb poly)])
|
||||
(printf "l ~s t ~s r ~s b ~s\n" l t r b)
|
||||
(make-image (make-translate (- l) (- t) poly)
|
||||
(make-bb (- r l) (- b t) (- b t))
|
||||
#f))))
|
||||
|
||||
;; swizzle : (listof X)[odd-length] -> (listof X)
|
||||
;; returns a list with the same elements,
|
||||
;; but reordered so the even elements come first
|
||||
;; and then the odd elements afterwards
|
||||
(define (swizzle l)
|
||||
(let ([v (list->vector l)])
|
||||
(let loop ([i 0])
|
||||
(cond
|
||||
[(= i (vector-length v)) '()]
|
||||
[else
|
||||
(cons (vector-ref v (modulo (* i 2) (vector-length v)))
|
||||
(loop (+ i 1)))]))))
|
||||
|
||||
;; regular-polygon-points : number number -> (listof point)
|
||||
(define (regular-polygon-points side-length side-count)
|
||||
(let loop ([p (make-rectangular 0 0)]
|
||||
[i 0])
|
||||
(cond
|
||||
[(= i side-count) '()]
|
||||
[else (cons (make-point (real-part p) (imag-part p))
|
||||
(loop (+ p (make-polar side-length
|
||||
(* -1 (* 2 pi) (/ i side-count))))
|
||||
(+ i 1)))])))
|
||||
|
||||
(define/chk (ellipse width height mode color)
|
||||
(make-image (make-ellipse width height
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ teachpack that has to be shared between drscheme
|
|||
and the user's program to make copy and paste
|
||||
work right.
|
||||
|
||||
Most of the exports are jsut for use in 2htdp/image
|
||||
Most of the exports are just for use in 2htdp/image
|
||||
(technically, 2htdp/private/image-more). The main
|
||||
use of this library is the snip class addition it
|
||||
does (and any code that that does not depend on
|
||||
|
|
@ -125,7 +125,7 @@ has been moved out).
|
|||
|
||||
;; a polygon is:
|
||||
;;
|
||||
;; - (make-polygon (listof points) angle pen brush)
|
||||
;; - (make-polygon (listof vector) mode color)
|
||||
(define-struct/reg-mk polygon (points mode color) #:transparent #:omit-define-syntaxes
|
||||
#:property prop:equal+hash
|
||||
(list (λ (a b rec) (polygon-equal? a b rec)) (λ (x y) 42) (λ (x y) 3)))
|
||||
|
|
@ -140,6 +140,8 @@ has been moved out).
|
|||
|
||||
;; an angle is a number between 0 and 360 (degrees)
|
||||
|
||||
;; a mode is either 'solid or 'outline (indicating a pen width for outline mode)
|
||||
|
||||
(define (polygon-equal? p1 p2 eq-recur)
|
||||
(and (eq-recur (polygon-mode p1) (polygon-mode p2))
|
||||
(eq-recur (polygon-color p1) (polygon-color p2))
|
||||
|
|
@ -312,12 +314,15 @@ has been moved out).
|
|||
(loop (overlay-top shape)
|
||||
dx dy x-scale y-scale bottom))]
|
||||
[(polygon? shape)
|
||||
(let ([this-one (make-polygon (map (λ (p)
|
||||
(make-point (+ dx (* x-scale (point-x p)))
|
||||
(+ dy (* y-scale (point-y p)))))
|
||||
(polygon-points shape))
|
||||
(polygon-mode shape)
|
||||
(polygon-color shape))])
|
||||
(let* ([scaled-points
|
||||
(map (λ (p)
|
||||
(make-point (+ dx (* x-scale (point-x p)))
|
||||
(+ dy (* y-scale (point-y p)))))
|
||||
(polygon-points shape))]
|
||||
[this-one
|
||||
(make-polygon scaled-points
|
||||
(polygon-mode shape)
|
||||
(polygon-color shape))])
|
||||
(if bottom
|
||||
(make-overlay bottom (f this-one))
|
||||
(f this-one)))]
|
||||
|
|
@ -330,16 +335,14 @@ has been moved out).
|
|||
(error 'normalize-shape "unknown shape ~s\n" shape)])))
|
||||
|
||||
(define (atomic-shape? shape)
|
||||
(or (ellipse? shape)
|
||||
(text? shape)
|
||||
(polygon? shape)
|
||||
(bitmap? shape)))
|
||||
(or (polygon? shape)
|
||||
(np-atomic-shape? shape)))
|
||||
|
||||
(define (np-atomic-shape? shape)
|
||||
(or (ellipse? shape)
|
||||
(text? shape)
|
||||
(bitmap? shape)))
|
||||
|
||||
(bitmap? shape)
|
||||
(point? shape)))
|
||||
|
||||
(define (scale-np-atomic x-scale y-scale shape)
|
||||
(cond
|
||||
|
|
@ -396,10 +399,16 @@ has been moved out).
|
|||
(let ([path (new dc-path%)]
|
||||
[points (polygon-points simple-shape)])
|
||||
(send path move-to (point-x (car points)) (point-y (car points)))
|
||||
(let loop ([points (cdr points)])
|
||||
(let loop ([point (make-rectangular (point-x (car points)) (point-y (car points)))]
|
||||
[points (cdr points)])
|
||||
(unless (null? points)
|
||||
(send path line-to (point-x (car points)) (point-y (car points)))
|
||||
(loop (cdr points))))
|
||||
(let* ([vec (make-rectangular (- (point-x (car points))
|
||||
(real-part point))
|
||||
(- (point-y (car points))
|
||||
(imag-part point)))]
|
||||
[endpoint (+ point vec (make-polar -1 (angle vec)))])
|
||||
(send path line-to (real-part endpoint) (imag-part endpoint))
|
||||
(loop endpoint (cdr points)))))
|
||||
(send path line-to (point-x (car points)) (point-y (car points)))
|
||||
(send dc set-pen (mode-color->pen (polygon-mode simple-shape) (polygon-color simple-shape)))
|
||||
(send dc set-brush (mode-color->brush (polygon-mode simple-shape) (polygon-color simple-shape)))
|
||||
|
|
@ -413,7 +422,7 @@ has been moved out).
|
|||
(let* ([path (new dc-path%)]
|
||||
[ew (ellipse-width atomic-shape)]
|
||||
[eh (ellipse-height atomic-shape)]
|
||||
[θ (ellipse-angle atomic-shape)])
|
||||
[θ (degrees->radians (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)))
|
||||
|
|
@ -435,26 +444,40 @@ has been moved out).
|
|||
(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))))
|
||||
(cond
|
||||
[(and (zero? ew) (zero? eh))
|
||||
(values 0 0)]
|
||||
[(zero? eh)
|
||||
(values (* (cos θ) ew)
|
||||
(* (sin θ) ew))]
|
||||
[(zero? ew)
|
||||
(values (* (sin θ) eh)
|
||||
(* (cos θ) eh))]
|
||||
[else
|
||||
(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)
|
||||
(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)]))
|
||||
(cond
|
||||
[(eq? mode 'solid)
|
||||
(send the-pen-list find-or-create-pen "black" 1 'transparent)]
|
||||
[else
|
||||
(send the-pen-list find-or-create-pen color 1 'solid)]))
|
||||
|
||||
(define (mode-color->brush mode color)
|
||||
(case mode
|
||||
[(outline) (send the-brush-list find-or-create-brush "black" 'transparent)]
|
||||
[(solid) (send the-brush-list find-or-create-brush color 'solid)]))
|
||||
(cond
|
||||
[(eq? mode 'solid)
|
||||
(send the-brush-list find-or-create-brush color 'solid)]
|
||||
[else
|
||||
(send the-brush-list find-or-create-brush "black" 'transparent)]))
|
||||
|
||||
(provide make-image image-shape image-bb image-normalized? image%
|
||||
|
||||
|
|
@ -467,7 +490,7 @@ has been moved out).
|
|||
make-text text? text-string text-angle text-font
|
||||
make-polygon polygon? polygon-points polygon-mode polygon-color
|
||||
make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-scale bitmap-rendered-bitmap
|
||||
|
||||
|
||||
degrees->radians
|
||||
normalize-shape
|
||||
ellipse-rotated-size
|
||||
|
|
@ -477,4 +500,7 @@ has been moved out).
|
|||
image-bottom
|
||||
image-baseline
|
||||
|
||||
render-image)
|
||||
render-image)
|
||||
|
||||
;; method names
|
||||
(provide get-shape get-bb get-normalized?)
|
||||
|
|
|
|||
|
|
@ -30,6 +30,33 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
|
|||
Constructs a rectangle with the given width, height, mode, and color.
|
||||
}
|
||||
|
||||
@defproc[(regular-polygon [side-length (and/c positive? real?)]
|
||||
[side-count side-count?]
|
||||
[mode mode?]
|
||||
[color (or/c symbol? string?)])
|
||||
image?]{
|
||||
Constructs a regular polygon with @scheme[side-count] sides.
|
||||
}
|
||||
|
||||
@defproc[(star [side-length (and/c positive? real?)]
|
||||
[mode mode?]
|
||||
[color (or/c symbol? string?)])
|
||||
image?]{
|
||||
Constructs a star with five points. The @scheme[side-length] argument
|
||||
determines the side length of the enclosing pentagon.
|
||||
}
|
||||
|
||||
@defproc[(triangle [side-length (and/c positive? real?)]
|
||||
[mode mode?]
|
||||
[color (or/c symbol? string?)])
|
||||
image?]{
|
||||
Constructs a upward-pointing equilateral triangle.
|
||||
The @scheme[side-length] argument
|
||||
determines the
|
||||
length of the side of the triangle.
|
||||
}
|
||||
|
||||
|
||||
@section{Overlaying Images}
|
||||
|
||||
@defproc[(overlay [i1 image?] [i2 image?] [is image?] ...) image?]{
|
||||
|
|
@ -96,6 +123,16 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
|
|||
certain sub-images appear within some larger image.
|
||||
}
|
||||
|
||||
@section{Image Properties}
|
||||
|
||||
@defproc[(image-width [i image?]) (and/c number? positive?)]{
|
||||
Returns the width of @scheme[i].
|
||||
}
|
||||
|
||||
@defproc[(image-height [i image?]) (and/c number? positive?)]{
|
||||
Returns the height of @scheme[i].
|
||||
}
|
||||
|
||||
@section{Image Predicates}
|
||||
|
||||
This section lists predicates for the basic structures provided by the image library.
|
||||
|
|
@ -152,6 +189,11 @@ This section lists predicates for the basic structures provided by the image lib
|
|||
and @scheme[360] (exclusive).
|
||||
}
|
||||
|
||||
@defproc[(side-count? [x any/c]) boolean?]{
|
||||
Determines if @scheme[x] is an integer
|
||||
greater than or equal to @scheme[3].
|
||||
}
|
||||
|
||||
@section{Equality Testing of Images}
|
||||
|
||||
Image equality testing is done structurally, i.e., based on
|
||||
|
|
|
|||
|
|
@ -4,14 +4,19 @@
|
|||
scheme/math
|
||||
scheme/class
|
||||
scheme/gui/base
|
||||
tests/eli-tester)
|
||||
schemeunit)
|
||||
|
||||
;(define-syntax-rule (test a => b) (begin a b))
|
||||
(define-syntax-rule (test a => b) (check-equal? a b))
|
||||
|
||||
;; test case: (beside (text "a"...) (text "b" ...)) vs (text "ab")
|
||||
|
||||
;(show-image (frame (rotate 30 (ellipse 200 400 'solid 'purple))))
|
||||
|
||||
(define-simple-check (check-close a b)
|
||||
(and (number? a)
|
||||
(number? b)
|
||||
(< (abs (- a b)) 0.001)))
|
||||
|
||||
#;
|
||||
(show-image
|
||||
(overlay/xy (rectangle 100 10 'solid 'red)
|
||||
|
|
@ -63,6 +68,84 @@
|
|||
(map loop (cdr (vector->list (struct->vector x))))))]
|
||||
[else x])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; width and height
|
||||
;;
|
||||
|
||||
(test (image-width (rectangle 10 20 'solid 'blue))
|
||||
=>
|
||||
10)
|
||||
(test (image-height (rectangle 10 20 'solid 'blue))
|
||||
=>
|
||||
20)
|
||||
(test (image-width (rectangle 0 100 'solid 'blue))
|
||||
=>
|
||||
0)
|
||||
(test (image-height (rectangle 0 100 'solid 'blue))
|
||||
=>
|
||||
100)
|
||||
(test (image-width (rectangle 100 0 'solid 'blue))
|
||||
=>
|
||||
100)
|
||||
(test (image-height (rectangle 100 0 'solid 'blue))
|
||||
=>
|
||||
0)
|
||||
|
||||
(check-close (image-width (rotate 45 (rectangle 100 0 'solid 'blue)))
|
||||
(* (sin (* pi 1/4)) 100))
|
||||
(check-close (image-height (rotate 45 (rectangle 100 0 'solid 'blue)))
|
||||
(* (sin (* pi 1/4)) 100))
|
||||
(check-close (image-width (rotate 45 (rectangle 0 100 'solid 'blue)))
|
||||
(* (sin (* pi 1/4)) 100))
|
||||
(check-close (image-height (rotate 45 (rectangle 0 100 'solid 'blue)))
|
||||
(* (sin (* pi 1/4)) 100))
|
||||
|
||||
(test (image-width (scale 4 (rectangle 10 10 'outline 'black)))
|
||||
=>
|
||||
40)
|
||||
(test (image-width (rotate 90 (scale 4 (rectangle 10 10 'outline 'black))))
|
||||
=>
|
||||
40.0)
|
||||
|
||||
(test (image-width (scale 4 (rectangle 10 10 'solid 'black)))
|
||||
=>
|
||||
40)
|
||||
(test (image-width (rotate 90 (scale 4 (rectangle 10 10 'solid 'black))))
|
||||
=>
|
||||
40.0)
|
||||
|
||||
|
||||
(test (image-width (ellipse 10 20 'solid 'blue))
|
||||
=>
|
||||
10)
|
||||
(test (image-height (ellipse 10 20 'solid 'blue))
|
||||
=>
|
||||
20)
|
||||
(test (image-width (ellipse 0 100 'solid 'blue))
|
||||
=>
|
||||
0)
|
||||
(test (image-height (ellipse 0 100 'solid 'blue))
|
||||
=>
|
||||
100)
|
||||
(test (image-width (ellipse 100 0 'solid 'blue))
|
||||
=>
|
||||
100)
|
||||
(test (image-height (ellipse 100 0 'solid 'blue))
|
||||
=>
|
||||
0)
|
||||
|
||||
(test (image-width (rotate 30 (ellipse 100 0 'solid 'blue)))
|
||||
=>
|
||||
(* (cos (* pi 1/6)) 100))
|
||||
(test (image-height (rotate 30 (ellipse 100 0 'solid 'blue)))
|
||||
=>
|
||||
(* (sin (* pi 1/6)) 100))
|
||||
(check-close (image-width (rotate 30 (ellipse 0 100 'solid 'blue)))
|
||||
(* (sin (* pi 1/6)) 100))
|
||||
(check-close (image-height (rotate 30 (ellipse 0 100 'solid 'blue)))
|
||||
(* (cos (* pi 1/6)) 100))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; testing overlays
|
||||
|
|
@ -445,4 +528,16 @@
|
|||
(test (rotate 90 (make-object image-snip% blue-10x20-bitmap))
|
||||
=>
|
||||
(image-snip->image (make-object image-snip% blue-20x10-bitmap)))
|
||||
|#
|
||||
|#
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; regular polygon
|
||||
;;
|
||||
|
||||
(check-equal? (round-numbers (regular-polygon 100 4 'outline 'green))
|
||||
(round-numbers (rectangle 100 100 'outline 'green)))
|
||||
|
||||
(check-equal? (swizzle (list 0 1 2 3 4))
|
||||
(list 0 2 4 1 3))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user