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

add pulled-point to 2htdp/image's core

Browse Source
This commit is contained in:
Robby Findler 2015-02-01 14:39:01 -06:00
parent 5a126f552e
commit 7a3c102d1c
2 changed files with 146 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gui-lib/info.rkt
View File

@ -30,4 +30,4 @@
(define pkg-authors '(mflatt robby)) (define pkg-authors '(mflatt robby))
(define version "1.6") (define version "1.7")

213
gui-lib/mrlib/image-core.rkt
View File

@ -10,24 +10,14 @@ work right.
Most of the exports are just for use in 2htdp/image Most of the exports are just for use in 2htdp/image
(technically, 2htdp/private/image-more). The main (technically, 2htdp/private/image-more). The main
use of this library is the snip class addition it 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). 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 (require racket/class
racket/list
racket/match
(except-in racket/draw (except-in racket/draw
make-pen make-color) make-pen make-color)
(for-syntax racket/base) (for-syntax racket/base)
@ -213,6 +203,17 @@ has been moved out).
(λ (r g b [a 255]) (λ (r g b [a 255])
(make-color r g b a))]) (make-color r g b a))])
make-color)) 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 (or (and (not (skip-image-equality-fast-path)) ;; this makes testing more effective
(equal? (get-normalized-shape) (send that get-normalized-shape))) (equal? (get-normalized-shape) (send that get-normalized-shape)))
;; some shapes (ie, rectangles) draw 1 outside the bounding box ;; some shapes (ie, outline rectangles with a 1 pixel edge) draw 1 outside
;; so we make the bitmap slightly bigger to accommodate that. ;; the bounding box so we make the bitmap slightly bigger to accommodate that.
(let ([w (+ 1 (round (inexact->exact (bb-right bb))))] (let ([w (+ 1 (round (inexact->exact (bb-right bb))))]
[h (+ 1 (round (inexact->exact (bb-bottom bb))))]) [h (+ 1 (round (inexact->exact (bb-bottom bb))))])
(or ;(zero? w) (or ;(zero? w)
@ -536,6 +537,22 @@ has been moved out).
[arg-count (length args)] [arg-count (length args)]
[parsed-args (map loop args)]) [parsed-args (map loop args)])
(cond (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)) [(and constructor (procedure-arity-includes? constructor arg-count))
(apply constructor parsed-args)] (apply constructor parsed-args)]
[(and (eq? tag 'struct:bitmap) [(and (eq? tag 'struct:bitmap)
@ -635,6 +652,13 @@ has been moved out).
(define (scale-point p) (define (scale-point p)
(make-point (+ dx (* x-scale (point-x p))) (make-point (+ dx (* x-scale (point-x p)))
(+ dy (* y-scale (point-y 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 (cond
[(translate? shape) [(translate? shape)
(loop (translate-shape shape) (loop (translate-shape shape)
@ -667,13 +691,13 @@ has been moved out).
(make-overlay bottom this-one) (make-overlay bottom this-one)
this-one))] this-one))]
[(polygon? shape) [(polygon? shape)
(let* ([this-one (define this-one
(make-polygon (map scale-point (polygon-points shape)) (make-polygon (map scale-pulled-point (polygon-points shape))
(polygon-mode shape) (polygon-mode shape)
(scale-color (polygon-color shape) x-scale y-scale))]) (scale-color (polygon-color shape) x-scale y-scale)))
(if bottom (if bottom
(make-overlay bottom this-one) (make-overlay bottom this-one)
this-one))] this-one)]
[(line-segment? shape) [(line-segment? shape)
(let ([this-one (let ([this-one
(make-line-segment (scale-point (line-segment-start shape)) (make-line-segment (scale-point (line-segment-start shape))
@ -883,6 +907,13 @@ has been moved out).
(define (scale-point p) (define (scale-point p)
(make-point (* x-scale (point-x p)) (make-point (* x-scale (point-x p))
(* y-scale (point-y 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 (cond
[(translate? shape) [(translate? shape)
(loop (translate-shape shape) (loop (translate-shape shape)
@ -905,11 +936,11 @@ has been moved out).
(crop-shape shape) (crop-shape shape)
(λ (s) (loop s dx dy x-scale y-scale)) dc dx dy)] (λ (s) (loop s dx dy x-scale y-scale)) dc dx dy)]
[(polygon? shape) [(polygon? shape)
(let* ([this-one (define this-one
(make-polygon (map scale-point (polygon-points shape)) (make-polygon (map scale-pulled-point (polygon-points shape))
(polygon-mode shape) (polygon-mode shape)
(scale-color (polygon-color shape) x-scale y-scale))]) (scale-color (polygon-color shape) x-scale y-scale)))
(render-poly/line-segment/curve-segment this-one dc dx dy))] (render-poly/line-segment/curve-segment this-one dc dx dy)]
[(line-segment? shape) [(line-segment? shape)
(let ([this-one (let ([this-one
(make-line-segment (scale-point (line-segment-start shape)) (make-line-segment (scale-point (line-segment-start shape))
@ -945,7 +976,7 @@ has been moved out).
[(polygon? simple-shape) [(polygon? simple-shape)
(let ([mode (polygon-mode simple-shape)] (let ([mode (polygon-mode simple-shape)]
[color (polygon-color 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-pen (mode-color->pen mode color))
(send dc set-brush (mode-color->brush mode color)) (send dc set-brush (mode-color->brush mode color))
(send dc set-smoothing (mode-color->smoothing mode color)) (send dc set-smoothing (mode-color->smoothing mode color))
@ -1067,46 +1098,78 @@ has been moved out).
(imag-part p) (imag-part p)
#f 0 θ))))])) #f 0 θ))))]))
(define (polygon-points->path points) (define (polygon-pulled-points->path pulled-points)
(let ([path (new dc-path%)]) (define path (new dc-path%))
(send path move-to (point-x (car points)) (point-y (car points))) (define first-point (car pulled-points))
(let loop ([points (cdr points)]) (send path move-to (pulled-point-x first-point) (pulled-point-y first-point))
(unless (null? points) (let loop ([prev-point (car pulled-points)]
(send path line-to [pulled-points (cdr pulled-points)])
(point-x (car points)) (define this-point (if (null? pulled-points)
(point-y (car points))) first-point
(loop (cdr points)))) (car pulled-points)))
(send path close) (match-define (pulled-point slpull slangle sx sy srpull srangle) prev-point)
;(send path line-to (round (point-x (car points))) (round (point-y (car points)))) (match-define (pulled-point elpull elangle ex ey erpull erangle) this-point)
path)) (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) (define (polygon-points->path points)
(let ([path (new dc-path%)]) (define path (new dc-path%))
(let-values ([(left top right bottom) (points->ltrb-values points)]) (send path move-to (point-x (car points)) (point-y (car points)))
(send path move-to left top) (let loop ([points (cdr points)])
(send path line-to right top) (unless (null? points)
(send path line-to right bottom) (define pt (car points))
(send path line-to left bottom) (send path line-to (point-x pt) (point-y pt))
(send path line-to left top) (loop (cdr points))))
path))) (send path close)
path)
;; points->ltrb-values : (cons point (listof points)) -> (values number number number number) ;; points->ltrb-values : (cons point (listof points)) -> (values number number number number)
(define (points->ltrb-values points) (define (points->ltrb-values points)
(let* ([fx (point-x (car points))] (unless (and (list? points)
[fy (point-y (car points))] (pair? points)
[left fx] (andmap (or/c point? pulled-point?) points))
[top fy] (raise-argument-error 'points->ltrb-values
[right fx] "(non-empty-listof (or/c point? pulled-point?))"
[bottom fy]) 0 points))
(for-each (λ (point) (define fx (pp->x (car points)))
(let ([new-x (point-x point)] (define fy (pp->y (car points)))
[new-y (point-y point)]) (define left fx)
(set! left (min new-x left)) (define top fy)
(set! top (min new-y top)) (define right fx)
(set! right (max new-x right)) (define bottom fy)
(set! bottom (max new-y bottom)))) (for ([point (in-list (cdr points))])
(cdr points)) (define new-x (pp->x point))
(values left top right bottom))) (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%) (let-values ([(w h) (if (is-a? is cis:cache-image-snip%)
(send is get-size) (send is get-size)
(values 0 0))]) (values 0 0))])
(make-image (make-polygon (make-image (construct-polygon
(list (make-point 0 0) (list (make-point 0 0)
(make-point w 0) (make-point w 0)
(make-point w h) (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) (or (send is get-bitmap-mask)
(send bm get-loaded-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 (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
(define w (send bm get-width)) (define w (send bm get-width))
(define h (send bm get-height)) (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 un/cache-image compute-image-cache
(struct-out bb) (struct-out bb)
(struct-out point) (struct-out point) (struct-out pulled-point) build-pulled-point
make-overlay overlay? overlay-top overlay-bottom make-overlay overlay? overlay-top overlay-bottom
make-translate translate? translate-dx translate-dy translate-shape make-translate translate? translate-dx translate-dy translate-shape
make-scale scale? scale-x scale-y scale-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-ellipse ellipse? ellipse-width ellipse-height ellipse-angle ellipse-mode ellipse-color
make-text text? text-string text-angle text-y-scale text-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 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-line-segment line-segment? line-segment-start line-segment-end line-segment-color
make-curve-segment curve-segment? make-curve-segment curve-segment?
curve-segment-start curve-segment-s-angle curve-segment-s-pull 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 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?) (provide np-atomic-shape? atomic-shape? simple-shape? cn-or-simple-shape? normalized-shape?)