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

slideshow/pict: add `rotate'

Browse Source 
which requires two new fields in the `child' struct to support
 `lt-find', etc., when child picts are rotated
This commit is contained in:
Matthew Flatt 2011-07-04 15:59:54 -06:00
parent 850b85cbdb
commit 4905d344dd
7 changed files with 115 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/scribblings/draw/bitmap-class.scrbl
View File

@ -32,7 +32,7 @@ A bitmap is convertible to @racket['png-bytes] through the
The @racket[make-bitmap], @racket[make-monochrome-bitmap], and
@racket[read-bitmap] functions are preferred over using
@racket[make-object] with @racket[bitmap%], because the functions are
less overloaded and provide more useful defaults.
less overloaded and they enable alpha channels by default.
When @racket[width] and @racket[height] are provided: Creates a new
bitmap. If @racket[monochrome?] is true, the bitmap is monochrome; if

25
collects/scribblings/slideshow/picts.scrbl
View File

@ -94,10 +94,15 @@ own last sub-pict.}
[dx real?]
[dy real?]
[sx real?]
[sy real?])]{
[sy real?]
[sxy real?]
[syx real?])]{
Records, for a pict constructed of other picts, the relative location
and scale of one nested pict.
Records, for a pict constructed of other picts, the transformation to
arrive at a @tech{inverted point} in the composed pict from an
@tech{inverted point} in a constituent pict's. An @deftech{inverted
point} is a point relative to a pict's lower-left corner with an
increasing value moving upward.
A @racket[child] structure is normally not created directly with
@racket[make-child]. Instead, functions like @racket[hc-append] create
@ -489,11 +494,25 @@ Scales a pict drawing, as well as its @tech{bounding-box}. The drawing
is scaled by adjusting the destination @racket[dc<%>]'s scale while
drawing the original @racket[pict].}
@defproc[(rotate [pict pict?] [theta real?]) pict?]{
Rotates a pict's drawing by @racket[theta] radians counter-clockwise.
The bounding box of the resulting pict is the box encloses the rotated
corners of @racket[pict] (which inflates the area of the bounding
box, unless @racket[theta] is a multiple of half of @racket[pi]). The
ascent and descent lines of the result's bounding box are the
horizontal lines that bisect the rotated original lines; if the ascent
line drops below the descent line, the two lines are flipped.}
@defproc[(ghost [pict pict?]) pict?]{
Creats a container picture that doesn't draw the child picture,
but uses the child's size.}
@defproc[(linewidth [w (or/c real? #f)] [pict pict?]) pict?]{
Selects a specific pen width for drawing, which applies to pen drawing

2
collects/slideshow/play.rkt
View File

@ -154,7 +154,7 @@
(pict-height orig)
da
dd
(list (make-child orig 0 0 1 1))
(list (make-child orig 0 0 1 1 0 0))
#f
(pict-last orig))])
(let ([left (+ atx (* (- btx atx) n))]

2
collects/texpict/doc.txt
View File

@ -162,7 +162,7 @@ A pict is an instance of the `pict' structure type:
The `children' field is a list of `child' structures:
> struct:child :: (struct child (pict dx dy sx sy))
> struct:child :: (struct child (pict dx dy sx sy sxy syx))
------------------------------------------------------------
Procedures

81
collects/texpict/private/common-unit.rkt
View File

