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

changed the internal representation of normalized images so that crop structs do no have to be duplicated, improved test suites

Browse Source 
svn: r17808

original commit: cf4294a28033788548f0057410b373f5f72b7c36
This commit is contained in:
Robby Findler 2010-01-24 20:22:58 +00:00
parent 87f4078b25
commit bb31704278
1 changed files with 64 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
collects/mrlib/image-core.ss
View File

@ -1,5 +1,4 @@
#lang scheme/base
#|
This library is the part of the 2htdp/image
@ -157,12 +156,12 @@ has been moved out).
(define-struct/reg-mk curve-segment (start s-angle s-pull end e-angle e-pull color) #:transparent #:omit-define-syntaxes)
;; a normalized-shape (subtype of shape) is either
;; - (make-overlay normalized-shape cropped-simple-shape)
;; - cropped-simple-shape
;; - (make-overlay normalized-shape cn-or-simple-shape)
;; - cn-or-simple-shape
;; a cropped-simple-shape is either
;; - (make-crop (listof points) cropped-simple-shape)
;; an cn-or-simple-shape is either:
;; - simple-shape
;; - (make-crop (listof points) normalized-shape)
;; a simple-shape (subtype of shape) is
;; - (make-translate dx dy np-atomic-shape))
@ -378,25 +377,10 @@ has been moved out).
[dy 0]
[x-scale 1]
[y-scale 1]
[crops '()] ;; (listof (listof point))
[bottom #f])
(define (scale-point p)
(make-point (+ dx (* x-scale (point-x p)))
(+ dy (* y-scale (point-y p)))))
(define (add-crops shape)
(let loop ([crops crops])
(cond
[(null? crops) shape]
[(null? (cdr crops))
(make-crop (car crops) shape)]
[else
(let ([fst (car crops)]
[snd (cadr crops)])
(cond
[(equal? fst snd)
(loop (cdr crops))]
[else
(make-crop (car crops) (loop (cdr crops)))]))])))
(cond
[(translate? shape)
(loop (translate-shape shape)
@ -404,7 +388,6 @@ has been moved out).
(+ dy (* y-scale (translate-dy shape)))
x-scale
y-scale
crops
bottom)]
[(scale? shape)
(loop (scale-shape shape)
@ -412,34 +395,36 @@ has been moved out).
dy
(* x-scale (scale-x shape))
(* y-scale (scale-y shape))
crops
bottom)]
[(overlay? shape)
(loop (overlay-bottom shape)
dx dy x-scale y-scale crops
dx dy x-scale y-scale
(loop (overlay-top shape)
dx dy x-scale y-scale crops
dx dy x-scale y-scale
bottom))]
[(crop? shape)
(loop (crop-shape shape)
dx dy x-scale y-scale
(cons (map scale-point (crop-points shape)) crops)
bottom)]
(let* ([inside (loop (crop-shape shape)
dx dy x-scale y-scale
#f)]
[this-one
(make-crop (map scale-point (crop-points shape))
inside)])
(if bottom
(make-overlay bottom this-one)
this-one))]
[(polygon? shape)
(let* ([this-one
(add-crops
(make-polygon (map scale-point (polygon-points shape))
(polygon-mode shape)
(scale-color (polygon-color shape) x-scale y-scale)))])
(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 (f this-one))
(f this-one)))]
[(line-segment? shape)
(let ([this-one
(add-crops
(make-line-segment (scale-point (line-segment-start shape))
(scale-point (line-segment-end shape))
(scale-color (line-segment-color shape) x-scale y-scale)))])
(make-line-segment (scale-point (line-segment-start shape))
(scale-point (line-segment-end shape))
(scale-color (line-segment-color shape) x-scale y-scale))])
(if bottom
(make-overlay bottom (f this-one))
(f this-one)))]
@ -448,27 +433,40 @@ has been moved out).
;; between the two points when it is drawn,
;; so we don't need to scale it here
(let ([this-one
(add-crops
(make-curve-segment (scale-point (curve-segment-start shape))
(curve-segment-s-angle shape)
(curve-segment-s-pull shape)
(scale-point (curve-segment-end shape))
(curve-segment-e-angle shape)
(curve-segment-e-pull shape)
(scale-color (curve-segment-color shape) x-scale y-scale)))])
(make-curve-segment (scale-point (curve-segment-start shape))
(curve-segment-s-angle shape)
(curve-segment-s-pull shape)
(scale-point (curve-segment-end shape))
(curve-segment-e-angle shape)
(curve-segment-e-pull shape)
(scale-color (curve-segment-color shape) x-scale y-scale))])
(if bottom
(make-overlay bottom (f this-one))
(f this-one)))]
[(np-atomic-shape? shape)
(let ([this-one
(add-crops
(make-translate dx dy (scale-np-atomic x-scale y-scale shape)))])
(make-translate dx dy (scale-np-atomic x-scale y-scale shape))])
(if bottom
(make-overlay bottom (f this-one))
(f this-one)))]
[else
(error 'normalize-shape "unknown shape ~s\n" shape)])))
(define (normalized-shape? s)
(cond
[(overlay? s)
(and (normalized-shape? (overlay-top s))
(cn-or-simple-shape? (overlay-bottom s)))]
[else
(cn-or-simple-shape? s)]))
(define (cn-or-simple-shape? s)
(cond
[(crop? s)
(normalized-shape? (crop-shape s))]
[else
(simple-shape? s)]))
(define (simple-shape? shape)
(or (and (translate? shape)
(np-atomic-shape? (translate-shape shape)))
@ -564,22 +562,30 @@ has been moved out).
(define (render-normalized-shape shape dc dx dy)
(cond
[(overlay? shape)
(render-cropped-simple-shape (overlay-bottom shape) dc dx dy)
(render-cn-or-simple-shape (overlay-bottom shape) dc dx dy)
(render-normalized-shape (overlay-top shape) dc dx dy)]
[else
(render-cropped-simple-shape shape dc dx dy)]))
(render-cn-or-simple-shape shape dc dx dy)]))
(define (render-cropped-simple-shape shape dc dx dy)
(define last-cropped-points (make-parameter #f))
(define (render-cn-or-simple-shape shape dc dx dy)
(cond
[(crop? shape)
(let ([old-region (send dc get-clipping-region)]
[new-region (new region% [dc dc])]
[path (polygon-points->path (crop-points shape))])
(send new-region set-path path dx dy)
(when old-region (send new-region intersect old-region))
(send dc set-clipping-region new-region)
(render-cropped-simple-shape (crop-shape shape) dc dx dy)
(send dc set-clipping-region old-region))]
(let ([points (crop-points shape)])
(cond
[(equal? points (last-cropped-points))
(render-normalized-shape (crop-shape shape) dc dx dy)]
[else
(let ([old-region (send dc get-clipping-region)]
[new-region (new region% [dc dc])]
[path (polygon-points->path points)])
(send new-region set-path path dx dy)
(when old-region (send new-region intersect old-region))
(send dc set-clipping-region new-region)
(parameterize ([last-cropped-points points])
(render-normalized-shape (crop-shape shape) dc dx dy))
(send dc set-clipping-region old-region))]))]
[else
(render-simple-shape shape dc dx dy)]))
@ -941,4 +947,4 @@ the mask bitmap and the original bitmap are all together in a single bytes!
;; method names
(provide get-shape get-bb get-normalized? get-normalized-shape)
(provide np-atomic-shape? atomic-shape? simple-shape?)
(provide np-atomic-shape? atomic-shape? simple-shape? cn-or-simple-shape? normalized-shape?)