[Racket]OpenGLでテクスチャ

球にテクスチャを貼り付けてみます。掲示板やgistにあったコードを参考にしました。

#lang racket

(require sgl sgl/gl sgl/gl-vectors)
(require racket/gui)

;; argbをrgbaに変換
(define (argb->gl-rgba argb)
  (let* ((len (bytes-length argb))
   (buf (make-gl-ubyte-vector len)))
    (for ((i (in-range 0 len 4)))
  (gl-vector-set! buf (+ i 0) (bytes-ref argb (+ i 1)))
  (gl-vector-set! buf (+ i 1) (bytes-ref argb (+ i 2)))
  (gl-vector-set! buf (+ i 2) (bytes-ref argb (+ i 3)))
  (gl-vector-set! buf (+ i 3) (bytes-ref argb (+ i 0))))
    buf))

;; bitmapからargbのバイト列を取得
(define (bm->argb bm)
  (let* ((w (send bm get-width))
  (h (send bm get-height))
  (mask (send bm get-loaded-mask))
  (buf (make-bytes (* w h 4) 255)))
    (send bm get-argb-pixels 0 0 w h buf #f)
    (when mask
      (send bm get-argb-pixels 0 0 w h buf #t))
    buf))

;; テクスチャ読み込み
(define (load-texture path)
  (gl-enable 'texture-2d)
  (let* ((bm (make-object bitmap% path))
  (w (send bm get-width))
  (h (send bm get-height))
  (vec (argb->gl-rgba (bm->argb bm)))
  (tex (gl-vector-ref (glGenTextures 1) 0)))
    (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)
    (gluBuild2DMipmaps GL_TEXTURE_2D GL_RGBA w h GL_RGBA GL_UNSIGNED_BYTE vec)
    tex))

(define current-texture #f)


;; OpenGLによる描画
(define (draw-gl)
  (gl-clear 'color-buffer-bit)
  (gl-push-matrix)
  (glBindTexture GL_TEXTURE_2D current-texture)
  (let ((q (gl-new-quadric))
 (list-id (gl-gen-lists 1)))
    (gl-quadric-texture q #t)
    (gl-quadric-draw-style q 'fill)
    (gl-new-list list-id 'compile)
    (gl-sphere q 0.5 20 20)
    (gl-end-list)
    (gl-call-list list-id))
  (gl-pop-matrix)
  (gl-flush))

(define gl-canvas%
  (class* canvas% ()
    (inherit with-gl-context swap-gl-buffers)
    ;; on-paintをオーバーライド
    (define/override (on-paint)
      (with-gl-context
       (lambda ()
  (draw-gl)
  (swap-gl-buffers))))
    ;; on-sizeをオーバーライド
    (define/override (on-size w h)
      (with-gl-context
       (lambda ()
  (gl-viewport 0 0 w h))))
    
    ;; canvas%のスタイルにglを指定
    (super-new [style '(gl)])))

(define top-level-frame
  (new frame%
       [label "OpenGL test"]
       [width 400]
       [height 400]))

(define canvas
  (new gl-canvas%
       [parent top-level-frame]))

(set! current-texture
 (send canvas with-gl-context
       (lambda () (load-texture "./texture.jpg"))))

(send top-level-frame show #t)