Add interface for simple compositing layers to dc<%>

draw-lib/info.rkt

@@ -17,4 +17,4 @@
 
 (define pkg-authors '(mflatt))
 
-(define version "1.15")
+(define version "1.16")

draw-lib/racket/draw/private/dc-intf.rkt

@@ -33,6 +33,7 @@
         'horizontal-hatch 'vertical-hatch))
 
 (define dc<%>
+  (let ([is-a-dc<%>/c (recursive-contract (is-a?/c dc<%>) #:flat)])
   (interface ()
     [cache-font-metrics-key (->m exact-integer?)]
     [clear (->m void?)]
@@ -65,6 +66,7 @@
                        (and/c real? (not/c negative?))
                        (and/c real? (not/c negative?))
                        void?)]
+    [draw-layer (->*m [is-a-dc<%>/c] [real? real?] void?)]
     [draw-line (->m real? real?
                     real? real?
                     void?)]
@@ -135,6 +137,7 @@
                                                  real? real? real?)
                                        real? real? real? real? real?))]
     [glyph-exists? (->m char? boolean?)]
+    [make-layer (->m is-a-dc<%>/c)]
     [ok? (->m boolean?)]
     [resume-flush (->m void?)]
     [rotate (->m real? void?)]
@@ -177,4 +180,4 @@
     [transform (->m (vector/c real? real? real? real? real? real?)
                     void?)]
     [translate (->m real? real? void?)]
-    [try-color (->m (is-a?/c color%) (is-a?/c color%) void?)]))
+    [try-color (->m (is-a?/c color%) (is-a?/c color%) void?)])))

draw-lib/racket/draw/private/dc.rkt

@@ -26,6 +26,8 @@
 (provide dc-mixin
          dc-backend<%>
          default-dc-backend%
+         layer-dc-backend<%>
+         layer-mixin
          do-set-pen!
          do-set-brush!
          (protect-out set-font-map-init-hook!))
@@ -857,6 +859,11 @@
                    (loop x y (- w dx) h x2 y2)])]))
              (cairo_set_operator cr CAIRO_OPERATOR_OVER)))))
 
+    (define/private (install-smoothing cr)
+      (cairo_set_antialias cr (case (dc-adjust-smoothing smoothing)
+                                [(unsmoothed) CAIRO_ANTIALIAS_NONE]
+                                [else CAIRO_ANTIALIAS_GRAY])))
+
     (define/private (make-pattern-surface cr col draw)
       (let* ([s (cairo_surface_create_similar (cairo_get_target cr)
                                               CAIRO_CONTENT_COLOR_ALPHA
@@ -865,9 +872,7 @@
         (install-color cr2 col alpha #f)
         (cairo_set_line_width cr2 1)
         (cairo_set_line_cap cr CAIRO_LINE_CAP_ROUND)
-        (cairo_set_antialias cr2 (case (dc-adjust-smoothing smoothing)
-                                   [(unsmoothed) CAIRO_ANTIALIAS_NONE]
-                                   [else CAIRO_ANTIALIAS_GRAY]))
+        (install-smoothing cr2)
         (draw cr2)
         (cairo_stroke cr2)
         (cairo_destroy cr2)
@@ -944,9 +949,7 @@
           (when transformation
             (do-reset-matrix cr))
           (cairo_pattern_destroy p)))
-      (cairo_set_antialias cr (case (dc-adjust-smoothing smoothing)
-                                [(unsmoothed) CAIRO_ANTIALIAS_NONE]
-                                [else CAIRO_ANTIALIAS_GRAY]))
+      (install-smoothing cr)
       (when brush?
         (let ([s (send brush get-style)])
           (unless (eq? 'transparent s)
@@ -2119,10 +2122,92 @@
                                (s-sel (cairo_matrix_t-xx mx)
                                       (cairo_matrix_t-yy mx)))))))))
 
+    (define/pubment (make-layer)
+      (define layer (inner (new surface-layer-dc% [owner this]) make-layer))
+      (send layer set-pen pen)
+      (send layer set-brush brush)
+      (send layer set-font font)
+      (send layer set-text-foreground text-fg)
+      (send layer set-text-background text-bg)
+      (send layer set-alignment-scale alignment-scale)
+      (send layer set-smoothing smoothing)
+      layer)
+
+    (def/public (draw-layer [dc<%> layer] [real? [x 0]] [real? [y 0]])
+      (unless (and (is-a? layer layer-dc-backend<%>)
+                   (object=? this (send layer get-owner)))
+        (raise-arguments-error (method-name 'dc<%> 'draw-layer)
+                               (string-append "the given dc<%> does not belong to this dc<%>;\n"
+                                              " it must have been created by a call to make-layer"
+                                              " on this object")))
+      (draw-owned-layer layer x y))
+
+    (define/public (draw-owned-layer layer x y)
+      (define surface (send layer get-cairo-surface))
+      (with-cr
+        (check-ok 'draw-layer)
+        cr
+        (install-smoothing cr)
+        (cairo_set_source_surface cr surface (align-x/delta x 0) (align-y/delta y 0))
+        (cairo_paint_with_alpha cr alpha)
+        (flush-cr)))
+
     (super-new))
 
   dc%)
 
