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

set up backing-dc%

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-06 05:35:12 -06:00
parent 72b671b665
commit bb68137829
5 changed files with 157 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
collects/mred/private/wx/common/backing-dc.rkt Normal file
View File

@ -0,0 +1,78 @@
#lang racket/base
(require racket/class
racket/draw/dc
racket/draw/bitmap-dc
racket/draw/bitmap
racket/draw/local)
(provide backing-dc%
;; scoped method names:
get-backing-size
flush-backing
start-on-paint
end-on-paint)
(define-local-member-name
get-backing-size
flush-backing
start-on-paint
end-on-paint)
(define backing-dc%
(class (dc-mixin bitmap-dc-backend%)
(inherit call-with-cr-lock
internal-get-bitmap
internal-set-bitmap)
(super-new)
;; Override this method to get the right size
(define/public (get-backing-size xb yb)
(set-box! xb 1)
(set-box! yb 1))
;; override this method to push the bitmap to
;; the device that it backs
(define/public (flush-backing bm)
(void))
(define on-paint-cr #f)
(define/public (start-on-paint)
(call-with-cr-lock
(lambda ()
(if on-paint-cr
(log-error "nested start-on-paint")
(set! on-paint-cr (get-cr))))))
(define/public (end-on-paint)
(call-with-cr-lock
(lambda ()
(if (not on-paint-cr)
(log-error "unbalanced end-on-paint")
(let ([cr on-paint-cr])
(set! on-paint-cr #f)
(release-cr cr))))))
(define/override (get-cr)
(or on-paint-cr
(let ([w (box 0)]
[h (box 0)])
(get-backing-size)
(let ([bm (get-backing-bitmap (unbox w) (unbox h))])
(internal-set-bitmap bm))
(super get-cr))))
(define/override (release-cr cr)
(unless (eq? cr on-paint-cr)
(let ([bm (internal-get-bitmap)])
(internal-set-bitmap #f)
(flush-backing bm)
(release-backing-bitmap bm))))))
(define (get-backing-bitmap w h)
(make-object bitmap% w h #f #t))
(define (release-backing-bitmap bm)
(send bm release-bitma-storage))

103
collects/racket/draw/bitmap-dc.rkt
View File

@ -7,21 +7,23 @@
"dc.ss"
"local.ss")
(provide bitmap-dc%)
(provide bitmap-dc%
bitmap-dc-backend%)
(define dc-backend%
(define bitmap-dc-backend%
(class default-dc-backend%
(init [_bm #f])
(inherit reset-cr)
(inherit reset-cr
call-with-cr-lock)
(define c #f)
(define bm #f)
(define b&w? #f)
(when _bm
(do-set-bitmap _bm))
(do-set-bitmap _bm #f))
(define/private (do-set-bitmap v)
(define/private (do-set-bitmap v reset?)
(when c
(cairo_destroy c)
(set! c #f))
@ -30,43 +32,18 @@
(set! c (cairo_create (send bm get-cairo-surface)))
(set! b&w? (not (send bm is-color?)))))
(def/public (set-bitmap [(make-or-false bitmap%) v])
(do-set-bitmap v)
(when c (reset-cr c)))
(define/public (internal-set-bitmap v)
(call-with-cr-lock
(lambda ()
(do-set-bitmap v #t)
(when c (reset-cr c)))))
(def/public (get-bitmap) bm)
(define/public (internal-get-bitmap) bm)
(def/override (get-size)
(values (exact->inexact (send bm get-width))
(exact->inexact (send bm get-height))))
(def/public (set-pixel [real? x][real? y][color% c])
(let ([s (bytes 255 (color-red c) (color-green c) (color-blue c))])
(set-argb-pixels x y 1 1 s)))
(def/public (get-pixel [real? x][real? y][color% c])
(let ([b (make-bytes 4)])
(get-argb-pixels x y 1 1 b)
(send c set (bytes-ref b 1) (bytes-ref b 2) (bytes-ref b 3))
#t))
(def/public (set-argb-pixels [exact-nonnegative-integer? x]
[exact-nonnegative-integer? y]
[exact-nonnegative-integer? w]
[exact-nonnegative-integer? h]
[bytes? bstr]
[any? [set-alpha? #f]])
(when bm
(send bm set-argb-pixels x y w h bstr set-alpha?)))
(def/public (get-argb-pixels [exact-nonnegative-integer? x]
[exact-nonnegative-integer? y]
[exact-nonnegative-integer? w]
[exact-nonnegative-integer? h]
[bytes? bstr]
[any? [get-alpha? #f]])
(when bm
(send bm get-argb-pixels x y w h bstr get-alpha?)))
(let ([bm bm])
(values (exact->inexact (send bm get-width))
(exact->inexact (send bm get-height)))))
(define/override (get-cr) c)
@ -97,9 +74,49 @@
(define black (send the-color-database find-color "black"))
(define bitmap-dc%
(class (dc-mixin dc-backend%)
(inherit draw-bitmap-section)
(class (dc-mixin bitmap-dc-backend%)
(inherit draw-bitmap-section
internal-set-bitmap
internal-get-bitmap)
(super-new)
(def/public (set-bitmap [(make-or-false bitmap%) v])
(internal-set-bitmap v))
(def/public (get-bitmap)
(internal-get-bitmap))
(def/public (set-pixel [real? x][real? y][color% c])
(let ([s (bytes 255 (color-red c) (color-green c) (color-blue c))])
(set-argb-pixels x y 1 1 s)))
(def/public (get-pixel [real? x][real? y][color% c])
(let ([b (make-bytes 4)])
(get-argb-pixels x y 1 1 b)
(send c set (bytes-ref b 1) (bytes-ref b 2) (bytes-ref b 3))
#t))
(def/public (set-argb-pixels [exact-nonnegative-integer? x]
[exact-nonnegative-integer? y]
[exact-nonnegative-integer? w]
[exact-nonnegative-integer? h]
[bytes? bstr]
[any? [set-alpha? #f]])
(let ([bm (internal-get-bitmap)])
(when bm
(send bm set-argb-pixels x y w h bstr set-alpha?))))
(def/public (get-argb-pixels [exact-nonnegative-integer? x]
[exact-nonnegative-integer? y]
[exact-nonnegative-integer? w]
[exact-nonnegative-integer? h]
[bytes? bstr]
[any? [get-alpha? #f]])
(let ([bm (internal-get-bitmap)])
(when bm
(send bm get-argb-pixels x y w h bstr get-alpha?))))
(def/public (draw-bitmap-section-smooth [bitmap% src]
[real? dest-x]
[real? dest-y]
@ -110,8 +127,6 @@
[(symbol-in solid opaque xor) [style 'solid]]
[(make-or-false color%) [color black]]
[(make-or-false bitmap%) [mask #f]])
(draw-bitmap-section src dest-x dest-y src-x src-y src-w src-h style color mask))
(super-new)))
(draw-bitmap-section src dest-x dest-y src-x src-y src-w src-h style color mask))))
(install-bitmap-dc-class! bitmap-dc%)

4
collects/racket/draw/bitmap.rkt
View File

@ -184,7 +184,7 @@
(def/public (get-loaded-mask) loaded-mask)
(def/public (set-loaded-mask [(make-or-false bitmap%) m]) (set! loaded-mask m))
(define/private (release-s)
(define/public (release-bitmap-storage)
(drop-alpha-s)
(when s
(let ([s2 s])
@ -201,7 +201,7 @@
(def/public (load-bitmap [(make-alts path-string? input-port?) in]
[kind-symbol? [kind 'unknown]]
[(make-or-false color%) [bg #f]])
(release-s)
(release-bitmap-storage)
(set!-values (s b&w?) (do-load-bitmap in kind bg))
(set! width (if s (cairo_image_surface_get_width s) 0))
(set! height (if s (cairo_image_surface_get_height s) 0)))

17
collects/racket/draw/dc.rkt
View File

@ -55,6 +55,10 @@
;; This is the interface that the backend specific code must implement
(define dc-backend<%>
(interface ()
;; call-with-cr-lock : (-> any) -> any
;;
;; Calls a thunk while holding the lock on the cairo context.
;; get-cr : -> cairo_t or #f
;;
;; Gets a cairo_t created in a backend specific manner.
@ -125,6 +129,12 @@
(define default-dc-backend%
(class* object% (dc-backend<%>)
(define lock (make-semaphore 1))
(define/public (call-with-cr-lock thunk)
(call-with-semaphore
lock
thunk))
(define/public (get-cr) #f)
(define/public (release-cr cr) (void))
(define/public (end-cr) (void))
@ -177,13 +187,10 @@
(inherit flush-cr get-cr release-cr end-cr init-cr-matrix get-pango
install-color dc-adjust-smoothing reset-clip
collapse-bitmap-b&w?)
(define lock (make-semaphore 1))
collapse-bitmap-b&w? call-with-cr-lock)
(define-syntax-rule (with-cr default cr . body)
(call-with-semaphore
lock
(call-with-cr-lock
(lambda ()
(let ([cr (get-cr)])
(if cr

6
collects/racket/draw/local.rkt
View File

@ -10,6 +10,11 @@
;; bitmap%
get-cairo-surface
get-cairo-alpha-surface
release-bitmap-storage
;; bitmap-dc%
internal-get-bitmap
internal-set-bitmap
;; dc%
in-cairo-context
@ -26,6 +31,7 @@
get-ps-pango
;; dc-backend<%>
call-with-cr-lock
get-cr
end-cr
reset-cr