added support for flipping bitmaps
This commit is contained in:
Robby Findler
parent
27bd7934d7
commit
132867518c
|
|
@ -510,12 +510,13 @@
|
|||
(text-string atomic-shape)
|
||||
(text->font atomic-shape))])
|
||||
(rotated-rectangular-bounding-box w h (text-angle atomic-shape)))]
|
||||
[(bitmap? atomic-shape)
|
||||
(let ([bb (bitmap-raw-bitmap atomic-shape)])
|
||||
[(flip? atomic-shape)
|
||||
(let* ([bitmap (flip-shape atomic-shape)]
|
||||
[bb (bitmap-raw-bitmap bitmap)])
|
||||
(let-values ([(l t r b)
|
||||
(rotated-rectangular-bounding-box (* (send bb get-width) (bitmap-x-scale atomic-shape))
|
||||
(* (send bb get-height) (bitmap-y-scale atomic-shape))
|
||||
(bitmap-angle atomic-shape))])
|
||||
(rotated-rectangular-bounding-box (* (send bb get-width) (bitmap-x-scale bitmap))
|
||||
(* (send bb get-height) (bitmap-y-scale bitmap))
|
||||
(bitmap-angle bitmap))])
|
||||
(values l t r b)))]
|
||||
[else
|
||||
(fprintf (current-error-port) "using bad bounding box for ~s\n" atomic-shape)
|
||||
|
|
@ -597,14 +598,20 @@
|
|||
(text-style atomic-shape)
|
||||
(text-weight atomic-shape)
|
||||
(text-underline atomic-shape))]
|
||||
[(bitmap? atomic-shape)
|
||||
(make-bitmap (bitmap-raw-bitmap atomic-shape)
|
||||
(bitmap-raw-mask atomic-shape)
|
||||
(bring-between (+ θ (bitmap-angle atomic-shape)) 360)
|
||||
(bitmap-x-scale atomic-shape)
|
||||
(bitmap-y-scale atomic-shape)
|
||||
#f
|
||||
#f)]))
|
||||
[(flip? atomic-shape)
|
||||
(let ([bitmap (flip-shape atomic-shape)]
|
||||
[flipped? (flip-flipped? atomic-shape)])
|
||||
(make-flip flipped?
|
||||
(make-bitmap (bitmap-raw-bitmap bitmap)
|
||||
(bitmap-raw-mask bitmap)
|
||||
(bring-between (if flipped?
|
||||
(+ θ (bitmap-angle bitmap))
|
||||
(- (+ θ (bitmap-angle bitmap))))
|
||||
360)
|
||||
(bitmap-x-scale bitmap)
|
||||
(bitmap-y-scale bitmap)
|
||||
#f
|
||||
#f)))]))
|
||||
|
||||
;; rotate-point : point angle -> point
|
||||
(define (rotate-point p θ)
|
||||
|
|
@ -684,10 +691,10 @@
|
|||
(line-segment-color simple-shape))]
|
||||
[(curve-segment? simple-shape)
|
||||
(make-curve-segment (flip-point (curve-segment-start simple-shape))
|
||||
(bring-between (- 360 (curve-segment-s-angle simple-shape)) 360)
|
||||
(bring-between (- (curve-segment-s-angle simple-shape)) 360)
|
||||
(curve-segment-s-pull simple-shape)
|
||||
(flip-point (curve-segment-end simple-shape))
|
||||
(bring-between (- 360 (curve-segment-e-angle simple-shape)) 360)
|
||||
(bring-between (- (curve-segment-e-angle simple-shape)) 360)
|
||||
(curve-segment-e-pull simple-shape)
|
||||
(curve-segment-color simple-shape))]
|
||||
[(polygon? simple-shape)
|
||||
|
|
@ -724,15 +731,9 @@
|
|||
(ellipse-color atomic-shape))]))])]
|
||||
[(text? atomic-shape)
|
||||
(error 'flip "cannot flip shapes that contain text")]
|
||||
[(bitmap? atomic-shape)
|
||||
atomic-shape
|
||||
#;(make-bitmap (bitmap-raw-bitmap atomic-shape)
|
||||
(bitmap-raw-mask atomic-shape)
|
||||
(bring-between (+ θ (bitmap-angle atomic-shape)) 360)
|
||||
(bitmap-x-scale atomic-shape)
|
||||
(bitmap-y-scale atomic-shape)
|
||||
#f
|
||||
#f)]))
|
||||
[(flip? atomic-shape)
|
||||
(make-flip (not (flip-flipped? atomic-shape))
|
||||
(flip-shape atomic-shape))]))
|
||||
|
||||
(define (flip-point point) (make-point (point-x point) (- (point-y point))))
|
||||
(define (flip-points points) (map flip-point points))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide define/chk
|
||||
to-img
|
||||
x-place?
|
||||
y-place?
|
||||
mode?
|
||||
|
|
@ -11,8 +10,6 @@
|
|||
pen-style?
|
||||
pen-cap?
|
||||
pen-join?
|
||||
image-snip->image
|
||||
bitmap->image
|
||||
check-mode/color-combination)
|
||||
|
||||
(require htdp/error
|
||||
|
|
@ -20,7 +17,6 @@
|
|||
lang/posn
|
||||
racket/gui/base
|
||||
"../../mrlib/image-core.ss"
|
||||
(prefix-in cis: "../../mrlib/cache-image-snip.ss")
|
||||
(for-syntax racket/base
|
||||
racket/list))
|
||||
|
||||
|
|
@ -266,43 +262,6 @@
|
|||
(member (if (string? arg) (string->symbol arg) arg)
|
||||
'(round bevel miter)))
|
||||
|
||||
(define (to-img arg)
|
||||
(cond
|
||||
[(is-a? arg image-snip%) (image-snip->image arg)]
|
||||
[(is-a? arg bitmap%) (bitmap->image arg)]
|
||||
[else arg]))
|
||||
|
||||
(define (image-snip->image is)
|
||||
(let ([bm (send is get-bitmap)])
|
||||
(cond
|
||||
[(not bm)
|
||||
;; this might mean we have a cache-image-snip%
|
||||
;; or it might mean we have a useless snip.
|
||||
(let-values ([(w h) (if (is-a? is cis:cache-image-snip%)
|
||||
(send is get-size)
|
||||
(values 0 0))])
|
||||
(make-image (make-polygon
|
||||
(list (make-point 0 0)
|
||||
(make-point w 0)
|
||||
(make-point w h)
|
||||
(make-point 0 h))
|
||||
'solid "black")
|
||||
(make-bb w h h)
|
||||
#f))]
|
||||
[else
|
||||
(bitmap->image bm
|
||||
(or (send is get-bitmap-mask)
|
||||
(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-bitmap bm mask-bm 0 1 1 #f #f))
|
||||
(make-bb w h h)
|
||||
#f)))
|
||||
|
||||
|
||||
;; checks the dependent part of the 'color' specification
|
||||
(define (check-mode/color-combination fn-name i mode color)
|
||||
|
|
|
|||
|
|
@ -34,11 +34,12 @@
|
|||
make-point
|
||||
make-crop
|
||||
crop?
|
||||
normalized-shape?)
|
||||
normalized-shape?
|
||||
image-snip->image
|
||||
to-img)
|
||||
(only-in "../private/image-more.ss"
|
||||
bring-between
|
||||
swizzle)
|
||||
(only-in "../private/img-err.ss" image-snip->image)
|
||||
; "../private/img-err.ss"
|
||||
"../../mrlib/private/image-core-bitmap.ss"
|
||||
lang/posn
|
||||
|
|
@ -1413,6 +1414,26 @@
|
|||
180 20 90 1/3
|
||||
"white"))
|
||||
|
||||
(let* ([bdc (make-object bitmap-dc%)]
|
||||
[bm-ul (make-object bitmap% 10 10)]
|
||||
[bm-ur (make-object bitmap% 10 10)]
|
||||
[bm-ll (make-object bitmap% 10 10)])
|
||||
(send bdc set-bitmap bm-ul)
|
||||
(send bdc set-pen "red" 1 'transparent)
|
||||
(send bdc set-brush "red" 'solid)
|
||||
(send bdc clear)
|
||||
(send bdc draw-rectangle 0 0 5 5)
|
||||
(send bdc set-bitmap bm-ur)
|
||||
(send bdc set-pen "red" 1 'solid)
|
||||
(send bdc clear)
|
||||
(send bdc draw-rectangle 5 0 5 5)
|
||||
(send bdc set-bitmap bm-ll)
|
||||
(send bdc clear)
|
||||
(send bdc draw-rectangle 0 5 5 5)
|
||||
(send bdc set-bitmap #f)
|
||||
(test (flip-vertical bm-ul) => (to-img bm-ll))
|
||||
(test (flip-horizontal bm-ul) => (to-img bm-ur)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; pen arguments
|
||||
|
|
|
|||
|
|
@ -1,4 +1,10 @@
|
|||
#lang racket/base
|
||||
|
||||
;; changed:
|
||||
;; - simple-shape
|
||||
;; - np-atomic-shape
|
||||
;; - atomic-shape
|
||||
|
||||
#|
|
||||
|
||||
This library is the part of the 2htdp/image
|
||||
|
|
@ -29,7 +35,9 @@ has been moved out).
|
|||
(require racket/class
|
||||
racket/gui/base
|
||||
racket/math
|
||||
racket/contract
|
||||
"private/image-core-bitmap.ss"
|
||||
(prefix-in cis: "cache-image-snip.ss")
|
||||
(for-syntax racket/base))
|
||||
|
||||
(define-for-syntax id-constructor-pairs '())
|
||||
|
|
@ -122,6 +130,7 @@ has been moved out).
|
|||
;; - polygon
|
||||
;; - line-segment
|
||||
;; - curve-segment
|
||||
;; - bitmap
|
||||
;; - np-atomic-shape
|
||||
|
||||
;; a np-atomic-shape is:
|
||||
|
|
@ -135,11 +144,22 @@ has been moved out).
|
|||
(define-struct/reg-mk text (string angle y-scale color size face family style weight underline)
|
||||
#:omit-define-syntaxes #:transparent)
|
||||
;;
|
||||
;; - flip
|
||||
|
||||
;; a bitmap is:
|
||||
;; - (make-bitmap (is-a?/c bitmap%) angle positive-real (or/c #f (is-a?/c bitmap%)))
|
||||
;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods
|
||||
(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale [rendered-bitmap #:mutable] [rendered-mask #:mutable])
|
||||
#:omit-define-syntaxes #:transparent)
|
||||
|
||||
;; a flip is:
|
||||
;; - (make-flip boolean bitmap)
|
||||
;; * the boolean is #t if the bitmap should be flipped vertically (after applying whatever rotation is in there)
|
||||
;; * this struct is here to avoid adding a field to bitmaps, so that old save files
|
||||
;; from when the library did not support flipping still load
|
||||
;; (since normalization will add a flip structure if necessary)
|
||||
(define-struct/reg-mk flip (flipped? shape))
|
||||
|
||||
;; a polygon is:
|
||||
;;
|
||||
;; - (make-polygon (listof vector) mode color)
|
||||
|
|
@ -164,7 +184,7 @@ has been moved out).
|
|||
;; - (make-crop (listof points) normalized-shape)
|
||||
|
||||
;; a simple-shape (subtype of shape) is
|
||||
;; - (make-translate dx dy np-atomic-shape))
|
||||
;; - (make-translate dx dy np-atomic-shape)
|
||||
;; - polygon
|
||||
;; - line-segment
|
||||
;; - curve-segment
|
||||
|
|
@ -213,21 +233,26 @@ has been moved out).
|
|||
(init-field shape bb normalized?)
|
||||
(define/public (equal-to? that eq-recur)
|
||||
(or (eq? this that)
|
||||
(and (is-a? that image%)
|
||||
(same-bb? bb (send that get-bb))
|
||||
(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 accomodate that.
|
||||
(or (zero? w)
|
||||
(zero? h)
|
||||
(let ([bm1 (make-object bitmap% w h)]
|
||||
[bm2 (make-object bitmap% w h)]
|
||||
[bytes1 (make-bytes (* w h 4) 0)]
|
||||
[bytes2 (make-bytes (* w h 4) 0)]
|
||||
[bdc (make-object bitmap-dc%)])
|
||||
(and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that)
|
||||
(check-same? bm1 bm2 bytes1 bytes2 bdc "green" that)))))))))
|
||||
(let ([that
|
||||
(cond
|
||||
[(is-a? that image-snip%) (image-snip->image that)]
|
||||
[(is-a? that bitmap%) (bitmap->image that)]
|
||||
[else that])])
|
||||
(and (is-a? that image%)
|
||||
(same-bb? bb (send that get-bb))
|
||||
(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 accomodate that.
|
||||
(or (zero? w)
|
||||
(zero? h)
|
||||
(let ([bm1 (make-object bitmap% w h)]
|
||||
[bm2 (make-object bitmap% w h)]
|
||||
[bytes1 (make-bytes (* w h 4) 0)]
|
||||
[bytes2 (make-bytes (* w h 4) 0)]
|
||||
[bdc (make-object bitmap-dc%)])
|
||||
(and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that)
|
||||
(check-same? bm1 bm2 bytes1 bytes2 bdc "green" that))))))))))
|
||||
|
||||
(define/private (check-same? bm1 bm2 bytes1 bytes2 bdc color that)
|
||||
(clear-bitmap/draw/bytes bm1 bdc bytes1 this color)
|
||||
|
|
@ -369,9 +394,51 @@ has been moved out).
|
|||
|
||||
(define-id->constructor id->constructor)
|
||||
|
||||
|
||||
(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)))
|
||||
(polygon? shape)
|
||||
(line-segment? shape)
|
||||
(curve-segment? shape)))
|
||||
|
||||
(define (atomic-shape? shape)
|
||||
(or (polygon? shape)
|
||||
(line-segment? shape)
|
||||
(curve-segment? shape)
|
||||
(bitmap? shape)
|
||||
(np-atomic-shape? shape)))
|
||||
|
||||
(define (np-atomic-shape? shape)
|
||||
(or (ellipse? shape)
|
||||
(text? shape)
|
||||
(and (flip? shape)
|
||||
(boolean? (flip-flipped? shape))
|
||||
(bitmap? (flip-shape shape)))
|
||||
(point? shape))) ;; does this belong here?
|
||||
|
||||
|
||||
;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape
|
||||
;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape.
|
||||
(define (normalize-shape shape [f values])
|
||||
(define/contract (normalize-shape shape [f values])
|
||||
(->* (any/c) ;; should be shape?
|
||||
((-> any/c any/c))
|
||||
normalized-shape?)
|
||||
(let loop ([shape shape]
|
||||
[dx 0]
|
||||
[dy 0]
|
||||
|
|
@ -443,50 +510,20 @@ has been moved out).
|
|||
(if bottom
|
||||
(make-overlay bottom (f this-one))
|
||||
(f this-one)))]
|
||||
[(np-atomic-shape? shape)
|
||||
(let ([this-one
|
||||
(make-translate dx dy (scale-np-atomic x-scale y-scale shape))])
|
||||
(if bottom
|
||||
(make-overlay bottom (f this-one))
|
||||
(f this-one)))]
|
||||
[(or (bitmap? shape) (np-atomic-shape? shape))
|
||||
(let ([shape (if (bitmap? shape)
|
||||
(make-flip #f shape)
|
||||
shape)])
|
||||
(let ([this-one
|
||||
(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)))
|
||||
(polygon? shape)
|
||||
(line-segment? shape)
|
||||
(curve-segment? shape)))
|
||||
|
||||
(define (atomic-shape? shape)
|
||||
(or (polygon? shape)
|
||||
(line-segment? shape)
|
||||
(curve-segment? shape)
|
||||
(np-atomic-shape? shape)))
|
||||
|
||||
(define (np-atomic-shape? shape)
|
||||
(or (ellipse? shape)
|
||||
(text? shape)
|
||||
(bitmap? shape)
|
||||
(point? shape)))
|
||||
|
||||
(define (scale-np-atomic x-scale y-scale shape)
|
||||
(define/contract (scale-np-atomic x-scale y-scale shape)
|
||||
(-> number? number? np-atomic-shape? np-atomic-shape?)
|
||||
(cond
|
||||
[(ellipse? shape)
|
||||
(make-ellipse (* x-scale (ellipse-width shape))
|
||||
|
|
@ -508,13 +545,15 @@ has been moved out).
|
|||
(text-style shape)
|
||||
(text-weight shape)
|
||||
(text-underline shape))]
|
||||
[(bitmap? shape)
|
||||
(make-bitmap (bitmap-raw-bitmap shape)
|
||||
(bitmap-raw-mask shape)
|
||||
(bitmap-angle shape)
|
||||
(* x-scale (bitmap-x-scale shape))
|
||||
(* y-scale (bitmap-y-scale shape))
|
||||
#f #f)]))
|
||||
[(flip? shape)
|
||||
(let ([bitmap (flip-shape shape)])
|
||||
(make-flip (flip-flipped? shape)
|
||||
(make-bitmap (bitmap-raw-bitmap bitmap)
|
||||
(bitmap-raw-mask bitmap)
|
||||
(bitmap-angle bitmap)
|
||||
(* x-scale (bitmap-x-scale bitmap))
|
||||
(* y-scale (bitmap-y-scale bitmap))
|
||||
#f #f)))]))
|
||||
|
||||
(define (scale-color color x-scale y-scale)
|
||||
(cond
|
||||
|
|
@ -658,15 +697,15 @@ has been moved out).
|
|||
[else
|
||||
(let ([dx (+ dx (translate-dx simple-shape))]
|
||||
[dy (+ dy (translate-dy simple-shape))]
|
||||
[atomic-shape (translate-shape simple-shape)])
|
||||
[np-atomic-shape (translate-shape simple-shape)])
|
||||
(cond
|
||||
[(ellipse? atomic-shape)
|
||||
[(ellipse? np-atomic-shape)
|
||||
(let* ([path (new dc-path%)]
|
||||
[ew (ellipse-width atomic-shape)]
|
||||
[eh (ellipse-height atomic-shape)]
|
||||
[θ (degrees->radians (ellipse-angle atomic-shape))]
|
||||
[color (ellipse-color atomic-shape)]
|
||||
[mode (ellipse-mode atomic-shape)])
|
||||
[ew (ellipse-width np-atomic-shape)]
|
||||
[eh (ellipse-height np-atomic-shape)]
|
||||
[θ (degrees->radians (ellipse-angle np-atomic-shape))]
|
||||
[color (ellipse-color np-atomic-shape)]
|
||||
[mode (ellipse-mode np-atomic-shape)])
|
||||
(let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)])
|
||||
(send path ellipse 0 0 ew eh)
|
||||
(send path translate (- (/ ew 2)) (- (/ eh 2)))
|
||||
|
|
@ -675,26 +714,26 @@ has been moved out).
|
|||
(send dc set-brush (mode-color->brush mode color))
|
||||
(send dc set-smoothing (mode-color->smoothing mode color))
|
||||
(send dc draw-path path dx dy)))]
|
||||
[(bitmap? atomic-shape)
|
||||
(let ([bm (get-rendered-bitmap atomic-shape)])
|
||||
[(flip? np-atomic-shape)
|
||||
(let ([bm (get-rendered-bitmap np-atomic-shape)])
|
||||
(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 atomic-shape)))]
|
||||
[(text? atomic-shape)
|
||||
(let ([θ (degrees->radians (text-angle atomic-shape))]
|
||||
(get-rendered-mask np-atomic-shape)))]
|
||||
[(text? np-atomic-shape)
|
||||
(let ([θ (degrees->radians (text-angle np-atomic-shape))]
|
||||
[font (send dc get-font)])
|
||||
(send dc set-font (text->font atomic-shape))
|
||||
(send dc set-font (text->font np-atomic-shape))
|
||||
(send dc set-text-foreground
|
||||
(or (send the-color-database find-color (text-color atomic-shape))
|
||||
(or (send the-color-database find-color (text-color np-atomic-shape))
|
||||
(send the-color-database find-color "black")))
|
||||
(let-values ([(w h _1 _2) (send dc get-text-extent (text-string atomic-shape))])
|
||||
(let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))])
|
||||
(let ([p (- (make-rectangular dx dy)
|
||||
(* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))])
|
||||
(send dc draw-text (text-string atomic-shape)
|
||||
(send dc draw-text (text-string np-atomic-shape)
|
||||
(real-part p)
|
||||
(imag-part p)
|
||||
#f 0 θ))))]))]))
|
||||
|
|
@ -747,43 +786,50 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
|||
|#
|
||||
|
||||
|
||||
(define (get-rendered-bitmap bitmap)
|
||||
(calc-renered-bitmap bitmap)
|
||||
(bitmap-rendered-bitmap bitmap))
|
||||
(define (get-rendered-bitmap flip-bitmap)
|
||||
(calc-rendered-bitmap flip-bitmap)
|
||||
(bitmap-rendered-bitmap (flip-shape flip-bitmap)))
|
||||
|
||||
(define (get-rendered-mask bitmap)
|
||||
(calc-renered-bitmap bitmap)
|
||||
(bitmap-rendered-mask bitmap))
|
||||
(define (get-rendered-mask flip-bitmap)
|
||||
(calc-rendered-bitmap flip-bitmap)
|
||||
(bitmap-rendered-mask (flip-shape flip-bitmap)))
|
||||
|
||||
(define (calc-renered-bitmap bitmap)
|
||||
(unless (bitmap-rendered-bitmap bitmap)
|
||||
;; fill in the rendered bitmap with the raw bitmaps.
|
||||
(set-bitmap-rendered-bitmap! bitmap (bitmap-raw-bitmap bitmap))
|
||||
(set-bitmap-rendered-mask! bitmap (bitmap-raw-mask bitmap))
|
||||
(cond
|
||||
[(and (= 1 (bitmap-x-scale bitmap))
|
||||
(= 1 (bitmap-y-scale bitmap))
|
||||
(= 0 (bitmap-angle bitmap)))
|
||||
;; if there's no scaling or rotation, we can just keep that bitmap.
|
||||
(void)]
|
||||
[(<= (* (bitmap-x-scale bitmap)
|
||||
(bitmap-y-scale bitmap))
|
||||
1)
|
||||
;; since we prefer to rotate big things, we rotate first
|
||||
(do-rotate bitmap)
|
||||
(do-scale bitmap)]
|
||||
[else
|
||||
;; since we prefer to rotate big things, we scale first
|
||||
(do-scale bitmap)
|
||||
(do-rotate bitmap)])))
|
||||
(define (calc-rendered-bitmap flip-bitmap)
|
||||
(let ([bitmap (flip-shape flip-bitmap)])
|
||||
(unless (bitmap-rendered-bitmap bitmap)
|
||||
(let ([flipped? (flip-flipped? flip-bitmap)])
|
||||
|
||||
;; fill in the rendered bitmap with the raw bitmaps.
|
||||
(set-bitmap-rendered-bitmap! bitmap (bitmap-raw-bitmap bitmap))
|
||||
(set-bitmap-rendered-mask! bitmap (bitmap-raw-mask bitmap))
|
||||
(cond
|
||||
[(and (= 1 (bitmap-x-scale bitmap))
|
||||
(= 1 (bitmap-y-scale bitmap))
|
||||
(= 0 (bitmap-angle bitmap))
|
||||
(not flipped?))
|
||||
;; if there's no scaling, rotation or flipping, we can just keep that bitmap.
|
||||
(void)]
|
||||
[(<= (* (bitmap-x-scale bitmap)
|
||||
(bitmap-y-scale bitmap))
|
||||
1)
|
||||
;; since we prefer to rotate big things, we rotate first
|
||||
(do-rotate bitmap flipped?)
|
||||
(do-scale bitmap)]
|
||||
[else
|
||||
;; since we prefer to rotate big things, we scale first
|
||||
(do-scale bitmap)
|
||||
(do-rotate bitmap flipped?)])))))
|
||||
|
||||
(define (do-rotate bitmap)
|
||||
(define (do-rotate bitmap flip?)
|
||||
(let ([θ (degrees->radians (bitmap-angle bitmap))])
|
||||
(let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap)
|
||||
(bitmap-rendered-mask bitmap))])
|
||||
(let-values ([(rotated-bytes rotated-w rotated-h)
|
||||
(rotate-bytes bytes w h θ)])
|
||||
(let* ([bm (bytes->bitmap rotated-bytes rotated-w rotated-h)]
|
||||
(let* ([flipped-bytes (if flip?
|
||||
(flip-bytes rotated-bytes w h)
|
||||
rotated-bytes)]
|
||||
[bm (bytes->bitmap flipped-bytes rotated-w rotated-h)]
|
||||
[mask (send bm get-loaded-mask)])
|
||||
(set-bitmap-rendered-bitmap! bitmap bm)
|
||||
(set-bitmap-rendered-mask! bitmap mask))))))
|
||||
|
|
@ -920,6 +966,43 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
|||
(send ans set-join (pen-join pen))
|
||||
ans))
|
||||
|
||||
(define (to-img arg)
|
||||
(cond
|
||||
[(is-a? arg image-snip%) (image-snip->image arg)]
|
||||
[(is-a? arg bitmap%) (bitmap->image arg)]
|
||||
[else arg]))
|
||||
|
||||
(define (image-snip->image is)
|
||||
(let ([bm (send is get-bitmap)])
|
||||
(cond
|
||||
[(not bm)
|
||||
;; this might mean we have a cache-image-snip%
|
||||
;; or it might mean we have a useless snip.
|
||||
(let-values ([(w h) (if (is-a? is cis:cache-image-snip%)
|
||||
(send is get-size)
|
||||
(values 0 0))])
|
||||
(make-image (make-polygon
|
||||
(list (make-point 0 0)
|
||||
(make-point w 0)
|
||||
(make-point w h)
|
||||
(make-point 0 h))
|
||||
'solid "black")
|
||||
(make-bb w h h)
|
||||
#f))]
|
||||
[else
|
||||
(bitmap->image bm
|
||||
(or (send is get-bitmap-mask)
|
||||
(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-bitmap bm mask-bm 0 1 1 #f #f))
|
||||
(make-bb w h h)
|
||||
#f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
|
@ -945,6 +1028,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
|||
make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale
|
||||
bitmap-rendered-bitmap bitmap-rendered-mask
|
||||
|
||||
make-flip flip? flip-flipped? flip-shape
|
||||
|
||||
(struct-out color)
|
||||
|
||||
degrees->radians
|
||||
|
|
@ -960,7 +1045,11 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
|||
|
||||
skip-image-equality-fast-path
|
||||
|
||||
scale-np-atomic)
|
||||
scale-np-atomic
|
||||
|
||||
to-img
|
||||
bitmap->image
|
||||
image-snip->image)
|
||||
|
||||
;; method names
|
||||
(provide get-shape get-bb get-normalized? get-normalized-shape)
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
|
||||
|
||||
(provide rotate-bytes ;; : bytes int[width] int[height] radians[radians] -> bytes
|
||||
flip-bytes ;; : bytes int[width] int[height] -> bytes
|
||||
bitmap->bytes
|
||||
bytes->bitmap)
|
||||
;; rotate-bitmap : (-> bytes? natural-number/c natural-number/c real? bytes?)
|
||||
|
|
@ -76,6 +77,14 @@ instead of this scaling code, we use the dc<%>'s scaling code.
|
|||
(send bm set-loaded-mask mask)
|
||||
bm))
|
||||
|
||||
(define (flip-bytes bmbytes w h)
|
||||
(build-bmbytes
|
||||
w h
|
||||
(λ (x y)
|
||||
(let ([new-x x]
|
||||
[new-y (- h y 1)])
|
||||
(bmbytes-ref/safe bmbytes w h new-x new-y)))))
|
||||
|
||||
(define (rotate-bytes bmbytes w h theta)
|
||||
(let* {[theta-rotation (exp (* i theta))]
|
||||
[theta-unrotation (make-rectangular (real-part theta-rotation)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user