71 lines
2.5 KiB
Scheme
71 lines
2.5 KiB
Scheme
|
|
(module bitmap mzscheme
|
|
(require (lib "mred.ss" "mred")
|
|
(lib "class.ss")
|
|
(lib "gl-vectors.ss" "sgl")
|
|
(prefix gl- (lib "sgl.ss" "sgl"))
|
|
(lib "gl.ss" "sgl")
|
|
(lib "kw.ss"))
|
|
|
|
(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)])
|
|
(let ([w (send bm get-width)]
|
|
[h (send bm get-height)]
|
|
[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))))))
|