gl-texturing.hs

module Images where

import            Data.ByteString         ( ByteString(..) )
import qualified  Data.ByteString  as BS
import qualified  Data.ByteString.Unsafe as BSU
import            Graphics.UI.GLUT
import qualified  Graphics.Rendering.OpenGL.GL	as GL
import qualified  Codec.BMP        as BMP 
import            Foreign.ForeignPtr
import            Foreign.Ptr
import            Control.Monad
import            Unsafe.Coerce

main :: IO ()
main = do
  (_progName, _args) <- getArgsAndInitialize
  initialDisplayMode $= [DoubleBuffered]
  _window <- createWindow "Hello World"
  
  Right bricks <- BMP.readBMP "data/bricks.bmp"
  
  let dta = BMP.bmpRawImageData bricks
  bPtr <- BSU.unsafeUseAsCString dta $ \cstr -> 
              return (castPtr cstr)
      
  [tex] <- GL.genObjectNames 1
  GL.textureBinding GL.Texture2D $= Just tex
  
  GL.texImage2D Nothing GL.NoProxy 0 GL.RGB8 (GL.TextureSize2D (gsizei 64) (gsizei 64)) 0 (GL.PixelData GL.BGR GL.UnsignedByte bPtr)

  displayCallback $= display tex

  mainLoop
 
display :: TextureObject -> DisplayCallback
display bricks = do 
  clear [ColorBuffer]
  drawBricks bricks
  flush

drawBricks tex = do
    setDefultTextureSettings
    --GL.preservingMatrix $ do
    do
        GL.scale (gf 30) (gf 30) (gf 1)
        withTexture tex $ do
            GL.textureBorderColor GL.Texture2D $= GL.Color4 (gf 1.0) (gf 0.0) (gf 0.0) (gf 1.0)
            GL.renderPrimitive GL.Polygon $ zipWithM_ makePoint 
                [(-1,-1), (1,-1), (1,1), (-1,1)] 
                [(0,0), (1,0), (1,1), (0,1)]
                --[(-32, -32), (0, -32), (0, 0), (-32, 0)]
                --(bitmapPath 64 64)
  where 
    makePoint (px, py) (tx, ty) = do
        texCoord2 tx ty
        vertex2 px py
        
-- | Generates the point path to display the bitmap centred
bitmapPath :: Float -> Float -> [(Float, Float)]
bitmapPath width height 
 = [(-width', -height'), (width', -height'), (width', height'), (-width', height')]
 where	width'  = width  / 2
	height' = height / 2

setDefultTextureSettings = do
    GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.ClampToBorder)
    GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.ClampToBorder)
    GL.textureFilter   GL.Texture2D      $= ((GL.Linear', Nothing), GL.Linear')

withTexture tex f = do
    GL.texture GL.Texture2D $= GL.Enabled
    GL.textureBinding GL.Texture2D $= Just tex
    f
    GL.texture GL.Texture2D $= GL.Disabled

texCoord2 x y = GL.texCoord $ GL.TexCoord2 (gf x) (gf y)
vertex2 x y = GL.vertex $ GL.Vertex2 (gf x) (gf y)

gf :: Float -> GL.GLfloat
{-# INLINE gf #-}
gf x = unsafeCoerce x

-- | Used for similar reasons to above
gsizei :: Int -> GL.GLsizei
{-# INLINE gsizei #-}
gsizei x = unsafeCoerce x