<commit_before>#lang racket/base
(require ffi/unsafe
	 ffi/winapi
         racket/class
         "utils.rkt"
         "types.rkt"
         "gl-context.rkt"
	 "../../lock.rkt"
         "../common/backing-dc.rkt"
         "../common/delay.rkt"
         racket/draw/unsafe/cairo
         racket/draw/private/dc
         racket/draw/private/bitmap
         racket/draw/private/local
         ffi/unsafe/alloc)

(provide 
 (protect-out dc%
              win32-bitmap%
              do-backing-flush
              request-flush-delay
              cancel-flush-delay))

(define-gdi32 SelectClipRgn (_wfun _pointer _pointer -> _int))

(define-gdi32 GetClipBox (_wfun _pointer _RECT-pointer -> _int))
(define SIMPLEREGION 2)

(define-gdi32 BitBlt (_wfun _pointer _int _int _int _int _pointer _int _int _DWORD -> _BOOL))
(define SRCCOPY #X00cc0020)

(define hwnd-param (make-parameter #f))

(define need-clip-workarounds? #t)

(define win32-bitmap%
  (class win32-no-hwnd-bitmap%
    (init w h hwnd [gl-config #f])
    (inherit get-cairo-surface)
    (parameterize ([hwnd-param hwnd])
      (super-new [w w] [h h] [backing-scale (->screen 1.0)]))
    
    (define/override (build-cairo-surface w h backing-scale)
      (define hwnd (hwnd-param))
      (if hwnd
          (atomically
           (let ([hdc (GetDC hwnd)])
             (begin0
	      (let ([sw (inexact->exact (floor (* backing-scale w)))]
		    [sh (inexact->exact (floor (* backing-scale h)))])
		(cairo_win32_surface_create_with_ddb hdc
						     CAIRO_FORMAT_RGB24 sw sh))
               (ReleaseDC hwnd hdc))))
          (super build-cairo-surface w h backing-scale)))
    
    (define gl (and gl-config
                    (let ([hdc (cairo_win32_surface_get_dc (get-cairo-surface))])
                      (set-cpointer-tag! hdc 'HDC)
                      (create-gl-context hdc 
                                         gl-config
                                         #t))))
    (define/override (get-bitmap-gl-context) gl)))

(define dc%
  (class backing-dc%
    (init [(cnvs canvas)]
          transparent?)
    (inherit end-delay)
    (define canvas cnvs)

    (super-new [transparent? transparent?])

    (inherit internal-get-bitmap)
    (define/override (reset-clip cr)
      (super reset-clip cr)
      ;; Work around a Cairo(?) bug. When a clipping
      ;; region is set, we draw text, and then the clipping
      ;; region is changed, the change doesn't take
      ;; until we draw more text --- but only with DDB surfaces.
      (when need-clip-workarounds?
	(let ([bm (internal-get-bitmap)])
	  (when (bm . is-a? . win32-bitmap%)
	    (SelectClipRgn (cairo_win32_surface_get_dc
			    (send bm get-cairo-surface))
			   #f)))))

    (define gl #f)
    (define/override (get-gl-context)
      (or gl
          (let ([v (create-gl-context (GetDC (send canvas get-client-hwnd))
                                      (send canvas get-gl-config)
                                      #f)])
	    (when v (set! gl v))
	    v)))

    (define/override (make-backing-bitmap w h)
      (if (send canvas get-canvas-background)
          (make-object win32-bitmap% w h (send canvas get-hwnd))
	  (make-object bitmap% w h #f #t (->screen 1.0))))

    (define/override (get-backing-size xb yb)
      (send canvas get-client-size xb yb))

    (define/override (get-size)
      (let ([xb (box 0)]
            [yb (box 0)])
        (send canvas get-virtual-size xb yb)
        (values (unbox xb) (unbox yb))))

    (define/override (queue-backing-flush)
      ;; Re-enable expose events so that the queued 
      ;; backing flush will be handled:
      (end-delay)
      (send canvas queue-backing-flush))

    (define/override (flush)
      (send canvas flush))

    (define/override (request-delay)
      (request-flush-delay canvas))
    (define/override (cancel-delay req)
      (cancel-flush-delay req))))

(define (do-backing-flush canvas dc hdc)
  (send dc on-backing-flush
        (lambda (bm)
          (let ([w (box 0)]
                [h (box 0)])
            (send canvas get-client-size w h)
	    (define sw (->screen (unbox w)))
	    (define sh (->screen (unbox h)))
	    (define r (make-RECT 0 0 sw sh))
	    (define clip-type
	      (if need-clip-workarounds?
		  (GetClipBox hdc r)
		  SIMPLEREGION))
	    (cond
	     [(and need-clip-workarounds?
		   (not (and (= clip-type SIMPLEREGION)
			     (= (RECT-left r) 0)
			     (= (RECT-top r) 0)
			     (= (RECT-right r) sw)
			     (= (RECT-bottom r) sh))))
	      ;; Another workaround: a clipping region installed by BeginPaint()
	      ;; seems to interfere with Cairo drawing. So, draw to a
	      ;; fresh context and copy back and forth using Win32.
	      (define cw (- (RECT-right r) (RECT-left r)))
	      (define ch (- (RECT-bottom r) (RECT-top r)))
	      (let* ([surface (cairo_win32_surface_create_with_ddb hdc<commit_msg>racket/gui Windows: rely on patched Cairo instead of workaround<commit_after>#lang racket/base
(require ffi/unsafe
	 ffi/winapi
         racket/class
         "utils.rkt"
         "types.rkt"
         "gl-context.rkt"
	 "../../lock.rkt"
         "../common/backing-dc.rkt"
         "../common/delay.rkt"
         racket/draw/unsafe/cairo
         racket/draw/private/dc
         racket/draw/private/bitmap
         racket/draw/private/local
         ffi/unsafe/alloc)

(provide 
 (protect-out dc%
              win32-bitmap%
              do-backing-flush
              request-flush-delay
              cancel-flush-delay))

(define-gdi32 SelectClipRgn (_wfun _pointer _pointer -> _int))

(define-gdi32 GetClipBox (_wfun _pointer _RECT-pointer -> _int))
(define SIMPLEREGION 2)

(define-gdi32 BitBlt (_wfun _pointer _int _int _int _int _pointer _int _int _DWORD -> _BOOL))
(define SRCCOPY #X00cc0020)

(define hwnd-param (make-parameter #f))

(define need-clip-text-workaround? #t)
(define need-clip-refresh-workaround? #f) ; patched Cairo

(define win32-bitmap%
  (class win32-no-hwnd-bitmap%
    (init w h hwnd [gl-config #f])
    (inherit get-cairo-surface)
    (parameterize ([hwnd-param hwnd])
      (super-new [w w] [h h] [backing-scale (->screen 1.0)]))
    
    (define/override (build-cairo-surface w h backing-scale)
      (define hwnd (hwnd-param))
      (if hwnd
          (atomically
           (let ([hdc (GetDC hwnd)])
             (begin0
	      (let ([sw (inexact->exact (floor (* backing-scale w)))]
		    [sh (inexact->exact (floor (* backing-scale h)))])
		(cairo_win32_surface_create_with_ddb hdc
						     CAIRO_FORMAT_RGB24 sw sh))
               (ReleaseDC hwnd hdc))))
          (super build-cairo-surface w h backing-scale)))
    
    (define gl (and gl-config
                    (let ([hdc (cairo_win32_surface_get_dc (get-cairo-surface))])
                      (set-cpointer-tag! hdc 'HDC)
                      (create-gl-context hdc 
                                         gl-config
                                         #t))))
    (define/override (get-bitmap-gl-context) gl)))

(define dc%
  (class backing-dc%
    (init [(cnvs canvas)]
          transparent?)
    (inherit end-delay)
    (define canvas cnvs)

    (super-new [transparent? transparent?])

    (inherit internal-get-bitmap)
    (define/override (reset-clip cr)
      (super reset-clip cr)
      ;; Work around a Cairo(?) bug. When a clipping
      ;; region is set, we draw text, and then the clipping
      ;; region is changed, the change doesn't take
      ;; until we draw more text --- but only with DDB surfaces.
      (when need-clip-text-workaround?
	(let ([bm (internal-get-bitmap)])
	  (when (bm . is-a? . win32-bitmap%)
	    (SelectClipRgn (cairo_win32_surface_get_dc
			    (send bm get-cairo-surface))
			   #f)))))

    (define gl #f)
    (define/override (get-gl-context)
      (or gl
          (let ([v (create-gl-context (GetDC (send canvas get-client-hwnd))
                                      (send canvas get-gl-config)
                                      #f)])
	    (when v (set! gl v))
	    v)))

    (define/override (make-backing-bitmap w h)
      (if (send canvas get-canvas-background)
          (make-object win32-bitmap% w h (send canvas get-hwnd))
	  (make-object bitmap% w h #f #t (->screen 1.0))))

    (define/override (get-backing-size xb yb)
      (send canvas get-client-size xb yb))

    (define/override (get-size)
      (let ([xb (box 0)]
            [yb (box 0)])
        (send canvas get-virtual-size xb yb)
        (values (unbox xb) (unbox yb))))

    (define/override (queue-backing-flush)
      ;; Re-enable expose events so that the queued 
      ;; backing flush will be handled:
      (end-delay)
      (send canvas queue-backing-flush))

    (define/override (flush)
      (send canvas flush))

    (define/override (request-delay)
      (request-flush-delay canvas))
    (define/override (cancel-delay req)
      (cancel-flush-delay req))))

(define (do-backing-flush canvas dc hdc)
  (send dc on-backing-flush
        (lambda (bm)
          (let ([w (box 0)]
                [h (box 0)])
            (send canvas get-client-size w h)
	    (define sw (->screen (unbox w)))
	    (define sh (->screen (unbox h)))
	    (define r (make-RECT 0 0 sw sh))
	    (define clip-type
	      (if need-clip-refresh-workaround?
		  (GetClipBox hdc r)
		  SIMPLEREGION))
	    (cond
	     [(and need-clip-refresh-workaround?
		   (not (and (= clip-type SIMPLEREGION)
			     (= (RECT-left r) 0)
			     (= (RECT-top r) 0)
			     (= (RECT-right r) sw)
			     (= (RECT-bottom r) sh))))
	      ;; Another workaround: a clipping region installed by BeginPaint()
	      ;; seems to interfere with Cairo drawing. So, draw to a
	      ;; fresh context and copy back and forth using Win32.
	      (define cw (- (RECT-right r) (RECT-left r)))
	      (define ch (- (RECT-bottom r) (RECT-top r)))
	      (let* ([surface (cairo_win32_surface_create_with_ddb hdc
{'fraction_non_alphanumeric': 0.13106106715358085, 'fraction_numerical': 0.009738283627510651, 'mean_word_length': 2.0251610923596197, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 21, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 12, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2268654', 'n_tokens_mistral': 3474, 'n_tokens_neox': 3244, 'n_words': 878}