101 lines
3.4 KiB
Racket
101 lines
3.4 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
ffi/unsafe
|
|
ffi/unsafe/alloc
|
|
racket/draw
|
|
racket/draw/private/local
|
|
racket/draw/unsafe/cairo
|
|
"../../lock.rkt"
|
|
racket/draw/unsafe/bstr
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
(only-in '#%foreign ffi-callback))
|
|
|
|
(provide
|
|
(protect-out bitmap->pixbuf
|
|
pixbuf->bitmap
|
|
|
|
_GdkPixbuf
|
|
gtk_image_new_from_pixbuf
|
|
release-pixbuf))
|
|
|
|
(define _GdkPixbuf (_cpointer/null 'GdkPixbuf))
|
|
|
|
(define release-pixbuf ((deallocator) g_object_unref))
|
|
|
|
(define-gtk gtk_image_new_from_pixbuf (_fun _GdkPixbuf -> _GtkWidget))
|
|
(define-gdk_pixbuf gdk_pixbuf_new_from_data (_fun _pointer ; data
|
|
_int ; 0 =RGB
|
|
_gboolean ; has_alpha?
|
|
_int ; bits_per_sample
|
|
_int ; width
|
|
_int ; height
|
|
_int ; rowstride
|
|
_fpointer ; destroy
|
|
_pointer ; destroy data
|
|
-> _GdkPixbuf)
|
|
#:wrap (allocator release-pixbuf))
|
|
|
|
(define-gdk gdk_cairo_set_source_pixbuf (_fun _cairo_t _GdkPixbuf _double* _double* -> _void))
|
|
(define-gdk_pixbuf gdk_pixbuf_get_width (_fun _GdkPixbuf -> _int))
|
|
(define-gdk_pixbuf gdk_pixbuf_get_height (_fun _GdkPixbuf -> _int))
|
|
|
|
(define free-it (ffi-callback free
|
|
(list _pointer)
|
|
_void
|
|
#f
|
|
#t))
|
|
|
|
(define (bitmap->pixbuf orig-bm [scale 1.0])
|
|
(let* ([w (send orig-bm get-width)]
|
|
[h (send orig-bm get-height)]
|
|
[sw (ceiling (inexact->exact (* scale w)))]
|
|
[sh (ceiling (inexact->exact (* scale h)))]
|
|
[str (make-bytes (* sw sh 4) 255)])
|
|
(define-values (bm unscaled? usw ush)
|
|
(cond
|
|
[(= scale 1.0) (values orig-bm #f w h)]
|
|
[(= scale (send orig-bm get-backing-scale)) (values orig-bm #t sw sh)]
|
|
[else (values (rescale orig-bm scale) #f sw sh)]))
|
|
(send bm get-argb-pixels 0 0 usw ush str #f #:unscaled? unscaled?)
|
|
(let ([mask (send bm get-loaded-mask)])
|
|
(when mask
|
|
(send mask get-argb-pixels 0 0 usw ush str #t #:unscaled? unscaled?)))
|
|
(atomically
|
|
(let ([rgba (scheme_make_sized_byte_string (malloc (* sw sh 4) 'raw) (* sw sh 4) 0)])
|
|
(memcpy rgba (ptr-add str 1) (sub1 (* sw sh 4)))
|
|
(for ([i (in-range 0 (* sw sh 4) 4)])
|
|
(bytes-set! rgba (+ i 3) (bytes-ref str i)))
|
|
(gdk_pixbuf_new_from_data rgba
|
|
0
|
|
#t
|
|
8
|
|
sw
|
|
sh
|
|
(* sw 4)
|
|
free-it
|
|
#f)))))
|
|
|
|
(define (pixbuf->bitmap pixbuf)
|
|
(let* ([w (gdk_pixbuf_get_width pixbuf)]
|
|
[h (gdk_pixbuf_get_height pixbuf)]
|
|
[bm (make-object bitmap% w h #f #t)]
|
|
[s (send bm get-cairo-surface)]
|
|
[cr (cairo_create s)])
|
|
(gdk_cairo_set_source_pixbuf cr pixbuf 0 0)
|
|
(cairo_rectangle cr 0 0 w h)
|
|
(cairo_fill cr)
|
|
(cairo_destroy cr)
|
|
bm))
|
|
|
|
(define (rescale bm scale)
|
|
(define w (send bm get-width))
|
|
(define h (send bm get-height))
|
|
(define new-bm (make-bitmap (ceiling (inexact->exact (* scale w)))
|
|
(ceiling (inexact->exact (* scale h)))))
|
|
(define dc (send new-bm make-dc))
|
|
(send dc set-scale scale scale)
|
|
(send dc set-smoothing 'smoothed)
|
|
(send dc draw-bitmap bm 0 0)
|
|
new-bm)
|