@ -24,7 +24,7 @@
#:mutable
#:property prop:convertible (lambda (v mode default)
(convert-pict v mode default)))
(define-struct child (pict dx dy sx sy))
(define-struct child (pict dx dy sx sy syx sxy))
(define-struct bbox (x1 y1 x2 y2 ay dy))
(define (quotient* a b)
@ -48,44 +48,46 @@
(make-pict (if draw draw (pict-draw box))
(+ w dw) (+ h da dd)
(max 0 (+ a da)) (max 0 (+ d dd))
(list (make-child box dx dy 1 1))
(list (make-child box dx dy 1 1 0 0))
#f
(pict-last box))))
(define (single-pict-offset pict subbox)
(define (transform dx dy tdx tdy tsx tsy tsxy tsyx)
(values (+ (* tsx dx) (* tsxy dy) tdx)
(+ (* tsy dy) (* tsyx dx) tdy)))
(define (single-pict-offset pict subbox dx dy)
(let floop ([box pict]
[found values]
[not-found (lambda () (error 'find-XX
"sub-pict: ~a not found in: ~a"
subbox pict))])
(if (eq? box subbox)
(found 0 0 1 1)
(found dx dy)
(let loop ([c (pict-children box)])
(if (null? c)
(not-found)
(floop (child-pict (car c))
(lambda (dx dy sx sy)
(let ([tsx (child-sx (car c))]
[tsy (child-sy (car c))])
(found (+ (* tsx dx)
(child-dx (car c)))
(+ (* tsy dy)
(child-dy (car c)))
(* sx tsx)
(* sy tsy))))
(lambda (dx dy)
(let ([c (car c)])
(let-values ([(dx dy)
(transform
dx dy
(child-dx c) (child-dy c)
(child-sx c) (child-sy c)
(child-sxy c) (child-syx c))])
(found dx dy))))
(lambda ()
(loop (cdr c)))))))))
(define (find-lbx pict subbox-path)
(define (find-lbx pict subbox-path dx dy)
(if (pict? subbox-path)
(single-pict-offset pict subbox-path)
(let loop ([p pict][l subbox-path][dx 0][dy 0][sx 1][sy 1])
(if (null? l)
(values dx dy sx sy)
(let-values ([(x y tsx tsy) (find-lbx p (car l))])
(loop (car l) (cdr l)
(+ (* sx x) dx) (+ (* sy y) dy)
(* sx tsx) (* sy tsy)))))))
(single-pict-offset pict subbox-path dx dy)
(let loop ([l (cons pict subbox-path)])
(if (null? (cdr l))
(values dx dy)
(let-values ([(dx dy) (loop (cdr l))])
(single-pict-offset (car l) (cadr l) dx dy))))))
(define-values (find-lt
find-lc
@ -109,14 +111,18 @@
[bline (lambda (x sx w d a) (+ x (* sx d)))]
[find (lambda (get-x get-y)
(lambda (pict pict-path)
(let-values ([(dx dy sx sy) (find-lbx pict pict-path)])
(let ([p (let loop ([path pict-path])
(cond
[(pict? path) path]
[(null? (cdr path)) (loop (car path))]
[else (loop (cdr path))]))])
(values (get-x dx sx (pict-width p) 0 0)
(get-y dy sy (pict-height p) (pict-descent p) (pict-ascent p)))))))])
(let ([p (let loop ([path pict-path])
(cond
[(pict? path) path]
[(null? (cdr path)) (loop (car path))]
[else (loop (cdr path))]))])
(let ([w (pict-width p)]
[h (pict-height p)]
[d (pict-descent p)]
[a (pict-ascent p)])
(find-lbx pict pict-path
(get-x 0 1 w 0 0)
(get-y 0 1 h d a))))))])
(values (find lb rt)
(find lb c)
(find lb lb)
@ -212,7 +218,8 @@
(child-pict c)
(child-dx c)
(+ dh (child-dy c))
1 1))
1 1
0 0))
(pict-children p))
#f
(pict-last p))))
@ -360,7 +367,7 @@
(make-pict (pict-draw p)
(pict-width p) (pict-height p)
(pict-ascent p) (pict-descent p)
(list (make-child p 0 0 1 1))
(list (make-child p 0 0 1 1 0 0))
#f
sub-p))
@ -525,8 +532,8 @@
w h
(combine-ascent fd1 rd1 fd2 rd2 fh rh h (+ dy1 fh) (+ dy2 rh))
(combine-descent fd2 rd2 fd1 rd1 fh rh h (- h dy1) (- h dy2))
(list (make-child first dx1 dy1 1 1)
(make-child rest dx2 dy2 1 1))
(list (make-child first dx1 dy1 1 1 0 0)
(make-child rest dx2 dy2 1 1 0 0))
#f
(last* rest)))])))])
*-append))]
@ -805,8 +812,8 @@
totalwidth totalheight
totalheight 0
(cons
(make-child title 0 title-y 1 1)
(map (lambda (child child-y) (make-child child 0 child-y 1 1)) fields field-ys))
(make-child title 0 title-y 1 1 0 0)
(map (lambda (child child-y) (make-child child 0 child-y 1 1 0 0)) fields field-ys))
#f
#f)))
@ -878,7 +885,7 @@
`(put ,x ,y ,(pict-draw p))
translated)
(cons
(make-child p x y 1 1)
(make-child p x y 1 1 0 0)
children)))]
[else (loop rest (cons c translated) children)])))))

42
collects/texpict/utils.rkt
View File

@ -70,6 +70,7 @@
(provide/contract
[scale (case-> (-> pict? number? number? pict?)
(-> pict? number? pict?))]
[rotate (case-> (-> pict? number? pict?))]
[pin-line (->* (pict?
pict-path? (-> pict? pict-path? (values number? number?))
pict-path? (-> pict? pict-path? (values number? number?)))
@ -107,7 +108,7 @@
(make-pict (pict-draw naya)
w h
a d
(list (make-child box 0 0 1 1))
(list (make-child box 0 0 1 1 0 0))
#f
(pict-last box))))
@ -974,11 +975,44 @@
(pict-height new)
(pict-ascent new)
(pict-descent new)
(list (make-child p 0 0 x-factor y-factor))
(list (make-child p 0 0 x-factor y-factor 0 0))
#f
(pict-last p))))]
[(p factor) (scale p factor factor)]))
(define (rotate p theta)
(let ([w (pict-width p)]
[h (pict-height p)]
[drawer (make-pict-drawer p)])
(let ([dl (min 0 (* w (cos theta)) (* h (sin theta)) (+ (* w (cos theta)) (* h (sin theta))))]
[dr (max 0 (* w (cos theta)) (* h (sin theta)) (+ (* w (cos theta)) (* h (sin theta))))]
[dt (min 0 (* w -1 (sin theta)) (* h (cos theta)) (+ (* w -1 (sin theta)) (* h (cos theta))))]
[db (max 0 (* w -1 (sin theta)) (* h (cos theta)) (+ (* w -1 (sin theta)) (* h (cos theta))))]
[da (- (* (pict-ascent p) (cos theta)) (* (sin theta) w 1/2))]
[dd (- (* (- (pict-height p) (pict-descent p)) (cos theta)) (* (sin theta) w 1/2))])
(let ([new (dc
(lambda (dc x y)
(let ([t (send dc get-transformation)])
(send dc translate (- x dl) (- y dt))
(send dc rotate theta)
(drawer dc 0 0)
(send dc set-transformation t)))
(- dr dl) (- db dt)
(min (- da dt) (- (- db dt) (- db dd)))
(min (- db da) (- db dd)))])
(make-pict (pict-draw new)
(pict-width new)
(pict-height new)
(pict-ascent new)
(pict-descent new)
(list (make-child p
(- (* h (sin theta)) dl)
(max 0 (- db (* h (cos theta))))
(cos theta) (cos theta)
(sin theta) (- (sin theta))))
#f
(pict-last p))))))
(define cellophane
(case-lambda
[(p alpha-factor)
@ -1005,7 +1039,7 @@
(pict-height new)
(pict-ascent new)
(pict-descent new)
(list (make-child p 0 0 1 1))
(list (make-child p 0 0 1 1 0 0))
#f
(pict-last p))))])]))
@ -1033,7 +1067,7 @@
(pict-height new)
(pict-ascent new)
(pict-descent new)
(list (make-child p 0 0 1 1))
(list (make-child p 0 0 1 1 0 0))
#f
(pict-last p))))]
[(p h v) (inset/clip p h v h v)]

9
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,7 @@
Version 5.1.1.8
slideshow/pict: added rotate function, and added sxy anf syx
fields to a child structure
Version 5.1.1.7
Replaced syntax certificates with syntax taints:
Added syntax-tainted?, syntax-arm, syntax-disarm, syntax-rearm,
@ -8,6 +12,8 @@ Replaced syntax certificates with syntax taints:
syntax-protect implicitly
Changed the way inspectors are associated to syntax objects
and variable references in compiled code
compiler/zo-struct: removed certificate structures; changed
wrapper to have a tamper-status field instead of certs
Version 5.1.1.2
Changed "sequence" to include exact nonnegative integers
@ -25,7 +31,8 @@ mzlib/contract: removed following (undocumented) exports:
opt-contract/info-id
synthesized-value
unknown?
compiler/zo-struct: added toplevel-map field to lam
Version 5.1.1, May 2011
Enabled single-precision floats by default
Added single-flonum?