Drezil/pioneers
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Merge branch 'master' into ui

Browse Source 
Conflicts:
	src/UI/Callbacks.hs

caused by using TMVar for camera state
This commit is contained in:
tpajenka 2014-05-21 14:57:39 +02:00
commit 9761e7c6c2
16 changed files with 457 additions and 296 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Pioneers.cabal
View File

@ -16,7 +16,6 @@ executable Pioneers
Map.Types, Map.Types,
Map.Graphics, Map.Graphics,
Map.Creation, Map.Creation,
Map.StaticMaps,
Importer.IQM.Types, Importer.IQM.Types,
Importer.IQM.Parser, Importer.IQM.Parser,
Render.Misc, Render.Misc,

15
shaders/map/fragmentShadow.shader Normal file
View File

@ -0,0 +1,15 @@
#version 330
smooth in vec3 teNormal;
smooth in vec3 tePosition;
smooth in float fogDist;
smooth in float gmix;
in vec4 teColor;
in vec3 tePatchDistance;
uniform mat4 ViewMatrix;
uniform mat4 ProjectionMatrix;
void main(void)
{
}

26
src/Importer/IQM/Parser.hs
View File

@ -13,6 +13,8 @@ import Data.ByteString.Char8 (pack)
import Data.ByteString (split, null, ByteString) import Data.ByteString (split, null, ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCString) import Data.ByteString.Unsafe (unsafeUseAsCString)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Graphics.GLUtil
import Graphics.Rendering.OpenGL.GL.BufferObjects
import Data.Word import Data.Word
import Data.Int import Data.Int
import Unsafe.Coerce import Unsafe.Coerce
@ -211,10 +213,29 @@ parseIQM a =
-- Fill Vertex-Arrays with data of Offsets -- Fill Vertex-Arrays with data of Offsets
let va = vertexArrays raw let va = vertexArrays raw
va' <- mapM (readInVAO f) va va' <- mapM (readInVAO f) va
return $ raw { vbo <- sequence $ map toVBOfromVAO va
vertexArrays = va' return $ raw
{ vertexArrays = va'
, vertexArrayObjects = vbo
} }
-- | Creates a BufferObject on the Graphicscard for each BufferObject
toVBOfromVAO :: IQMVertexArray -> IO BufferObject
toVBOfromVAO (IQMVertexArray type' _ _ num _ ptr) =
fromPtr (toBufferTargetfromVAType type') (fromIntegral num) ptr
-- | translates from VA-type to BufferTarget
toBufferTargetfromVAType :: IQMVertexArrayType -> BufferTarget
toBufferTargetfromVAType IQMPosition = ArrayBuffer
toBufferTargetfromVAType IQMTexCoord = TextureBuffer
toBufferTargetfromVAType IQMNormal = ArrayBuffer
toBufferTargetfromVAType IQMBlendIndexes = ElementArrayBuffer
toBufferTargetfromVAType IQMBlendWeights = ArrayBuffer
toBufferTargetfromVAType IQMColor = ArrayBuffer
toBufferTargetfromVAType _ = ArrayBuffer
-- | Allocates memory for the Vertex-data and copies it over there -- | Allocates memory for the Vertex-data and copies it over there
-- from the given input-String -- from the given input-String
-- --
@ -254,6 +275,7 @@ doIQMparse =
, texts = filter (not.null) (split (unsafeCoerce '\0') text) , texts = filter (not.null) (split (unsafeCoerce '\0') text)
, meshes = meshes' , meshes = meshes'
, vertexArrays = vaf , vertexArrays = vaf
, vertexArrayObjects = [] --initialized later, after vaf get allocated.
} }
-- | Helper-Function for Extracting a random substring out of a Bytestring -- | Helper-Function for Extracting a random substring out of a Bytestring

2
src/Importer/IQM/Types.hs
View File

@ -13,6 +13,7 @@ import Graphics.Rendering.OpenGL.Raw.Types
import Prelude as P import Prelude as P
import Foreign.Storable import Foreign.Storable
import Foreign.C.Types import Foreign.C.Types
import Graphics.Rendering.OpenGL.GL.BufferObjects hiding (Offset)
-- | Mesh-Indices to distinguish the meshes referenced -- | Mesh-Indices to distinguish the meshes referenced
newtype Mesh = Mesh Word32 deriving (Show, Eq) newtype Mesh = Mesh Word32 deriving (Show, Eq)
@ -108,6 +109,7 @@ data IQM = IQM
, texts :: [ByteString] , texts :: [ByteString]
, meshes :: [IQMMesh] , meshes :: [IQMMesh]
, vertexArrays :: [IQMVertexArray] , vertexArrays :: [IQMVertexArray]
, vertexArrayObjects :: [BufferObject]
} deriving (Show, Eq) } deriving (Show, Eq)
-- | Different Vertex-Array-Types in IQM -- | Different Vertex-Array-Types in IQM

73
src/Main.hs
View File

