Cocoa: make copy method work for canvas DC

Also correct problems with disabled scrolling via `copy`.

gui-lib/info.rkt

@@ -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"

gui-lib/mred/private/wx/cocoa/dc.rkt

@@ -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

gui-lib/mred/private/wxme/editor-canvas.rkt

@@ -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)])))