Scene renders better now
- Enabled BackCulling - Wrote shadow-mapping-functions - temp. changed to flat-shading for better distinction - defined Tiles CCW for BackCulling
This commit is contained in:
parent
e1cad5786e
commit
7110d9404b
@ -10,7 +10,7 @@ executable Pioneers
|
||||
build-depends:
|
||||
base >= 4,
|
||||
gtk,
|
||||
OpenGL >=2.8.0 && <2.9,
|
||||
OpenGL >=2.9,
|
||||
gtkglext >=0.12,
|
||||
containers >=0.5 && <0.6,
|
||||
array >=0.4.0 && <0.5,
|
||||
@ -19,7 +19,6 @@ executable Pioneers
|
||||
text >=0.11.3 && <0.12,
|
||||
stm >=2.4.2 && <2.5,
|
||||
transformers >=0.3.0 && <0.4,
|
||||
List >=0.5.1 && <0.6,
|
||||
List >=0.5.1 && <0.6
|
||||
ghc-options: -Wall
|
||||
other-modules:
|
||||
|
||||
237
src/Main.hs
237
src/Main.hs
@ -1,29 +1,31 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module Main where
|
||||
|
||||
import qualified Graphics.UI.Gtk as Gtk
|
||||
import Graphics.UI.Gtk (AttrOp((:=)))
|
||||
import qualified Graphics.UI.Gtk.OpenGL as GtkGL
|
||||
import Graphics.UI.Gtk (AttrOp ((:=)))
|
||||
import qualified Graphics.UI.Gtk as Gtk
|
||||
import qualified Graphics.UI.Gtk.OpenGL as GtkGL
|
||||
|
||||
import Graphics.Rendering.OpenGL as GL
|
||||
import qualified Data.Array.IArray as A
|
||||
import Graphics.Rendering.OpenGL as GL
|
||||
import qualified Graphics.UI.Gtk.Gdk.EventM as Event
|
||||
import qualified Data.Array.IArray as A
|
||||
|
||||
import Map.Coordinates
|
||||
import Map.Map
|
||||
import Map.Coordinates
|
||||
import Map.Map
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Debug.Trace
|
||||
import Data.IntSet as IS
|
||||
import Data.IORef
|
||||
import Data.IntSet as IS
|
||||
import Data.IORef
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Debug.Trace
|
||||
|
||||
import Prelude as P
|
||||
import Control.Monad
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.STM
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import GHC.Conc.Sync (unsafeIOToSTM)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Foreign.Ptr (nullPtr)
|
||||
import GHC.Conc.Sync (unsafeIOToSTM)
|
||||
import Prelude as P
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Foreign.Marshal.Array (allocaArray)
|
||||
|
||||
data ProgramState = PS { keysPressed :: IntSet
|
||||
, px :: GLfloat
|
||||
@ -38,27 +40,47 @@ data ProgramState = PS { keysPressed :: IntSet
|
||||
, dpitch :: GLfloat }
|
||||
deriving (Show)
|
||||
|
||||
type RenderObject = (Vector3 GLfloat, Color3 GLfloat, [Vertex3 GLfloat])
|
||||
|
||||
(Vertex4 a b c d) .+ (Vertex4 w x y z) = Vertex4 (a+w) (b+x) (c+y) (d+z)
|
||||
(Vertex4 a b c d) .* e = Vertex4 (a*e) (b*e) (c*e) (d*e)
|
||||
|
||||
animationWaitTime = 3 :: Int
|
||||
canvasWidth = 1024 :: Int
|
||||
canvasHeight = 768 :: Int
|
||||
deltaV = 0.10
|
||||
deltaH = 0.5
|
||||
deltaP = 0.15
|
||||
black = Color3 0 0 0 :: Color3 GLfloat
|
||||
shadowMapSize :: TextureSize2D
|
||||
shadowMapSize = TextureSize2D 256 256
|
||||
|
||||
-- TODO: Put render-stuff in render-module
|
||||
up :: Vector3 GLdouble
|
||||
up = Vector3 0 1 0
|
||||
|
||||
origin :: Vertex3 GLdouble
|
||||
origin = Vertex3 0 0 0
|
||||
|
||||
sun = Light 0
|
||||
|
||||
-- TODO: Put render-stuff in render-modul
|
||||
|
||||
--gets Sun position in given format
|
||||
getSunPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a
|
||||
getSunPos f = do
|
||||
Vertex4 x y z _ <- get (position sun)
|
||||
return $ f (realToFrac x) (realToFrac y) (realToFrac z)
|
||||
|
||||
glTexCoord2f (x,y) = texCoord (TexCoord2 x y :: TexCoord2 GLfloat)
|
||||
glVertex3f (x,y,z) = vertex (Vertex3 x y z :: Vertex3 GLfloat)
|
||||
glNormal3f (x,y,z) = normal (Normal3 x y z :: Normal3 GLfloat)
|
||||
|
||||
|
||||
prepareRenderTile :: PlayMap -> ((Int,Int),MapEntry) -> (Vector3 GLfloat, Color3 GLfloat, [Vertex3 GLfloat])
|
||||
prepareRenderTile m (c@(cx,cz),(_,t)) =
|
||||
(
|
||||
if even cx then
|
||||
Vector3 (1.5*(fromIntegral cx)) 0.0 (2*(fromIntegral cz))
|
||||
else
|
||||
Vector3 (1.5*(fromIntegral cx)) 0.0 (2*(fromIntegral cz)-1)
|
||||
Vector3 (1.5 * fromIntegral cx) 0.0
|
||||
(if even cx then 2 * fromIntegral cz else
|
||||
2 * fromIntegral cz - 1)
|
||||
,
|
||||
case t of
|
||||
Water -> Color3 0.5 0.5 1 :: Color3 GLfloat
|
||||
@ -67,28 +89,50 @@ prepareRenderTile m (c@(cx,cz),(_,t)) =
|
||||
Mountain -> Color3 0.5 0.5 0.5 :: Color3 GLfloat
|
||||
,getTileVertices m c)
|
||||
|
||||
renderTile :: (Vector3 GLfloat, Color3 GLfloat, [Vertex3 GLfloat]) -> IO ()
|
||||
renderTile :: RenderObject -> IO ()
|
||||
renderTile (coord,c,ts) =
|
||||
preservingMatrix $ do
|
||||
color c
|
||||
translate coord
|
||||
_ <- renderPrimitive Polygon $ do
|
||||
{-color black
|
||||
lineWidth $= 4.0
|
||||
lineSmooth $= Enabled
|
||||
_ <- renderPrimitive LineLoop $ do
|
||||
glNormal3f(0.0,0.0,1.0)
|
||||
mapM vertex ts-}
|
||||
color c
|
||||
_ <- renderPrimitive Polygon $ do
|
||||
glNormal3f(0.0,1.0,0.0)
|
||||
mapM vertex ts
|
||||
return ()
|
||||
|
||||
drawSphere = do
|
||||
renderQuadric (QuadricStyle
|
||||
(Just Smooth)
|
||||
GenerateTextureCoordinates
|
||||
Outside
|
||||
FillStyle)
|
||||
(Sphere 1.0 48 48)
|
||||
drawSphere :: IO ()
|
||||
drawSphere = renderQuadric
|
||||
(QuadricStyle (Just Smooth) GenerateTextureCoordinates Outside
|
||||
FillStyle)
|
||||
(Sphere 2.0 48 48)
|
||||
|
||||
drawObjects :: [RenderObject] -> [RenderObject] -> Bool -> IO ()
|
||||
drawObjects map ent shadowRender = do
|
||||
textureOn <- get (texture Texture2D) --are textures enabled?
|
||||
|
||||
when shadowRender $
|
||||
texture Texture2D $= Disabled --disable textures if we render shadows.
|
||||
|
||||
--draw objects
|
||||
preservingMatrix $ do
|
||||
translate (Vector3 15.0 15.0 25.0 :: Vector3 GLfloat)
|
||||
drawSphere
|
||||
mapM_ renderTile map
|
||||
|
||||
|
||||
when (shadowRender && textureOn == Enabled) $ --reset texture-rendering
|
||||
texture Texture2D $= Enabled
|
||||
|
||||
-- OpenGL polygon-function for drawing stuff.
|
||||
display :: MVar ProgramState -> PlayMap -> IO ()
|
||||
display state t =
|
||||
let
|
||||
-- Todo: have tiles static somewhere .. dont calculate every frame
|
||||
tiles = P.map (prepareRenderTile t) (A.assocs t)
|
||||
in
|
||||
do
|
||||
@ -104,11 +148,12 @@ display state t =
|
||||
GL.rotate heading (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat)
|
||||
translate (Vector3 (-px) (-py) (-pz)::Vector3 GLfloat)
|
||||
|
||||
position (Light 0) $= Vertex4 0.0 0.0 (20.0) 1.0
|
||||
generateShadowMap tiles [] True
|
||||
generateTextureMatrix
|
||||
clear [ ColorBuffer, DepthBuffer ]
|
||||
preservingMatrix $ do
|
||||
drawObjects tiles [] False
|
||||
|
||||
-- Instead of glBegin ... glEnd there is renderPrimitive.
|
||||
--trace (show tiles) $
|
||||
mapM_ renderTile tiles
|
||||
return ()
|
||||
|
||||
updateCamera :: MVar ProgramState -> IO ()
|
||||
@ -155,13 +200,81 @@ updateCamera state = do
|
||||
, heading = heading'
|
||||
}
|
||||
|
||||
-- Note: preservingViewport is not exception safe, but it doesn't matter here
|
||||
preservingViewport :: IO a -> IO a
|
||||
preservingViewport act = do
|
||||
v <- get viewport
|
||||
x <- act
|
||||
viewport $= v
|
||||
return x
|
||||
|
||||
generateTextureMatrix :: IO ()
|
||||
generateTextureMatrix = do
|
||||
-- Set up projective texture matrix. We use the Modelview matrix stack and
|
||||
-- OpenGL matrix commands to make the matrix.
|
||||
m <- preservingMatrix $ do
|
||||
loadIdentity
|
||||
-- resolve overloading, not needed in "real" programs
|
||||
let translatef = translate :: Vector3 GLfloat -> IO ()
|
||||
scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO ()
|
||||
translatef (Vector3 0.5 0.5 0.0)
|
||||
scalef 0.5 0.5 1.0
|
||||
perspective 60 1 1 1000
|
||||
lightPos' <- getSunPos Vertex3
|
||||
lookAt lightPos' origin up
|
||||
get (matrix (Just (Modelview 0)))
|
||||
|
||||
[ sx, sy, sz, sw,
|
||||
tx, ty, tz, tw,
|
||||
rx, ry, rz, rw,
|
||||
qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble)
|
||||
|
||||
textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw))
|
||||
textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw))
|
||||
textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw))
|
||||
textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw))
|
||||
|
||||
generateShadowMap :: [RenderObject] -> [RenderObject] -> Bool -> IO ()
|
||||
generateShadowMap tiles obj showShadow' = do
|
||||
lightPos' <- getSunPos Vertex3
|
||||
let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize
|
||||
shadowMapSize' = Size shadowMapWidth shadowMapHeight
|
||||
|
||||
preservingViewport $ do
|
||||
viewport $= (Position 0 0, shadowMapSize')
|
||||
|
||||
clear [ ColorBuffer, DepthBuffer ]
|
||||
|
||||
matrixMode $= Projection
|
||||
preservingMatrix $ do
|
||||
loadIdentity
|
||||
perspective 80 1 10 1000
|
||||
matrixMode $= Modelview 0
|
||||
preservingMatrix $ do
|
||||
loadIdentity
|
||||
lookAt lightPos' origin up
|
||||
drawObjects tiles obj True
|
||||
matrixMode $= Projection
|
||||
matrixMode $= Modelview 0
|
||||
|
||||
copyTexImage2D Texture2D 0 DepthComponent' (Position 0 0) shadowMapSize 0
|
||||
|
||||
when showShadow' $ do
|
||||
let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight)
|
||||
allocaArray numShadowMapPixels $ \depthImage -> do
|
||||
let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat
|
||||
readPixels (Position 0 0) shadowMapSize' (pixelData DepthComponent)
|
||||
(_, Size viewPortWidth _) <- get viewport
|
||||
windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0)
|
||||
drawPixels shadowMapSize' (pixelData Luminance)
|
||||
|
||||
--Adjust size to given dimensions
|
||||
reconfigure :: Int -> Int -> IO (Int, Int)
|
||||
reconfigure w h = do
|
||||
-- maintain aspect ratio
|
||||
let aspectRatio = (fromIntegral canvasWidth) / (fromIntegral canvasHeight)
|
||||
(w1, h1) = (fromIntegral w, (fromIntegral w) / aspectRatio)
|
||||
(w2, h2) = ((fromIntegral h) * aspectRatio, fromIntegral h)
|
||||
let aspectRatio = fromIntegral canvasWidth / fromIntegral canvasHeight
|
||||
(w1, h1) = (fromIntegral w, fromIntegral w / aspectRatio)
|
||||
(w2, h2) = (fromIntegral h * aspectRatio, fromIntegral h)
|
||||
(w', h') = if h1 <= fromIntegral h
|
||||
then (floor w1, floor h1)
|
||||
else (floor w2, floor h2)
|
||||
@ -210,10 +323,11 @@ keyEvent state press = do
|
||||
deny a = return (a, False)
|
||||
in do
|
||||
-- keep list of pressed keys up2date
|
||||
ps <- if not press
|
||||
then return ps { keysPressed = fromIntegral code `IS.delete` kp }
|
||||
else return ps { keysPressed = fromIntegral code `IS.insert` kp }
|
||||
-- putStrLn $ unwords [name , show val, show code, show ps] -- trace (unwords [name , show val]) -- debugging
|
||||
ps <- return (if not press then
|
||||
(ps{keysPressed = fromIntegral code `delete` kp})
|
||||
else
|
||||
(ps{keysPressed = fromIntegral code `insert` kp}))
|
||||
putStrLn $ unwords [name , show val, show code, show ps] -- trace (unwords [name , show val]) -- debugging
|
||||
-- process keys
|
||||
case press of
|
||||
-- on PRESS only
|
||||
@ -247,7 +361,7 @@ main :: IO ()
|
||||
main = do
|
||||
! terrain <- testmap
|
||||
-- create TVar using unsafePerformIO -> currently no other thread -> OK
|
||||
state <- newMVar $ PS { keysPressed = IS.empty
|
||||
state <- newMVar PS { keysPressed = IS.empty
|
||||
, px = 7.5
|
||||
, py = 20
|
||||
, pz = 15
|
||||
@ -279,27 +393,48 @@ main = do
|
||||
-- we are using wouldn't heve been setup yet)
|
||||
Gtk.onRealize canvas $ GtkGL.withGLDrawingArea canvas $ \_ -> do
|
||||
reconfigure canvasWidth canvasHeight
|
||||
--set up shadow-map
|
||||
texImage2D Texture2D NoProxy 0 DepthComponent' shadowMapSize 0
|
||||
(PixelData DepthComponent UnsignedByte nullPtr)
|
||||
|
||||
materialAmbient Front $= Color4 0.4 0.4 0.4 1.0
|
||||
materialDiffuse Front $= Color4 0.4 0.4 0.4 1.0
|
||||
materialSpecular Front $= Color4 0.8 0.8 0.8 1.0
|
||||
materialShininess Front $= 25.0
|
||||
|
||||
ambient (Light 0) $= Color4 0.3 0.3 0.3 1.0
|
||||
diffuse (Light 0) $= Color4 1.0 1.0 1.0 1.0
|
||||
specular (Light 0) $= Color4 0.8 0.8 0.8 1.0
|
||||
ambient sun $= Color4 0.3 0.3 0.3 1.0
|
||||
diffuse sun $= Color4 1.0 1.0 1.0 1.0
|
||||
specular sun $= Color4 0.8 0.8 0.8 1.0
|
||||
lightModelAmbient $= Color4 0.2 0.2 0.2 1.0
|
||||
position sun $= (Vertex4 2.0 1.0 1.3 1.0 :: Vertex4 GLfloat) .* 5
|
||||
spotDirection sun $= (Normal3 (-2.0) (-1.0) (-1.3) :: Normal3 GLfloat)
|
||||
--spotExponent sun $= 1.0
|
||||
--attenuation sun $= (1.0, 0.0, 0.0)
|
||||
|
||||
lighting $= Enabled
|
||||
light (Light 0) $= Enabled
|
||||
light sun $= Enabled
|
||||
depthFunc $= Just Less
|
||||
shadeModel $= Smooth
|
||||
--lightModelLocalViewer $= Enabled
|
||||
--vertexProgramTwoSide $= Enabled
|
||||
|
||||
clearColor $= Color4 0.0 0.0 0.0 0.0
|
||||
drawBuffer $= BackBuffers
|
||||
colorMaterial $= Just (Front, Diffuse)
|
||||
|
||||
frontFace $= CCW
|
||||
cullFace $= Just Back
|
||||
|
||||
texture Texture2D $= Enabled
|
||||
|
||||
shadeModel $= Smooth
|
||||
shadeModel $= Flat
|
||||
|
||||
fog $= Enabled
|
||||
fogMode $= Linear 45.0 50.0
|
||||
fogColor $= Color4 0.5 0.5 0.5 1.0
|
||||
fogDistanceMode $= EyeRadial
|
||||
|
||||
|
||||
return ()
|
||||
{-clearColor $= (Color4 0.0 0.0 0.0 0.0)
|
||||
matrixMode $= Projection
|
||||
|
||||
@ -63,17 +63,18 @@ data TileVertex =
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
|
||||
--Culling is done with GL_CCW
|
||||
getTileVertices :: PlayMap -> Tile -> [Vertex3 GLfloat]
|
||||
getTileVertices heights t = let p = (listArray (0,5) hexagon)
|
||||
::Array Int (Float,Float) in
|
||||
P.map floatToVertex $
|
||||
[
|
||||
(fst $ p ! 0, getHeight heights VertexNW t, snd $ p ! 0),
|
||||
(fst $ p ! 1, getHeight heights VertexNE t, snd $ p ! 1),
|
||||
(fst $ p ! 2, getHeight heights VertexE t, snd $ p ! 2),
|
||||
(fst $ p ! 3, getHeight heights VertexSE t, snd $ p ! 3),
|
||||
(fst $ p ! 5, getHeight heights VertexW t, snd $ p ! 5),
|
||||
(fst $ p ! 4, getHeight heights VertexSW t, snd $ p ! 4),
|
||||
(fst $ p ! 5, getHeight heights VertexW t, snd $ p ! 5)
|
||||
(fst $ p ! 3, getHeight heights VertexSE t, snd $ p ! 3),
|
||||
(fst $ p ! 2, getHeight heights VertexE t, snd $ p ! 2),
|
||||
(fst $ p ! 1, getHeight heights VertexNE t, snd $ p ! 1),
|
||||
(fst $ p ! 0, getHeight heights VertexNW t, snd $ p ! 0)
|
||||
]
|
||||
|
||||
getHeight :: PlayMap -> TileVertex -> Tile -> Float
|
||||
|
||||
@ -26,23 +26,33 @@ type PlayMap = Array (Int, Int) MapEntry
|
||||
-- row-minor -> row-major
|
||||
testMapTemplate :: [Text]
|
||||
testMapTemplate = T.transpose [
|
||||
"~~~~~~~~~~",
|
||||
"~~SSSSSS~~",
|
||||
"~SSGGGGS~~",
|
||||
"~SSGGMMS~~",
|
||||
"~SGGMMS~~~",
|
||||
"~SGMMMS~~~",
|
||||
"~GGGGGGS~~",
|
||||
"~SGGGGGS~~",
|
||||
"~~SSSS~~~~",
|
||||
"~~~~~~~~~~"
|
||||
"~~~~~~~~~~~~~~~~~~~~",
|
||||
"~~SSSSSSSSSSSSSS~~~~",
|
||||
"~SSGGGGGGGSGSGGS~~~~",
|
||||
"~SSGGGGGGMSGSGMS~~~~",
|
||||
"~SGGGGGGMMMGGGS~~~S~",
|
||||
"~SGGGMGMMMMMGGS~~~SS",
|
||||
"~GGGGGGGGGGGGGGS~~~~",
|
||||
"~SGGGGGGGGGGGGGS~~~~",
|
||||
"~~SSSSGGGSSSSS~~~~~~",
|
||||
"~~~~~SGGGGS~~~~~~~~~",
|
||||
"~~~~SSGGGGSS~~~~~~~~",
|
||||
"~~SSSGGGGGGSSSSS~~~~",
|
||||
"~SSGSGSGGGSGSGGS~~~~",
|
||||
"~SSGSGSGGMSGSGMS~~~~",
|
||||
"~SGGMMMMGGGGGGS~~~~~",
|
||||
"~SGMMMMMGGGGSSS~~~~~",
|
||||
"~GGMMMMMGGGSSSSS~~~~",
|
||||
"~SGGGGGGGSSSSSSS~~~~",
|
||||
"~~SSSSSSSSSSSS~~~~~~",
|
||||
"~~~~~~~~~~~~~~~~~~~~"
|
||||
]
|
||||
|
||||
testmap :: IO PlayMap
|
||||
testmap = do
|
||||
g <- getStdGen
|
||||
rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate)
|
||||
return $ listArray ((0,0),(9,9)) rawMap
|
||||
return $ listArray ((0,0),(19,19)) rawMap
|
||||
|
||||
|
||||
parseTemplate :: [Int] -> Text -> [MapEntry]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user