@ -12,8 +12,8 @@ import Control.Arrow ((***))
-- data consistency/conversion -- data consistency/conversion
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (TQueue, import Control.Concurrent.STM (TQueue, newTQueueIO, atomically)
newTQueueIO) import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVar)
import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify)
import Data.Functor ((<$>)) import Data.Functor ((<$>))
@ -43,6 +43,7 @@ import Render.Render (initRendering,
import Render.Types import Render.Types
import UI.Callbacks import UI.Callbacks
import Map.Graphics import Map.Graphics
import Map.Creation (exportedMap)
import Types import Types
import qualified UI.UIBase as UI import qualified UI.UIBase as UI
import Importer.IQM.Parser import Importer.IQM.Parser
@ -54,7 +55,7 @@ import Importer.IQM.Parser
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
testParser :: String -> IO () testParser :: String -> IO ()
testParser a = putStrLn . show =<< parseIQM a testParser a = print =<< parseIQM a
{-do {-do
f <- B.readFile a f <- B.readFile a
putStrLn "reading in:" putStrLn "reading in:"
@ -86,22 +87,33 @@ main =
(SDL.Size fbWidth fbHeight) <- SDL.glGetDrawableSize window' (SDL.Size fbWidth fbHeight) <- SDL.glGetDrawableSize window'
initRendering initRendering
--generate map vertices --generate map vertices
glMap' <- initMapShader 4 =<< getMapBufferObject curMap <- exportedMap
glMap' <- initMapShader 4 =<< getMapBufferObject curMap
eventQueue <- newTQueueIO :: IO (TQueue SDL.Event) eventQueue <- newTQueueIO :: IO (TQueue SDL.Event)
now <- getCurrentTime now <- getCurrentTime
--font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10 --font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
--TTF.setFontStyle font TTFNormal --TTF.setFontStyle font TTFNormal
--TTF.setFontHinting font TTFHNormal --TTF.setFontHinting font TTFHNormal
let
glHud' <- initHud
let zDistClosest' = 1
zDistFarthest' = zDistClosest' + 50
--TODO: Move near/far/fov to state for runtime-changability & central storage
fov = 90 --field of view fov = 90 --field of view
near = 1 --near plane near = 1 --near plane
far = 500 --far plane far = 500 --far plane
ratio = fromIntegral fbWidth / fromIntegral fbHeight ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio frust = createFrustum fov near far ratio
cam' <- newTVarIO CameraState
{ _xAngle = pi/6
, _yAngle = pi/2
, _zDist = 10
, _frustum = frust
, _camObject = createFlatCam 25 25 curMap
}
game' <- newTVarIO GameState
{ _currentMap = curMap
}
glHud' <- initHud
let zDistClosest' = 2
zDistFarthest' = zDistClosest' + 10
--TODO: Move near/far/fov to state for runtime-changability & central storage
(guiMap, guiRoots) = createGUI (guiMap, guiRoots) = createGUI
aks = ArrowKeyState { aks = ArrowKeyState {
_up = False _up = False
@ -121,17 +133,11 @@ main =
, _height = fbHeight , _height = fbHeight
, _shouldClose = False , _shouldClose = False
} }
, _camera = CameraState
{ _xAngle = pi/6
, _yAngle = pi/2
, _zDist = 10
, _frustum = frust
, _camObject = createFlatCam 25 25
}
, _io = IOState , _io = IOState
{ _clock = now { _clock = now
, _tessClockFactor = 0 , _tessClockFactor = 0
} }
, _camera = cam'
, _mouse = MouseState , _mouse = MouseState
{ _isDragging = False { _isDragging = False
, _dragStartX = 0 , _dragStartX = 0
@ -152,9 +158,7 @@ main =
, _glRenderbuffer = renderBuffer , _glRenderbuffer = renderBuffer
, _glFramebuffer = frameBuffer , _glFramebuffer = frameBuffer
} }
, _game = GameState , _game = game'
{
}
, _ui = UIState , _ui = UIState
{ _uiHasChanged = True { _uiHasChanged = True
, _uiMap = guiMap , _uiMap = guiMap
@ -204,20 +208,26 @@ run = do
| otherwise = newYAngle' | otherwise = newYAngle'
newYAngle' = sodya + myrot/100 newYAngle' = sodya + myrot/100
modify $ ((camera.xAngle) .~ newXAngle) liftIO $ atomically $ do
. ((camera.yAngle) .~ newYAngle) cam <- readTVar (state ^. camera)
cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam
writeTVar (state ^. camera) cam'
-- get cursor-keys - if pressed -- get cursor-keys - if pressed
--TODO: Add sin/cos from stateYAngle --TODO: Add sin/cos from stateYAngle
(kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
liftIO $ atomically $ do
cam <- readTVar (state ^. camera)
game' <- readTVar (state ^. game)
let let
multc = cos $ state ^. camera.yAngle multc = cos $ cam ^. yAngle
mults = sin $ state ^. camera.yAngle mults = sin $ cam ^. yAngle
modx x' = x' - 0.2 * kxrot * multc modx x' = x' - 0.2 * kxrot * multc
- 0.2 * kyrot * mults - 0.2 * kyrot * mults
mody y' = y' + 0.2 * kxrot * mults mody y' = y' + 0.2 * kxrot * mults
- 0.2 * kyrot * multc - 0.2 * kyrot * multc
modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y))) cam' <- return $ camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (game' ^. currentMap)) $ cam
writeTVar (state ^. camera) cam'
{- {-
--modify the state with all that happened in mt time. --modify the state with all that happened in mt time.
@ -233,7 +243,7 @@ run = do
targetFrametime = 1.0/targetFramerate targetFrametime = 1.0/targetFramerate
--targetFrametimeμs = targetFrametime * 1000000.0 --targetFrametimeμs = targetFrametime * 1000000.0
now <- getCurrentTime now <- getCurrentTime
let diff = diffUTCTime now (state ^. io.clock) -- get time-diffs let diff = max 0.1 $ diffUTCTime now (state ^. io.clock) -- get time-diffs
title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"] title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
ddiff = double diff ddiff = double diff
SDL.setWindowTitle (env ^. windowObject) title SDL.setWindowTitle (env ^. windowObject) title
@ -287,7 +297,10 @@ adjustWindow = do
ratio = fromIntegral fbWidth / fromIntegral fbHeight ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio frust = createFrustum fov near far ratio
liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight) liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight)
modify $ camera.frustum .~ frust liftIO $ atomically $ do
cam <- readTVar (state ^. camera)
cam' <- return $ frustum .~ frust $ cam
writeTVar (state ^. camera) cam'
rb <- liftIO $ do rb <- liftIO $ do
-- bind ints to CInt for lateron. -- bind ints to CInt for lateron.
let fbCWidth = (fromInteger.toInteger) fbWidth let fbCWidth = (fromInteger.toInteger) fbWidth
@ -305,6 +318,7 @@ adjustWindow = do
let hudtexid = state ^. gl.glHud.hudTexture let hudtexid = state ^. gl.glHud.hudTexture
maptexid = state ^. gl.glMap.renderedMapTexture maptexid = state ^. gl.glMap.renderedMapTexture
smaptexid = state ^. gl.glMap.shadowMapTexture
allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do
--default to ugly pink to see if --default to ugly pink to see if
--somethings go wrong. --somethings go wrong.
@ -321,6 +335,13 @@ adjustWindow = do
textureFilter Texture2D GL.$= ((Linear', Nothing), Linear') textureFilter Texture2D GL.$= ((Linear', Nothing), Linear')
texImage2D Texture2D GL.NoProxy 0 RGBA8 (GL.TextureSize2D fbCWidth fbCHeight) 0 texImage2D Texture2D GL.NoProxy 0 RGBA8 (GL.TextureSize2D fbCWidth fbCHeight) 0
(GL.PixelData GL.RGBA GL.UnsignedByte ptr) (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
allocaBytes (2048*2048) $ \ptr -> do
let smapdata = genColorData (2048*2048) [0]
pokeArray ptr smapdata
textureBinding Texture2D GL.$= Just smaptexid
textureFilter Texture2D GL.$= ((Nearest,Nothing), Nearest)
texImage2D Texture2D GL.NoProxy 0 GL.DepthComponent16 (GL.TextureSize2D 2048 2048) 0
(GL.PixelData GL.DepthComponent GL.UnsignedByte ptr)
checkError "setting up HUD-Tex" checkError "setting up HUD-Tex"
return renderBuffer return renderBuffer
modify $ gl.glRenderbuffer .~ rb modify $ gl.glRenderbuffer .~ rb

54
src/Map/Creation.hs
View File

@ -2,21 +2,13 @@ module Map.Creation
where where
import Map.Types import Map.Types
import Map.StaticMaps
-- import Map.Map unused (for now)
import Data.Array import Data.Array
import System.Random import System.Random
-- preliminary -- entirely empty map, only uses the minimal constructor
infix 5 ->- mapEmpty :: PlayMap
(->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap mapEmpty = array ((0,0), (199,199)) [((a,b), Node (a,b) (fromIntegral a, (if even b then (fromIntegral b) else(fromIntegral b) - 0.5), 1) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199]]
f ->- g = g . f
-- also preliminary
infix 5 -<-
(-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
f -<- g = f . g
exportedMap :: IO PlayMap exportedMap :: IO PlayMap
exportedMap = do mounts <- mnt exportedMap = do mounts <- mnt
@ -52,18 +44,7 @@ gauss3Dgeneral :: Floating q =>
-> q -- ^ Coordinate in question on X -> q -- ^ Coordinate in question on X
-> q -- ^ Coordinate in question on Z -> q -- ^ Coordinate in question on Z
-> q -- ^ elevation on coordinate in question -> q -- ^ elevation on coordinate in question
gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Integer)/(2 * sX^(2 :: Integer)))+((z-z0)^(2 :: Integer)/(2 * sZ^(2 :: Integer))))) gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Int)/(2 * sX^(2 :: Int)))+((z-z0)^(2 :: Int)/(2 * sZ^(2 :: Int)))))
-- specialised 3D gaussian with an origin on 100/100, an amplitude of 15 and two sigmas of 15
gauss3D :: Floating q =>
q -- ^ X-Coordinate
-> q -- ^ Z-Coordinate
-> q -- ^ elevation on coordinate in quesion
gauss3D = gauss3Dgeneral 15 100.0 100.0 15.0 15.0
-- 2D Manhattan distance
mnh2D :: (Int,Int) -> (Int,Int) -> Int
mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d)
-- | Basic Terrain-Generator. Will not implement "abnormal" Stuff for given Biome -- | Basic Terrain-Generator. Will not implement "abnormal" Stuff for given Biome
-- (like Deserts on Grass-Islands or Grass on Deserts) -- (like Deserts on Grass-Islands or Grass on Deserts)
@ -72,9 +53,9 @@ mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d)
heightToTerrain :: MapType -> YCoord -> TileType heightToTerrain :: MapType -> YCoord -> TileType
heightToTerrain GrassIslandMap y heightToTerrain GrassIslandMap y
| y < 0.1 = Ocean | y < 0.1 = Ocean
| y < 1 = Beach | y < 0.2 = Beach
| y < 5 = Grass | y < 1.5 = Grass
| y < 10 = Hill | y < 3 = Hill
| otherwise = Mountain | otherwise = Mountain
heightToTerrain _ _ = undefined heightToTerrain _ _ = undefined
@ -87,26 +68,23 @@ river = undefined
mnt :: IO [PlayMap -> PlayMap] mnt :: IO [PlayMap -> PlayMap]
mnt = do g <- newStdGen mnt = do g <- newStdGen
let seeds = take 10 $ randoms g let seeds = take 50 $ randoms g
return $ map (gaussMountain) seeds return $ map gaussMountain seeds
gaussMountain :: Int -> PlayMap -> PlayMap gaussMountain :: Int -> PlayMap -> PlayMap
gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp
where where
g = mkStdGen seed gs = map mkStdGen (map (*seed) [1..])
c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) g), (head (randomRs (b,y) g))) c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) (gs !! 0)), (head (randomRs (b,y) (gs !! 1))))
amp = head $ randomRs (5.0, 20.0) g amp = head $ randomRs ((2.0, 5.0) :: (Double, Double)) (gs !! 2)
sig = head $ randomRs (5.0, 25.0) g sig = head $ randomRs ((2.0, 8.0) :: (Double, Double)) (gs !! 3)
fi = fromIntegral
htt = heightToTerrain htt = heightToTerrain
-- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map -- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map
liftUp :: (Int, Int) -> Node -> Node liftUp :: (Int, Int) -> Node -> Node
liftUp (gx,gz) (Full (x,z) y _ b pl pa r s) = let y_neu = max y e liftUp (gx,gz) (Node (x,z) (rx,rz,y) _ b pl pa r s) = let y_neu = max y e
in Full (x,z) y_neu (htt GrassIslandMap y_neu) b pl pa r s in Node (x,z) (rx, rz, y_neu) (htt GrassIslandMap y_neu) b pl pa r s
where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z) where e = gauss3Dgeneral amp (fromIntegral gx) (fromIntegral gz) sig sig rx rz
liftUp (gx, gz) (Minimal (x,z)) = Full (x,z) e (htt GrassIslandMap e) BFlag NoPlayer NoPath Plain []
where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z)
-- | Makes sure the edges of the Map are mountain-free -- | Makes sure the edges of the Map are mountain-free
makeIsland :: PlayMap -> PlayMap makeIsland :: PlayMap -> PlayMap

