From 1f02106318edba9c011afaf24d6ef34a3081c9ff Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 22 Aug 2011 18:36:33 -0500 Subject: [PATCH] 2htdp/image normalize the internal representation of bitmaps so it always uses an alpha bitmap instead of sometimes using a mask bitmap and sometimes using alpha. This also fixes a bug where the library would get consfused when it saved a bitmap to a file, since it didn't record if it was an alpha bitmap or not. This improves the save files that contain images, cutting the size for bitmaps in half (bringing the drracket save file down to a mere 25x larger than the png file format for the example I was using...) --- collects/2htdp/private/image-more.rkt | 3 +- collects/2htdp/tests/test-image.rkt | 17 +++ collects/2htdp/tests/u.png | Bin 0 -> 3485 bytes collects/mrlib/image-core.rkt | 162 ++++++++++++++------------ 4 files changed, 107 insertions(+), 75 deletions(-) create mode 100644 collects/2htdp/tests/u.png diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index 092d271620..2bafea6776 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/collects/2htdp/private/image-more.rkt @@ -734,7 +734,6 @@ [flipped? (flip-flipped? atomic-shape)]) (make-flip flipped? (make-ibitmap (ibitmap-raw-bitmap bitmap) - (ibitmap-raw-mask bitmap) (bring-between (if flipped? (+ (ibitmap-angle bitmap) θ) (- (ibitmap-angle bitmap) θ)) @@ -1297,7 +1296,7 @@ (not (file-exists? arg))) (error 'bitmap "could not find the file ~a" (path->string arg))) ;; the rotate does a coercion to a 2htdp/image image - (rotate 0 (make-object image-snip% (make-object bitmap% arg 'unknown/mask)))) + (rotate 0 (make-object image-snip% (make-object bitmap% arg 'unknown/alpha)))) (define/chk (bitmap/url string) ;; the rotate does a coercion to a 2htdp/image image diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index c5e9df09a5..dc3f002c61 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/collects/2htdp/tests/test-image.rkt @@ -45,6 +45,7 @@ mrlib/private/image-core-bitmap lang/posn racket/math + racket/runtime-path racket/class racket/file racket/gui/base @@ -1391,6 +1392,22 @@ (test (equal? (rotate 0 i1) i2) => #t) (test (equal? i1 (rotate 0 i2)) => #t)) +(define-runtime-path u.png "u.png") +(let () + (define i (rotate 0 (make-object bitmap% u.png 'unknown/mask))) + (define t (new text%)) + (send t insert i) + (define bop (open-output-bytes)) + (void (send t save-port bop)) + (define bip (open-input-bytes (get-output-bytes bop))) + (define t2 (new text%)) + (void (send t2 insert-port bip)) + (test (equal? (send t find-first-snip) + (send t2 find-first-snip)) + => + #t)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; cropping (and place-image) diff --git a/collects/2htdp/tests/u.png b/collects/2htdp/tests/u.png new file mode 100644 index 0000000000000000000000000000000000000000..b07f4d5ba0f173716b537afa6d0fae838d470654 GIT binary patch literal 3485 zcmV;O4Px?%P)002b@1^@s60z?~{00006VoOIv0RI60 z0RN!9r;`8x4N^%&K~#90?VMR~9LIf!zwYVT8;b?CAVmQSGNPHH1X9j}A}6ZIsyv7) z#VHfKl!_gNsiG`7FL_A0qBuvn@{pr)JjgG3i5?_MrBI*%QdWFLcIdJ~T8tP|k}1n6 zkrr_g5I~5)Vy~I$?mWycZiu@$r7HZYrdSyE^!)nk|Mc`VE84bg`yoR9wjcO99#1%6 z0l|987)`lUHj!vV2F6?-85#N99k*})xqw^{1SS@b%XKwWmDZX{xvZnnsAG)&FJ%E& zDF%nHZ-k#|rJ^xnu^3^YGM~`y+_;GyCTURquN*twl z=9y>c?(Qa+%K;E`V*GO810FwqoTHCEN~Ka+w|KYK;<_$=5b*TV-{kclyvFTq9Vj;% z1z^{%T|E5o!|P;cuKEWCX-YQ(;8xGcxC6lM-MiVpfB%N~dhZwiN2aBP3g9S#s{M!2 z8i309IHN!M5z=+B)~=};X$=!wvb>vHrhY9Yfc&3+4dWZHCQ(;y~U*?M~JMG zugQP<7gXooIX6={wG^RS={QJ0u7fE6Hx@%h+$HZNHpo{b7Q<0$9;}7#Z~)oX4uwL9 zc@5mzcpPzk2&ojt-1-K>ac}@<=T7X+iPbk$EvJn{5Fd^pgv1y#rx&#lmbDnbj*nwY z#nm@e)6IN%JEQA*%UNSEfSH)Y-u!6oeAVt}&2)QJ)1r|j09=JAt)ZEC6iNY&c7TQB z+&a+;WO1O@kk8XXShZ))u5sJ2>^H4l<2GyQ+&5$x@oCj2tOm3Rs{wrqVXg0s$ZRdr zz*lAM99t`GROc6Q*+Z%7b+!Cf-4{y_r51^->gCG8R?XCAxK>i9cHV)zbUiJqYEK?V z&dG1peMMqRrdgiH9`oya)ng73HiP6;$OM4 zEMvi!{s59mFgiRd1(Zsd?b}gCvtVpdyT00EFC>!q2M;5*wqk>@aGvLpNhZ+UFQIST zsM}W!lx^8UaNqza7pw`-3IU#nZE8X;H8xD9QnupxTpk>P$Bq$5fk2>jKqA$|ukHC& ze*Uv}s9d>1;{y(d%0v6H*=#tuC&hHB9BXlfz*Jj&W!0SWMq)AY`6+(k`H17k2}J12 z_kFUrZ=g`od;t-UqvYHc$*~q!N=$XY-~g&rE*pS%-hRjY{onnq z85zBSip8uoM!K#mthGG#)Sq!%_BM2-(lDk_8kBf^PuMpF3wJCi2|4c@rlRvDR8Cr4Xq^lE3)tza&vCVn#-m)s9+YkP(-B zsl>(qxqy%Y-}6IXBJ|bYcg-}%69m3*R8TG_cC_dC{;S`P^z`-+1!f_!TS0u|>ra92 zV}tr;2o{qJG^SGK)#p#}Zr`<9AWR2oHq#p*9cEg1r9!`X->+Lc?$0#-_pl4vG_+t(*Dt=Xv{2*!mF5^GUz z#At1j3VwOV9d}rv_0>w?+pR6z$}%cM$@7R=Ym`!3ild_`H<=_bCY&5pE(G%@r0b9n zp)bcFg(T6M6`tqa6jDsqd`YFWF6m}m(XYzB|Fx(PsYI$-r&1~5Xvb-$dHl-cl|Qk8 z{<=VD!7`eu*`B76LBw@~E!nJ!CzCJl+`045CnhGgXsvZVpQkc5CQLF}9v&JhcWm4C z`?gSsM6+4j)YOFII8JkO^Z4N4;6D_{CXQJMM6JyYRx&3azGY+SlujlRPBa$%*Insd z-<*hqzNV(8Y-yt8RD6F*jgOD_190QUoGjYf+WLIYBPOD&IwPXBrcx^5+UUsHvuB5a z;W-KN;iO>S$jH^%f7i6Lqhq9Cy?OoYl@Ea`#gdJsJhbQao$X)57h%oRx+$~IRe*#L z0uf#1v6v7@DX}qI?fnr2f_bSl3!_;96)9zuHIR@JAq3KOYrWk0zN~@;gQ0Mu)NxFh za&4yCq?EOcHH%M8&OaB{n$~MK_h%t6rp9A|uTSBu!^UY7Rs-6E)qpl(HK0vc4QLZq z1KNbufHq+@piNi}XcJZg+Jx1BHeofO1{d$vMD;HHZQN3HRT~yr#ux$6+1Xix^|41a z9XLzvK3#jQe`HyUF$PgCR{$9Q`60sPrQsEaFu_%<+aJO(( z>jFy`r`Xn!i)LR!M`x&D>M>1TDR?G&R$C<<2QTpL(BL2=Zj}6Q-cR(s_n-=@ zp3t98m!B!nYCVd}*@0*QVZ%)%{^7$o$s~4soKm@Do29^bdPydWy^SPbQW5vwXgvPN z^??C1GCC^LEn9@zyAR{KsJGu*WUJw=jjq*E@BL@{tvq%NbNC1qufn%ZpSC}H_p)ip zWE|~zujWgo3pEb2^H>a)1<035*OKwr=bM@{9p`>>-Uw^No_p>Qa_>HjS{|^C(gIL_ zcnp2?Q9Ntte&KoBeX85+XwRv@^DYdHj{X%;V3ELGs-Gi)seGYurYRABFq>`7{rCBE z2G5%T=DMi2KKa1r`zt^G1m@5YJgwa3+~bJ(x+SbLTI-VXWtgJ^Stva^F6T8$rEw=@ScV0jRG$f$2Jk7X-X?;#qsD z=VjB;o^vGj?9HjEF3=`&0xyp z^QR-}^l!AJn}6l}g*U8=wY%@WTgbh8(aF>&3fKZrPdtg~>cXpdoId%YIeDs^9ql>C zhM>BDJYhNK?-QG&dd6l3P##Q8PENkuoJ!r7Y0m6={rowr!0z62w{Z4$qEji<#ks&X z>R15kz(FciP%obRcXqVrq&4~neM3VB>jhOWtZ86Cc_N?hX-=g+m&s&yy?*YTb*;6# z@48z!oqMam-mDt_*oa<3DMaJun^c?LUry%H`Rcd4T`KPs3*UQ?dqafDAN7>bLLcU4?A)l(i&dt8yY;=D5yqZ z%>y>slTN08y(QE9nb*&sv%>f7u04B%yYC)!stM=fn+;~Yda6A6$Jhg16beO7op{dl zymFeI9UamH_CNct_a6eLIw3OJ04P{~TU@J=WNv$|S1R$)wf;VH@QVjH`q(j-#Vv$Nwn4A=+UUr@6d7QE&`+19hQ;~eOIsWAK&@5*pcfHIxycGxISmr (cons (is-a?/c bitmap%) (is-a?/c bitmap%)]) +;; - (make-ibitmap (and/c (is-a?/c bitmap%) (lambda (x) (send x has-alpha-channel?))) +;; angle positive-real +;; hash[(list boolean[flip] number[x-scale] number[y-scale] number[angle]) -o> (is-a?/c bitmap%)]) ;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods -(define-struct/reg-mk ibitmap #:reflect-id bitmap (raw-bitmap raw-mask angle x-scale y-scale cache) +(define-struct/reg-mk ibitmap #:reflect-id bitmap (raw-bitmap angle x-scale y-scale cache) #:omit-define-syntaxes #:transparent #:property prop:custom-write (λ (x y z) (bitmap-write x y z))) @@ -264,8 +266,11 @@ has been moved out). (equal? pinhole (send that get-pinhole)) (or (and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective (equal? (get-normalized-shape) (send that get-normalized-shape))) - (let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box - [h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accommodate that. + + ;; some shapes (ie, rectangles) 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) ;(zero? h) (let ([bm1 (make-bitmap w h #t)] @@ -453,6 +458,19 @@ has been moved out). (list-ref parsed-args 3) (list-ref parsed-args 4) (make-hash))] + [(and (eq? tag 'struct:bitmap) + (= arg-count 6)) + ;; we changed the arity of the bitmap constructor from old versions, + ;; so fix it up here. + ;; it used to have these fields: (raw-bitmap raw-mask angle x-scale y-scale cache) + ;; and the mask field was dropped in favor of always having an alpha bitmap in the + ;; raw-bitmap field. The bytes that were written out always had the mask + ;; factored in, tho (which led to a bug) so we can just ignore the mask here + (make-bitmap (list-ref parsed-args 0) + (list-ref parsed-args 2) + (list-ref parsed-args 3) + (list-ref parsed-args 4) + (make-hash))] [(and (eq? tag 'struct:color) (= arg-count 3)) ;; we changed the arity of the color constructor from old versions, @@ -620,7 +638,6 @@ has been moved out). (let ([bitmap (flip-shape shape)]) (make-flip (flip-flipped? shape) (make-ibitmap (ibitmap-raw-bitmap bitmap) - (ibitmap-raw-mask bitmap) (ibitmap-angle bitmap) (* x-scale (ibitmap-x-scale bitmap)) (* y-scale (ibitmap-y-scale bitmap)) @@ -720,7 +737,10 @@ has been moved out). (define (render-cn-or-simple-shape shape dc dx dy) (cond [(crop? shape) - (render-cropped-shape (crop-points shape) (crop-shape shape) (λ (s) (render-normalized-shape s dc dx dy)) dc dx dy)] + (render-cropped-shape (crop-points shape) + (crop-shape shape) + (λ (s) (render-normalized-shape s dc dx dy)) + dc dx dy)] [else (render-simple-shape shape dc dx dy)])) @@ -889,10 +909,7 @@ has been moved out). (send dc draw-bitmap bm (- dx (/ (send bm get-width) 2)) - (- dy (/ (send bm get-height) 2)) - 'solid - (send the-color-database find-color "black") - (get-rendered-mask np-atomic-shape)))] + (- dy (/ (send bm get-height) 2))))] [(text? np-atomic-shape) (let ([θ (degrees->radians (text-angle np-atomic-shape))] [font (send dc get-font)]) @@ -963,15 +980,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! (define (get-rendered-bitmap flip-bitmap) (let ([key (get-bitmap-cache-key flip-bitmap)]) - (calc-rendered-bitmap flip-bitmap key) - (car (hash-ref (ibitmap-cache (flip-shape flip-bitmap)) - key)))) - -(define (get-rendered-mask flip-bitmap) - (let ([key (get-bitmap-cache-key flip-bitmap)]) - (calc-rendered-bitmap flip-bitmap key) - (cdr (hash-ref (ibitmap-cache (flip-shape flip-bitmap)) - key)))) + (lookup/calc-rendered-bitmap flip-bitmap key))) (define (get-bitmap-cache-key flip-bitmap) (let ([bm (flip-shape flip-bitmap)]) @@ -980,70 +989,65 @@ the mask bitmap and the original bitmap are all together in a single bytes! (ibitmap-y-scale bm) (ibitmap-angle bm)))) -(define (calc-rendered-bitmap flip-bitmap key) +(define (lookup/calc-rendered-bitmap flip-bitmap key) (let ([bitmap (flip-shape flip-bitmap)]) (cond - [(hash-ref (ibitmap-cache bitmap) key #f) => (λ (x) x)] + [(hash-ref (ibitmap-cache bitmap) key #f) => values] [else (let ([flipped? (flip-flipped? flip-bitmap)]) - (define-values (orig-bitmap-obj orig-mask-obj) (values (ibitmap-raw-bitmap bitmap) - (ibitmap-raw-mask bitmap))) - (define-values (bitmap-obj mask-obj) + (define orig-bitmap-obj (ibitmap-raw-bitmap bitmap)) + (define bitmap-obj (cond [(<= (* (ibitmap-x-scale bitmap) (ibitmap-y-scale bitmap)) 1) ;; since we prefer to rotate big things, we rotate first - (let-values ([(bitmap-obj mask-obj) (do-rotate bitmap orig-bitmap-obj orig-mask-obj flipped?)]) - (do-scale bitmap bitmap-obj mask-obj))] + (do-scale bitmap (do-rotate bitmap orig-bitmap-obj flipped?))] [else ;; since we prefer to rotate big things, we scale first - (let-values ([(bitmap-obj mask-obj) (do-scale bitmap orig-bitmap-obj orig-mask-obj)]) - (do-rotate bitmap bitmap-obj mask-obj flipped?))])) - (define pair (cons bitmap-obj mask-obj)) - (hash-set! (ibitmap-cache bitmap) key pair) - pair)]))) + (do-rotate bitmap (do-scale bitmap orig-bitmap-obj) flipped?)])) + (hash-set! (ibitmap-cache bitmap) key bitmap-obj) + bitmap-obj)]))) -(define (do-rotate bitmap bitmap-obj mask-obj flip?) +(define (do-rotate bitmap bitmap-obj flip?) (cond [(and (not flip?) (zero? (ibitmap-angle bitmap))) ;; don't rotate anything in this case. - (values bitmap-obj mask-obj)] + bitmap-obj] [else (let ([θ (degrees->radians (ibitmap-angle bitmap))]) - (let-values ([(bytes w h) (bitmap->bytes bitmap-obj mask-obj)]) + (let-values ([(bytes w h) (bitmap->bytes bitmap-obj #f)]) (let-values ([(rotated-bytes rotated-w rotated-h) (rotate-bytes bytes w h θ)]) (let* ([flipped-bytes (if flip? (flip-bytes rotated-bytes rotated-w rotated-h) rotated-bytes)] - [bm (bytes->bitmap flipped-bytes rotated-w rotated-h)] - [mask (send bm get-loaded-mask)]) - (values bm mask)))))])) + [bm (bytes->bitmap flipped-bytes rotated-w rotated-h)]) + bm))))])) -(define (do-scale bitmap orig-bm orig-mask) - (let ([x-scale (ibitmap-x-scale bitmap)] - [y-scale (ibitmap-y-scale bitmap)]) - (cond - [(and (= 1 x-scale) (= 1 y-scale)) - ;; no need to scale in this case - (values orig-bm orig-mask)] - [else - (let* ([bdc (make-object bitmap-dc%)] - [orig-w (send orig-bm get-width)] - [orig-h (send orig-bm get-height)] - [scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))] - [scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))] - [new-bm (make-bitmap scale-w scale-h)]) - - (send bdc set-bitmap new-bm) - (send bdc set-scale x-scale y-scale) - (send bdc erase) - (send bdc draw-bitmap orig-bm 0 0 'solid (send the-color-database find-color "black") orig-mask) - - (send bdc set-bitmap #f) - - (values new-bm #f))]))) +(define (do-scale bitmap orig-bm) + (define x-scale (ibitmap-x-scale bitmap)) + (define y-scale (ibitmap-y-scale bitmap)) + (cond + [(and (= 1 x-scale) (= 1 y-scale)) + ;; no need to scale in this case + orig-bm] + [else + (define bdc (make-object bitmap-dc%)) + (define orig-w (send orig-bm get-width)) + (define orig-h (send orig-bm get-height)) + (define scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))) + (define scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))) + (define new-bm (make-bitmap scale-w scale-h)) + + (send bdc set-bitmap new-bm) + (send bdc set-scale x-scale y-scale) + (send bdc erase) + (send bdc draw-bitmap orig-bm 0 0) + + (send bdc set-bitmap #f) + + new-bm])) (define (text->font text) (define adjusted-size (min (max (inexact->exact (round (text-size text))) 1) 255)) @@ -1171,13 +1175,26 @@ the mask bitmap and the original bitmap are all together in a single bytes! (send bm get-loaded-mask)))]))) (define (bitmap->image bm [mask-bm (send bm get-loaded-mask)]) - (let ([w (send bm get-width)] - [h (send bm get-height)]) - (make-image (make-translate (/ w 2) - (/ h 2) - (make-ibitmap bm mask-bm 0 1 1 (make-hash))) - (make-bb w h h) - #f))) + (define w (send bm get-width)) + (define h (send bm get-height)) + (define alpha-bm + (cond + [(and (is-a? bm bitmap%) + (send bm has-alpha-channel?)) + bm] + [else + (define bm (make-bitmap w h)) + (define bdc (make-object bitmap-dc% bm)) + (send bdc draw-bitmap bm 0 0 'solid + (send the-color-database find-color "black") + mask-bm) + (send bdc set-bitmap #f) + bm])) + (make-image (make-translate (/ w 2) + (/ h 2) + (make-ibitmap alpha-bm 0 1 1 (make-hash))) + (make-bb w h h) + #f)) (define (bitmap-write bitmap port mode) (let* ([v (struct->vector bitmap)] @@ -1189,12 +1206,11 @@ the mask bitmap and the original bitmap are all together in a single bytes! (λ (i) (let ([o (vector-ref v i)]) (let ([nv (and o - (call-with-values (λ () (bitmap->bytes o)) vector))]) + (call-with-values (λ () (bitmap->bytes o #f)) vector))]) (vector-set! v i nv))))]) (update 1) - (update 2) ;; don't save the cache - (vector-set! v 6 (make-hash)) + (vector-set! v 5 (make-hash)) (recur v port))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1221,7 +1237,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! curve-segment-color make-pen pen? pen-color pen-width pen-style pen-cap pen-join pen - make-ibitmap ibitmap? ibitmap-raw-bitmap ibitmap-raw-mask ibitmap-angle ibitmap-x-scale ibitmap-y-scale + make-ibitmap ibitmap? ibitmap-raw-bitmap ibitmap-angle ibitmap-x-scale ibitmap-y-scale ibitmap-cache make-flip flip? flip-flipped? flip-shape