add pulled-point to 2htdp/image's core
This commit is contained in:
Robby Findler
parent
5a126f552e
commit
7a3c102d1c
|
|
@ -30,4 +30,4 @@
|
|||
|
||||
(define pkg-authors '(mflatt robby))
|
||||
|
||||
(define version "1.6")
|
||||
(define version "1.7")
|
||||
|
|
|
|||
|
|
@ -10,24 +10,14 @@ work right.
|
|||
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 does not depend on
|
||||
does (and any code that does not depend on that
|
||||
has been moved out).
|
||||
|
||||
|
||||
-- in the middle of text:
|
||||
|
||||
- bounding boxes
|
||||
- rotating (and bounding boxes)
|
||||
- hbl append(?)
|
||||
- this doesn't work (how to test?)
|
||||
(beside/places "baseline"
|
||||
(text "ijy" 12 'black)
|
||||
(text "ijy" 24 'black))
|
||||
- /places => /align
|
||||
|
||||
|#
|
||||
|
||||
(require racket/class
|
||||
racket/list
|
||||
racket/match
|
||||
(except-in racket/draw
|
||||
make-pen make-color)
|
||||
(for-syntax racket/base)
|
||||
|
|
@ -213,6 +203,17 @@ has been moved out).
|
|||
(λ (r g b [a 255])
|
||||
(make-color r g b a))])
|
||||
make-color))
|
||||
|
||||
|
||||
;; a pulled-point is
|
||||
;; - (make-pulled-point real real real real real real)
|
||||
(define-struct/reg-mk pulled-point (lpull langle x y rpull rangle) #:transparent)
|
||||
(define (build-pulled-point lpull langle x y rpull rangle)
|
||||
(make-pulled-point lpull
|
||||
(if (zero? lpull) 0 langle)
|
||||
x y
|
||||
rpull
|
||||
(if (zero? rpull) 0 rangle)))
|
||||
;
|
||||
;
|
||||
;
|
||||
|
|
@ -336,8 +337,8 @@ has been moved out).
|
|||
(or (and (not (skip-image-equality-fast-path)) ;; this makes testing more effective
|
||||
(equal? (get-normalized-shape) (send that get-normalized-shape)))
|
||||
|
||||
;; some shapes (ie, rectangles) draw 1 outside the bounding box
|
||||
;; so we make the bitmap slightly bigger to accommodate that.
|
||||
;; some shapes (ie, outline rectangles with a 1 pixel edge) draw 1 outside
|
||||
;; the bounding box so we make the bitmap slightly bigger to accommodate that.
|
||||
(let ([w (+ 1 (round (inexact->exact (bb-right bb))))]
|
||||
[h (+ 1 (round (inexact->exact (bb-bottom bb))))])
|
||||
(or ;(zero? w)
|
||||
|
|
@ -536,6 +537,22 @@ has been moved out).
|
|||
[arg-count (length args)]
|
||||
[parsed-args (map loop args)])
|
||||
(cond
|
||||
[(and constructor
|
||||
(procedure-arity-includes? constructor arg-count)
|
||||
(equal? tag 'struct:polygon))
|
||||
(define points (list-ref parsed-args 0))
|
||||
;; in older versions, polygons had points as the
|
||||
;; first argument, but now they have pulled-points
|
||||
(define adjusted-points
|
||||
(for/list ([p (in-list points)])
|
||||
(cond
|
||||
[(point? p)
|
||||
(make-pulled-point 0 0
|
||||
(point-x p)
|
||||
(point-y p)
|
||||
0 0)]
|
||||
[else p])))
|
||||
(apply constructor adjusted-points (cdr parsed-args))]
|
||||
[(and constructor (procedure-arity-includes? constructor arg-count))
|
||||
(apply constructor parsed-args)]
|
||||
[(and (eq? tag 'struct:bitmap)
|
||||
|
|
@ -635,6 +652,13 @@ has been moved out).
|
|||
(define (scale-point p)
|
||||
(make-point (+ dx (* x-scale (point-x p)))
|
||||
(+ dy (* y-scale (point-y p)))))
|
||||
(define (scale-pulled-point p)
|
||||
(make-pulled-point (pulled-point-lpull p)
|
||||
(pulled-point-langle p)
|
||||
(+ dx (* x-scale (pulled-point-x p)))
|
||||
(+ dy (* y-scale (pulled-point-y p)))
|
||||
(pulled-point-rpull p)
|
||||
(pulled-point-rangle p)))
|
||||
(cond
|
||||
[(translate? shape)
|
||||
(loop (translate-shape shape)
|
||||
|
|
@ -667,13 +691,13 @@ has been moved out).
|
|||
(make-overlay bottom this-one)
|
||||
this-one))]
|
||||
[(polygon? shape)
|
||||
(let* ([this-one
|
||||
(make-polygon (map scale-point (polygon-points shape))
|
||||
(polygon-mode shape)
|
||||
(scale-color (polygon-color shape) x-scale y-scale))])
|
||||
(if bottom
|
||||
(make-overlay bottom this-one)
|
||||
this-one))]
|
||||
(define this-one
|
||||
(make-polygon (map scale-pulled-point (polygon-points shape))
|
||||
(polygon-mode shape)
|
||||
(scale-color (polygon-color shape) x-scale y-scale)))
|
||||
(if bottom
|
||||
(make-overlay bottom this-one)
|
||||
this-one)]
|
||||
[(line-segment? shape)
|
||||
(let ([this-one
|
||||
(make-line-segment (scale-point (line-segment-start shape))
|
||||
|
|
@ -883,6 +907,13 @@ has been moved out).
|
|||
(define (scale-point p)
|
||||
(make-point (* x-scale (point-x p))
|
||||
(* y-scale (point-y p))))
|
||||
(define (scale-pulled-point p)
|
||||
(make-pulled-point (pulled-point-lpull p)
|
||||
(pulled-point-langle p)
|
||||
(* x-scale (pulled-point-x p))
|
||||
(* y-scale (pulled-point-y p))
|
||||
(pulled-point-rpull p)
|
||||
(pulled-point-rangle p)))
|
||||
(cond
|
||||
[(translate? shape)
|
||||
(loop (translate-shape shape)
|
||||
|
|
@ -905,11 +936,11 @@ has been moved out).
|
|||
(crop-shape shape)
|
||||
(λ (s) (loop s dx dy x-scale y-scale)) dc dx dy)]
|
||||
[(polygon? shape)
|
||||
(let* ([this-one
|
||||
(make-polygon (map scale-point (polygon-points shape))
|
||||
(polygon-mode shape)
|
||||
(scale-color (polygon-color shape) x-scale y-scale))])
|
||||
(render-poly/line-segment/curve-segment this-one dc dx dy))]
|
||||
(define this-one
|
||||
(make-polygon (map scale-pulled-point (polygon-points shape))
|
||||
(polygon-mode shape)
|
||||
(scale-color (polygon-color shape) x-scale y-scale)))
|
||||
(render-poly/line-segment/curve-segment this-one dc dx dy)]
|
||||
[(line-segment? shape)
|
||||
(let ([this-one
|
||||
(make-line-segment (scale-point (line-segment-start shape))
|
||||
|
|
@ -945,7 +976,7 @@ has been moved out).
|
|||
[(polygon? simple-shape)
|
||||
(let ([mode (polygon-mode simple-shape)]
|
||||
[color (polygon-color simple-shape)]
|
||||
[path (polygon-points->path (polygon-points simple-shape))])
|
||||
[path (polygon-pulled-points->path (polygon-points simple-shape))])
|
||||
(send dc set-pen (mode-color->pen mode color))
|
||||
(send dc set-brush (mode-color->brush mode color))
|
||||
(send dc set-smoothing (mode-color->smoothing mode color))
|
||||
|
|
@ -1067,46 +1098,78 @@ has been moved out).
|
|||
(imag-part p)
|
||||
#f 0 θ))))]))
|
||||
|
||||
(define (polygon-points->path points)
|
||||
(let ([path (new dc-path%)])
|
||||
(send path move-to (point-x (car points)) (point-y (car points)))
|
||||
(let loop ([points (cdr points)])
|
||||
(unless (null? points)
|
||||
(send path line-to
|
||||
(point-x (car points))
|
||||
(point-y (car points)))
|
||||
(loop (cdr points))))
|
||||
(send path close)
|
||||
;(send path line-to (round (point-x (car points))) (round (point-y (car points))))
|
||||
path))
|
||||
(define (polygon-pulled-points->path pulled-points)
|
||||
(define path (new dc-path%))
|
||||
(define first-point (car pulled-points))
|
||||
(send path move-to (pulled-point-x first-point) (pulled-point-y first-point))
|
||||
(let loop ([prev-point (car pulled-points)]
|
||||
[pulled-points (cdr pulled-points)])
|
||||
(define this-point (if (null? pulled-points)
|
||||
first-point
|
||||
(car pulled-points)))
|
||||
(match-define (pulled-point slpull slangle sx sy srpull srangle) prev-point)
|
||||
(match-define (pulled-point elpull elangle ex ey erpull erangle) this-point)
|
||||
(define vec (- (make-rectangular ex ey) (make-rectangular sx sy)))
|
||||
(define sa (degrees->radians srangle))
|
||||
(define ea (degrees->radians elangle))
|
||||
(define p1 (* vec (make-polar srpull sa)))
|
||||
(define p2 (* (- vec) (make-polar elpull ea)))
|
||||
|
||||
(send path curve-to
|
||||
(+ sx (real-part p1))
|
||||
(+ sy (imag-part p1))
|
||||
(+ ex (real-part p2))
|
||||
(+ ey (imag-part p2))
|
||||
ex
|
||||
ey)
|
||||
(unless (null? pulled-points)
|
||||
(loop (car pulled-points) (cdr pulled-points))))
|
||||
(send path close)
|
||||
path)
|
||||
|
||||
(define (points->bb-path points)
|
||||
(let ([path (new dc-path%)])
|
||||
(let-values ([(left top right bottom) (points->ltrb-values points)])
|
||||
(send path move-to left top)
|
||||
(send path line-to right top)
|
||||
(send path line-to right bottom)
|
||||
(send path line-to left bottom)
|
||||
(send path line-to left top)
|
||||
path)))
|
||||
(define (polygon-points->path points)
|
||||
(define path (new dc-path%))
|
||||
(send path move-to (point-x (car points)) (point-y (car points)))
|
||||
(let loop ([points (cdr points)])
|
||||
(unless (null? points)
|
||||
(define pt (car points))
|
||||
(send path line-to (point-x pt) (point-y pt))
|
||||
(loop (cdr points))))
|
||||
(send path close)
|
||||
path)
|
||||
|
||||
;; points->ltrb-values : (cons point (listof points)) -> (values number number number number)
|
||||
(define (points->ltrb-values points)
|
||||
(let* ([fx (point-x (car points))]
|
||||
[fy (point-y (car points))]
|
||||
[left fx]
|
||||
[top fy]
|
||||
[right fx]
|
||||
[bottom fy])
|
||||
(for-each (λ (point)
|
||||
(let ([new-x (point-x point)]
|
||||
[new-y (point-y point)])
|
||||
(set! left (min new-x left))
|
||||
(set! top (min new-y top))
|
||||
(set! right (max new-x right))
|
||||
(set! bottom (max new-y bottom))))
|
||||
(cdr points))
|
||||
(values left top right bottom)))
|
||||
(unless (and (list? points)
|
||||
(pair? points)
|
||||
(andmap (or/c point? pulled-point?) points))
|
||||
(raise-argument-error 'points->ltrb-values
|
||||
"(non-empty-listof (or/c point? pulled-point?))"
|
||||
0 points))
|
||||
(define fx (pp->x (car points)))
|
||||
(define fy (pp->y (car points)))
|
||||
(define left fx)
|
||||
(define top fy)
|
||||
(define right fx)
|
||||
(define bottom fy)
|
||||
(for ([point (in-list (cdr points))])
|
||||
(define new-x (pp->x point))
|
||||
(define new-y (pp->y point))
|
||||
(set! left (min new-x left))
|
||||
(set! top (min new-y top))
|
||||
(set! right (max new-x right))
|
||||
(set! bottom (max new-y bottom)))
|
||||
(values left top right bottom))
|
||||
|
||||
(define (pp->x p)
|
||||
(if (pulled-point? p)
|
||||
(pulled-point-x p)
|
||||
(point-x p)))
|
||||
|
||||
(define (pp->y p)
|
||||
(if (pulled-point? p)
|
||||
(pulled-point-y p)
|
||||
(point-y p)))
|
||||
|
||||
#|
|
||||
|
||||
|
|
@ -1335,7 +1398,7 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
|||
(let-values ([(w h) (if (is-a? is cis:cache-image-snip%)
|
||||
(send is get-size)
|
||||
(values 0 0))])
|
||||
(make-image (make-polygon
|
||||
(make-image (construct-polygon
|
||||
(list (make-point 0 0)
|
||||
(make-point w 0)
|
||||
(make-point w h)
|
||||
|
|
@ -1348,6 +1411,19 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
|||
(or (send is get-bitmap-mask)
|
||||
(send bm get-loaded-mask)))])))
|
||||
|
||||
(define (construct-polygon points mode color)
|
||||
(make-polygon
|
||||
(for/list ([prev (in-list (cons (last points) points))]
|
||||
[p (in-list points)]
|
||||
[next (in-list (append (cdr points) (list (car points))))])
|
||||
(cond
|
||||
[(point? p)
|
||||
(define x (point-x p))
|
||||
(define y (point-y p))
|
||||
(make-pulled-point 0 0 x y 0 0)]
|
||||
[else p]))
|
||||
mode color))
|
||||
|
||||
(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
|
||||
(define w (send bm get-width))
|
||||
(define h (send bm get-height))
|
||||
|
|
@ -1394,7 +1470,7 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
|||
un/cache-image compute-image-cache
|
||||
|
||||
(struct-out bb)
|
||||
(struct-out point)
|
||||
(struct-out point) (struct-out pulled-point) build-pulled-point
|
||||
make-overlay overlay? overlay-top overlay-bottom
|
||||
make-translate translate? translate-dx translate-dy translate-shape
|
||||
make-scale scale? scale-x scale-y scale-shape
|
||||
|
|
@ -1402,7 +1478,9 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
|||
make-ellipse ellipse? ellipse-width ellipse-height ellipse-angle ellipse-mode ellipse-color
|
||||
make-text text? text-string text-angle text-y-scale text-color
|
||||
text-angle text-size text-face text-family text-style text-weight text-underline
|
||||
make-polygon polygon? polygon-points polygon-mode polygon-color
|
||||
(contract-out [rename construct-polygon make-polygon
|
||||
(-> (listof (or/c point? pulled-point?)) any/c any/c polygon?)])
|
||||
polygon? polygon-points polygon-mode polygon-color
|
||||
make-line-segment line-segment? line-segment-start line-segment-end line-segment-color
|
||||
make-curve-segment curve-segment?
|
||||
curve-segment-start curve-segment-s-angle curve-segment-s-pull
|
||||
|
|
@ -1450,4 +1528,3 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
|||
(provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape)
|
||||
|
||||
(provide np-atomic-shape? atomic-shape? simple-shape? cn-or-simple-shape? normalized-shape?)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user