neocturne/htanks
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Render floor

Browse source
This commit is contained in:
Matthias Schiffer 2010-02-25 03:48:17 +01:00
parent c23e63e667
commit 656b5e8bc1
1 changed files with 39 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

45
Render.hs
View file

@ -18,12 +18,14 @@ import qualified Data.Map as M
import Bindings.GLPng import Bindings.GLPng
import Graphics.Rendering.OpenGL.GL (($=), GLfloat, GLdouble) import Graphics.Rendering.OpenGL.GL (($=), GLfloat, GLdouble, Capability(..))
import Graphics.Rendering.OpenGL.GL.BeginEnd (renderPrimitive, PrimitiveMode(..)) import Graphics.Rendering.OpenGL.GL.BeginEnd (renderPrimitive, PrimitiveMode(..))
import Graphics.Rendering.OpenGL.GL.CoordTrans (matrixMode, MatrixMode(..), viewport, Position(..), Size(..), loadIdentity, ortho) import Graphics.Rendering.OpenGL.GL.CoordTrans (matrixMode, MatrixMode(..), viewport, Position(..), Size(..), loadIdentity, ortho)
import Graphics.Rendering.OpenGL.GL.Framebuffer (clear, ClearBuffer(..)) import Graphics.Rendering.OpenGL.GL.Framebuffer (clear, ClearBuffer(..))
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject(..)) import Graphics.Rendering.OpenGL.GL.Texturing.Application (texture)
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (textureBinding, TextureObject(..))
import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (Repetition(..), Clamping(..), TextureFilter(..), MinificationFilter, MagnificationFilter) import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (Repetition(..), Clamping(..), TextureFilter(..), MinificationFilter, MagnificationFilter)
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureTarget(..))
import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.GL.VertexSpec
@ -78,15 +80,46 @@ render = do
tank <- liftM head $ gets tanks tank <- liftM head $ gets tanks
let x = fromReal . posx $ tank let x = fromReal . posx $ tank
y = fromReal . posy $ tank y = fromReal . posy $ tank
(lw, lh) <- gets level >>= \l -> return (fromIntegral . levelWidth $ l :: GLfloat, fromIntegral . levelHeight $ l :: GLfloat)
textureWood <- getTexture TextureWood
liftIO $ do liftIO $ do
clear [ColorBuffer] clear [ColorBuffer]
loadIdentity
texture Texture2D $= Enabled
textureBinding Texture2D $= Just textureWood
renderPrimitive Quads $ do renderPrimitive Quads $ do
vertex $ Vertex2 (x-0.5 :: GLfloat) (y-0.5 :: GLfloat) texCoord $ TexCoord2 (0 :: GLfloat) (0 :: GLfloat)
vertex $ Vertex2 (x-0.5 :: GLfloat) (y+0.5 :: GLfloat) vertex $ Vertex2 (-0.5*lw) (-0.5*lh)
vertex $ Vertex2 (x+0.5 :: GLfloat) (y+0.5 :: GLfloat)
vertex $ Vertex2 (x+0.5 :: GLfloat) (y-0.5 :: GLfloat) texCoord $ TexCoord2 0 lw
vertex $ Vertex2 (-0.5*lw) (0.5*lh)
texCoord $ TexCoord2 lh lw
vertex $ Vertex2 (0.5*lw) (0.5*lh)
texCoord $ TexCoord2 lh (0 :: GLfloat)
vertex $ Vertex2 (0.5*lw) (-0.5*lh)
texture Texture2D $= Disabled
renderPrimitive Quads $ do
texCoord $ TexCoord2 (0 :: GLfloat) (0 :: GLfloat)
vertex $ Vertex2 (x-0.5 :: GLfloat) (y-0.5 :: GLfloat)
texCoord $ TexCoord2 (0 :: GLfloat) (1 :: GLfloat)
vertex $ Vertex2 (x-0.5 :: GLfloat) (y+0.5 :: GLfloat)
texCoord $ TexCoord2 (1 :: GLfloat) (1 :: GLfloat)
vertex $ Vertex2 (x+0.5 :: GLfloat) (y+0.5 :: GLfloat)
texCoord $ TexCoord2 (1 :: GLfloat) (0 :: GLfloat)
vertex $ Vertex2 (x+0.5 :: GLfloat) (y-0.5 :: GLfloat)
fromReal :: (Real a, Fractional b) => a -> b fromReal :: (Real a, Fractional b) => a -> b
fromReal = fromRational . toRational fromReal = fromRational . toRational