[plt-scheme] Re : interaction bug of draw-bitmap set-scale and get-loaded-mask

From: stephane bonnet (stefanbonnet at yahoo.fr)
Date: Sun Jan 10 14:30:53 EST 2010

here's an ugly/lazy illustration (from its matched code...) :

#lang scheme/gui

(define gray (send the-color-database find-color "gray"))
(define misspelled-gray (make-object color% 158 158 150))
(define black (send the-color-database find-color "black"))
(define white (send the-color-database find-color "white"))
(define red (send the-color-database find-color "red"))
(define blue (send the-color-database find-color "blue"))

;you can play around with those, for maximum effect :

(define background-color black) 
(define different-background-color white)
(define pen-color white)
(define pen-size 0)

(define image-name "essai.png")
(define image-path (build-path (find-system-path 'desk-dir) image-name))

(define image (make-object bitmap% 500 500))
(define mask (make-object bitmap% (send image get-width) (send image get-height)))
(define image-dc (instantiate bitmap-dc% (image)))
(define mask-dc (instantiate bitmap-dc% (mask)))

(define draw-pen (make-object pen% pen-color pen-size 'solid))
(define mask-pen (make-object pen% black pen-size 'solid))
(define draw-brush (make-object brush% red 'transparent))
(define mask-brush (make-object brush% black 'transparent))

(send image-dc set-pen draw-pen)
(send image-dc set-brush draw-brush)

(send mask-dc set-pen mask-pen)
(send mask-dc set-brush mask-brush)

(send image-dc set-background background-color)
(send image-dc clear)

(send mask-dc set-background white)
(send mask-dc clear)

(send mask-dc set-smoothing 'unsmoothed)
(send image-dc set-smoothing 'unsmoothed)
(send image-dc draw-rectangle 50 50 400 400)
(send mask-dc draw-rectangle 50 50 400 400)

(send image set-loaded-mask mask)
(send image save-file image-path 'png)

(send image-dc set-bitmap #f)
(send image load-file image-path 'png/mask)

(define scale 0.5)

(define (draw dc)
  (send dc set-scale scale scale)
  (send dc draw-bitmap image 0 0 'solid black mask))

(define (draw-with-get-loaded-mask dc)
  (send dc set-scale scale scale)
  (send dc draw-bitmap image 0 0 'solid black (send image get-loaded-mask)))

(define f (new frame% (label "same-color/mask") (x 0) (y 0)))
(define c (new canvas%
              (parent f)
              (min-width (inexact->exact (* scale (send mask get-width))))
              (min-height  (inexact->exact (* scale (send mask get-height))))
              (paint-callback
                (λ (c dc) (begin (send dc set-background background-color)
                                  (send dc clear)
                                  (draw dc))))))
(define f1 (new frame% (label "same-color/get-loaded") (x (inexact->exact (* scale (send mask get-width)))) (y 0)))
(define c1 (new canvas%
              (parent f1)
              (min-width (inexact->exact (* scale (send mask get-width))))
              (min-height  (inexact->exact (* scale (send mask get-height))))
              (paint-callback
                (λ (c dc) (begin (send dc set-background background-color)
                                  (send dc clear)
                                  (draw-with-get-loaded-mask dc))))))
(define f2 (new frame% (label "different-color/get-loaded") (x (inexact->exact (* 2 scale (send mask get-width)))) (y 0)))
(define c2 (new canvas%
              (parent f2)
              (min-width (inexact->exact (* scale (send mask get-width))))
              (min-height  (inexact->exact (* scale (send mask get-height))))
              (paint-callback
                (λ (c dc) (begin (send dc set-background different-background-color)
                                  (send dc clear)
                                  (draw-with-get-loaded-mask dc))))))
(define f3 (new frame% (label "different-color/mask") (x (inexact->exact (* 3 scale (send mask get-width)))) (y 0)))
(define c3 (new canvas%
              (parent f3)
              (min-width (inexact->exact (* scale (send mask get-width))))
              (min-height  (inexact->exact (* scale (send mask get-height))))
              (paint-callback
                (λ (c dc) (begin (send dc set-background different-background-color)
                                  (send dc clear)
                                  (draw dc))))))


(send f show #t)
(send f1 show #t)
(send f2 show #t)
(send f3 show #t)


Posted on the users mailing list.