+(define layer-dc-backend<%>
+  (interface (dc-backend<%>)
+    get-owner))
+
+(define-syntax-rule (define-proxy-methods #:to target method-name ...)
+  (begin
+    (define/override (method-name . args)
+      (send target method-name . args))
+    ...))
+
+(define layer-mixin
+  (mixin (dc-backend<%>) (layer-dc-backend<%>)
+    (init owner)
+    (define owner-dc owner)
+    (define/public (get-owner) owner-dc)
+
+    (define-proxy-methods #:to owner-dc
+      get-pango
+      collapse-bitmap-b&w?
+      get-font-metrics-key
+      dc-adjust-smoothing
+      dc-adjust-cap-shape
+      get-hairline-width
+      install-color
+      get-size
+      get-device-scale
+      get-backing-scale
+      can-combine-text?
+      can-mask-bitmap?
+      get-clear-operator)
+
+    (super-new)))
+
+(define surface-layer-dc%
+  (dc-mixin
+   (class (layer-mixin default-dc-backend%)
+     (define surface (cairo_recording_surface_create CAIRO_CONTENT_COLOR_ALPHA #f))
+     (unless surface
+       (raise (exn:fail:unsupported
+               (format (string-append "~a: operation not supported by backend\n"
+                                      "  backend: cairo\n"
+                                      "  current version: ~a\n"
+                                      "  required version: 1.10")
+                       (method-name 'dc<%> 'new-layer) (cairo_version_string)))
+              (current-continuation-marks)))
+
+     (define cr (cairo_create surface))
+     (define/public (get-cairo-surface) surface)
+     (define/override (get-cr) cr)
+
+     (super-new))))
+
 (set-text-to-path!
  (lambda (font str x y combine?)
    (define s (cairo_recording_surface_create CAIRO_CONTENT_COLOR_ALPHA #f))

draw-lib/racket/draw/private/local.rkt

@@ -27,6 +27,7 @@
   get-clipping-matrix
   reset-config
   internal-copy
+  draw-owned-layer
 
   ;; region%
   install-region
@@ -59,4 +60,7 @@
   can-combine-text?
   can-mask-bitmap?
   reset-clip
-  get-clear-operator)
+  get-clear-operator
+
+  ;; layer-dc-backend<%>
+  get-owner)

draw-lib/racket/draw/private/page-dc.rkt

@@ -103,6 +103,7 @@
      (draw-rectangle x y w h)
      (draw-point x y)
      (draw-line x1 y1 x2 y2)
+     (draw-layer layer [x [y]])
      (clear)
      (erase))
 

draw-lib/racket/draw/private/record-dc.rkt

@@ -388,7 +388,7 @@
              get-pen get-brush get-font
              get-smoothing get-text-mode 
              get-background get-text-background get-text-foreground
-             get-alpha get-clipping-region
+             get-alpha get-clipping-region get-size
              translate rotate scale)
 
     (define record-limit +inf.0)
@@ -457,7 +457,7 @@
 
     (define-syntax (generate-record-unconvert stx)
       (syntax-case stx ()
-        [(_ ([clause-tags clause-rhs] ...) (defn (name arg ...)) ...)
+        [(_ record-unconvert ([clause-tags clause-rhs] ...) (defn (name arg ...)) ...)
          (with-syntax ([((arg-id ...) ...)
                         (let ([names (syntax->list #'(name ...))]
                               [argss (syntax->list #'((arg ...) ...))])
@@ -646,7 +646,22 @@
                   (install-transform dc (apply-transform state t)))
                 (lambda () `(transform ,t)))))
 
+    (define/augride (make-layer)
+      (define-values (w h) (get-size))
+      (new record-layer-dc% [owner this] [width w] [height h]))
+
+    (define/override (draw-owned-layer layer x y)
+      (define proc (send layer get-recorded-command #f))
+      (define datum (send layer get-recorded-command #t))
+      (record (lambda (dc state)
+                (define layer (send dc make-layer))
+                (proc layer)
+                (send dc draw-layer layer x y)
+                state)
+              (lambda () `(draw-layer ,datum ,x ,y))))
+
     (generate-record-unconvert
+     record-unconvert
      ([(set-clipping-region) (lambda (r) 
                                (define make-r (unconvert-region r))
                                (lambda (dc state)
@@ -682,7 +697,14 @@
                                 (install-transform dc (struct-copy dc-state state [initial-matrix mi]))))]
       [(transform) (lambda (t)
                      (lambda (dc state)
-                       (install-transform dc (apply-transform state t))))])
+                       (install-transform dc (apply-transform state t))))]
+      [(draw-layer) (lambda (datum x y)
+                      (define layer-drawer (generate-drawer (record-unconvert datum)))
+                      (lambda (dc state)
+                        (define layer (send dc make-layer))
+                        (layer-drawer layer)
+                        (send dc draw-layer layer x y)
+                        state))])
      ;; remaining clauses are generated:
 
      (define/record (set-smoothing s))
@@ -780,6 +802,8 @@
     (super-new)
     (reset-recording)))
 
+(define record-layer-dc% (record-dc-mixin (dc-mixin (layer-mixin record-dc-backend%))))
+
 (define (recorded-datum->procedure d)
   (generate-drawer/restore (send (new record-dc%) record-unconvert d)))
 

draw-lib/racket/draw/unsafe/cairo.rkt

@@ -56,6 +56,8 @@
 (define-syntax-rule (_cbfun . rest)
   (_fun #:atomic? #t . rest))
 
+(define-cairo cairo_version_string (_cfun -> _string))
+
 (define-cairo cairo_destroy (_cfun _cairo_t -> _void) 
   #:wrap (deallocator))