Stefan Dresselhaus
7110d9404b
- Enabled BackCulling - Wrote shadow-mapping-functions - temp. changed to flat-shading for better distinction - defined Tiles CCW for BackCulling
498 lines
18 KiB
Haskell
498 lines
18 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
module Main where
|
|
|
|
import Graphics.UI.Gtk (AttrOp ((:=)))
|
|
import qualified Graphics.UI.Gtk as Gtk
|
|
import qualified Graphics.UI.Gtk.OpenGL as GtkGL
|
|
|
|
import qualified Data.Array.IArray as A
|
|
import Graphics.Rendering.OpenGL as GL
|
|
import qualified Graphics.UI.Gtk.Gdk.EventM as Event
|
|
|
|
import Map.Coordinates
|
|
import Map.Map
|
|
|
|
import Data.IntSet as IS
|
|
import Data.IORef
|
|
import Data.Maybe (fromMaybe)
|
|
import Debug.Trace
|
|
|
|
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
|
|
, py :: GLfloat
|
|
, pz :: GLfloat
|
|
, heading :: GLfloat
|
|
, pitch :: GLfloat
|
|
, dx :: GLfloat
|
|
, dy :: GLfloat
|
|
, dz :: GLfloat
|
|
, dheading :: GLfloat
|
|
, 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
|
|
|
|
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)) =
|
|
(
|
|
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
|
|
Grass -> Color3 0.3 0.9 0.1 :: Color3 GLfloat
|
|
Sand -> Color3 0.9 0.85 0.7 :: Color3 GLfloat
|
|
Mountain -> Color3 0.5 0.5 0.5 :: Color3 GLfloat
|
|
,getTileVertices m c)
|
|
|
|
renderTile :: RenderObject -> IO ()
|
|
renderTile (coord,c,ts) =
|
|
preservingMatrix $ do
|
|
translate coord
|
|
{-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 :: 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
|
|
ps@PS {
|
|
px = px
|
|
, py = py
|
|
, pz = pz
|
|
, pitch = pitch
|
|
, heading = heading }
|
|
<- readMVar state
|
|
loadIdentity
|
|
GL.rotate pitch (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat)
|
|
GL.rotate heading (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat)
|
|
translate (Vector3 (-px) (-py) (-pz)::Vector3 GLfloat)
|
|
|
|
generateShadowMap tiles [] True
|
|
generateTextureMatrix
|
|
clear [ ColorBuffer, DepthBuffer ]
|
|
preservingMatrix $ do
|
|
drawObjects tiles [] False
|
|
|
|
return ()
|
|
|
|
updateCamera :: MVar ProgramState -> IO ()
|
|
updateCamera state = do
|
|
ps@PS { dx = dx
|
|
, dy = dy
|
|
, dz = dz
|
|
, px = px
|
|
, py = py
|
|
, pz = pz
|
|
, pitch = pitch
|
|
, heading = heading
|
|
, dpitch = dpitch
|
|
, dheading = dheading }
|
|
<- takeMVar state
|
|
|
|
d@((dx,dy,dz),(heading',pitch')) <-
|
|
if any (/= 0.0) [dx,dy,dz,dpitch,dheading] then
|
|
preservingMatrix $ do
|
|
-- putStrLn $ unwords $ P.map show [dx,dy,dz,dpitch,dheading]
|
|
loadIdentity
|
|
|
|
-- in direction of current heading and pitch
|
|
rotate (-heading) (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat)
|
|
rotate (-pitch) (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat)
|
|
|
|
-- perform motion
|
|
translate (Vector3 (-dx) (-dy) (-dz))
|
|
|
|
|
|
-- get changes in location components
|
|
mat <- get (matrix Nothing) :: IO (GLmatrix GLfloat)
|
|
comps <- getMatrixComponents ColumnMajor mat
|
|
-- putStrLn $ show $ comps
|
|
let [dx', dy', dz', _] = drop 12 comps
|
|
(heading', pitch') = (heading + dheading, pitch + dpitch)
|
|
return ((dx',dy',dz'),(heading',pitch'))
|
|
else
|
|
return ((0,0,0),(heading, pitch))
|
|
putMVar state ps { px = px + dx
|
|
, py = py + dy
|
|
, pz = pz + dz
|
|
, pitch = pitch'
|
|
, 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)
|
|
(w', h') = if h1 <= fromIntegral h
|
|
then (floor w1, floor h1)
|
|
else (floor w2, floor h2)
|
|
reshape $ Just (w', h')
|
|
return (w', h')
|
|
|
|
-- Called by reconfigure to fix the OpenGL viewport according to the
|
|
-- dimensions of the widget, appropriately.
|
|
reshape :: Maybe (Int, Int) -> IO ()
|
|
reshape dims = do
|
|
let (width, height) = fromMaybe (canvasWidth, canvasHeight) dims
|
|
viewport $= (Position 0 0, Size (fromIntegral width) (fromIntegral height))
|
|
matrixMode $= Projection
|
|
loadIdentity
|
|
let (w, h) = if width <= height
|
|
then (fromIntegral height, fromIntegral width )
|
|
else (fromIntegral width, fromIntegral height)
|
|
-- open, aspect-ratio, near-plane, far-plane
|
|
perspective 60.0 (fromIntegral canvasWidth / fromIntegral canvasHeight) 1.0 100.0
|
|
matrixMode $= Modelview 0
|
|
loadIdentity
|
|
|
|
keyEvent state press = do
|
|
code <- Event.eventHardwareKeycode
|
|
val <- Event.eventKeyVal
|
|
mods <- Event.eventModifier
|
|
name <- Event.eventKeyName
|
|
liftIO $ do
|
|
ps@PS { keysPressed = kp
|
|
, dx = dx
|
|
, dy = dy
|
|
, dz = dz
|
|
, px = px
|
|
, py = py
|
|
, pz = pz
|
|
, pitch = pitch
|
|
, heading = heading
|
|
, dpitch = dpitch
|
|
, dheading = dheading }
|
|
<- takeMVar state
|
|
-- Only process the key event if it is not a repeat
|
|
(ps',ret) <- if (fromIntegral code `member` kp && not press) ||
|
|
(fromIntegral code `notMember` kp && press)
|
|
then let
|
|
accept a = return (a, True)
|
|
deny a = return (a, False)
|
|
in do
|
|
-- keep list of pressed keys up2date
|
|
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
|
|
True
|
|
| code == 9 -> Gtk.mainQuit >> deny ps
|
|
| code == 26 -> accept $ ps { dz = dz + deltaV }
|
|
| code == 40 -> accept $ ps { dz = dz - deltaV }
|
|
| code == 39 -> accept $ ps { dx = dx + deltaV }
|
|
| code == 41 -> accept $ ps { dx = dx - deltaV }
|
|
| code == 65 -> accept $ ps { dy = dy - deltaV }
|
|
| code == 66 -> accept $ ps { dy = dy + deltaV }
|
|
| code == 25 -> accept $ ps { dheading = dheading - deltaH }
|
|
| code == 27 -> accept $ ps { dheading = dheading + deltaH }
|
|
| otherwise -> deny ps
|
|
-- on RELEASE only
|
|
False
|
|
| code == 26 -> accept $ ps { dz = dz - deltaV }
|
|
| code == 40 -> accept $ ps { dz = dz + deltaV }
|
|
| code == 39 -> accept $ ps { dx = dx - deltaV }
|
|
| code == 41 -> accept $ ps { dx = dx + deltaV }
|
|
| code == 65 -> accept $ ps { dy = dy + deltaV }
|
|
| code == 66 -> accept $ ps { dy = dy - deltaV }
|
|
| code == 25 -> accept $ ps { dheading = dheading + deltaH }
|
|
| code == 27 -> accept $ ps { dheading = dheading - deltaH }
|
|
| otherwise -> deny ps
|
|
else return (ps, False)
|
|
putMVar state ps'
|
|
return ret
|
|
|
|
main :: IO ()
|
|
main = do
|
|
! terrain <- testmap
|
|
-- create TVar using unsafePerformIO -> currently no other thread -> OK
|
|
state <- newMVar PS { keysPressed = IS.empty
|
|
, px = 7.5
|
|
, py = 20
|
|
, pz = 15
|
|
, heading = 0
|
|
, pitch = 60
|
|
, dx = 0
|
|
, dy = 0
|
|
, dz = 0
|
|
, dheading = 0
|
|
, dpitch = 0}
|
|
trace (show terrain) Gtk.initGUI
|
|
-- Initialise the Gtk+ OpenGL extension
|
|
-- (including reading various command line parameters)
|
|
GtkGL.initGL
|
|
|
|
-- We need a OpenGL frame buffer configuration to be able to create other
|
|
-- OpenGL objects.
|
|
glconfig <- GtkGL.glConfigNew [GtkGL.GLModeRGBA,
|
|
GtkGL.GLModeDepth,
|
|
GtkGL.GLModeDouble]
|
|
|
|
-- Create an OpenGL drawing area widget
|
|
canvas <- GtkGL.glDrawingAreaNew glconfig
|
|
|
|
Gtk.widgetSetSizeRequest canvas canvasWidth canvasHeight
|
|
|
|
-- Initialise some GL setting just before the canvas first gets shown
|
|
-- (We can't initialise these things earlier since the GL resources that
|
|
-- 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 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 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 $= 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
|
|
loadIdentity
|
|
ortho 0.0 1.0 0.0 1.0 (-1.0) 1.0
|
|
depthFunc $= Just Less
|
|
drawBuffer $= BackBuffers-}
|
|
|
|
-- Set the repaint handler
|
|
Gtk.onExpose canvas $ \_ -> do
|
|
GtkGL.withGLDrawingArea canvas $ \glwindow -> do
|
|
GL.clear [GL.DepthBuffer, GL.ColorBuffer]
|
|
display state terrain
|
|
GtkGL.glDrawableSwapBuffers glwindow
|
|
return True
|
|
|
|
-- Setup the animation
|
|
Gtk.timeoutAddFull (do
|
|
updateCamera state
|
|
Gtk.widgetQueueDraw canvas
|
|
return True)
|
|
Gtk.priorityDefaultIdle animationWaitTime
|
|
|
|
--------------------------------
|
|
-- Setup the rest of the GUI:
|
|
--
|
|
-- Objects
|
|
window <- Gtk.windowNew
|
|
button <- Gtk.buttonNew
|
|
exitButton <- Gtk.buttonNew
|
|
label <- Gtk.labelNew (Just "Gtk2Hs using OpenGL via HOpenGL!")
|
|
vbox <- Gtk.vBoxNew False 4
|
|
|
|
--Wrench them together
|
|
|
|
Gtk.set window [ Gtk.containerBorderWidth := 10,
|
|
Gtk.containerChild := canvas,
|
|
Gtk.windowTitle := "Pioneer" ]
|
|
|
|
------
|
|
-- Events
|
|
--
|
|
Gtk.afterClicked button (putStrLn "Hello World")
|
|
Gtk.afterClicked exitButton Gtk.mainQuit
|
|
Gtk.onDestroy window Gtk.mainQuit
|
|
|
|
Gtk.on window Gtk.keyPressEvent $ keyEvent state True
|
|
|
|
Gtk.on window Gtk.keyReleaseEvent $ keyEvent state False
|
|
|
|
-- "reshape" event handler
|
|
Gtk.on canvas Gtk.configureEvent $ Event.tryEvent $ do
|
|
(w, h) <- Event.eventSize
|
|
(w', h') <- liftIO $ reconfigure w h
|
|
liftIO $ Gtk.labelSetText label $ unwords ["Width:",show w',"Height:",show h']
|
|
|
|
|
|
Gtk.widgetShowAll window
|
|
Gtk.mainGUI
|
|
|