/usr/share/racket/pkgs/sgl/bitmap.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | (module bitmap mzscheme
(require mred
mzlib/class
sgl/gl-vectors
sgl
sgl/gl
mzlib/kw)
(provide bitmap->gl-list)
(define (argb->rgba argb)
(let* ((length (bytes-length argb))
(rgba (make-gl-ubyte-vector length)))
(let loop ((i 0))
(when (< i length)
(gl-vector-set! rgba (+ i 0) (bytes-ref argb (+ i 1)))
(gl-vector-set! rgba (+ i 1) (bytes-ref argb (+ i 2)))
(gl-vector-set! rgba (+ i 2) (bytes-ref argb (+ i 3)))
(gl-vector-set! rgba (+ i 3) (bytes-ref argb (+ i 0)))
(loop (+ i 4))))
rgba))
(define (bitmap->argb bmp bmp-mask)
(let* ((width (send bmp get-width))
(height (send bmp get-height))
(argb (make-bytes (* 4 width height) 255)))
(send bmp get-argb-pixels 0 0 width height argb #f)
(when bmp-mask
(send bmp-mask get-argb-pixels 0 0 width height argb #t))
argb))
(define/kw (bitmap->gl-list bm
#:key
[with-gl (lambda (f) (f))]
[mask (send bm get-loaded-mask)])
(define w (send bm get-width))
(define h (send bm get-height))
(define rgba (argb->rgba (bitmap->argb bm mask)))
(with-gl
(lambda ()
(let ((tex (gl-vector-ref (glGenTextures 1) 0))
(list-id (gl-gen-lists 1)))
(glBindTexture GL_TEXTURE_2D tex)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP)
(glTexImage2D GL_TEXTURE_2D 0 GL_RGBA w h 0
GL_RGBA GL_UNSIGNED_BYTE rgba)
(gl-new-list list-id 'compile)
(gl-enable 'texture-2d)
(glBindTexture GL_TEXTURE_2D tex)
(gl-material-v 'front 'ambient-and-diffuse
(gl-float-vector 1 1 1 1))
(gl-begin 'polygon)
(gl-tex-coord 0.0 0.0)
(gl-vertex 0.0 0.0 0.0)
(gl-tex-coord 1.0 0.0)
(gl-vertex 1.0 0.0 0.0)
(gl-tex-coord 1.0 1.0)
(gl-vertex 1.0 1.0 0.0)
(gl-tex-coord 0.0 1.0)
(gl-vertex 0.0 1.0 0.0)
(gl-end)
(gl-disable 'texture-2d)
(gl-end-list)
list-id)))))
|