18
src/Map/Graphics.hs
View File

@ -30,9 +30,8 @@ import Linear
import Control.Arrow ((***)) import Control.Arrow ((***))
import Map.Types import Map.Types
import Map.Creation
type Height = Float type Height = Double
type MapEntry = ( type MapEntry = (
Height, Height,
@ -50,16 +49,14 @@ stripify :: (Int,Int) -> (Int,Int)
stripify (x,z) = (if even z then 2*x else 2*x+1, z `div` 2) stripify (x,z) = (if even z then 2*x else 2*x+1, z `div` 2)
strp :: Node -> Node strp :: Node -> Node
strp (Full xz y tt bi pli p ri si) = Full (stripify xz) y tt bi pli p ri si strp (Node i (x,z,y) tt bi pli p ri si) = Node (stripify i) (x,z,y) tt bi pli p ri si
strp (Minimal xz ) = Minimal (stripify xz)
-- extract graphics information from Playmap -- extract graphics information from Playmap
convertToGraphicsMap :: PlayMap -> GraphicsMap convertToGraphicsMap :: PlayMap -> GraphicsMap
convertToGraphicsMap mp = array (bounds mp) [(i, graphicsyfy (mp ! i))| i <- indices mp] convertToGraphicsMap mp = array (bounds mp) [(i, graphicsyfy (mp ! i))| i <- indices mp]
where where
graphicsyfy :: Node -> MapEntry graphicsyfy :: Node -> MapEntry
graphicsyfy (Minimal _ ) = (1.0, Grass) graphicsyfy (Node _ (_,_,y) t _ _ _ _ _ ) = (y, t)
graphicsyfy (Full _ y t _ _ _ _ _ ) = (y, t)
lineHeight :: GLfloat lineHeight :: GLfloat
lineHeight = 0.8660254 lineHeight = 0.8660254
@ -87,9 +84,8 @@ fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color
fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal
getMapBufferObject :: IO (BufferObject, NumArrayIndices) getMapBufferObject :: PlayMap -> IO (BufferObject, NumArrayIndices)
getMapBufferObject = do getMapBufferObject eMap = do
eMap <- exportedMap
myMap' <- return $ convertToGraphicsMap $ convertToStripeMap eMap myMap' <- return $ convertToGraphicsMap $ convertToStripeMap eMap
! myMap <- return $ generateTriangles myMap' ! myMap <- return $ generateTriangles myMap'
len <- return $ fromIntegral $ P.length myMap `div` numComponents len <- return $ fromIntegral $ P.length myMap `div` numComponents
@ -203,8 +199,8 @@ colorLookup hs t = if inRange (bounds hs) t then c else (0.0, 0.0, 0.0)
Beach -> (0.90, 0.85, 0.70) Beach -> (0.90, 0.85, 0.70)
Desert -> (1.00, 0.87, 0.39) Desert -> (1.00, 0.87, 0.39)
Grass -> (0.30, 0.90, 0.10) Grass -> (0.30, 0.90, 0.10)
Hill -> (0.80, 0.80, 0.80) Mountain -> (0.80, 0.80, 0.80)
Mountain -> (0.50, 0.50, 0.50) Hill -> (0.50, 0.50, 0.50)
coordLookup :: (Int,Int) -> GLfloat -> V3 GLfloat coordLookup :: (Int,Int) -> GLfloat -> V3 GLfloat
coordLookup (x,z) y = coordLookup (x,z) y =

53
src/Map/Map.hs
View File

@ -2,7 +2,7 @@ module Map.Map where
import Map.Types import Map.Types
import Data.Array (bounds) import Data.Array (bounds, (!))
import Data.List (sort, group) import Data.List (sort, group)
-- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet. -- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet.
@ -36,6 +36,57 @@ giveNeighbourhood _ 0 (a,b) = [(a,b)]
giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in
remdups . concat $ ns : map (giveNeighbourhood mp (n-1)) ns remdups . concat $ ns : map (giveNeighbourhood mp (n-1)) ns
-- | Calculates the height of any given point on the map.
-- Does not add camera distance to ground to that.
giveMapHeight :: PlayMap
-> (Double, Double)
-> Double
giveMapHeight mop (x, z)
| outsideMap (x,z') = 0.0
| otherwise = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups
where
z' = z * 2/(sqrt 3)
outsideMap :: (Double, Double) -> Bool
outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop
fr = fromIntegral
in mx < (fr a) || mx > (fr c) || mz < (fr b) || mz > (fr d)
-- Height LookUp on PlayMap
hlu :: (Int, Int) -> Double
hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y
-- reference Points
refs :: [(Int, Int)]
refs = remdups $ map clmp $ map (tadd (floor x, floor z')) mods
where
mods = [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)]
tadd (a,b) (c,d) = (a+b,c+d)
-- tupels with reference point and distance
tups = map (\t -> (t, dist (x,z') t)) refs
-- total distance of all for reference point from the point in question
totald = sum $ map (\(_,d) -> d) tups
-- clamp, as she is programmed
clamp :: (Ord a) => a -> a -> a -> a
clamp mn mx = max mn . min mx
-- clamp for tupels
clmp :: (Int, Int) -> (Int, Int)
clmp (a,b) = let ((xmin,zmin),(xmax,zmax)) = bounds mop
in ((clamp (xmin+2) (xmax-2) a),(clamp (zmin+2) (zmax-2) b))
-- Real distance on PlayMap
dist :: (Double, Double) -> (Int, Int) -> Double
dist (x1,z1) pmp = let xf = x1 - realx
zf = z1 - realz
in sqrt $ xf*xf + zf*zf
where
realx = (\(Node _ (nx,_,_) _ _ _ _ _ _) -> nx) (mop ! pmp)
realz = (\(Node _ (_,nz,_) _ _ _ _ _ _) -> nz) (mop ! pmp)
-- removing duplicates in O(n log n), losing order and adding Ord requirement -- removing duplicates in O(n log n), losing order and adding Ord requirement
remdups :: Ord a => [a] -> [a] remdups :: Ord a => [a] -> [a]
remdups = map head . group . sort remdups = map head . group . sort

49
src/Map/StaticMaps.hs
View File

@ -1,49 +0,0 @@
module Map.StaticMaps
where
import Map.Types
import Data.Array
-- entirely empty map, only uses the minimal constructor
mapEmpty :: PlayMap
mapEmpty = array ((0,0), (199,199)) [((a,b), Minimal (a,b)) | a <- [0..199], b <- [0..199]]
--mapCenterMountain :: PlayMap
--mapCenterMountain = array ((0,0),(199,199)) nodes
-- where
-- nodes = water ++ beach ++ grass ++ hill ++ mountain
-- water = [((a,b), Full (a,b) 0.0 Ocean BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) > 95]
-- beach = [((a,b), Full (a,b) (g2d a b) Beach BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 95, m2d (a,b) > 75]
-- grass = [((a,b), Full (a,b) (g2d a b) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 75, m2d (a,b) > 25]
-- hill = [((a,b), Full (a,b) (g2d a b) Hill BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 25, m2d (a,b) > 10]
-- mountain = [((a,b), Full (a,b) (g2d a b) Mountain BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 10]
-- g2d :: Int -> Int -> Float
-- g2d x y = gauss3D (fromIntegral x) (fromIntegral y)
-- m2d :: (Int,Int) -> Int
-- m2d (x,y) = mnh2D (x,y) (100,100)
-- small helper for some hills. Should be replaced by multi-layer perlin-noise
-- TODO: Replace as given in comment.
--_noisyMap :: (Floating q) => q -> q -> q
--_noisyMap x y = gauss3Dgeneral 15 100.0 100.0 15.0 15.0 x y
-- + gauss3Dgeneral 5 10.0 10.0 10.0 10.0 x y
-- + gauss3Dgeneral 5 150.0 120.0 10.0 10.0 x y
-- + gauss3Dgeneral 5 50.0 75.0 10.0 10.0 x y
-- generates a noisy map
-- TODO: add real noise to a simple pattern
--mapNoise :: PlayMap
--mapNoise = array ((0,0),(199,199)) nodes
-- where
-- nodes = [((a,b), Full (a,b)
-- (height a b)
-- (heightToTerrain GrassIslandMap $ height a b)
-- BNothing
-- NoPlayer
-- NoPath
-- Plain
-- []) | a <- [0..199], b <- [0..199]]
-- where
-- height a b = _noisyMap (fromIntegral a) (fromIntegral b)

78
src/Map/Types.hs
View File

@ -1,15 +1,15 @@
module Map.Types module Map.Types
where where
import Types
import Data.Array import Data.Array
type PlayMap = Array (XCoord, ZCoord) Node type PlayMap = Array (Xindex, Zindex) Node
type XCoord = Int type Xindex = Int
type ZCoord = Int type Zindex = Int
type YCoord = Float type XCoord = Double
type ZCoord = Double
type YCoord = Double
data MapType = GrassIslandMap data MapType = GrassIslandMap
| DesertMap | DesertMap
@ -66,7 +66,67 @@ data TileType = Ocean
| Mountain -- ^ Not accessible | Mountain -- ^ Not accessible
deriving (Show, Eq) deriving (Show, Eq)
-- TODO: Record Syntax -- TODO: Record Syntax?
data Node = Full (XCoord, ZCoord) YCoord TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo data Node = Node (Xindex, Zindex) (XCoord, ZCoord, YCoord) TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo
| Minimal (XCoord, ZCoord) -- defaults to empty green grass node on height 1
deriving (Show) deriving (Show)
data Structure = Flag -- Flag
| Woodcutter -- Huts
| Forester
| Stonemason
| Fisher
| Hunter
| Barracks
| Guardhouse
| LookoutTower
| Well
| Sawmill -- Houses
| Slaughterhouse
| Mill
| Bakery
| IronSmelter
| Metalworks
| Armory
| Mint
| Shipyard
| Brewery
| Storehouse
| Watchtower
| Catapult
| GoldMine -- Mines
| IronMine
| GraniteMine
| CoalMine
| Farm -- Castles
| PigFarm
| DonkeyBreeder
| Harbor
| Fortress
deriving (Show, Eq)
data Amount = Infinite -- Neverending supply
| Finite Int -- Finite supply
-- Extremely preliminary, expand when needed
data Commodity = WoodPlank
| Sword
| Fish
deriving Eq
data Resource = Coal
| Iron
| Gold
| Granite
| Water
| Fishes
deriving (Show, Eq)
instance Show Amount where
show (Infinite) = "inexhaustable supply"
show (Finite n) = show n ++ " left"
instance Show Commodity where
show WoodPlank = "wooden plank"
show Sword = "sword"
show Fish = "fish"

14
src/Render/Misc.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE ForeignFunctionInterface #-}
module Render.Misc where module Render.Misc where
import Control.Monad import Control.Monad
@ -75,6 +74,16 @@ createFrustum fov n' f' rat =
(V4 0 0 (-((f+n)/(f-n))) (-((2*f*n)/(f-n)))) (V4 0 0 (-((f+n)/(f-n))) (-((2*f*n)/(f-n))))
(V4 0 0 (-1) 0) (V4 0 0 (-1) 0)
-- | Creates an orthogonal frustum with given width, height, near and far-plane
createFrustumOrtho :: Float -> Float -> Float -> Float -> M44 CFloat
createFrustumOrtho w' h' n' f' =
let [w,h,n,f] = map realToFrac [w',h',n',f']
in
V4 (V4 (0.5/w) 0 0 0)
(V4 0 (0.5/h) 0 0)
(V4 0 0 (-2/(f-n)) ((-f+n)/(f-n)))
(V4 0 0 0 1)
-- from vmath.h -- from vmath.h
lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat
lookAt eye center up' = lookAt eye center up' =
@ -128,5 +137,4 @@ tryWithTexture t f fail' =
genColorData :: Int -- ^ Amount genColorData :: Int -- ^ Amount
-> [Int8] -- ^ [r,g,b,a], [r,g,b] - whatever should be repeatet. -> [Int8] -- ^ [r,g,b,a], [r,g,b] - whatever should be repeatet.
-> [Int8] -> [Int8]
genColorData n c = take ((length c)*n) (cycle c) genColorData n c = take (length c*n) (cycle c)

199
src/Render/Render.hs
View File

@ -7,11 +7,13 @@ import Foreign.Storable
import Graphics.Rendering.OpenGL.GL import Graphics.Rendering.OpenGL.GL
import Graphics.Rendering.OpenGL.Raw.Core31 import Graphics.Rendering.OpenGL.Raw.Core31
import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
import Graphics.GLUtil.BufferObjects (offset0) import Graphics.GLUtil.BufferObjects
import qualified Linear as L import qualified Linear as L
import Control.Lens ((^.)) import Control.Lens ((^.))
import Control.Monad.RWS.Strict (liftIO) import Control.Monad.RWS.Strict (liftIO)
import qualified Control.Monad.RWS.Strict as RWS (get) import qualified Control.Monad.RWS.Strict as RWS (get)
import Control.Concurrent.STM.TVar (readTVarIO)
import Control.Concurrent.STM (atomically)
import Data.Distributive (distribute, collect) import Data.Distributive (distribute, collect)
-- FFI -- FFI
import Foreign (Ptr, castPtr, with) import Foreign (Ptr, castPtr, with)
@ -24,6 +26,7 @@ import Render.Types
import Graphics.GLUtil.BufferObjects (makeBuffer) import Graphics.GLUtil.BufferObjects (makeBuffer)
import Importer.IQM.Parser import Importer.IQM.Parser
import Importer.IQM.Types import Importer.IQM.Types
import Map.Map (giveMapHeight)
mapVertexShaderFile :: String mapVertexShaderFile :: String
mapVertexShaderFile = "shaders/map/vertex.shader" mapVertexShaderFile = "shaders/map/vertex.shader"
@ -33,6 +36,8 @@ mapTessEvalShaderFile :: String
mapTessEvalShaderFile = "shaders/map/tessEval.shader" mapTessEvalShaderFile = "shaders/map/tessEval.shader"
mapFragmentShaderFile :: String mapFragmentShaderFile :: String
mapFragmentShaderFile = "shaders/map/fragment.shader" mapFragmentShaderFile = "shaders/map/fragment.shader"
mapFragmentShaderShadowMapFile :: String
mapFragmentShaderShadowMapFile = "shaders/map/fragmentShadow.shader"
objectVertexShaderFile :: String objectVertexShaderFile :: String
objectVertexShaderFile = "shaders/mapobjects/vertex.shader" objectVertexShaderFile = "shaders/mapobjects/vertex.shader"
@ -66,6 +71,7 @@ initMapShader tessFac (buf, vertDes) = do
! tessControlSource <- B.readFile mapTessControlShaderFile ! tessControlSource <- B.readFile mapTessControlShaderFile
! tessEvalSource <- B.readFile mapTessEvalShaderFile ! tessEvalSource <- B.readFile mapTessEvalShaderFile
! fragmentSource <- B.readFile mapFragmentShaderFile ! fragmentSource <- B.readFile mapFragmentShaderFile
! fragmentShadowSource <- B.readFile mapFragmentShaderShadowMapFile
vertexShader <- compileShaderSource VertexShader vertexSource vertexShader <- compileShaderSource VertexShader vertexSource
checkError "compile Vertex" checkError "compile Vertex"
tessControlShader <- compileShaderSource TessControlShader tessControlSource tessControlShader <- compileShaderSource TessControlShader tessControlSource
@ -74,7 +80,10 @@ initMapShader tessFac (buf, vertDes) = do
checkError "compile TessEval" checkError "compile TessEval"
fragmentShader <- compileShaderSource FragmentShader fragmentSource fragmentShader <- compileShaderSource FragmentShader fragmentSource
checkError "compile Frag" checkError "compile Frag"
fragmentShadowShader <- compileShaderSource FragmentShader fragmentShadowSource
checkError "compile Frag"
program <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShader] program <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShader]
shadowProgram <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShadowShader]
checkError "compile Program" checkError "compile Program"
currentProgram $= Just program currentProgram $= Just program
@ -120,6 +129,8 @@ initMapShader tessFac (buf, vertDes) = do
texts <- genObjectNames 6 texts <- genObjectNames 6
smap <- genObjectName
testobj <- parseIQM "sample.iqm" testobj <- parseIQM "sample.iqm"
let let
@ -137,25 +148,31 @@ initMapShader tessFac (buf, vertDes) = do
currentProgram $= Just objProgram currentProgram $= Just objProgram
checkError "initShader" checkError "initShader"
let sdata = MapShaderData
{ shdrVertexIndex = vertexIndex
, shdrColorIndex = colorIndex
, shdrNormalIndex = normalIndex
, shdrProjMatIndex = projectionMatrixIndex
, shdrViewMatIndex = viewMatrixIndex
, shdrModelMatIndex = modelMatrixIndex
, shdrNormalMatIndex = normalMatrixIndex
, shdrTessInnerIndex = tessLevelInner
, shdrTessOuterIndex = tessLevelOuter
}
return GLMapState return GLMapState
{ _mapProgram = program { _mapProgram = program
, _shdrColorIndex = colorIndex , _mapShaderData = sdata
, _shdrNormalIndex = normalIndex
, _shdrVertexIndex = vertexIndex
, _shdrProjMatIndex = projectionMatrixIndex
, _shdrViewMatIndex = viewMatrixIndex
, _shdrModelMatIndex = modelMatrixIndex
, _shdrNormalMatIndex = normalMatrixIndex
, _shdrTessInnerIndex = tessLevelInner
, _shdrTessOuterIndex = tessLevelOuter
, _renderedMapTexture = tex , _renderedMapTexture = tex
, _stateTessellationFactor = tessFac , _stateTessellationFactor = tessFac
, _stateMap = buf , _stateMap = buf
, _mapVert = vertDes , _mapVert = vertDes
, _overviewTexture = overTex , _overviewTexture = overTex
, _mapTextures = texts , _mapTextures = texts
, _shadowMapTexture = smap
, _mapObjects = objs , _mapObjects = objs
, _objectProgram = objProgram , _objectProgram = objProgram
, _shadowMapProgram = shadowProgram
} }
initHud :: IO GLHud initHud :: IO GLHud
@ -190,7 +207,7 @@ initHud = do
att <- get (activeAttribs program) att <- get (activeAttribs program)
putStrLn $ unlines $ "Attributes: ":map show att putStrLn $ unlines $ "Attributes: ":map show att
putStrLn $ unlines $ ["Indices: ", show (texIndex)] putStrLn $ unlines $ ["Indices: ", show texIndex]
checkError "initHud" checkError "initHud"
return GLHud return GLHud
@ -299,38 +316,126 @@ renderObject :: MapObject -> IO ()
renderObject (MapObject model pos@(L.V3 x y z) _{-state-}) = renderObject (MapObject model pos@(L.V3 x y z) _{-state-}) =
renderIQM model pos (L.V3 1 1 1) renderIQM model pos (L.V3 1 1 1)
drawMap :: Pioneers ()
drawMap = do
state <- RWS.get
let
d = state ^. gl.glMap.mapShaderData
vi = shdrVertexIndex d
ni = shdrNormalIndex d
ci = shdrColorIndex d
numVert = state ^. gl.glMap.mapVert
map' = state ^. gl.glMap.stateMap
tessFac = state ^. gl.glMap.stateTessellationFactor
(UniformLocation tli) = shdrTessInnerIndex d
(UniformLocation tlo) = shdrTessOuterIndex d
liftIO $ do
glUniform1f tli (fromIntegral tessFac)
glUniform1f tlo (fromIntegral tessFac)
bindBuffer ArrayBuffer $= Just map'
vertexAttribPointer ci $= fgColorIndex
vertexAttribArray ci $= Enabled
vertexAttribPointer ni $= fgNormalIndex
vertexAttribArray ni $= Enabled
vertexAttribPointer vi $= fgVertexIndex
vertexAttribArray vi $= Enabled
checkError "beforeDraw"
glPatchParameteri gl_PATCH_VERTICES 3
cullFace $= Just Front
glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
checkError "draw map"
---- RENDER MAPOBJECTS --------------------------------------------
currentProgram $= Just (state ^. gl.glMap.objectProgram)
mapM_ renderObject (state ^. gl.glMap.mapObjects)
-- set sample 1 as target in renderbuffer
{-framebufferRenderbuffer
DrawFramebuffer --write-only
(ColorAttachment 1) --sample 1
Renderbuffer --const
rb --buffer-}
render :: Pioneers () render :: Pioneers ()
render = do render = do
state <- RWS.get state <- RWS.get
let xa = state ^. camera.xAngle cam <- liftIO $ readTVarIO (state ^. camera)
ya = state ^. camera.yAngle let xa = cam ^. xAngle
(UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex ya = cam ^. yAngle
(UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex frust = cam ^. Types.frustum
(UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex camPos = cam ^. camObject
(UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex zDist' = cam ^. zDist
(UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex d = state ^. gl.glMap.mapShaderData
vi = state ^. gl.glMap.shdrVertexIndex (UniformLocation proj) = shdrProjMatIndex d
ni = state ^. gl.glMap.shdrNormalIndex (UniformLocation nmat) = shdrNormalMatIndex d
ci = state ^. gl.glMap.shdrColorIndex (UniformLocation vmat) = shdrViewMatIndex d
numVert = state ^. gl.glMap.mapVert
map' = state ^. gl.glMap.stateMap
frust = state ^. camera.Types.frustum
camPos = state ^. camera.camObject
zDist' = state ^. camera.zDist
tessFac = state ^. gl.glMap.stateTessellationFactor
liftIO $ do liftIO $ do
---- RENDER MAP IN TEXTURE ------------------------------------------ ---- RENDER MAP IN TEXTURE ------------------------------------------
bindFramebuffer Framebuffer $= (state ^. gl.glFramebuffer) bindFramebuffer Framebuffer $= (state ^. gl.glFramebuffer)
bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer) {-bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer)
framebufferRenderbuffer framebufferRenderbuffer
Framebuffer Framebuffer
DepthAttachment DepthAttachment
Renderbuffer Renderbuffer
(state ^. gl.glRenderbuffer) (state ^. gl.glRenderbuffer)-}
textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
-- SHADOWMAP
textureBinding Texture2D $= Just (state ^. gl.glMap.shadowMapTexture)
framebufferTexture2D
Framebuffer
DepthAttachment
Texture2D
(state ^. gl.glMap.shadowMapTexture)
0
drawBuffer $= NoBuffers --color-buffer is not needed but must(?) be set up
checkError "setup Render-Target"
clear [DepthBuffer]
checkError "clearing shadowmap-buffer"
--TODO: simplified program for shadows?
currentProgram $= Just (state ^. gl.glMap.mapProgram)
checkError "setting up shadowmap-program"
--set up projection (= copy from state)
--TODO: Fix width/depth
with (distribute (createFrustumOrtho 20 20 0 100)) $ \ptr ->
glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
checkError "copy shadowmap-projection"
--set up camera
--TODO: Fix magic constants... and camPos
let ! cam = getCam camPos 1 0.7 0
with (distribute cam) $ \ptr ->
glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
checkError "copy shadowmap-cam"
--set up normal--Mat transpose((model*camera)^-1)
--needed?
let normal' = (case L.inv33 (fmap (^. L._xyz) cam ^. L._xyz) of
(Just a) -> a
Nothing -> L.eye3) :: L.M33 CFloat
nmap = collect id normal' :: L.M33 CFloat --transpose...
with (distribute nmap) $ \ptr ->
glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (L.M33 CFloat)))
checkError "nmat"
drawMap
liftIO $ do
checkError "draw ShadowMap"
-- COLORMAP
textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
framebufferTexture2D framebufferTexture2D
Framebuffer Framebuffer
(ColorAttachment 0) (ColorAttachment 0)
@ -371,38 +476,8 @@ render = do
checkError "nmat" checkError "nmat"
glUniform1f tli (fromIntegral tessFac) drawMap --draw map -> put to another function for readability
glUniform1f tlo (fromIntegral tessFac) liftIO $ do
bindBuffer ArrayBuffer $= Just map'
vertexAttribPointer ci $= fgColorIndex
vertexAttribArray ci $= Enabled
vertexAttribPointer ni $= fgNormalIndex
vertexAttribArray ni $= Enabled
vertexAttribPointer vi $= fgVertexIndex
vertexAttribArray vi $= Enabled
checkError "beforeDraw"
glPatchParameteri gl_PATCH_VERTICES 3
cullFace $= Just Front
glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
checkError "draw map"
---- RENDER MAPOBJECTS --------------------------------------------
currentProgram $= Just (state ^. gl.glMap.objectProgram)
mapM_ renderObject (state ^. gl.glMap.mapObjects)
-- set sample 1 as target in renderbuffer
{-framebufferRenderbuffer
DrawFramebuffer --write-only
(ColorAttachment 1) --sample 1
Renderbuffer --const
rb --buffer-}
---- COMPOSE RENDERING -------------------------------------------- ---- COMPOSE RENDERING --------------------------------------------
-- Render to BackBuffer (=Screen) -- Render to BackBuffer (=Screen)

32
src/Render/Types.hs
View File

@ -4,6 +4,10 @@ module Render.Types (createFlatCam, createSphereCam, Camera, GLCamera(..)) where
import Linear import Linear
import Foreign.C (CFloat) import Foreign.C (CFloat)
import Render.Misc (lookAt) import Render.Misc (lookAt)
import Map.Map (giveMapHeight)
import Map.Types (PlayMap)
import GHC.Float
import qualified Debug.Trace as D
type Distance = Double type Distance = Double
type Pitch = Double type Pitch = Double
@ -11,30 +15,32 @@ type Yaw = Double
class GLCamera a where class GLCamera a where
getCam :: a -> Distance -> Pitch -> Yaw -> M44 CFloat getCam :: a -> Distance -> Pitch -> Yaw -> M44 CFloat
moveBy :: a -> (Position -> Position) -> a moveBy :: a -> (Position -> Position) -> PlayMap -> a
move :: a -> Position -> a move :: a -> Position -> PlayMap -> a
type Position = (Double, Double) type Position = (Double, Double)
type Radius = Double type Radius = Double
data Camera = Flat Position type Height = Double
data Camera = Flat Position Height
| Sphere Position Radius | Sphere Position Radius
-- | create a Flatcam-Camera starting at given x/z-Coordinates -- | create a Flatcam-Camera starting at given x/z-Coordinates
createFlatCam :: Double -> Double -> Camera createFlatCam :: Double -> Double -> PlayMap -> Camera
createFlatCam x z = Flat (x,z) createFlatCam x z map' = Flat (x,z) (giveMapHeight map' (x, z))
-- | create a Flatcam-Camera starting at given pitch/azimuth/radius -- | create a Flatcam-Camera starting at given pitch/azimuth/radius
createSphereCam :: Double -> Double -> Double -> Camera createSphereCam :: Double -> Double -> Double -> Camera
createSphereCam p a r = Sphere (p,a) r createSphereCam p a = Sphere (p,a)
instance GLCamera Camera where instance GLCamera Camera where
getCam (Flat (x',z')) dist' xa' ya' = getCam (Flat (x',z') y') dist' xa' ya' =
lookAt (cpos ^+^ at') at' up lookAt (cpos ^+^ at') at' up
where where
at' = V3 x 0 z at' = V3 x (y+2) z
cpos = crot !* (V3 0 0 (-dist)) cpos = crot !* (V3 0 0 (-dist))
crot = ( crot = (
(fromQuaternion $ axisAngle upmap (xa::CFloat)) (fromQuaternion $ axisAngle upmap (xa::CFloat))
@ -44,6 +50,7 @@ instance GLCamera Camera where
upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat) upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat)
!* (V3 1 0 0) !* (V3 1 0 0)
x = realToFrac x' x = realToFrac x'
y = realToFrac y'
z = realToFrac z' z = realToFrac z'
dist = realToFrac dist' dist = realToFrac dist'
xa = realToFrac xa' xa = realToFrac xa'
@ -68,9 +75,12 @@ instance GLCamera Camera where
dist = realToFrac dist' dist = realToFrac dist'
xa = realToFrac xa' xa = realToFrac xa'
ya = realToFrac ya' ya = realToFrac ya'
moveBy (Sphere (inc, az) r) f = undefined moveBy (Sphere (inc, az) r) f map = undefined
moveBy (Flat (x', z')) f = Flat (f (x',z')) moveBy (Flat (x', z') y) f map = Flat (x,z) y
move c (x', z') = moveBy c (\(x,z) -> (x+x',z+z')) where
(x,z) = f (x', z')
y = giveMapHeight map (x,z)
move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map
sphereToCart :: (Floating a) => a -> a -> a -> V3 a sphereToCart :: (Floating a) => a -> a -> a -> V3 a
sphereToCart r inc az = V3 sphereToCart r inc az = V3

103
src/Types.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Types where module Types where
import Control.Concurrent.STM (TQueue) import Control.Concurrent.STM (TQueue, TVar, readTVar, writeTVar, atomically)
import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.GL as GL
import Graphics.UI.SDL as SDL (Event, Window) import Graphics.UI.SDL as SDL (Event, Window)
import Foreign.C (CFloat) import Foreign.C (CFloat)
@ -9,12 +9,14 @@ import qualified Data.HashMap.Strict as Map
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Linear.Matrix (M44) import Linear.Matrix (M44)
import Linear (V3) import Linear (V3)
import Control.Monad.RWS.Strict (RWST) import Control.Monad.RWS.Strict (RWST, liftIO, get)
import Control.Monad (when)
import Control.Lens import Control.Lens
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
import Render.Types import Render.Types
import Importer.IQM.Types import Importer.IQM.Types
import UI.UIBase import UI.UIBase
import Map.Types (PlayMap)
data Coord3D a = Coord3D a a a data Coord3D a = Coord3D a a a
@ -56,7 +58,7 @@ data IOState = IOState
} }
data GameState = GameState data GameState = GameState
{ { _currentMap :: !PlayMap
} }
data MouseState = MouseState data MouseState = MouseState
@ -100,24 +102,30 @@ data KeyboardState = KeyboardState
data GLMapState = GLMapState data GLMapState = GLMapState
{ _shdrVertexIndex :: !GL.AttribLocation { _mapShaderData :: !MapShaderData
, _shdrColorIndex :: !GL.AttribLocation
, _shdrNormalIndex :: !GL.AttribLocation
, _shdrProjMatIndex :: !GL.UniformLocation
, _shdrViewMatIndex :: !GL.UniformLocation
, _shdrModelMatIndex :: !GL.UniformLocation
, _shdrNormalMatIndex :: !GL.UniformLocation
, _shdrTessInnerIndex :: !GL.UniformLocation
, _shdrTessOuterIndex :: !GL.UniformLocation
, _stateTessellationFactor :: !Int , _stateTessellationFactor :: !Int
, _stateMap :: !GL.BufferObject , _stateMap :: !GL.BufferObject
, _mapVert :: !GL.NumArrayIndices , _mapVert :: !GL.NumArrayIndices
, _mapProgram :: !GL.Program , _mapProgram :: !GL.Program
, _renderedMapTexture :: !TextureObject --TODO: Probably move to UI? , _renderedMapTexture :: !TextureObject --TODO: Probably move to UI?
, _overviewTexture :: !TextureObject , _overviewTexture :: !TextureObject
, _shadowMapTexture :: !TextureObject
, _mapTextures :: ![TextureObject] --TODO: Fix size on list? , _mapTextures :: ![TextureObject] --TODO: Fix size on list?
, _objectProgram :: !GL.Program , _objectProgram :: !GL.Program
, _mapObjects :: ![MapObject] , _mapObjects :: ![MapObject]
, _shadowMapProgram :: !GL.Program
}
data MapShaderData = MapShaderData
{ shdrVertexIndex :: !GL.AttribLocation
, shdrColorIndex :: !GL.AttribLocation
, shdrNormalIndex :: !GL.AttribLocation
, shdrProjMatIndex :: !GL.UniformLocation
, shdrViewMatIndex :: !GL.UniformLocation
, shdrModelMatIndex :: !GL.UniformLocation
, shdrNormalMatIndex :: !GL.UniformLocation
, shdrTessInnerIndex :: !GL.UniformLocation
, shdrTessOuterIndex :: !GL.UniformLocation
} }
data MapObject = MapObject !IQM !MapCoordinates !MapObjectState data MapObject = MapObject !IQM !MapCoordinates !MapObjectState
@ -153,12 +161,12 @@ data UIState = UIState
data State = State data State = State
{ _window :: !WindowState { _window :: !WindowState
, _camera :: !CameraState , _camera :: TVar CameraState
, _io :: !IOState , _io :: !IOState
, _mouse :: !MouseState , _mouse :: !MouseState
, _keyboard :: !KeyboardState , _keyboard :: !KeyboardState
, _gl :: !GLState , _gl :: !GLState
, _game :: !GameState , _game :: TVar GameState
, _ui :: !UIState , _ui :: !UIState
} }
@ -180,63 +188,18 @@ $(makeLenses ''Position)
$(makeLenses ''Env) $(makeLenses ''Env)
$(makeLenses ''UIState) $(makeLenses ''UIState)
data Structure = Flag -- Flag -- helper-functions for types
| Woodcutter -- Huts
| Forester
| Stonemason
| Fisher
| Hunter
| Barracks
| Guardhouse
| LookoutTower
| Well
| Sawmill -- Houses
| Slaughterhouse
| Mill
| Bakery
| IronSmelter
| Metalworks
| Armory
| Mint
| Shipyard
| Brewery
| Storehouse
| Watchtower
| Catapult
| GoldMine -- Mines
| IronMine
| GraniteMine
| CoalMine
| Farm -- Castles
| PigFarm
| DonkeyBreeder
| Harbor
| Fortress
deriving (Show, Eq)
data Amount = Infinite -- Neverending supply -- | atomically change gamestate on condition
| Finite Int -- Finite supply changeIfGamestate :: (GameState -> Bool) -> (GameState -> GameState) -> Pioneers ()
changeIfGamestate cond f = do
state <- get
liftIO $ atomically $ do
game' <- readTVar (state ^. game)
when (cond game') (writeTVar (state ^. game) (f game'))
-- Extremely preliminary, expand when needed
data Commodity = WoodPlank
| Sword
| Fish
deriving Eq
data Resource = Coal -- | atomically change gamestate
| Iron changeGamestate :: (GameState -> GameState) -> Pioneers ()
| Gold changeGamestate = changeIfGamestate (const True)
| Granite
| Water
| Fishes
deriving (Show, Eq)
instance Show Amount where
show (Infinite) = "inexhaustable supply"
show (Finite n) = show n ++ " left"
instance Show Commodity where
show WoodPlank = "wooden plank"
show Sword = "sword"
show Fish = "fish"

12
src/UI/Callbacks.hs
View File

@ -13,6 +13,8 @@ import Data.Maybe
import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Alloc (allocaBytes)
import qualified Graphics.UI.SDL as SDL import qualified Graphics.UI.SDL as SDL
import Control.Concurrent.STM.TVar (readTVar, readTVarIO, writeTVar)
import Control.Concurrent.STM (atomically)
import Render.Misc (curb,genColorData) import Render.Misc (curb,genColorData)
@ -102,6 +104,7 @@ eventCallback e = do
return () return ()
SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
mouseMoveHandler (x, y) mouseMoveHandler (x, y)
SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
case state of case state of
SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button
@ -110,8 +113,13 @@ eventCallback e = do
SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
do -- TODO: MouseWheelHandler do -- TODO: MouseWheelHandler
state <- get state <- get
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in liftIO $ atomically $ do
modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' cam <- readTVar (state ^. camera)
let zDist' = (cam ^. zDist) + realToFrac (negate vscroll)
zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
cam' <- return $ zDist .~ zDist'' $ cam
writeTVar (state ^. camera) cam'
-- there is more (joystic, touchInterface, ...), but currently ignored -- there is more (joystic, touchInterface, ...), but currently ignored
SDL.Quit -> modify $ window.shouldClose .~ True SDL.Quit -> modify $ window.shouldClose .~ True
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] _ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]

8
src/UI/UIWidgets.hs
View File

@ -2,9 +2,10 @@
module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
import Control.Concurrent.STM.TVar (readTVarIO)
import Control.Lens ((^.), (.~), (%~), (&)) import Control.Lens ((^.), (.~), (%~), (&))
import Control.Monad import Control.Monad
-- import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.RWS.Strict (get, modify) import Control.Monad.RWS.Strict (get, modify)
import Data.List import Data.List
import Data.Maybe import Data.Maybe
@ -57,11 +58,12 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
let press btn' (x, y) _ w = let press btn' (x, y) _ w =
do when (btn == btn') $ do do when (btn == btn') $ do
state <- get state <- get
cam <- liftIO $ readTVarIO (state ^. camera)
modify $ mouse %~ (isDragging .~ True) modify $ mouse %~ (isDragging .~ True)
. (dragStartX .~ fromIntegral x) . (dragStartX .~ fromIntegral x)
. (dragStartY .~ fromIntegral y) . (dragStartY .~ fromIntegral y)
. (dragStartXAngle .~ (state ^. camera.xAngle)) . (dragStartXAngle .~ (cam ^. xAngle))
. (dragStartYAngle .~ (state ^. camera.yAngle)) . (dragStartYAngle .~ (cam ^. yAngle))
. (mousePosition.Types._x .~ fromIntegral x) . (mousePosition.Types._x .~ fromIntegral x)
. (mousePosition.Types._y .~ fromIntegral y) . (mousePosition.Types._y .~ fromIntegral y)
return w return w