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

move collecting-blit helper to common code

Browse Source 
original commit: 5dd568050b8ea693302f71561406d7be5e3bdfec
This commit is contained in:
Matthew Flatt 2010-10-10 18:38:06 -06:00
parent 5ad1f535b4
commit 5c3ee6847e
3 changed files with 23 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -717,16 +717,7 @@
(cons win r))))))) (cons win r)))))))
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
(let ([on (if (and (zero? on-x) (let ([on (fix-bitmap-size on w h on-x on-y)])
(zero? on-y)
(= (send on get-width) w)
(= (send on get-height) h))
on
(let ([bm (make-object bitmap% w h)])
(let ([dc (make-object bitmap-dc% on)])
(send dc draw-bitmap-section on 0 0 on-x on-y w h)
(send dc set-bitmap #f)
bm)))])
(let ([img (bitmap->image on)]) (let ([img (bitmap->image on)])
(atomically (atomically
(set! blits (cons (list x y w h img) blits)) (set! blits (cons (list x y w h img) blits))

17
collects/mred/private/wx/common/canvas-mixin.rkt
View File

@ -1,9 +1,11 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/draw
"backing-dc.rkt") "backing-dc.rkt")
(provide canvas-autoscroll-mixin (provide canvas-autoscroll-mixin
canvas-mixin) canvas-mixin
fix-bitmap-size)
;; Implements canvas autoscroll, applied *before* platform-specific canvas ;; Implements canvas autoscroll, applied *before* platform-specific canvas
;; methods: ;; methods:
@ -160,3 +162,16 @@
(when (or paint-queued (when (or paint-queued
(not (send (get-dc) can-backing-flush?))) (not (send (get-dc) can-backing-flush?)))
(do-on-paint #f #f))))) (do-on-paint #f #f)))))
;; useful for fixing the size of a collecting blit:
(define (fix-bitmap-size on w h on-x on-y)
(if (and (zero? on-x)
(zero? on-y)
(= (send on get-width) w)
(= (send on get-height) h))
on
(let ([bm (make-object bitmap% w h)])
(let ([dc (make-object bitmap-dc% on)])
(send dc draw-bitmap-section on 0 0 on-x on-y w h)
(send dc set-bitmap #f)
bm))))

17
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -560,23 +560,12 @@
(cons win r)))))) (cons win r))))))
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
(let ([fix-size (lambda (on on-x on-y) (let ([on (fix-bitmap-size on w h on-x on-y)]
(if (and (zero? on-x) [off (fix-bitmap-size off w h off-x off-y)])
(zero? on-y)
(= (send on get-width) w)
(= (send on get-height) h))
on
(let ([bm (make-object bitmap% w h)])
(let ([dc (make-object bitmap-dc% on)])
(send dc draw-bitmap-section on 0 0 on-x on-y w h)
(send dc set-bitmap #f)
bm))))])
(let ([on (fix-size on on-x on-y)]
[off (fix-size off off-x off-y)])
(let ([on-pixbuf (bitmap->pixbuf on)] (let ([on-pixbuf (bitmap->pixbuf on)]
[off-pixbuf (bitmap->pixbuf off)]) [off-pixbuf (bitmap->pixbuf off)])
(atomically (atomically
(set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits))))))) (set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits))))))
(define/public (unregister-collecting-blits) (define/public (unregister-collecting-blits)
(atomically (atomically