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

more progress on picture.ss; hopefully this is a final version of the internal data definitions

Browse Source 
svn: r16132
This commit is contained in:
Robby Findler 2009-09-26 15:39:00 +00:00
parent 9b8c2d15cc
commit c91a9847aa
2 changed files with 461 additions and 204 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

567
collects/2htdp/private/picture.ss
View File

@ -1,4 +1,40 @@
#lang scheme/base #lang scheme/base
#|
improvments/changes wrt to htdp/image:
- copying and pasting does not introduce jaggies
- equal comparisions are more efficient
- added rotation & scaling
- got rid of pinholes (see the new overlay, beside, and above functions)
todo: sort out wxme library support (loading in text mode).
;; when rendering these things in error messages,
;; they should come out as #<picture: {THE ACTUAL PICTURE}>
;; (automatically scale them down so they fit)
;; redex randomized testing: see if normalization produces normalized shapes.
;; see if normalization always puts things in the right order
;; need to change error messages to say "the width (second) argument"
;; by passing "width (second)" to the check-arg function
From Matthias: (to use to compare with this library)
You asked about exercises and code snippets for HtDP/2e yesterday. I actually do have a bunch of stuff in
svn: 2HtDP/SampleCode/
and they all have good sample contracts. (It is amazing what we can do with kids who have just a few weeks of cs down; I would have never dared to write an editor after six weeks in Algol.)
|#
(require scheme/class (require scheme/class
scheme/gui/base scheme/gui/base
htdp/error htdp/error
@ -35,33 +71,35 @@
make-ellipse make-ellipse
make-text make-text
make-polygon make-polygon
make-point) make-point
bring-between)
(define-struct point (x y) #:transparent)
;; when rendering these things in error messages,
;; they should come out as #<picture: {THE ACTUAL PICTURE}>
;; (automatically scale them down so they fit)
;; redex randomized testing: see if normalization produces normalized shapes.
;; see if normalization always puts things in the right order
;; need to change error messages to say "the width (second) argument"
;; by passing "width (second)" to the check-arg function
#|
From Matthias: (to use to compare with this library)
You asked about exercises and code snippets for HtDP/2e yesterday. I actually do have a bunch of stuff in (define-for-syntax id-constructor-pairs '())
(define-for-syntax (add-id-constructor-pair a b)
(set! id-constructor-pairs (cons (list a b) id-constructor-pairs)))
svn: 2HtDP/SampleCode/ (define-syntax (define-struct/reg-mk stx)
(syntax-case stx ()
[(_ id . rest)
(let ([build-name
(λ (fmt)
(datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))])
(add-id-constructor-pair (build-name "struct:~a")
(build-name "make-~a"))
#'(define-struct id . rest))]))
and they all have good sample contracts. (It is amazing what we can do with kids who have just a few weeks of cs down; I would have never dared to write an editor after six weeks in Algol.) (define-syntax (define-id->constructor stx)
(syntax-case stx ()
[(_ fn)
#`(define (fn x)
(case x
#,@(map (λ (x)
(with-syntax ([(struct: maker) x])
#`[(struct:) maker]))
id-constructor-pairs)))]))
(define-struct/reg-mk point (x y) #:transparent)
|#
; ;
@ -88,11 +126,21 @@ and they all have good sample contracts. (It is amazing what we can do with kids
;; (make-picture shape bb boolean) ;; (make-picture shape bb boolean)
;; NOTE: the shape field is mutated when normalized, as ;; NOTE: the shape field is mutated when normalized, as
;; is the normalized? field. ;; is the normalized? field.
(define-struct picture (shape bb normalized?) #:mutable #:transparent) (define (make-picture shape bb normalized?) (new picture% [shape shape] [bb bb] [normalized? normalized?]))
(define (picture-shape p) (send p get-shape))
(define (picture-bb p) (send p get-bb))
(define (picture-normalized? p) (send p get-normalized?))
(define (set-picture-shape! p s) (send p set-shape s))
(define (set-picture-normalized?! p n?) (send p set-normalized? n?))
(define (picture-right picture) (bb-right (picture-bb picture)))
(define (picture-bottom picture) (bb-bottom (picture-bb picture)))
(define (picture-baseline picture) (bb-baseline (picture-bb picture)))
(define (picture? p) (is-a? p picture%))
;; a bb is (bounding box) ;; a bb is (bounding box)
;; (make-bb number number number) ;; (make-bb number number number)
(define-struct bb (right bottom baseline) #:transparent) (define-struct/reg-mk bb (right bottom baseline) #:transparent)
;; a shape is either: ;; a shape is either:
;; ;;
@ -100,42 +148,177 @@ and they all have good sample contracts. (It is amazing what we can do with kids
;; the shapes are in the order passed to the overlay or beside, ;; the shapes are in the order passed to the overlay or beside,
;; which means the bottom one should be drawn first so as to appear ;; which means the bottom one should be drawn first so as to appear
;; underneath the top one. ;; underneath the top one.
(define-struct overlay (top bottom) #:transparent #:omit-define-syntaxes) (define-struct/reg-mk overlay (top bottom) #:transparent #:omit-define-syntaxes)
;; ;;
;; - (make-translate dx dy shape) ;; - (make-translate dx dy shape)
(define-struct translate (dx dy shape) #:transparent #:omit-define-syntaxes) (define-struct/reg-mk translate (dx dy shape) #:transparent #:omit-define-syntaxes)
;; ;;
;; - atomic-shape ;; - atomic-shape
;; an atomic-shape is either: ;; an atomic-shape is either:
;; - polygon
;; - np-atomic-shape
;; a np-atomic-shape is:
;; ;;
;; - (make-ellipse width height angle pen brush) ;; - (make-ellipse width height angle mode color)
(define-struct ellipse (width height angle pen brush) #:transparent #:omit-define-syntaxes) (define-struct/reg-mk ellipse (width height angle mode color) #:transparent #:omit-define-syntaxes)
;; ;;
;; - (make-text string angle font) ;; - (make-text string angle font)
(define-struct text (string angle font) #:omit-define-syntaxes #:transparent) (define-struct/reg-mk text (string angle font) #:omit-define-syntaxes #:transparent)
;;
;; - (make-polygon (listof points) angle pen brush)
(define-struct polygon (points angle pen brush) #:transparent)
;; ;;
;; - (make-bitmap (is-a?/c bitmap%) angle) ;; - (make-bitmap (is-a?/c bitmap%) angle)
(define-struct bitmap (bitmap angle)) (define-struct/reg-mk bitmap (bitmap angle))
;; a polygon is:
;;
;; - (make-polygon (listof points) angle pen brush)
(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)))
;; a normalized-shape (subtype of shape) is either ;; a normalized-shape (subtype of shape) is either
;; - (make-overlay normalized-shape simple-shape) ;; - (make-overlay normalized-shape simple-shape)
;; - simple-shape ;; - simple-shape
;; a simple-shape (subtype of shape) is ;; a simple-shape (subtype of shape) is
;; - (make-translate dx dy atomic-shape) ;; - (make-translate dx dy np-atomic-shape)
;; - polygon
;; picture-normalized-shape : picture -> normalized-shape ;; an angle is a number between 0 and 360 (degrees)
(define (picture-normalized-shape picture)
(unless (picture-normalized? picture)
(set-picture-shape! picture (normalize-shape (picture-shape picture) values))
(set-picture-normalized?! picture #t))
(picture-shape picture))
;; normalize-shape : shape (atomic-shape -> void) -> normalized-shape (define (polygon-equal? p1 p2 eq-recur)
(and (eq-recur (polygon-mode p1) (polygon-mode p2))
(eq-recur (polygon-color p1) (polygon-color p2))
(let ([p1-points (polygon-points p1)]
[p2-points (polygon-points p2)])
(or (and (null? p1-points)
(null? p2-points))
(and (not (or (null? p1-points)
(null? p2-points)))
(eq-recur (rotate-to-zero (closest-to-zero p1-points) p1-points)
(rotate-to-zero (closest-to-zero p2-points) p2-points)))))))
(define (rotate-to-zero zero-p points)
(let loop ([points points]
[acc null])
(cond
[(equal? (car points) zero-p)
(append points (reverse acc))]
[else
(loop (cdr points)
(cons (car points) acc))])))
(define (closest-to-zero points)
(car (sort points < #:key (λ (p) (+ (point-x p) (point-y p))))))
;
;
;
; ;; ;; ;;
; ;; ;;;; ;
; ; ; ;; ;
; ;; ;;;;;;;;; ;;;;; ;;;;;; ;;;; ; ;; ;
; ;; ;; ;;; ;;;; ;; ;; ;; ;;; ;; ;; ;
; ;; ;; ;;; ;;; ;;;; ;;; ;; ;;;;;; ; ;;;
; ;; ;; ;;; ;;;;; ;; ;;; ;; ;;; ;;
; ;; ;; ;;; ;;;;; ;; ;;;;; ;;; ; ; ;; ;;
; ;; ;; ;;; ;;;;;;;;;; ;;;;;; ;;;; ;; ;;;
; ;; ;;
; ;; ;
; ;;;;
(define-local-member-name get-shape set-shape get-bb get-normalized? set-normalized get-normalized-shape)
(define picture%
(class* snip% (equal<%>)
(init-field shape bb normalized?)
(define/public (equal-to? that eq-recur)
(eq-recur (get-normalized-shape)
(send that get-normalized-shape)))
(define/public (equal-hash-code-of y) 42)
(define/public (equal-secondary-hash-code-of y) 3)
(define/public (get-shape) shape)
(define/public (set-shape s) (set! shape s))
(define/public (get-bb) bb)
(define/public (get-normalized?) normalized?)
(define/public (set-normalized? n?) (set! normalized? n?))
(define/public (get-normalized-shape)
(unless normalized?
(set! shape (normalize-shape shape values))
(set! normalized? #t))
shape)
(define/override (copy) (make-picture shape bb normalized?))
(define/override (draw dc x y left top right bottom dx dy draw-caret?)
(render-picture this dc x y))
(define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f])
(send (get-the-snip-class-list) add snip-class)
(let ([bottom (bb-bottom bb)])
(set-box/f! w (bb-right bb))
(set-box/f! h bottom)
(set-box/f! descent (- bottom (bb-baseline bb)))
(set-box/f! space 0)
(set-box/f! lspace 0)
(set-box/f! rspace 0)))
(define/override (write f)
(send f put (string->bytes/utf-8 (format "~s" (list shape bb)))))
(super-new)
(inherit set-snipclass)
(set-snipclass snip-class)))
(define scheme/base:read read)
(define picture-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)))])
(if lst
(make-picture (list-ref lst 0)
(list-ref lst 1)
#f)
(rectangle 20 20 'solid 'black))))
(super-new)))
(provide snip-class)
(define snip-class (new picture-snipclass%))
(send snip-class set-classname (format "~s" '(lib "picture.ss" "2htdp/private")))
(send snip-class set-version 1)
(send (get-the-snip-class-list) add snip-class)
(define (set-box/f! b v) (when (box? b) (set-box! b v)))
(define (parse sexp)
(let/ec k
(let loop ([sexp sexp])
(cond
[(pair? sexp) (cons (loop (car sexp)) (loop (cdr sexp)))]
[(vector? sexp)
(if (= (vector-length sexp) 0)
(k #f)
(let ([constructor (id->constructor (vector-ref sexp 0))]
[args (cdr (vector->list sexp))])
(if (and constructor
(procedure-arity-includes? constructor (length args)))
(apply constructor (map loop args))
(k #f))))]
[else sexp]))))
(define-id->constructor id->constructor)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape
;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape. ;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape.
(define (normalize-shape shape [f values]) (define (normalize-shape shape [f values])
(let loop ([shape shape] (let loop ([shape shape]
@ -153,11 +336,23 @@ and they all have good sample contracts. (It is amazing what we can do with kids
dx dy dx dy
(loop (overlay-top shape) (loop (overlay-top shape)
dx dy bottom))] dx dy bottom))]
[(atomic-shape? shape) [(polygon? shape)
(let ([this-one (make-polygon (map (λ (p)
(make-point (+ dx (point-x p))
(+ dy (point-y p))))
(polygon-points shape))
(polygon-mode shape)
(polygon-color shape))])
(if bottom
(make-overlay bottom (f this-one))
(f this-one)))]
[(np-atomic-shape? shape)
(let ([this-one (make-translate dx dy shape)]) (let ([this-one (make-translate dx dy shape)])
(if bottom (if bottom
(make-overlay bottom (f this-one)) (make-overlay bottom (f this-one))
(f this-one)))]))) (f this-one)))]
[else
(error 'normalize-shape "unknown shape ~s\n" shape)])))
(define (atomic-shape? shape) (define (atomic-shape? shape)
(or (ellipse? shape) (or (ellipse? shape)
@ -165,10 +360,14 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(polygon? shape) (polygon? shape)
(bitmap? shape))) (bitmap? shape)))
(define (np-atomic-shape? shape)
(or (ellipse? shape)
(text? shape)
(bitmap? shape)))
;; rotate-point : x,y theta -> x,y ;; rotate-point : x,y angle -> x,y
(define (rotate-point x y θ) (define (rotate-point x y θ)
(c->xy (* (make-polar 1 θ) (c->xy (* (make-polar 1 (degrees->radians θ))
(xy->c x y)))) (xy->c x y))))
(define (xy->c x y) (make-rectangular x (- y))) (define (xy->c x y) (make-rectangular x (- y)))
@ -176,10 +375,6 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(values (real-part c) (values (real-part c)
(- (imag-part c)))) (- (imag-part c))))
(define (picture-right picture) (bb-right (picture-bb picture)))
(define (picture-bottom picture) (bb-bottom (picture-bb picture)))
(define (picture-baseline picture) (bb-baseline (picture-bb picture)))
; ;
; ;
@ -282,20 +477,32 @@ and they all have good sample contracts. (It is amazing what we can do with kids
'non-negative-number 'non-negative-number
i arg) i arg)
arg] arg]
[(dx dy angle) [(dx dy)
(check-arg fn-name (check-arg fn-name
(number? arg) (number? arg)
'number 'number
i arg) i arg)
arg] arg]
[(angle)
(check-arg fn-name
(and (number? arg)
(<= 0 arg)
(< arg 360))
'angle\ in\ degrees
i arg)
arg]
[(color) [(color)
(check-color fn-name i arg) (check-color fn-name i arg)
(cond (let ([color-str
[(symbol? arg) (cond
(send the-color-database find-color (symbol->string arg))] [(symbol? arg)
[(string? arg) (symbol->string arg)]
(send the-color-database find-color arg)] [(string? arg)
[else arg])] (symbol->string arg)]
[else arg])])
(if (send the-color-database find-color color-str)
color-str
"black"))]
[else [else
(error 'check "the function ~a has an argument with an unknown name: ~s" (error 'check "the function ~a has an argument with an unknown name: ~s"
fn-name fn-name
@ -358,7 +565,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
;; render-picture : normalized-shape dc dx dy -> void ;; render-picture : normalized-shape dc dx dy -> void
(define (render-picture picture dc dx dy) (define (render-picture picture dc dx dy)
(let loop ([shape (picture-normalized-shape picture)]) (let loop ([shape (send picture get-normalized-shape)])
(cond (cond
[(overlay? shape) [(overlay? shape)
(render-simple-shape (overlay-bottom shape) dc dx dy) (render-simple-shape (overlay-bottom shape) dc dx dy)
@ -366,56 +573,59 @@ and they all have good sample contracts. (It is amazing what we can do with kids
[else [else
(render-simple-shape shape dc dx dy)]))) (render-simple-shape shape dc dx dy)])))
(define (render-simple-shape shape dc dx dy) (define (render-simple-shape simple-shape dc dx dy)
(let ([dx (+ dx (translate-dx shape))] (cond
[dy (+ dy (translate-dy shape))] [(polygon? simple-shape)
[atomic-shape (translate-shape shape)]) (let ([path (new dc-path%)]
(cond [points (polygon-points simple-shape)])
[(ellipse? atomic-shape) (send path move-to (point-x (car points)) (point-y (car points)))
(let ([path (new dc-path%)] (let loop ([points (cdr points)])
[θ (ellipse-angle atomic-shape)]) (unless (null? points)
(send path ellipse 0 0 (ellipse-width atomic-shape) (ellipse-height atomic-shape)) (send path line-to (point-x (car points)) (point-y (car points)))
(send path rotate θ) (loop (cdr points))))
(send dc set-pen (ellipse-pen atomic-shape)) (send path line-to (point-x (car points)) (point-y (car points)))
(send dc set-brush (ellipse-brush atomic-shape)) (send dc set-pen (mode-color->pen (polygon-mode simple-shape) (polygon-color simple-shape)))
(send dc draw-path path dx dy))] (send dc set-brush (mode-color->brush (polygon-mode simple-shape) (polygon-color simple-shape)))
[(polygon? atomic-shape) (send dc draw-path path dx dy))]
(let ([path (new dc-path%)] [else
[points (polygon-points atomic-shape)] (let ([dx (+ dx (translate-dx simple-shape))]
[θ (polygon-angle atomic-shape)]) [dy (+ dy (translate-dy simple-shape))]
(send path move-to (point-x (car points)) (point-y (car points))) [atomic-shape (translate-shape simple-shape)])
(let loop ([points (cdr points)]) (cond
(unless (null? points) [(ellipse? atomic-shape)
(send path line-to (point-x (car points)) (point-y (car points))) (let ([path (new dc-path%)]
(loop (cdr points)))) [θ (degrees->radians (ellipse-angle atomic-shape))])
(send path line-to (point-x (car points)) (point-y (car points))) (send path ellipse 0 0 (ellipse-width atomic-shape) (ellipse-height atomic-shape))
(send path rotate θ) (send path rotate θ)
(send dc set-pen (polygon-pen atomic-shape)) (send dc set-pen (mode-color->pen (ellipse-mode atomic-shape) (ellipse-color atomic-shape)))
(send dc set-brush (polygon-brush 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))]
[(text? atomic-shape)
(let ([θ (text-angle atomic-shape)]) [(text? atomic-shape)
(send dc set-font (text-font atomic-shape)) (let ([θ (degrees->radians (text-angle atomic-shape))])
(send dc draw-text (text-string atomic-shape) dx dy #f 0 angle))]))) (send dc set-font (text-font atomic-shape))
(send dc draw-text (text-string atomic-shape) dx dy #f 0 angle))]))]))
(define (degrees->radians θ)
(* θ 2 pi (/ 360)))
; ;
; ;
; ;
; ; ;;
; ; ;;
; ;; ;; ;; ; ;;
; ;; ;; ;;; ; ;;;; ;;; ;;;;;; ;; ; ;; ;;;;; ;;; ;
; ;;;; ;;;; ;;;;;; ;;; ;;;;; ;; ;; ;;; ;;;; ;;;;; ;;;; ;;;; ;;;;; ; ;; ;; ;; ;;;; ;; ;;;; ;; ; ;; ;; ;;
; ;;;;;; ;;;;;; ;;;;;;;;;; ;;;;;; ;; ;;;;;; ;; ;; ;;;; ;;;;;; ;;;; ;; ;; ; ;;; ;; ;;;; ;;;;;; ;; ;; ;;;; ;;;;
; ;;; ;;; ;;; ;; ;; ;; ;; ;;; ;; ;; ;; ;;;; ;;; ;;; ;;; ;; ;;;;; ; ;;; ;; ;;;; ;; ;; ;; ;; ;; ;;;
; ;;; ;;; ;;; ;; ;; ;; ;; ;;; ;; ;; ;; ;;; ;; ;;; ;;; ;;; ;; ;;;; ; ;; ;; ;;; ;;; ; ;; ;; ;; ;; ;;;
; ;;;;;; ;;;;;; ;; ;; ;; ;;;;;; ;; ;; ;; ;;; ;; ;;;; ;;;;;; ;; ;; ;;; ; ;;;; ;; ;;;; ;; ;; ;;;;;;; ;;
; ;;;; ;;;; ;; ;; ;; ;; ;; ;; ;; ;; ;;;;;; ;;; ;;;; ;; ;;;;; ; ;;
; ; ;
; ; ;;
;
; ; ; ;
;; bitmap : string -> picture ;; bitmap : string -> picture
;; gets one of the bitmaps that comes with drscheme, scales it down by 1/8 or something ;; gets one of the bitmaps that comes with drscheme, scales it down by 1/8 or something
@ -529,6 +739,19 @@ and they all have good sample contracts. (It is amazing what we can do with kids
;; like beside, but vertically ;; like beside, but vertically
;
; ;; ;; ;;
; ;; ;; ;;;
; ;;;; ;;;; ;;;;;; ;;; ;;;;; ;; ;; ;;; ;;;; ;;;;; ;;;; ;;;; ;;;;;
; ;;;;;; ;;;;;; ;;;;;;;;;; ;;;;;; ;; ;;;;;; ;; ;; ;;;; ;;;;;; ;;;; ;; ;;
; ;;; ;;; ;;; ;; ;; ;; ;; ;;; ;; ;; ;; ;;;; ;;; ;;; ;;; ;; ;;;;;
; ;;; ;;; ;;; ;; ;; ;; ;; ;;; ;; ;; ;; ;;; ;; ;;; ;;; ;;; ;; ;;;;
; ;;;;;; ;;;;;; ;; ;; ;; ;;;;;; ;; ;; ;; ;;; ;; ;;;; ;;;;;; ;; ;; ;;;
; ;;;; ;;;; ;; ;; ;; ;; ;; ;; ;; ;; ;;;;;; ;;; ;;;; ;; ;;;;;
;
;
;
;; frame : picture -> picture ;; frame : picture -> picture
;; draws a black frame around a picture where the bounding box is ;; draws a black frame around a picture where the bounding box is
;; (useful for debugging pictures) ;; (useful for debugging pictures)
@ -574,63 +797,94 @@ and they all have good sample contracts. (It is amazing what we can do with kids
;; returns the bounding box of 'shape' ;; returns the bounding box of 'shape'
;; (only called for rotated shapes, so bottom=baseline) ;; (only called for rotated shapes, so bottom=baseline)
(define (simple-bb simple-shape) (define (simple-bb simple-shape)
(let ([dx (translate-dx simple-shape)] (cond
[dy (translate-dy simple-shape)] [(polygon? simple-shape)
[atomic-shape (translate-shape simple-shape)]) (let ([points (polygon-points simple-shape)])
(cond (let* ([fx (point-x (car points))]
[(polygon? atomic-shape) [fy (point-y (car points))]
(let ([θ (polygon-angle atomic-shape)] [left fx]
[points (polygon-points atomic-shape)]) [top fy]
(let-values ([(x y) (rotate-point (point-x (car points)) (point-y (car points)) θ)]) [right fx]
(let ([left x] [bottom fy])
[top y] (for-each (λ (point)
[right x] (let ([new-x (point-x point)]
[bottom y]) [new-y (point-y point)])
(for-each (λ (point) (set! left (min new-x left))
(let-values ([(new-x new-y) (set! top (min new-y top))
(rotate-point (point-x point) (point-y point) θ)]) (set! right (max new-x right))
(set! left (min new-x left)) (set! bottom (max new-y bottom))))
(set! top (min new-y top)) (cdr points))
(set! right (max new-x right)) (values left top right bottom)))]
(set! bottom (max new-y bottom)))) [else
(cdr points)) (let ([dx (translate-dx simple-shape)]
(values (+ dx left) (+ dy top) (+ dx right) (+ dy bottom)))))] [dy (translate-dy simple-shape)]
[else [atomic-shape (translate-shape simple-shape)])
(fprintf (current-error-port) "BAD\n") (fprintf (current-error-port) "BAD bounding box\n")
(values 0 0 100 100)]))) (values 0 0 100 100))]))
;; rotate-simple : angle simple-shape -> simple-shape ;; rotate-simple : angle simple-shape -> simple-shape
(define (rotate-simple θ simple-shape) (define (rotate-simple θ simple-shape)
(let-values ([(dx dy) (c->xy (* (make-polar 1 θ) (cond
(xy->c (translate-dx simple-shape) [(polygon? simple-shape)
(translate-dy simple-shape))))]) (make-polygon (map (λ (p)
(make-translate (let-values ([(xn yn) (rotate-point (point-x p) (point-y p) θ)])
dx (make-point xn yn)))
dy (polygon-points simple-shape))
(rotate-atomic θ (translate-shape simple-shape))))) (polygon-mode simple-shape)
(polygon-color simple-shape))]
[else
(let-values ([(dx dy) (c->xy (* (make-polar 1 (degrees->radians θ))
(xy->c (translate-dx simple-shape)
(translate-dy simple-shape))))])
(make-translate
dx
dy
(rotate-atomic θ (translate-shape simple-shape))))]))
;; rotate-atomic : angle atomic-shape -> atomic-shape ;; rotate-atomic : angle np-atomic-shape -> np-atomic-shape
(define (rotate-atomic θ atomic-shape) (define (rotate-atomic θ atomic-shape)
(cond (cond
[(ellipse? atomic-shape) [(ellipse? atomic-shape)
(make-ellipse (ellipse-width atomic-shape) (cond
(ellipse-height atomic-shape) [(= (ellipse-width atomic-shape)
(+ θ (ellipse-angle atomic-shape)) (ellipse-height atomic-shape))
(ellipse-pen atomic-shape) atomic-shape]
(ellipse-brush atomic-shape))] [else
(let ([new-angle (bring-between (+ θ (ellipse-angle atomic-shape)) 180)])
(cond
[(< new-angle 90)
(make-ellipse (ellipse-width atomic-shape)
(ellipse-height atomic-shape)
new-angle
(ellipse-mode atomic-shape)
(ellipse-color atomic-shape))]
[else
(make-ellipse (ellipse-height atomic-shape)
(ellipse-width atomic-shape)
(- new-angle 90)
(ellipse-mode atomic-shape)
(ellipse-color atomic-shape))]))])]
[(text? atomic-shape) [(text? atomic-shape)
(make-text (text-string atomic-shape) (make-text (text-string atomic-shape)
(+ θ (text-angle atomic-shape)) (bring-between (+ θ (text-angle atomic-shape)) 360)
(text-font atomic-shape))] (text-font atomic-shape))]
[(polygon? atomic-shape)
(make-polygon (polygon-points atomic-shape)
(+ θ (polygon-angle atomic-shape))
(polygon-pen atomic-shape)
(polygon-brush atomic-shape))]
[(bitmap? atomic-shape) [(bitmap? atomic-shape)
(make-bitmap (bitmap-bitmap atomic-shape) (make-bitmap (bitmap-bitmap atomic-shape)
(+ θ (bitmap-angle atomic-shape)))])) (bring-between (+ θ (bitmap-angle atomic-shape)) 360))]))
;; bring-between : number number -> number
;; returns a number that is much like the modulo of 'x' and 'upper-bound'
;; but does this by repeated subtraction, since modulo only works on integers
(define (bring-between x upper-bound)
(let loop ([x x])
(cond
[(< x 0)
(loop (+ x upper-bound))]
[(< x upper-bound)
x]
[else
(loop (- x upper-bound))])))
;; stamp : I I -> I ;; stamp : I I -> I
;; treats the first I as if it were a mask and uses that mask to ;; treats the first I as if it were a mask and uses that mask to
@ -649,18 +903,21 @@ and they all have good sample contracts. (It is amazing what we can do with kids
;; rectangle ;; rectangle
(define/chk (rectangle width height mode color) (define/chk (rectangle width height mode color)
(make-picture (make-polygon (list (make-point 0 0) (make-picture (make-polygon (rectangle-points width height)
(make-point width 0) mode
(make-point width height) color)
(make-point 0 height))
0
(mode-color->pen mode color)
(mode-color->brush mode color))
(make-bb width (make-bb width
height height
height) height)
#f)) #f))
(define (rectangle-points width height)
(list (make-point 0 0)
(make-point width 0)
(make-point width height)
(make-point 0 height)))
;; circle ;; circle
;; ellipse ;; ellipse
;; triangle ;; triangle
@ -672,8 +929,8 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(define/chk (ellipse width height mode color) (define/chk (ellipse width height mode color)
(make-picture (make-ellipse width height (make-picture (make-ellipse width height
0 0
(mode-color->pen mode color) mode
(mode-color->brush mode color)) color)
(make-bb width height height) (make-bb width height height)
#f)) #f))

86
collects/tests/2htdp/test-picture.ss
View File

@ -12,7 +12,7 @@
[else [else
(loop (overlay/places 'center 'center (loop (overlay/places 'center 'center
picture picture
(rotate (* pi (/ 1 n)) picture)) (rotate (* 180 (/ 1 n)) picture))
(+ n 1))]))) (+ n 1))])))
(define-syntax-rule (define-syntax-rule
@ -24,7 +24,10 @@
(define (round-numbers/proc x) (define (round-numbers/proc x)
(let loop ([x x]) (let loop ([x x])
(cond (cond
[(number? x) (/ (round (* 100. x)) 100)] [(number? x) (let ([n (exact->inexact (/ (round (* 100. x)) 100))])
(if (equal? n -0.0)
0.0
n))]
[(pair? x) (cons (loop (car x)) (loop (cdr x)))] [(pair? x) (cons (loop (car x)) (loop (cdr x)))]
[(vector? x) (apply vector (map loop (vector->list x)))] [(vector? x) (apply vector (map loop (vector->list x)))]
[(let-values ([(a b) (struct-info x)]) a) [(let-values ([(a b) (struct-info x)]) a)
@ -266,51 +269,48 @@
;; testing rotating ;; testing rotating
;; ;;
(test (bring-between 123 360) => 123)
(test (bring-between 365 360) => 5)
(test (bring-between -5 360) => 355)
(test (bring-between 720 360) => 0)
(test (bring-between 720.5 360) => .5)
(test (round-numbers (test (round-numbers
(simple-bb (normalize-shape (picture-shape (rotate 90 (rectangle 100 100 'solid 'blue)))
(make-translate values))
50.0
0
(make-polygon
(list (make-point 0 0) (make-point 50 0) (make-point 50 100) (make-point 0 100))
pi
'pen
'brush))))
=> =>
(values 0. -100. 50. 0.)) (round-numbers (picture-shape (rectangle 100 100 'solid 'blue))))
(test (normalize-shape (picture-shape (rotate pi (rectangle 50 100 'solid 'blue)))
values)
=>
(make-translate 50.0 100.0 (rotate-atomic pi (picture-shape (rectangle 50 100 'solid 'blue)))))
(test (rotate-simple (* pi 1/2)
(rotate-simple (* pi 1/2)
(make-translate 0 0
(picture-shape (rectangle 50 100 'solid 'purple)))))
=>
(rotate-simple pi
(make-translate 0 0 (picture-shape (rectangle 50 100 'solid 'purple)))))
(test (normalize-shape (picture-shape (rotate (* pi 1/2) (rotate (* pi 1/2) (rectangle 50 100 'solid 'blue))))
values)
=>
(make-translate 50.0 100.0 (rotate-atomic pi (picture-shape (rectangle 50 100 'solid 'blue)))))
(test (round-numbers (test (round-numbers
(normalize-shape (normalize-shape (picture-shape (rotate 90 (rotate 90 (rectangle 50 100 'solid 'purple))))
(picture-shape values))
(rotate pi
(overlay/xy (rectangle 50 50 'solid 'blue)
50 50
(rectangle 50 50 'solid 'red))))
values))
=> =>
(round-numbers (round-numbers
(normalize-shape (normalize-shape (picture-shape (rotate 180 (rectangle 50 100 'solid 'purple)))
(picture-shape values)))
(overlay/xy (rectangle 50 50 'solid 'red)
50 50 (test (normalize-shape (picture-shape (rotate 90 (ellipse 10 10 'solid 'red))))
(rectangle 50 50 'solid 'blue)))))) =>
(normalize-shape (picture-shape (ellipse 10 10 'solid 'red))))
(test (normalize-shape (picture-shape (rotate 90 (ellipse 10 12 'solid 'red))))
=>
(normalize-shape (picture-shape (ellipse 12 10 'solid 'red))))
(test (normalize-shape (picture-shape (rotate 135 (ellipse 10 12 'solid 'red))))
=>
(normalize-shape (picture-shape (rotate 45 (ellipse 12 10 'solid 'red)))))
(require (only-in lang/htdp-advanced equal~?))
(test (equal~? (rectangle 100 10 'solid 'red)
(rotate 90 (rectangle 10 100 'solid 'red))
0.1)
=>
#t)
(test (equal~? (rectangle 100 10 'solid 'red)
(rotate 90 (rectangle 10.001 100.0001 'solid 'red))
0.1)
=>
#t)