first cut checkin (still problems, of course)
svn: r15750
This commit is contained in:
Robby Findler
parent
6de735bf59
commit
eb304cf4c3
16
collects/2htdp/picture.ss
Normal file
16
collects/2htdp/picture.ss
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
#lang scheme/base
|
||||
(require "private/picture.ss")
|
||||
(provide overlay
|
||||
overlay/places
|
||||
overlay/xy
|
||||
|
||||
beside
|
||||
beside/places
|
||||
|
||||
rotate
|
||||
rotate/places
|
||||
|
||||
frame
|
||||
|
||||
ellipse
|
||||
rectangle)
|
||||
692
collects/2htdp/private/picture.ss
Normal file
692
collects/2htdp/private/picture.ss
Normal file
|
|
@ -0,0 +1,692 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/gui/base
|
||||
htdp/error
|
||||
scheme/math
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(provide overlay
|
||||
overlay/places
|
||||
overlay/xy
|
||||
|
||||
beside
|
||||
beside/places
|
||||
|
||||
rotate
|
||||
rotate/places
|
||||
|
||||
frame
|
||||
|
||||
ellipse
|
||||
rectangle
|
||||
|
||||
;; internal stuff, for the test suite
|
||||
|
||||
show-picture
|
||||
|
||||
normalize-shape
|
||||
|
||||
simple-bb
|
||||
make-picture picture-shape
|
||||
|
||||
make-bb
|
||||
make-overlay
|
||||
make-translate
|
||||
make-rotate
|
||||
make-ellipse
|
||||
make-text
|
||||
make-polygon)
|
||||
|
||||
(define-struct posn (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
|
||||
|
||||
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.)
|
||||
|
||||
|
||||
|#
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ;; ;; ;; ;;;
|
||||
; ;; ;;; ;; ;;;
|
||||
; ;;;;; ;;;; ;;;;; ;;;; ;;;;; ;;;; ;;;;; ;; ;;;
|
||||
; ;;;;;; ;; ;; ;;;; ;; ;; ;;;;;; ;; ;; ;;;; ;;;;;;
|
||||
; ;;; ;; ;;;; ;;; ;;;; ;;; ;; ;;;;;;;; ;; ;; ;;
|
||||
; ;;; ;; ;;; ;; ;;; ;;; ;; ;;; ;; ;;; ;; ;; ;;
|
||||
; ;;;;;; ;;; ;; ;;;;;;; ;; ;;;;;; ;;; ;; ;; ;; ;;
|
||||
; ;;;;; ;;;;;; ;;; ;;;;;; ;;;;; ;;;; ;; ;; ;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
|
||||
;; a picture is
|
||||
;; (make-picture shape bb boolean)
|
||||
;; NOTE: the shape field is mutated when normalized, as
|
||||
;; is the normalized? field.
|
||||
(define-struct picture (shape bb normalized?) #:mutable #:transparent)
|
||||
|
||||
;; a bb is (bounding box)
|
||||
;; (make-bb number number number)
|
||||
(define-struct bb (right bottom baseline) #:transparent)
|
||||
|
||||
;; a shape is either:
|
||||
;;
|
||||
;; - (make-overlay shape shape)
|
||||
;; 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
|
||||
;; underneath the top one.
|
||||
(define-struct overlay (top bottom) #:transparent #:omit-define-syntaxes)
|
||||
;;
|
||||
;; - (make-translate dx dy shape)
|
||||
(define-struct translate (dx dy shape) #:transparent #:omit-define-syntaxes)
|
||||
;;
|
||||
;; - (make-rotate angle shape)
|
||||
(define-struct rotate (angle shape) #:transparent #:omit-define-syntaxes)
|
||||
;;
|
||||
;; - atomic-shape
|
||||
|
||||
;; an atomic-shape is either:
|
||||
;;
|
||||
;; - (make-ellipse width height pen brush)
|
||||
(define-struct ellipse (width height pen brush) #:transparent #:omit-define-syntaxes)
|
||||
;;
|
||||
;; - (make-text string font)
|
||||
(define-struct text (string font) #:omit-define-syntaxes)
|
||||
;;
|
||||
;; - (make-polygon (listof points) pen brush)
|
||||
(define-struct polygon (points pen brush))
|
||||
;;
|
||||
;; - (is-a?/c bitmap%)
|
||||
|
||||
|
||||
;; a normalized-shape (subtype of shape) is either
|
||||
;; - (make-overlay normalized-shape simple-shape)
|
||||
;; - simple-shape
|
||||
|
||||
;; a simple-shape (subtype of shape) is
|
||||
;; - (make-translate dx dy (make-rotate angle atomic-shape))
|
||||
|
||||
;; picture-normalized-shape : picture -> normalized-shape
|
||||
(define (picture-normalized-shape picture)
|
||||
(unless (picture-normalized? picture)
|
||||
(set-picture-shape! picture (normalize-shape (picture-shape picture) void))
|
||||
(set-picture-normalized?! picture #t))
|
||||
(picture-shape picture))
|
||||
|
||||
;; normalize-shape : shape (atomic-shape -> void) -> normalized-shape
|
||||
;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape.
|
||||
(define (normalize-shape shape f)
|
||||
(let loop ([shape shape]
|
||||
[angle 0]
|
||||
[translation (xy->c 0 0)]
|
||||
[bottom #f])
|
||||
(cond
|
||||
[(translate? shape)
|
||||
(loop (translate-shape shape)
|
||||
angle
|
||||
(+ translation
|
||||
(* (xy->c (translate-dx shape)
|
||||
(translate-dy shape))
|
||||
(make-polar 1 angle)))
|
||||
bottom)]
|
||||
[(rotate? shape)
|
||||
(loop (rotate-shape shape)
|
||||
(+ angle (rotate-angle shape))
|
||||
translation
|
||||
bottom)]
|
||||
[(overlay? shape)
|
||||
(loop (overlay-bottom shape)
|
||||
angle translation
|
||||
(loop (overlay-top shape)
|
||||
angle translation bottom))]
|
||||
[(atomic-shape? shape)
|
||||
(let-values ([(dx dy) (c->xy translation)])
|
||||
(let ([this-one (make-translate dx dy (make-rotate angle shape))])
|
||||
(f this-one)
|
||||
(if bottom
|
||||
(make-overlay bottom this-one)
|
||||
this-one)))])))
|
||||
|
||||
(define (atomic-shape? shape)
|
||||
(or (ellipse? shape)
|
||||
(text? shape)
|
||||
(polygon? shape)
|
||||
(and (object? shape)
|
||||
(is-a?/c shape bitmap%))))
|
||||
|
||||
;; simple-bb : simple-shape -> (values number number number number)
|
||||
;; returns the bounding box of 'shape'
|
||||
;; (only called for rotated shapes, so bottom=baseline)
|
||||
(define (simple-bb shape)
|
||||
(let ([dx (translate-dx shape)]
|
||||
[dy (translate-dy shape)]
|
||||
[θ (rotate-angle (translate-shape shape))]
|
||||
[simple-shape (rotate-shape (translate-shape shape))])
|
||||
(cond
|
||||
[(polygon? simple-shape)
|
||||
(let ([points (polygon-points simple-shape)])
|
||||
(let-values ([(x y) (rotate-point (+ dx (posn-x (car points)))
|
||||
(+ dy (posn-y (car points)))
|
||||
θ)])
|
||||
(let ([left x]
|
||||
[top y]
|
||||
[right x]
|
||||
[bottom y])
|
||||
(for-each (λ (posn)
|
||||
(let-values ([(new-x new-y)
|
||||
(rotate-point (+ dx (posn-x posn))
|
||||
(+ dy (posn-y posn))
|
||||
θ)])
|
||||
(set! left (min new-x left))
|
||||
(set! right (max new-x right))
|
||||
(set! top (min new-y top))
|
||||
(set! bottom (max new-y bottom))))
|
||||
(cdr points))
|
||||
(values left top right bottom))))]
|
||||
[else
|
||||
(fprintf (current-error-port) "BAD\n")
|
||||
(values 0 0 100 100)])))
|
||||
|
||||
;; rotate-point : x,y theta -> x,y
|
||||
(define (rotate-point x y θ)
|
||||
(c->xy (* (make-polar 1 θ)
|
||||
(xy->c x y))))
|
||||
|
||||
(define (xy->c x y) (make-rectangular x (- y)))
|
||||
(define (c->xy c)
|
||||
(values (real-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)))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ;; ;; ;;
|
||||
; ;; ;; ;;
|
||||
; ;;;; ;;;;;;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;; ;;; ;; ;; ;;; ;;;;;;
|
||||
; ;; ;; ;;;; ;;;; ;;;;;; ;;;; ;;;;;; ;;;;;; ;; ;; ;;;;;; ;;;;; ;; ;;;;;; ;;;;;;
|
||||
; ;;;;;;;; ;; ;; ;;; ;;; ;; ;;; ;; ;; ;;;;;;;;;;; ;;;;; ;; ;; ;; ;;; ;;
|
||||
; ;;; ;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;;; ;;;;; ;; ;; ;; ;;; ;;
|
||||
; ;;; ;; ;; ;; ;;;;;; ;; ;;;;;; ;; ;; ;;; ;; ;;;;;; ;; ;; ;; ;; ;; ;;;;;;
|
||||
; ;;;; ;; ;; ;;;; ;; ;;;; ;; ;; ;;;; ;;;; ;; ;;; ;; ;; ;; ;;;;;
|
||||
; ;; ;;;
|
||||
; ;;;;;
|
||||
;
|
||||
;
|
||||
|
||||
|
||||
(define-syntax define/chk
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(define/chk (fn-name args ... . final-arg) body)
|
||||
(identifier? #'final-arg)
|
||||
(let ([len (length (syntax->list #'(args ...)))])
|
||||
(with-syntax ([(i ...) (build-list len values)])
|
||||
#`(define (fn-name args ... . final-arg)
|
||||
(let ([args (check/normalize 'fn-name 'args args i)] ...
|
||||
[final-arg (map/i (λ (x j) (check/normalize 'fn-name 'final-arg x (+ #,len j)))
|
||||
final-arg)])
|
||||
body))))]
|
||||
[(define/chk (fn-name args ...) body)
|
||||
(with-syntax ([(i ...) (build-list (length (syntax->list #'(args ...))) add1)])
|
||||
#'(define (fn-name args ...)
|
||||
(let ([args (check/normalize 'fn-name 'args args i)] ...)
|
||||
body)))])))
|
||||
|
||||
(define (map/i f l)
|
||||
(let loop ([l l]
|
||||
[i 0])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[else (cons (f (car l) i)
|
||||
(loop (cdr l) (+ i 1)))])))
|
||||
|
||||
;; check/normalize : symbol symbol any number -> any
|
||||
;; based on the name of the argument, checks to see if the input
|
||||
;; is valid and, if so, transforms it to a specific kind of value
|
||||
;; width, height -> number
|
||||
;; mode -> 'outline 'solid
|
||||
;; color -> (is-a?/c color<%>)
|
||||
(define (check/normalize fn-name argname arg i)
|
||||
(case argname
|
||||
[(x-place)
|
||||
(check-arg fn-name
|
||||
(member arg '("left" left "right" right "middle" middle "center" center))
|
||||
'x-place
|
||||
i
|
||||
arg)
|
||||
(let ([sym (if (string? arg)
|
||||
(string->symbol arg)
|
||||
arg)])
|
||||
(if (eq? sym 'center)
|
||||
'middle
|
||||
sym))]
|
||||
[(y-place)
|
||||
(check-arg fn-name
|
||||
(member arg '("top" top "bottom" bottom "middle" middle "center" center "baseline" baseline))
|
||||
'y-place
|
||||
i
|
||||
arg)
|
||||
(let ([sym (if (string? arg)
|
||||
(string->symbol arg)
|
||||
arg)])
|
||||
(if (eq? sym 'center)
|
||||
'middle
|
||||
sym))]
|
||||
[(picture picture1 picture2 picture3)
|
||||
(check-arg fn-name
|
||||
(picture? arg)
|
||||
'picture
|
||||
i
|
||||
arg)
|
||||
arg]
|
||||
[(mode)
|
||||
(check-arg fn-name
|
||||
(member arg '(solid outline "solid" "outline"))
|
||||
'mode
|
||||
i
|
||||
arg)
|
||||
(if (string? arg)
|
||||
(string->symbol arg)
|
||||
arg)]
|
||||
[(width height)
|
||||
(check-arg fn-name
|
||||
(and (number? arg)
|
||||
(not (negative? arg)))
|
||||
'non-negative-number
|
||||
i arg)
|
||||
arg]
|
||||
[(dx dy angle)
|
||||
(check-arg fn-name
|
||||
(number? arg)
|
||||
'number
|
||||
i arg)
|
||||
arg]
|
||||
[(color)
|
||||
(check-color fn-name i arg)
|
||||
(cond
|
||||
[(symbol? arg)
|
||||
(send the-color-database find-color (symbol->string arg))]
|
||||
[(string? arg)
|
||||
(send the-color-database find-color arg)]
|
||||
[else arg])]
|
||||
[else
|
||||
(error 'check "the function ~a has an argument with an unknown name: ~s"
|
||||
fn-name
|
||||
argname)]))
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ;; ;;
|
||||
; ;; ;;
|
||||
; ;;;; ;;;; ;; ;;; ;;;;; ;;;; ;;;;;;; ;; ;;; ;;;;;;
|
||||
; ;;;; ;; ;; ;;;;;; ;;;;;; ;; ;; ;;;; ;; ;;;;;; ;;;;;;
|
||||
; ;; ;;;;;;;; ;; ;; ;;; ;; ;;;;;;;; ;; ;; ;; ;; ;;; ;;
|
||||
; ;; ;;; ;; ;; ;;; ;; ;;; ;; ;; ;; ;; ;;; ;;
|
||||
; ;; ;;; ;; ;; ;; ;;;;;; ;;; ;; ;; ;; ;; ;; ;;;;;;
|
||||
; ;; ;;;; ;; ;; ;;;;; ;;;; ;; ;; ;; ;; ;;;;;
|
||||
; ;; ;;;
|
||||
; ;;;;;
|
||||
;
|
||||
;
|
||||
|
||||
(define (show-picture g [extra-space 0])
|
||||
(letrec ([f (new frame% [label ""])]
|
||||
[c (new canvas%
|
||||
[parent f]
|
||||
[min-width (+ extra-space (inexact->exact (floor (picture-right g))))]
|
||||
[min-height (+ extra-space (inexact->exact (floor (picture-bottom g))))]
|
||||
[paint-callback
|
||||
(λ (c dc)
|
||||
(send dc set-smoothing 'aligned)
|
||||
(let-values ([(w h) (send c get-client-size)])
|
||||
(let ([scale (send sl get-value)])
|
||||
(send dc set-scale scale scale)
|
||||
(render-picture
|
||||
g
|
||||
dc
|
||||
(inexact->exact (floor (- (/ w 2 scale) (/ (picture-right g) 2))))
|
||||
(inexact->exact (floor (- (/ h 2 scale) (/ (picture-bottom g) 2))))))))])]
|
||||
[min-scale 1]
|
||||
[max-scale 10]
|
||||
[sl (new slider%
|
||||
[label "Scale factor"]
|
||||
[parent f]
|
||||
[min-value min-scale]
|
||||
[max-value max-scale]
|
||||
[callback (λ ignore (send c refresh))])]
|
||||
[bp (new horizontal-panel% [parent f] [alignment '(center center)] [stretchable-height #f])]
|
||||
[scale-adjust
|
||||
(λ (f)
|
||||
(send sl set-value (max min-scale (min max-scale (f (send sl get-value)))))
|
||||
(send c refresh))])
|
||||
(new button% [label "√"] [callback (λ x (scale-adjust sub1))] [parent bp])
|
||||
(new button% [label "²"] [callback (λ x (scale-adjust add1))] [parent bp])
|
||||
(send f show #t)))
|
||||
|
||||
;; render-picture : normalized-shape dc dx dy -> void
|
||||
(define (render-picture picture dc dx dy)
|
||||
(let loop ([shape (picture-normalized-shape picture)])
|
||||
(cond
|
||||
[(overlay? shape)
|
||||
(render-simple-shape (overlay-bottom shape) dc dx dy)
|
||||
(loop (overlay-top shape))]
|
||||
[else
|
||||
(render-simple-shape shape dc dx dy)])))
|
||||
|
||||
(define (render-simple-shape shape dc dx dy)
|
||||
(let ([dx (+ dx (translate-dx shape))]
|
||||
[dy (+ dy (translate-dy shape))]
|
||||
[θ (rotate-angle (translate-shape shape))]
|
||||
[atomic-shape (rotate-shape (translate-shape shape))])
|
||||
(cond
|
||||
[(ellipse? atomic-shape)
|
||||
(let ([path (new dc-path%)])
|
||||
(send path ellipse 0 0 (ellipse-width atomic-shape) (ellipse-height atomic-shape))
|
||||
(send path rotate θ)
|
||||
(send dc set-pen (ellipse-pen atomic-shape))
|
||||
(send dc set-brush (ellipse-brush atomic-shape))
|
||||
(send dc draw-path path dx dy))]
|
||||
[(polygon? atomic-shape)
|
||||
(let ([path (new dc-path%)]
|
||||
[points (polygon-points atomic-shape)])
|
||||
(send path move-to (posn-x (car points)) (posn-y (car points)))
|
||||
(let loop ([points (cdr points)])
|
||||
(unless (null? points)
|
||||
(send path line-to (posn-x (car points)) (posn-y (car points)))
|
||||
(loop (cdr points))))
|
||||
(send path line-to (posn-x (car points)) (posn-y (car points)))
|
||||
(send path rotate θ)
|
||||
(send dc set-pen (polygon-pen atomic-shape))
|
||||
(send dc set-brush (polygon-brush atomic-shape))
|
||||
(send dc draw-path path dx dy))]
|
||||
[(text? atomic-shape)
|
||||
(send dc set-font (text-font atomic-shape))
|
||||
(send dc draw-text (text-string atomic-shape) dx dy #f 0 angle)])))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ;; ;; ;;
|
||||
; ;; ;; ;;;
|
||||
; ;;;; ;;;; ;;;;;; ;;; ;;;;; ;; ;; ;;; ;;;; ;;;;; ;;;; ;;;; ;;;;;
|
||||
; ;;;;;; ;;;;;; ;;;;;;;;;; ;;;;;; ;; ;;;;;; ;; ;; ;;;; ;;;;;; ;;;; ;; ;;
|
||||
; ;;; ;;; ;;; ;; ;; ;; ;; ;;; ;; ;; ;; ;;;; ;;; ;;; ;;; ;; ;;;;;
|
||||
; ;;; ;;; ;;; ;; ;; ;; ;; ;;; ;; ;; ;; ;;; ;; ;;; ;;; ;;; ;; ;;;;
|
||||
; ;;;;;; ;;;;;; ;; ;; ;; ;;;;;; ;; ;; ;; ;;; ;; ;;;; ;;;;;; ;; ;; ;;;
|
||||
; ;;;; ;;;; ;; ;; ;; ;; ;; ;; ;; ;; ;;;;;; ;;; ;;;; ;; ;;;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ; ; ;
|
||||
|
||||
;; bitmap : string -> picture
|
||||
;; gets one of the bitmaps that comes with drscheme, scales it down by 1/8 or something
|
||||
;; so that later scaling /translation/whatever will look reasonable.
|
||||
;; (the error message for a bad argument will list all of the currently installed example pictures;
|
||||
;; we may want to have some way teachers can stick new ones in there)
|
||||
|
||||
;; overlay : picture picture picture ... -> picture
|
||||
;; places pictures on top of each other with their upper left corners aligned. last one goes on the bottom
|
||||
|
||||
(define/chk (overlay picture picture2 . picture3)
|
||||
(overlay/internal 'left 'top picture (cons picture2 picture3)))
|
||||
|
||||
;; overlay/places : string string picture picture picture ... -> picture
|
||||
;; the first string has to be one of "center" "middle" "left" or "right" (or symbols)
|
||||
;; the second string has to be one of "center" "middle" "top" "bottom" or "baseline" (or symbols)
|
||||
;; behaves like overlay, but lines up the pictures in the various places.
|
||||
;; overlay without string arguments is the same as passing "left" and "top"
|
||||
;; for the two string arguments. Passing, eg, "center" "center" lines the
|
||||
;; pictures up at their centers.
|
||||
|
||||
(define/chk (overlay/places x-place y-place picture picture2 . picture3)
|
||||
(overlay/internal x-place y-place picture (cons picture2 picture3)))
|
||||
|
||||
(define (overlay/internal x-place y-place fst rst)
|
||||
(let loop ([fst fst]
|
||||
[rst rst])
|
||||
(cond
|
||||
[(null? rst) fst]
|
||||
[else
|
||||
(let* ([fst-x-spot (find-x-spot x-place fst)]
|
||||
[fst-y-spot (find-y-spot y-place fst)]
|
||||
[snd-x-spot (find-x-spot x-place (car rst))]
|
||||
[snd-y-spot (find-y-spot y-place (car rst))]
|
||||
[dx (- fst-x-spot snd-x-spot)]
|
||||
[dy (- fst-y-spot snd-y-spot)])
|
||||
(loop (overlay/δ fst
|
||||
(if (< dx 0) (- dx) 0)
|
||||
(if (< dy 0) (- dy) 0)
|
||||
(car rst)
|
||||
(if (< dx 0) 0 dx)
|
||||
(if (< dy 0) 0 dy))
|
||||
(cdr rst)))])))
|
||||
|
||||
(define (find-x-spot x-place picture)
|
||||
(case x-place
|
||||
[(left) 0]
|
||||
[(middle) (/ (picture-right picture) 2)]
|
||||
[(right) (picture-right picture)]))
|
||||
|
||||
(define (find-y-spot y-place picture)
|
||||
(case y-place
|
||||
[(top) 0]
|
||||
[(middle) (/ (picture-bottom picture) 2)]
|
||||
[(bottom) (picture-bottom picture)]
|
||||
[(baseline) (picture-baseline picture)]))
|
||||
|
||||
;; overlay/xy : picture number number picture -> picture
|
||||
;; places pictures on top of each other with their upper-left corners offset by the two numbers
|
||||
|
||||
(define/chk (overlay/xy picture dx dy picture2)
|
||||
(overlay/δ picture
|
||||
(if (< dx 0) (- dx) 0)
|
||||
(if (< dy 0) (- dy) 0)
|
||||
picture2
|
||||
(if (< dx 0) 0 dx)
|
||||
(if (< dy 0) 0 dy)))
|
||||
|
||||
(define (overlay/δ picture1 dx1 dy1 picture2 dx2 dy2)
|
||||
(make-picture (make-overlay (make-translate dx1 dy1 (picture-shape picture1))
|
||||
(make-translate dx2 dy2 (picture-shape picture2)))
|
||||
(make-bb (max (+ (picture-right picture1) dx1)
|
||||
(+ (picture-right picture2) dx2))
|
||||
(max (+ (picture-bottom picture1) dy1)
|
||||
(+ (picture-bottom picture2) dy2))
|
||||
(max (+ (picture-baseline picture1) dy1)
|
||||
(+ (picture-baseline picture2) dy2)))
|
||||
#f))
|
||||
|
||||
|
||||
;; beside : picture picture picture ... -> picture
|
||||
;; places pictures in a single horizontal row, top aligned
|
||||
(define/chk (beside picture1 picture2 . picture3)
|
||||
(beside/internal 'top picture1 (cons picture2 picture3)))
|
||||
|
||||
;; beside/places : string picture picture picture ... -> picture
|
||||
;; places pictures in a horizontal row where the vertical alignment is
|
||||
;; covered by the string argument
|
||||
(define/chk (beside/places y-place picture1 picture2 . picture3)
|
||||
(beside/internal y-place picture1 (cons picture2 picture3)))
|
||||
|
||||
(define (beside/internal y-place fst rst)
|
||||
(let loop ([fst fst]
|
||||
[rst rst])
|
||||
(cond
|
||||
[(null? rst) fst]
|
||||
[else
|
||||
(let* ([snd (car rst)]
|
||||
[fst-y-spot (find-y-spot y-place fst)]
|
||||
[snd-y-spot (find-y-spot y-place (car rst))]
|
||||
[dy (- fst-y-spot snd-y-spot)])
|
||||
(loop (overlay/δ fst
|
||||
0
|
||||
(if (< dy 0) (- dy) 0)
|
||||
(car rst)
|
||||
(picture-right fst)
|
||||
(if (< dy 0) 0 dy))
|
||||
(cdr rst)))])))
|
||||
|
||||
;; above : picture picture picture ... -> picture
|
||||
;; above/places : string I I I ... -> I
|
||||
;; like beside, but vertically
|
||||
|
||||
|
||||
;; frame : picture -> picture
|
||||
;; draws a black frame around a picture where the bounding box is
|
||||
;; (useful for debugging pictures)
|
||||
|
||||
(define/chk (frame picture)
|
||||
(make-picture (make-overlay (picture-shape picture)
|
||||
(picture-shape
|
||||
(rectangle (picture-right picture)
|
||||
(picture-bottom picture)
|
||||
'outline
|
||||
'black)))
|
||||
(make-bb (picture-right picture)
|
||||
(picture-bottom picture)
|
||||
(picture-baseline picture))
|
||||
#f))
|
||||
|
||||
;; scale : I number -> I
|
||||
;; scales the I by the given factor
|
||||
|
||||
;; rotate : I number -> I
|
||||
;; rotates the I around the top-left corner by the given angle
|
||||
;; (in degrees)
|
||||
|
||||
(define/chk (rotate angle picture)
|
||||
(rotate/internal 'left 'top angle picture))
|
||||
|
||||
;; rotate/places : string string I number -> I
|
||||
;; rotates the I around the given point inside the I, using
|
||||
;; the strings like overlay does.
|
||||
(define/chk (rotate/places x-place y-place angle picture)
|
||||
(rotate/internal x-place y-place angle picture))
|
||||
|
||||
;; LINEAR TIME OPERATION!!
|
||||
(define (rotate/internal x-place y-place angle picture)
|
||||
(define left #f)
|
||||
(define top #f)
|
||||
(define right #f)
|
||||
(define bottom #f)
|
||||
(define (add-to-bounding-box simple-shape)
|
||||
(let-values ([(this-left this-top this-right this-bottom) (simple-bb simple-shape)])
|
||||
(set! left (if left (min this-left left) this-left))
|
||||
(set! top (if top (min this-top top) this-top))
|
||||
(set! right (if right (max this-right right) this-right))
|
||||
(set! bottom (if bottom (max this-bottom bottom) this-bottom))))
|
||||
(let ([rotated (normalize-shape (make-rotate angle (picture-shape picture)) add-to-bounding-box)])
|
||||
(make-picture (make-translate (- left) (- top) rotated)
|
||||
(make-bb (- right left) (- bottom top) (- bottom top))
|
||||
#f)))
|
||||
|
||||
;; stamp : I I -> I
|
||||
;; treats the first I as if it were a mask and uses that mask to
|
||||
;; mask out parts of the first I (the mask is solid; no alpha stuff
|
||||
;; here, even if dim were used).
|
||||
;; only accepts solid black Is
|
||||
|
||||
;; see-thru : I number -> I
|
||||
;; applies an alpha value to the I, making it translucent
|
||||
|
||||
|
||||
;; -- as in the current I library, but they don't actually create
|
||||
;; bitmaps, but instead just records that are rendered right as they are
|
||||
;; about to be drawn
|
||||
|
||||
;; rectangle
|
||||
|
||||
(define/chk (rectangle width height mode color)
|
||||
(make-picture (make-polygon (list (make-posn 0 0)
|
||||
(make-posn width 0)
|
||||
(make-posn width height)
|
||||
(make-posn 0 height))
|
||||
(mode-color->pen mode color)
|
||||
(mode-color->brush mode color))
|
||||
(make-bb width
|
||||
height
|
||||
height)
|
||||
#f))
|
||||
|
||||
;; circle
|
||||
;; ellipse
|
||||
;; triangle
|
||||
;; line
|
||||
;; star
|
||||
;; text
|
||||
;; regular-polygon
|
||||
|
||||
(define/chk (ellipse width height mode color)
|
||||
(make-picture (make-ellipse width height
|
||||
(mode-color->pen mode color)
|
||||
(mode-color->brush mode color))
|
||||
(make-bb width height height)
|
||||
#f))
|
||||
|
||||
(define (mode-color->pen mode color)
|
||||
(send the-pen-list find-or-create-pen color 1
|
||||
(case mode
|
||||
[(outline) 'solid]
|
||||
[(solid) 'transparent])))
|
||||
|
||||
(define (mode-color->brush mode color)
|
||||
(send the-brush-list find-or-create-brush color
|
||||
(case mode
|
||||
[(outline) 'transparent]
|
||||
[(solid) 'solid])))
|
||||
|
||||
;; add-line : I number number number number -> I
|
||||
;; add-line : string string I number number number number -> I
|
||||
;; like add-line, but adapted to use coordinates relative the top-left of the I,
|
||||
;; or to the user-specified spot
|
||||
|
||||
;; add-curve : I posn number number posn number number -> I
|
||||
;; add-curve : string string I posn number number posn number number -> I
|
||||
;; the posns are the start and end points of the curve
|
||||
;; the pair of numbers following each posn are the angle and "pull" of the curve
|
||||
;; see pin-line in slideshow
|
||||
;; the initial strings in the second instance of add-curve are like the strings in add-line
|
||||
|
||||
292
collects/2htdp/private/test-picture.ss
Normal file
292
collects/2htdp/private/test-picture.ss
Normal file
|
|
@ -0,0 +1,292 @@
|
|||
#lang scheme/base
|
||||
(require "picture.ss"
|
||||
scheme/math
|
||||
tests/eli-tester)
|
||||
|
||||
(let* ([first (rectangle 100 10 'solid 'red)]
|
||||
[second
|
||||
(overlay/places 'center
|
||||
'center
|
||||
first
|
||||
(rotate/places 'center 'center
|
||||
(* pi 1/4)
|
||||
first))]
|
||||
[third
|
||||
(overlay/places 'center
|
||||
'center
|
||||
(frame second)
|
||||
(rotate/places 'center 'center
|
||||
(* pi 1/8)
|
||||
(frame second)))])
|
||||
(show-picture (frame third)))
|
||||
|
||||
(define (round-numbers x)
|
||||
(let loop ([x x])
|
||||
(cond
|
||||
[(number? x) (/ (round (* 100. x)) 100)]
|
||||
[(pair? x) (cons (loop (car x)) (loop (cdr x)))]
|
||||
[(let-values ([(a b) (struct-info x)]) a)
|
||||
=>
|
||||
(λ (struct-type)
|
||||
(apply
|
||||
(struct-type-make-constructor
|
||||
struct-type)
|
||||
(map loop (cdr (vector->list (struct->vector x))))))])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; testing overlays
|
||||
;;
|
||||
|
||||
(test (overlay (ellipse 100 100 'solid 'blue)
|
||||
(ellipse 120 120 'solid 'red))
|
||||
=>
|
||||
(make-picture
|
||||
(make-overlay
|
||||
(make-translate 0 0 (picture-shape (ellipse 100 100 'solid 'blue)))
|
||||
(make-translate 0 0 (picture-shape (ellipse 120 120 'solid 'red))))
|
||||
(make-bb 120
|
||||
120
|
||||
120)
|
||||
#f))
|
||||
|
||||
(test (overlay/xy (ellipse 100 100 'solid 'blue)
|
||||
0 0
|
||||
(ellipse 120 120 'solid 'red))
|
||||
=>
|
||||
(overlay (ellipse 100 100 'solid 'blue)
|
||||
(ellipse 120 120 'solid 'red)))
|
||||
|
||||
|
||||
(test (overlay/xy (ellipse 50 100 'solid 'red)
|
||||
-25 25
|
||||
(ellipse 100 50 'solid 'green))
|
||||
=>
|
||||
(make-picture
|
||||
(make-overlay
|
||||
(make-translate
|
||||
25 0
|
||||
(picture-shape (ellipse 50 100 'solid 'red)))
|
||||
(make-translate
|
||||
0 25
|
||||
(picture-shape (ellipse 100 50 'solid 'green))))
|
||||
(make-bb 100
|
||||
100
|
||||
100)
|
||||
#f))
|
||||
|
||||
(test (overlay/xy (ellipse 100 50 'solid 'green)
|
||||
10 10
|
||||
(ellipse 50 100 'solid 'red))
|
||||
=>
|
||||
(make-picture
|
||||
(make-overlay
|
||||
(make-translate 0 0 (picture-shape (ellipse 100 50 'solid 'green)))
|
||||
(make-translate 10 10 (picture-shape (ellipse 50 100 'solid 'red))))
|
||||
(make-bb 100
|
||||
110
|
||||
110)
|
||||
#f))
|
||||
|
||||
(test (overlay (ellipse 100 50 'solid 'green)
|
||||
(ellipse 50 100 'solid 'red))
|
||||
=>
|
||||
(make-picture
|
||||
(make-overlay
|
||||
(make-translate 0 0 (picture-shape (ellipse 100 50 'solid 'green)))
|
||||
(make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'red))))
|
||||
(make-bb 100
|
||||
100
|
||||
100)
|
||||
#f))
|
||||
|
||||
(test (overlay (ellipse 100 100 'solid 'blue)
|
||||
(ellipse 120 120 'solid 'red)
|
||||
(ellipse 140 140 'solid 'green))
|
||||
=>
|
||||
(make-picture
|
||||
(make-overlay
|
||||
(make-translate
|
||||
0 0
|
||||
(make-overlay
|
||||
(make-translate 0 0 (picture-shape (ellipse 100 100 'solid 'blue)))
|
||||
(make-translate 0 0 (picture-shape (ellipse 120 120 'solid 'red)))))
|
||||
(make-translate 0 0 (picture-shape (ellipse 140 140 'solid 'green))))
|
||||
(make-bb 140 140 140)
|
||||
#f))
|
||||
|
||||
(test (overlay/places 'middle
|
||||
'middle
|
||||
(ellipse 100 50 'solid 'green)
|
||||
(ellipse 50 100 'solid 'red))
|
||||
=>
|
||||
(make-picture
|
||||
(make-overlay
|
||||
(make-translate 0 25 (picture-shape (ellipse 100 50 'solid 'green)))
|
||||
(make-translate 25 0 (picture-shape (ellipse 50 100 'solid 'red))))
|
||||
(make-bb 100 100 100)
|
||||
#f))
|
||||
|
||||
(test (overlay/places 'middle
|
||||
'middle
|
||||
(ellipse 50 100 'solid 'red)
|
||||
(ellipse 100 50 'solid 'green))
|
||||
=>
|
||||
(make-picture
|
||||
(make-overlay
|
||||
(make-translate 25 0 (picture-shape (ellipse 50 100 'solid 'red)))
|
||||
(make-translate 0 25 (picture-shape (ellipse 100 50 'solid 'green))))
|
||||
(make-bb 100 100 100)
|
||||
#f))
|
||||
|
||||
|
||||
(test (overlay/places 'right
|
||||
'bottom
|
||||
(ellipse 50 100 'solid 'red)
|
||||
(ellipse 100 50 'solid 'green))
|
||||
=>
|
||||
(make-picture
|
||||
(make-overlay
|
||||
(make-translate 50 0 (picture-shape (ellipse 50 100 'solid 'red)))
|
||||
(make-translate 0 50 (picture-shape (ellipse 100 50 'solid 'green))))
|
||||
(make-bb 100 100 100)
|
||||
#f))
|
||||
|
||||
(test (overlay/places 'right
|
||||
'baseline
|
||||
(ellipse 50 100 'solid 'red)
|
||||
(ellipse 100 50 'solid 'green))
|
||||
=>
|
||||
(make-picture
|
||||
(make-overlay
|
||||
(make-translate 50 0 (picture-shape (ellipse 50 100 'solid 'red)))
|
||||
(make-translate 0 50 (picture-shape (ellipse 100 50 'solid 'green))))
|
||||
(make-bb 100 100 100)
|
||||
#f))
|
||||
|
||||
(test (beside/places 'top
|
||||
(ellipse 50 100 'solid 'red)
|
||||
(ellipse 100 50 'solid 'blue))
|
||||
|
||||
=>
|
||||
(make-picture
|
||||
(make-overlay
|
||||
(make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'red)))
|
||||
(make-translate 50 0 (picture-shape (ellipse 100 50 'solid 'blue))))
|
||||
(make-bb 150 100 100)
|
||||
#f))
|
||||
|
||||
(test (beside/places 'center
|
||||
(ellipse 50 100 'solid 'red)
|
||||
(ellipse 100 50 'solid 'blue))
|
||||
|
||||
=>
|
||||
(make-picture
|
||||
(make-overlay
|
||||
(make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'red)))
|
||||
(make-translate 50 25 (picture-shape (ellipse 100 50 'solid 'blue))))
|
||||
(make-bb 150 100 100)
|
||||
#f))
|
||||
|
||||
(test (beside/places 'baseline
|
||||
(ellipse 50 100 'solid 'red)
|
||||
(ellipse 100 50 'solid 'blue))
|
||||
|
||||
=>
|
||||
(make-picture
|
||||
(make-overlay
|
||||
(make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'red)))
|
||||
(make-translate 50 50 (picture-shape (ellipse 100 50 'solid 'blue))))
|
||||
(make-bb 150 100 100)
|
||||
#f))
|
||||
|
||||
(test (beside (ellipse 50 100 'solid 'red)
|
||||
(ellipse 100 50 'solid 'blue))
|
||||
=>
|
||||
(beside/places 'top
|
||||
(ellipse 50 100 'solid 'red)
|
||||
(ellipse 100 50 'solid 'blue)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; testing rotation bounding boxes.
|
||||
;;
|
||||
|
||||
(test (simple-bb (make-translate 0 0 (make-rotate (* pi 1/4) (picture-shape (rectangle 100 50 'solid 'red)))))
|
||||
=>
|
||||
(values 0.0
|
||||
(- (imag-part (* (make-rectangular 100 0) (make-polar 1 (* pi 1/4)))))
|
||||
(real-part (* (make-rectangular 100 -50) (make-polar 1 (* pi 1/4))))
|
||||
(- (imag-part (* (make-rectangular 0 -50) (make-polar 1 (* pi 1/4)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; testing normalization
|
||||
;;
|
||||
|
||||
(test (normalize-shape (picture-shape (ellipse 50 100 'solid 'red))
|
||||
void)
|
||||
=>
|
||||
(make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'red)))))
|
||||
|
||||
(test (normalize-shape (make-overlay (picture-shape (ellipse 50 100 'solid 'red))
|
||||
(picture-shape (ellipse 50 100 'solid 'blue)))
|
||||
void)
|
||||
=>
|
||||
(make-overlay (make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'red))))
|
||||
(make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'blue))))))
|
||||
|
||||
(test (normalize-shape (make-overlay
|
||||
(make-overlay (picture-shape (ellipse 50 100 'solid 'red))
|
||||
(picture-shape (ellipse 50 100 'solid 'blue)))
|
||||
(picture-shape (ellipse 50 100 'solid 'green)))
|
||||
void)
|
||||
=>
|
||||
(make-overlay
|
||||
(make-overlay (make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'red))))
|
||||
(make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'blue)))))
|
||||
(make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'green))))))
|
||||
|
||||
(test (normalize-shape (make-overlay
|
||||
(picture-shape (ellipse 50 100 'solid 'green))
|
||||
(make-overlay (picture-shape (ellipse 50 100 'solid 'red))
|
||||
(picture-shape (ellipse 50 100 'solid 'blue))))
|
||||
void)
|
||||
=>
|
||||
(make-overlay
|
||||
(make-overlay (make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'green))))
|
||||
(make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'red)))))
|
||||
(make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'blue))))))
|
||||
|
||||
(test (normalize-shape (make-translate 100 100 (picture-shape (ellipse 50 100 'solid 'blue)))
|
||||
void)
|
||||
=>
|
||||
(make-translate 100 100 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'blue)))))
|
||||
|
||||
(test (normalize-shape (make-translate 10 20 (make-translate 100 100 (picture-shape (ellipse 50 100 'solid 'blue))))
|
||||
void)
|
||||
=>
|
||||
(make-translate 110 120 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'blue)))))
|
||||
|
||||
(test (normalize-shape (make-rotate pi (picture-shape (ellipse 50 100 'solid 'blue)))
|
||||
void)
|
||||
=>
|
||||
(make-translate 0 0 (make-rotate pi (picture-shape (ellipse 50 100 'solid 'blue)))))
|
||||
|
||||
(test (normalize-shape (make-rotate (* pi 1/2) (make-rotate (* pi 1/2) (picture-shape (ellipse 50 100 'solid 'blue))))
|
||||
void)
|
||||
=>
|
||||
(make-translate 0 0 (make-rotate pi (picture-shape (ellipse 50 100 'solid 'blue)))))
|
||||
|
||||
(test (round-numbers
|
||||
(normalize-shape (make-rotate pi (make-translate 100 100 (picture-shape (rectangle 50 100 'solid 'blue))))
|
||||
void))
|
||||
=>
|
||||
(round-numbers (make-translate -100 -100 (make-rotate pi (picture-shape (rectangle 50 100 'solid 'blue))))))
|
||||
|
||||
|
||||
(test (round-numbers
|
||||
(normalize-shape (make-rotate (* pi 1/2) (make-translate 100 50 (picture-shape (rectangle 50 100 'solid 'blue))))
|
||||
void))
|
||||
=>
|
||||
(round-numbers (make-translate 50 -100 (make-rotate (* pi 1/2) (picture-shape (rectangle 50 100 'solid 'blue))))))
|
||||
Loading…
Reference in New Issue
Block a user