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

2htdp/image

Browse Source 
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...)

original commit: 1f02106318edba9c011afaf24d6ef34a3081c9ff
This commit is contained in:
Robby Findler 2011-08-22 18:36:33 -05:00
parent 400906e376
commit eb3bb743f5
1 changed files with 89 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

162
collects/mrlib/image-core.rkt
View File

@ -67,7 +67,8 @@ has been moved out).
;; (make-image shape bb boolean (or/c point #f)) ;; (make-image shape bb boolean (or/c point #f))
;; NOTE: the shape field is mutated when normalized, as ;; NOTE: the shape field is mutated when normalized, as
;; is the normalized? field. ;; is the normalized? field.
(define (make-image shape bb normalized? [pinhole #f]) (new image% [shape shape] [bb bb] [normalized? normalized?] [pinhole pinhole])) (define (make-image shape bb normalized? [pinhole #f])
(new image% [shape shape] [bb bb] [normalized? normalized?] [pinhole pinhole]))
(define (image-shape p) (send p get-shape)) (define (image-shape p) (send p get-shape))
(define (image-bb p) (send p get-bb)) (define (image-bb p) (send p get-bb))
(define (image-normalized? p) (send p get-normalized?)) (define (image-normalized? p) (send p get-normalized?))
@ -132,10 +133,11 @@ has been moved out).
;; - flip ;; - flip
;; a bitmap is: ;; a bitmap is:
;; - (make-ibitmap (is-a?/c bitmap%) angle positive-real ;; - (make-ibitmap (and/c (is-a?/c bitmap%) (lambda (x) (send x has-alpha-channel?)))
;; hash[(list boolean[flip] number[x-scale] number[y-scale] number[angle]) -o> (cons (is-a?/c bitmap%) (is-a?/c bitmap%)]) ;; 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 ;; 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 #:omit-define-syntaxes #:transparent
#:property prop:custom-write (λ (x y z) (bitmap-write x y z))) #: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)) (equal? pinhole (send that get-pinhole))
(or (and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective (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))) (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) (or ;(zero? w)
;(zero? h) ;(zero? h)
(let ([bm1 (make-bitmap w h #t)] (let ([bm1 (make-bitmap w h #t)]
@ -453,6 +458,19 @@ has been moved out).
(list-ref parsed-args 3) (list-ref parsed-args 3)
(list-ref parsed-args 4) (list-ref parsed-args 4)
(make-hash))] (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) [(and (eq? tag 'struct:color)
(= arg-count 3)) (= arg-count 3))
;; we changed the arity of the color constructor from old versions, ;; we changed the arity of the color constructor from old versions,
@ -620,7 +638,6 @@ has been moved out).
(let ([bitmap (flip-shape shape)]) (let ([bitmap (flip-shape shape)])
(make-flip (flip-flipped? shape) (make-flip (flip-flipped? shape)
(make-ibitmap (ibitmap-raw-bitmap bitmap) (make-ibitmap (ibitmap-raw-bitmap bitmap)
(ibitmap-raw-mask bitmap)
(ibitmap-angle bitmap) (ibitmap-angle bitmap)
(* x-scale (ibitmap-x-scale bitmap)) (* x-scale (ibitmap-x-scale bitmap))
(* y-scale (ibitmap-y-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) (define (render-cn-or-simple-shape shape dc dx dy)
(cond (cond
[(crop? shape) [(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 [else
(render-simple-shape shape dc dx dy)])) (render-simple-shape shape dc dx dy)]))
@ -889,10 +909,7 @@ has been moved out).
(send dc draw-bitmap (send dc draw-bitmap
bm bm
(- dx (/ (send bm get-width) 2)) (- dx (/ (send bm get-width) 2))
(- dy (/ (send bm get-height) 2)) (- dy (/ (send bm get-height) 2))))]
'solid
(send the-color-database find-color "black")
(get-rendered-mask np-atomic-shape)))]
[(text? np-atomic-shape) [(text? np-atomic-shape)
(let ([θ (degrees->radians (text-angle np-atomic-shape))] (let ([θ (degrees->radians (text-angle np-atomic-shape))]
[font (send dc get-font)]) [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) (define (get-rendered-bitmap flip-bitmap)
(let ([key (get-bitmap-cache-key flip-bitmap)]) (let ([key (get-bitmap-cache-key flip-bitmap)])
(calc-rendered-bitmap flip-bitmap key) (lookup/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))))
(define (get-bitmap-cache-key flip-bitmap) (define (get-bitmap-cache-key flip-bitmap)
(let ([bm (flip-shape 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-y-scale bm)
(ibitmap-angle 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)]) (let ([bitmap (flip-shape flip-bitmap)])
(cond (cond
[(hash-ref (ibitmap-cache bitmap) key #f) => (λ (x) x)] [(hash-ref (ibitmap-cache bitmap) key #f) => values]
[else [else
(let ([flipped? (flip-flipped? flip-bitmap)]) (let ([flipped? (flip-flipped? flip-bitmap)])
(define-values (orig-bitmap-obj orig-mask-obj) (values (ibitmap-raw-bitmap bitmap) (define orig-bitmap-obj (ibitmap-raw-bitmap bitmap))
(ibitmap-raw-mask bitmap))) (define bitmap-obj
(define-values (bitmap-obj mask-obj)
(cond (cond
[(<= (* (ibitmap-x-scale bitmap) [(<= (* (ibitmap-x-scale bitmap)
(ibitmap-y-scale bitmap)) (ibitmap-y-scale bitmap))
1) 1)
;; since we prefer to rotate big things, we rotate first ;; 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 (do-rotate bitmap orig-bitmap-obj flipped?))]
(do-scale bitmap bitmap-obj mask-obj))]
[else [else
;; since we prefer to rotate big things, we scale first ;; 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 (do-scale bitmap orig-bitmap-obj) flipped?)]))
(do-rotate bitmap bitmap-obj mask-obj flipped?))])) (hash-set! (ibitmap-cache bitmap) key bitmap-obj)
(define pair (cons bitmap-obj mask-obj)) bitmap-obj)])))
(hash-set! (ibitmap-cache bitmap) key pair)
pair)])))
(define (do-rotate bitmap bitmap-obj mask-obj flip?) (define (do-rotate bitmap bitmap-obj flip?)
(cond (cond
[(and (not flip?) (zero? (ibitmap-angle bitmap))) [(and (not flip?) (zero? (ibitmap-angle bitmap)))
;; don't rotate anything in this case. ;; don't rotate anything in this case.
(values bitmap-obj mask-obj)] bitmap-obj]
[else [else
(let ([θ (degrees->radians (ibitmap-angle bitmap))]) (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) (let-values ([(rotated-bytes rotated-w rotated-h)
(rotate-bytes bytes w h θ)]) (rotate-bytes bytes w h θ)])
(let* ([flipped-bytes (if flip? (let* ([flipped-bytes (if flip?
(flip-bytes rotated-bytes rotated-w rotated-h) (flip-bytes rotated-bytes rotated-w rotated-h)
rotated-bytes)] rotated-bytes)]
[bm (bytes->bitmap flipped-bytes rotated-w rotated-h)] [bm (bytes->bitmap flipped-bytes rotated-w rotated-h)])
[mask (send bm get-loaded-mask)]) bm))))]))
(values bm mask)))))]))
(define (do-scale bitmap orig-bm orig-mask) (define (do-scale bitmap orig-bm)
(let ([x-scale (ibitmap-x-scale bitmap)] (define x-scale (ibitmap-x-scale bitmap))
[y-scale (ibitmap-y-scale bitmap)]) (define y-scale (ibitmap-y-scale bitmap))
(cond (cond
[(and (= 1 x-scale) (= 1 y-scale)) [(and (= 1 x-scale) (= 1 y-scale))
;; no need to scale in this case ;; no need to scale in this case
(values orig-bm orig-mask)] orig-bm]
[else [else
(let* ([bdc (make-object bitmap-dc%)] (define bdc (make-object bitmap-dc%))
[orig-w (send orig-bm get-width)] (define orig-w (send orig-bm get-width))
[orig-h (send orig-bm get-height)] (define orig-h (send orig-bm get-height))
[scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))] (define scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width)))))
[scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))] (define scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height)))))
[new-bm (make-bitmap scale-w scale-h)]) (define new-bm (make-bitmap scale-w scale-h))
(send bdc set-bitmap new-bm) (send bdc set-bitmap new-bm)
(send bdc set-scale x-scale y-scale) (send bdc set-scale x-scale y-scale)
(send bdc erase) (send bdc erase)
(send bdc draw-bitmap orig-bm 0 0 'solid (send the-color-database find-color "black") orig-mask) (send bdc draw-bitmap orig-bm 0 0)
(send bdc set-bitmap #f) (send bdc set-bitmap #f)
(values new-bm #f))]))) new-bm]))
(define (text->font text) (define (text->font text)
(define adjusted-size (min (max (inexact->exact (round (text-size text))) 1) 255)) (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)))]))) (send bm get-loaded-mask)))])))
(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)]) (define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
(let ([w (send bm get-width)] (define w (send bm get-width))
[h (send bm get-height)]) (define h (send bm get-height))
(make-image (make-translate (/ w 2) (define alpha-bm
(/ h 2) (cond
(make-ibitmap bm mask-bm 0 1 1 (make-hash))) [(and (is-a? bm bitmap%)
(make-bb w h h) (send bm has-alpha-channel?))
#f))) 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) (define (bitmap-write bitmap port mode)
(let* ([v (struct->vector bitmap)] (let* ([v (struct->vector bitmap)]
@ -1189,12 +1206,11 @@ the mask bitmap and the original bitmap are all together in a single bytes!
(λ (i) (λ (i)
(let ([o (vector-ref v i)]) (let ([o (vector-ref v i)])
(let ([nv (and o (let ([nv (and o
(call-with-values (λ () (bitmap->bytes o)) vector))]) (call-with-values (λ () (bitmap->bytes o #f)) vector))])
(vector-set! v i nv))))]) (vector-set! v i nv))))])
(update 1) (update 1)
(update 2)
;; don't save the cache ;; don't save the cache
(vector-set! v 6 (make-hash)) (vector-set! v 5 (make-hash))
(recur v port))) (recur v port)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1221,7 +1237,7 @@ the mask bitmap and the original bitmap are all together in a single bytes!
curve-segment-color curve-segment-color
make-pen pen? pen-color pen-width pen-style pen-cap pen-join pen 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 ibitmap-cache
make-flip flip? flip-flipped? flip-shape make-flip flip? flip-flipped? flip-shape