1#lang racket/base 2(require racket/class 3 ffi/unsafe 4 ffi/unsafe/alloc 5 racket/draw 6 racket/draw/private/local 7 racket/draw/unsafe/cairo 8 "../../lock.rkt" 9 racket/draw/unsafe/bstr 10 "utils.rkt" 11 "types.rkt" 12 (only-in '#%foreign ffi-callback)) 13 14(provide 15 (protect-out bitmap->pixbuf 16 pixbuf->bitmap 17 18 _GdkPixbuf 19 gtk_image_new_from_pixbuf 20 release-pixbuf)) 21 22(define _GdkPixbuf (_cpointer/null 'GdkPixbuf)) 23 24(define release-pixbuf ((deallocator) g_object_unref)) 25 26(define-gtk gtk_image_new_from_pixbuf (_fun _GdkPixbuf -> _GtkWidget)) 27(define-gdk_pixbuf gdk_pixbuf_new_from_data (_fun _pointer ; data 28 _int ; 0 =RGB 29 _gboolean ; has_alpha? 30 _int ; bits_per_sample 31 _int ; width 32 _int ; height 33 _int ; rowstride 34 _fpointer ; destroy 35 _pointer ; destroy data 36 -> _GdkPixbuf) 37 #:wrap (allocator release-pixbuf)) 38 39(define-gdk gdk_cairo_set_source_pixbuf (_fun _cairo_t _GdkPixbuf _double* _double* -> _void)) 40(define-gdk_pixbuf gdk_pixbuf_get_width (_fun _GdkPixbuf -> _int)) 41(define-gdk_pixbuf gdk_pixbuf_get_height (_fun _GdkPixbuf -> _int)) 42 43(define free-it (ffi-callback free 44 (list _pointer) 45 _void 46 #f 47 #t)) 48 49(define (bitmap->pixbuf orig-bm [scale 1.0]) 50 (let* ([w (send orig-bm get-width)] 51 [h (send orig-bm get-height)] 52 [sw (ceiling (inexact->exact (* scale w)))] 53 [sh (ceiling (inexact->exact (* scale h)))] 54 [str (make-bytes (* sw sh 4) 255)]) 55 (define-values (bm unscaled? usw ush) 56 (cond 57 [(= scale 1.0) (values orig-bm #f w h)] 58 [(= scale (send orig-bm get-backing-scale)) (values orig-bm #t sw sh)] 59 [else (values (rescale orig-bm scale) #f sw sh)])) 60 (send bm get-argb-pixels 0 0 usw ush str #f #:unscaled? unscaled?) 61 (let ([mask (send bm get-loaded-mask)]) 62 (when mask 63 (send mask get-argb-pixels 0 0 usw ush str #t #:unscaled? unscaled?))) 64 (atomically 65 (let ([rgba (malloc (* sw sh 4) 'raw)]) 66 (memcpy rgba (ptr-add str 1) (sub1 (* sw sh 4))) 67 (for ([i (in-range 0 (* sw sh 4) 4)]) 68 (ptr-set! rgba _byte (+ i 3) (bytes-ref str i))) 69 (gdk_pixbuf_new_from_data rgba 70 0 71 #t 72 8 73 sw 74 sh 75 (* sw 4) 76 free-it 77 #f))))) 78 79(define (pixbuf->bitmap pixbuf) 80 (let* ([w (gdk_pixbuf_get_width pixbuf)] 81 [h (gdk_pixbuf_get_height pixbuf)] 82 [bm (make-object bitmap% w h #f #t)] 83 [s (send bm get-cairo-surface)] 84 [cr (cairo_create s)]) 85 (gdk_cairo_set_source_pixbuf cr pixbuf 0 0) 86 (cairo_rectangle cr 0 0 w h) 87 (cairo_fill cr) 88 (cairo_destroy cr) 89 bm)) 90 91(define (rescale bm scale) 92 (define w (send bm get-width)) 93 (define h (send bm get-height)) 94 (define new-bm (make-bitmap (ceiling (inexact->exact (* scale w))) 95 (ceiling (inexact->exact (* scale h))))) 96 (define dc (send new-bm make-dc)) 97 (send dc set-scale scale scale) 98 (send dc set-smoothing 'smoothed) 99 (send dc draw-bitmap bm 0 0) 100 new-bm) 101