HaskellとOpenGLを使って四角形を描画しテクスチャを貼り付ける

こんな感じになります↓

結構苦労しました。誰かの役に立ってくれると嬉しいです。

参考サイト
  いろいろなサンプルがある:Index of /GLUT/examples/RedBook

    今回役に立ったのは Tex〜.hs

  視野の設定:Lichu's_Base
  テクスチャの読み込み・設定:https://github.com/fumieval/free-game/blob/master/Graphics/FreeGame/Backends/GLFW.hs
  


import Graphics.UI.GLUT hiding (Bitmap)
import qualified Graphics.Rendering.OpenGL.GL as GL
import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )
import Data.IORef
import Codec.Picture.Repa
import Data.Array.Repa as R hiding (reshape)
import qualified Data.Array.Repa.Repr.ForeignPtr as RF
import Foreign.ForeignPtr
import Data.Word
import Control.Applicative
import Control.Monad
import Unsafe.Coerce

-- テクスチャをファイルから読み込む
-- 何をやっているのか未だによくわからない
-- FreeGameのサンプルをちょっといじったもの
loadTextureFromFile :: FilePath -> IO GL.TextureObject
loadTextureFromFile path = do
    content <- delay <$> (flipVertically.imgData) <$> either error id <$> (readImageRGBA path)
    let (Z :. width :. height :. _) = R.extent content
    [tex] <- GL.genObjectNames 1
    GL.textureBinding GL.Texture2D GL.$= Just tex
    GL.textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
    fptr <- liftM RF.toForeignPtr $ R.computeP $ content
    withForeignPtr fptr
        $ GL.texImage2D Nothing GL.NoProxy 0 GL.RGBA8 (GL.TextureSize2D (gsizei width) (gsizei height)) 0
        . GL.PixelData GL.RGBA GL.UnsignedInt8888
    return tex

gsizei :: Int -> GL.GLsizei
{-# INLINE gsizei #-}
gsizei x = unsafeCoerce x

--タイマの間隔
timerInterval = 40

main = do 
    --回転の角度を初期化
    rot <- newIORef 0.0
    arg <- newIORef 10.4
    
    --GLUTの初期化
    initialDisplayMode $= [RGBAMode, DoubleBuffered]
    initialWindowSize $= Size 640 480
    initialize "" []

    --ウィンドウを作る
    createWindow "DrawPictureWithOpneGL"

    --テクスチャを読み込む
    tex <- loadTextureFromFile "読み込みたい画像ファイルへのパス"
    texture Texture2D $= Enabled
    GL.blend $= GL.Enabled
    GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)


    --表示に使うコールバック関数の指定
    displayCallback $= display rot arg tex
    
    --ウィンドウのサイズが変更された時に呼ぶコールバック関数の指定
    reshapeCallback $= Just reshape
    
    --キーボードやマウスのコールバック
    keyboardMouseCallback $= Just (keyboardProc arg)
    
    --タイマを作る
    addTimerCallback timerInterval $ timerProc (display rot arg tex)

    --GLUTのメインループに入る
    mainLoop

display rot arg texname = do
    --回転させる
    w<-readIORef arg 
    --w <- readIORef hoge
    modifyIORef rot (+w)
    r <- readIORef rot
 
    --背景を黒にする
    clearColor $= Color4 0.0 0.0 0.0 0.0
    clear [ColorBuffer]
    
    --単位行列を読み込む
    loadIdentity
    
    -- texCoord,vetexは多くの型について定義されているので
    -- オーバーロードに関する問題を避けるために以下の関数が必要
    let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
        vertex3f = vertex :: Vertex3 GLfloat -> IO ()

    -- 表示
    -- 描写する直前に色を指定するようだ
    -- Color4 赤 緑 青 透明度(0で完全に透明、1で完全に不透明)
    currentColor $= Color4 1 1 1 1 

    -- テクスチャの設定
    textureBinding Texture2D $= Just texname

    preservingMatrix $ do
        translate (Vector3 100 100 (0::Double))
        
        -- rotate 度数法での角度
        rotate r (Vector3 0.0 0.0 1.0 :: Vector3 GLdouble)
        
        -- 描画
        renderPrimitive Quads $ do
      -- ここから
            texCoord2f (TexCoord2 0 0)
            vertex3f (Vertex3 (-50) (-50) 0.0)
            -- ここまでで一つの頂点の設定(テクスチャに関するもの、場所に関するもの)
            texCoord2f (TexCoord2 0 1)
            vertex3f (Vertex3 (-50) 50 0.0)
            texCoord2f (TexCoord2 1 1)
            vertex3f (Vertex3 50 50 0.0)
            texCoord2f (TexCoord2 1 0)
            vertex3f (Vertex3 50 (-50) 0.0)
    
    --バッファの入れ替え
    swapBuffers

--タイマが呼ばれるたびにactを繰り返す
timerProc act = do
    act
    addTimerCallback timerInterval $ timerProc act

--ウィンドウのサイズが変更された時の処理
reshape (Size w h)=do
    viewport $= (Position 0 0, (Size w h)) --ウィンドウ全体を使う
    
    --ビューボリュームの設定-
    matrixMode $= Projection
    loadIdentity

    -- 視野のセッティング
    ortho 0.0 640.0 0.0 480.0 (-1000.0) 1000.0
    
    -- これ大事(理由はよくわからない)
    matrixMode $= Modelview 0 

--キー入力の処理
keyboardProc arg ch state _ _
    -- Qが押されたら終了 
    | ch     == Char 'q'    = exitWith ExitSuccess
    -- Aが押されたら回転速度を二倍にする
    | ch    == Char 'a'     = modifyIORef arg (*(2))
    -- Sが押されたら回転速度を二分の1にする
    | ch    == Char 's'     = modifyIORef arg (*(0.5))
    -- それ以外なら回転の方向を変える
    | state    == Down        = modifyIORef arg (*(-1))    
    | otherwise            = return ()