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