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