1#lang racket/base 2(require ffi/unsafe 3 ffi/unsafe/define 4 racket/class 5 "utils.rkt" 6 "types.rkt" 7 "queue.rkt" 8 "window.rkt" 9 "frame.rkt" 10 "x11.rkt" 11 "win32.rkt" 12 "gl-context.rkt" 13 "../../lock.rkt" 14 "../common/backing-dc.rkt" 15 racket/draw/unsafe/cairo 16 racket/draw/private/dc 17 racket/draw/private/bitmap 18 racket/draw/private/local 19 ffi/unsafe/alloc) 20 21(provide 22 (protect-out dc% 23 do-backing-flush 24 x11-bitmap% 25 26 gdk_gc_new 27 gdk_gc_unref 28 gdk_gc_set_rgb_fg_color 29 gdk_gc_set_line_attributes 30 gdk_draw_rectangle)) 31 32(define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t) 33 #:wrap (allocator cairo_destroy)) 34 35(define-gdk gdk_gc_unref (_fun _pointer -> _void) 36 #:wrap (deallocator) 37 #:make-fail make-not-available) 38(define-gdk gdk_gc_new (_fun _GdkWindow -> _pointer) 39 #:wrap (allocator gdk_gc_unref) 40 #:make-fail make-not-available) 41(define-gdk gdk_gc_set_rgb_fg_color (_fun _pointer _GdkColor-pointer -> _void) 42 #:make-fail make-not-available) 43(define-gdk gdk_gc_set_line_attributes (_fun _pointer _int _int _int _int -> _void) 44 #:make-fail make-not-available) 45(define-gdk gdk_draw_rectangle (_fun _GdkWindow _pointer _gboolean _int _int _int _int -> _void) 46 #:make-fail make-not-available) 47 48(define-cstruct _GdkVisual-rec ([type-instance _pointer] 49 [ref_count _uint] 50 [qdata _pointer] 51 [type _int] 52 [depth _int])) 53(define-gdk gdk_visual_get_system (_fun -> _GdkVisual-rec-pointer)) 54 55(define x11-bitmap% 56 (class bitmap% 57 (init w h gtk) 58 59 (define sf 60 (if gtk3? 61 (if gtk 62 (->screen (gtk_widget_get_scale_factor gtk)) 63 (display-bitmap-resolution 0 (lambda () 1.0))) 64 (->screen 1.0))) 65 (define/private (scale x) 66 (min (max 1 (ceiling (inexact->exact (* sf x)))) 32000)) 67 68 (define-values (pixmap xdisplay xvisual) 69 (let ([gdk-win (and gtk (widget-window gtk))]) 70 (if gtk3? 71 (let* ([gdk-win (or gdk-win 72 (gdk_screen_get_root_window 73 (gdk_screen_get_default)))] 74 [xdisplay (gdk_x11_display_get_xdisplay 75 (if gdk-win 76 (gdk_window_get_display gdk-win) 77 (gdk_display_get_default)))] 78 [visual (gdk_window_get_visual gdk-win)]) 79 ;; We must not get here for a transparent canvas, 80 ;; because getting an XID will force a native window. 81 (values (XCreatePixmap xdisplay 82 (gdk_x11_window_get_xid gdk-win) 83 (scale w) (scale h) 84 (gdk_visual_get_depth visual)) 85 xdisplay 86 (gdk_x11_visual_get_xvisual visual))) 87 (let ([pixmap (gdk_pixmap_new gdk-win 88 (scale w) 89 (scale h) 90 (if gdk-win 91 -1 92 (GdkVisual-rec-depth 93 (gdk_visual_get_system))))]) 94 (values pixmap 95 (gdk_x11_display_get_xdisplay 96 (gdk_drawable_get_display pixmap)) 97 (gdk_x11_visual_get_xvisual 98 (gdk_drawable_get_visual pixmap))))))) 99 100 (define s 101 (cairo_xlib_surface_create xdisplay 102 (if gtk3? 103 (cast pixmap _Pixmap _ulong) 104 (gdk_x11_drawable_get_xid pixmap)) 105 xvisual 106 (scale w) 107 (scale h))) 108 109 (define gl #f) 110 111 (super-make-object (make-alternate-bitmap-kind 112 w 113 h 114 sf)) 115 116 ;; initialize bitmap to white: 117 (let ([cr (cairo_create s)]) 118 (cairo_set_source_rgba cr 1.0 1.0 1.0 1.0) 119 (cairo_paint cr) 120 (cairo_destroy cr)) 121 122 ;; `get-gdk-pixmap' and `install-gl-context' are 123 ;; localized in "gl-context.rkt" 124 (define/public (get-gdk-pixmap) pixmap) 125 (define/public (install-gl-context new-gl) (set! gl new-gl)) 126 127 (define/override (get-bitmap-gl-context) gl) 128 129 (define/override (ok?) #t) 130 (define/override (is-color?) #t) 131 (define/override (has-alpha-channel?) #f) 132 133 (define/override (get-cairo-surface) s) 134 135 (define/override (release-bitmap-storage) 136 (atomically 137 (cairo_surface_destroy s) 138 (if gtk3? 139 (XFreePixmap xdisplay pixmap) 140 (gobject-unref pixmap)) 141 (set! s #f))))) 142 143(define cairo-bitmap% 144 (class bitmap% 145 (init w h gtk) 146 (super-make-object w h #f #t 147 (if gtk3? 148 (if gtk 149 (->screen (gtk_widget_get_scale_factor gtk)) 150 (display-bitmap-resolution 0 (lambda () 1.0))) 151 (->screen 1.0))))) 152 153(define win32-bitmap% 154 (class bitmap% 155 (init w h gdk-win) 156 (super-make-object (make-alternate-bitmap-kind w h)) 157 158 (define s 159 (if (not gdk-win) 160 (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) 161 (atomically 162 (let ([hdc (GetDC (gdk_win32_drawable_get_handle gdk-win))]) 163 (begin0 164 (cairo_win32_surface_create_with_ddb hdc 165 CAIRO_FORMAT_RGB24 w h) 166 (ReleaseDC hdc)))))) 167 168 (define/override (ok?) #t) 169 (define/override (is-color?) #t) 170 (define/override (has-alpha-channel?) #f) 171 172 (define/override (get-cairo-surface) s) 173 174 (define/override (release-bitmap-storage) 175 (atomically 176 (cairo_surface_destroy s) 177 (set! s #f))))) 178 179(define dc% 180 (class backing-dc% 181 (init [(cnvs canvas)] 182 transparentish?) 183 (inherit end-delay) 184 (define canvas cnvs) 185 (define gl #f) 186 (define is-transparentish? transparentish?) 187 188 (super-new [transparent? transparentish?]) 189 190 (define/override (get-gl-context) 191 (or gl 192 (let ([v (create-widget-gl-context (send canvas get-client-gtk))]) 193 (when v (set! gl v)) 194 v))) 195 196 (define/override (make-backing-bitmap w h) 197 (cond 198 [(and (not is-transparentish?) 199 (not wayland?) 200 (eq? 'unix (system-type))) 201 (make-object x11-bitmap% w h (send canvas get-client-gtk))] 202 [(and (not is-transparentish?) 203 (not wayland?) 204 (eq? 'windows (system-type))) 205 (make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))] 206 [else 207 ;; Transparent canvas always use a Cairo bitmap: 208 (make-object cairo-bitmap% (max 1 w) (max 1 h) (send canvas get-client-gtk))])) 209 210 (define/override (get-backing-size xb yb) 211 (send canvas get-client-size xb yb)) 212 213 (define/override (get-size) 214 (let ([xb (box 0)] 215 [yb (box 0)]) 216 (send canvas get-virtual-size xb yb) 217 (values (unbox xb) (unbox yb)))) 218 219 (define/override (queue-backing-flush) 220 ;; Re-enable expose events so that the queued 221 ;; backing flush will be handled: 222 (end-delay) 223 (send canvas queue-backing-flush)) 224 225 (define/override (flush) 226 (send canvas flush)) 227 228 (define/override (request-delay) 229 (request-flush-delay (send canvas get-flush-window) is-transparentish?)) 230 (define/override (cancel-delay req) 231 (cancel-flush-delay req)))) 232 233(define (do-backing-flush canvas dc win-or-cr) 234 (send dc on-backing-flush 235 (lambda (bm) 236 (let ([w (box 0)] 237 [h (box 0)]) 238 (send canvas get-client-size w h) 239 (let ([cr (if gtk3? 240 win-or-cr 241 (gdk_cairo_create win-or-cr))]) 242 (cairo_scale cr (->screen 1.0) (->screen 1.0)) 243 (backing-draw-bm bm cr (unbox w) (unbox h) 0 0 (->screen 1.0)) 244 (unless gtk3? 245 (cairo_destroy cr))))))) 246