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

Cocoa: make copy method work for canvas DC

Browse Source 
Also correct problems with disabled scrolling via `copy`.
This commit is contained in:
Matthew Flatt 2015-11-23 10:49:52 -07:00
parent b29a7ae399
commit facc07e123
3 changed files with 46 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gui-lib/info.rkt
View File

@ -6,7 +6,7 @@
"data-lib"
["base" #:version "6.2.900.17"]
"syntax-color-lib"
["draw-lib" #:version "1.10"]
["draw-lib" #:version "1.11"]
"snip-lib"
"wxme-lib"
"pict-lib"

40
gui-lib/mred/private/wx/cocoa/dc.rkt
View File

@ -33,7 +33,7 @@
transparent?)
(define canvas cnvs)
(inherit end-delay)
(inherit end-delay internal-get-bitmap internal-copy)
(super-new [transparent? transparent?])
(define gl #f)
@ -67,6 +67,14 @@
(make-window-bitmap w h (send canvas get-cocoa-window)
trans?
(send canvas is-flipped?)))
(def/override (copy [real? x] [real? y] [nonnegative-real? w] [nonnegative-real? h]
[real? x2] [real? y2])
(internal-copy x y w h x2 y2
(lambda (cr x y w h x2 y2)
(define bm (internal-get-bitmap))
(and bm
(send bm do-self-copy cr x y w h x2 y2)))))
(define/override (can-combine-text? sz) #t)
@ -236,6 +244,36 @@
#t)]
[else #f]))
(define/override (do-self-copy cr x y w h x2 y2)
(define bs (get-backing-scale))
(define s (cairo_get_target cr))
(cairo_surface_flush s)
(define cg (cairo_quartz_surface_get_cg_context s))
(define orig-size (CGLayerGetSize layer))
(atomically
(begin
;; A Cairo flush doesn't reset the clipping region. The
;; implementation of clipping is that there's a saved
;; GState that we can use to get back to the original
;; clipping region, so restore (and save again) that state:
(CGContextRestoreGState cg)
(CGContextSaveGState cg))
(define new-layer (CGLayerCreateWithContext cg (make-NSSize w h) #f))
(define new-cg (CGLayerGetContext new-layer))
(CGContextTranslateCTM new-cg 0 h)
(CGContextScaleCTM new-cg 1 -1)
(CGContextScaleCTM cg bs bs)
(CGContextDrawLayerAtPoint new-cg
(make-NSPoint (- x) (- (- (NSSize-height orig-size) y h)))
layer)
(CGContextDrawLayerAtPoint cg
(make-NSPoint x2 y2)
new-layer)
(CGContextScaleCTM cg (/ bs) (/ bs))
(CGLayerRelease new-layer)
(cairo_surface_mark_dirty s))
#t)
(define s-bm #f)
(define/override (get-cairo-surface)
;; Convert to a platform bitmap, which Cairo understands

10
gui-lib/mred/private/wxme/editor-canvas.rkt
View File

@ -628,12 +628,14 @@
(when clear?
(let ([bg (get-canvas-background)])
(when bg
(let ([adc (get-dc)])
(let* ([dx (box 0)]
[dy (box 0)]
[adc (get-dc-and-offset dx dy)])
(let ([b (send adc get-brush)]
[p (send adc get-pen)])
(send adc set-brush bg 'solid)
(send adc set-pen bg 1 'transparent)
(send adc draw-rectangle localx localy fw fh)
(send adc draw-rectangle (- localx (unbox dx)) (- localy (unbox dy)) fw fh)
(send adc set-brush b)
(send adc set-pen p))))))
(let ([x (box 0)]
@ -990,7 +992,7 @@
xmargin ymargin
vw (- (+ new-fy vh) old-fy)
xmargin (+ ymargin (- old-fy new-fy)))
(redraw xmargin ymargin
(redraw vx vy
vw (- old-fy new-fy)
#t))]
[(and (old-fy . < . new-fy)
@ -1001,7 +1003,7 @@
vw (- (+ old-fy vh) new-fy)
xmargin ymargin)
(let ([d (- (+ old-fy vh) new-fy)])
(redraw xmargin (+ ymargin d)
(redraw vx (+ vy d)
vw (- vh d)
#t)))]
[else (repaint)])))