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

Merge branch 'master' into ui

Browse Source
This commit is contained in:
tpajenka
2014-05-15 21:47:15 +02:00
parent 51c48e62db dba5c9d809
commit c17852d8e1
19 changed files with 657 additions and 132 deletions
Download Patch File Download Diff File Expand all files Collapse all files

66
src/Main.hs
View File

@ -27,7 +27,7 @@ import Foreign.Marshal.Alloc (allocaBytes)
import Control.Lens ((^.), (.~), (%~))
-- GUI
import Graphics.UI.SDL as SDL
import qualified Graphics.UI.SDL as SDL
-- Render
import qualified Graphics.Rendering.OpenGL.GL as GL
@ -66,15 +66,15 @@ testParser a = putStrLn . show =<< parseIQM a
main :: IO ()
main =
SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ --also: InitNoParachute -> faster, without parachute!
SDL.withWindow "Pioneers" (SDL.Position 100 100) (Size 1024 600) [WindowOpengl -- we want openGL
,WindowShown -- window should be visible
,WindowResizable -- and resizable
,WindowInputFocus -- focused (=> active)
,WindowMouseFocus -- Mouse into it
SDL.withInit [SDL.InitVideo, SDL.InitAudio, SDL.InitEvents, SDL.InitTimer] $ --also: InitNoParachute -> faster, without parachute!
SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size 1024 600) [SDL.WindowOpengl -- we want openGL
,SDL.WindowShown -- window should be visible
,SDL.WindowResizable -- and resizable
,SDL.WindowInputFocus -- focused (=> active)
,SDL.WindowMouseFocus -- Mouse into it
--,WindowInputGrabbed-- never let go of input (KB/Mouse)
] $ \window' -> do
withOpenGL window' $ do
SDL.withOpenGL window' $ do
--Create Renderbuffer & Framebuffer
-- We will render to this buffer to copy the result into textures
@ -83,15 +83,12 @@ main =
GL.bindFramebuffer GL.Framebuffer GL.$= frameBuffer
GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
(Size fbWidth fbHeight) <- glGetDrawableSize window'
(SDL.Size fbWidth fbHeight) <- SDL.glGetDrawableSize window'
initRendering
--generate map vertices
glMap' <- initMapShader 4 =<< getMapBufferObject
print window'
eventQueue <- newTQueueIO :: IO (TQueue Event)
putStrLn "foo"
eventQueue <- newTQueueIO :: IO (TQueue SDL.Event)
now <- getCurrentTime
putStrLn "foo"
--font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
--TTF.setFontStyle font TTFNormal
--TTF.setFontHinting font TTFHNormal
@ -133,6 +130,7 @@ main =
}
, _io = IOState
{ _clock = now
, _tessClockFactor = 0
}
, _mouse = MouseState
{ _isDown = False
@ -182,7 +180,7 @@ run = do
-- draw Scene
draw
liftIO $ glSwapWindow (env ^. windowObject)
liftIO $ SDL.glSwapWindow (env ^. windowObject)
-- getEvents & process
processEvents
@ -230,17 +228,33 @@ run = do
}
-}
mt <- liftIO $ do
let double = fromRational.toRational :: (Real a) => a -> Double
(mt,tc,sleepAmount,frameTime) <- liftIO $ do
let double = fromRational.toRational :: (Real a) => a -> Double
targetFramerate = 60.0
targetFrametime = 1.0/targetFramerate
targetFrametimeμs = targetFrametime * 1000000.0
now <- getCurrentTime
diff <- return $ diffUTCTime now (state ^. io.clock) -- get time-diffs
title <- return $ unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
setWindowTitle (env ^. windowObject) title
sleepAmount <- return $ floor (max 0 (0.04 - diff))*1000000 -- get time until next frame in microseconds
threadDelay sleepAmount
return now
let diff = diffUTCTime now (state ^. io.clock) -- get time-diffs
title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
ddiff = double diff
SDL.setWindowTitle (env ^. windowObject) title
let sleepAmount = floor ((targetFrametime - double diff)*1000000) :: Int -- get time until next frame in microseconds
clockFactor = (state ^. io.tessClockFactor)
tessChange
| (clockFactor < (75*targetFrametime)) && (state ^. gl.glMap.stateTessellationFactor < 5) = ((+)1 :: Int -> Int)
-- > last 100 frames had > 25% leftover (on avg.)
| (clockFactor > (110*targetFrametime)) && (state ^. gl.glMap.stateTessellationFactor > 1) = (flip (-) 1 :: Int -> Int)
-- > last 100 frames had < 90% of target-fps
| otherwise = ((+)0 :: Int -> Int) -- 0ms > x > 10% -> keep settings
when (sleepAmount > 0) $ threadDelay sleepAmount
now' <- getCurrentTime
return (now',tessChange,sleepAmount,ddiff)
-- set state with new clock-time
modify $ io.clock .~ mt
--liftIO $ putStrLn $ unwords ["clockFactor:",show (state ^. io.tessClockFactor),"\ttc:", show (tc (state ^. gl.glMap.stateTessellationFactor)),"\tsleep ",show frameTime,"ms"]
modify $ (io.clock .~ mt)
. (gl.glMap.stateTessellationFactor %~ tc)
. (io.tessClockFactor %~ (((+) frameTime).((*) 0.99)))
-- liftIO $ putStrLn $ concat $ ["TessFactor at: ",show (state ^. gl.glMap.stateTessellationFactor), " - slept for ",show sleepAmount, "μs."]
shouldClose' <- return $ state ^. window.shouldClose
unless shouldClose' run
@ -315,14 +329,14 @@ adjustWindow = do
processEvents :: Pioneers ()
processEvents = do
me <- liftIO pollEvent
me <- liftIO SDL.pollEvent
case me of
Just e -> do
processEvent e
processEvents
Nothing -> return ()
processEvent :: Event -> Pioneers ()
processEvent :: SDL.Event -> Pioneers ()
processEvent e = do
eventCallback e
-- env <- ask
@ -331,7 +345,7 @@ processEvent e = do
case winEvent of
SDL.Closing ->
modify $ window.shouldClose .~ True
SDL.Resized {windowResizedTo=size} -> do
SDL.Resized {SDL.windowResizedTo=size} -> do
modify $ (window . width .~ SDL.sizeWidth size)
. (window . height .~ SDL.sizeHeight size)
adjustWindow

46
src/Map/Combinators.hs
View File

@ -1,46 +0,0 @@
module Map.Combinators where
import Map.Types
import Map.Creation
import Data.Array
import System.Random
-- preliminary
infix 5 ->-
(->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
f ->- g = g . f
-- also preliminary
infix 5 -<-
(-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
f -<- g = f . g
lake :: Int -> PlayMap -> PlayMap
lake = undefined
river :: Int -> PlayMap -> PlayMap
river = undefined
mnt :: IO [PlayMap -> PlayMap]
mnt = do g <- newStdGen
let seeds = take 10 $ randoms g
return $ map gaussMountain seeds
gaussMountain :: Int -> PlayMap -> PlayMap
gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp
where
g = mkStdGen seed
c = head $ randomRs (bounds mp) g
amp = head $ randomRs (5.0, 20.0) g
sig = head $ randomRs (5.0, 25.0) g
fi = fromIntegral
htt = heightToTerrain
-- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map
liftUp :: (Int, Int) -> Node -> Node
liftUp (gx,gz) (Full (x,z) 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
where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z)
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)

61
src/Map/Creation.hs
View File

@ -2,19 +2,25 @@ module Map.Creation
where
import Map.Types
import Map.Map
import Map.StaticMaps
-- import Map.Map unused (for now)
import Data.Array
import System.Random
-- Orphan instance since this isn't where either Random nor Tuples are defined
instance (Random x, Random y) => Random (x, y) where
randomR ((x1, y1), (x2, y2)) gen1 = let (a, gen2) = randomR (x1, x2) gen1
(b, gen3) = randomR (y1, y2) gen2
in ((a, b), gen3)
-- preliminary
infix 5 ->-
(->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
f ->- g = g . f
random gen1 = let (a, gen2) = random gen1
(b, gen3) = random gen2 in ((a,b), gen3)
-- also preliminary
infix 5 -<-
(-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
f -<- g = f . g
exportedMap :: IO PlayMap
exportedMap = do mounts <- mnt
return $ aplAll mounts mapEmpty
-- | Generate a new Map of given Type and Size
--
@ -31,7 +37,10 @@ aplByNode :: (Node -> Node) -> (Node -> Bool) -> PlayMap -> PlayMap
aplByNode f g mp = array (bounds mp) (map (\(ab,c) -> (if g c then (ab, f c) else (ab,c))) (assocs mp))
aplAll :: [a -> a] -> a -> a
aplAll fs m = foldl (\ m f -> f m) m fs
aplAll fs m = foldl (\ n f -> f n) m fs
aplAllM :: Monad m => [m a -> m a] -> m a -> m a
aplAllM fs x = foldl (\ n f -> f n) x fs
-- general 3D-Gaussian
gauss3Dgeneral :: Floating q =>
@ -68,3 +77,37 @@ heightToTerrain GrassIslandMap y
| y < 10 = Hill
| otherwise = Mountain
heightToTerrain _ _ = undefined
lake :: Int -> PlayMap -> PlayMap
lake = undefined
river :: Int -> PlayMap -> PlayMap
river = undefined
mnt :: IO [PlayMap -> PlayMap]
mnt = do g <- newStdGen
let seeds = take 10 $ randoms g
return $ map (gaussMountain) seeds
gaussMountain :: Int -> PlayMap -> PlayMap
gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp
where
g = mkStdGen seed
c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) g), (head (randomRs (b,y) g)))
amp = head $ randomRs (5.0, 20.0) g
sig = head $ randomRs (5.0, 25.0) g
fi = fromIntegral
htt = heightToTerrain
-- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map
liftUp :: (Int, Int) -> Node -> Node
liftUp (gx,gz) (Full (x,z) 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
where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z)
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
makeIsland :: PlayMap -> PlayMap
makeIsland = undefined -- tomorrow....

6
src/Map/Graphics.hs
View File

@ -30,9 +30,7 @@ import Linear
import Control.Arrow ((***))
import Map.Types
import Map.StaticMaps
import Map.Creation
import Map.Combinators
type Height = Float
@ -91,8 +89,8 @@ fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal
getMapBufferObject :: IO (BufferObject, NumArrayIndices)
getMapBufferObject = do
mountains <- mnt
myMap' <- return $ convertToGraphicsMap $ convertToStripeMap $ aplAll mountains mapEmpty
eMap <- exportedMap
myMap' <- return $ convertToGraphicsMap $ convertToStripeMap eMap
! myMap <- return $ generateTriangles myMap'
len <- return $ fromIntegral $ P.length myMap `div` numComponents
putStrLn $ P.unwords ["num verts in map:",show len]

3
src/Map/Map.hs
View File

@ -39,6 +39,3 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in
-- removing duplicates in O(n log n), losing order and adding Ord requirement
remdups :: Ord a => [a] -> [a]
remdups = map head . group . sort
prop_rd_idempot :: Ord a => [a] -> Bool
prop_rd_idempot xs = remdups xs == (remdups . remdups) xs

63
src/Map/StaticMaps.hs
View File

@ -3,48 +3,47 @@ where
import Map.Types
import Data.Array
import Map.Creation
-- 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]
--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)
-- g2d :: Int -> Int -> Float
-- g2d x y = gauss3D (fromIntegral x) (fromIntegral y)
m2d :: (Int,Int) -> Int
m2d (x,y) = mnh2D (x,y) (100,100)
-- 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
--_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)
--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)

41
src/Render/Render.hs
View File

@ -22,6 +22,8 @@ import Types
import Render.Misc
import Render.Types
import Graphics.GLUtil.BufferObjects (makeBuffer)
import Importer.IQM.Parser
import Importer.IQM.Types
mapVertexShaderFile :: String
mapVertexShaderFile = "shaders/map/vertex.shader"
@ -32,6 +34,11 @@ mapTessEvalShaderFile = "shaders/map/tessEval.shader"
mapFragmentShaderFile :: String
mapFragmentShaderFile = "shaders/map/fragment.shader"
objectVertexShaderFile :: String
objectVertexShaderFile = "shaders/mapobjects/vertex.shader"
objectFragmentShaderFile :: String
objectFragmentShaderFile = "shaders/mapobjects/fragment.shader"
uiVertexShaderFile :: String
uiVertexShaderFile = "shaders/ui/vertex.shader"
uiFragmentShaderFile :: String
@ -113,6 +120,21 @@ initMapShader tessFac (buf, vertDes) = do
texts <- genObjectNames 6
testobj <- parseIQM "sample.iqm"
let
objs = [MapObject testobj (L.V3 0 10 0) (MapObjectState ())]
! vertexSource' <- B.readFile objectVertexShaderFile
! fragmentSource' <- B.readFile objectFragmentShaderFile
vertexShader' <- compileShaderSource VertexShader vertexSource'
checkError "compile Object-Vertex"
fragmentShader' <- compileShaderSource FragmentShader fragmentSource'
checkError "compile Object-Fragment"
objProgram <- createProgramUsing [vertexShader', fragmentShader']
checkError "compile Object-Program"
currentProgram $= Just objProgram
checkError "initShader"
return GLMapState
@ -132,6 +154,8 @@ initMapShader tessFac (buf, vertDes) = do
, _mapVert = vertDes
, _overviewTexture = overTex
, _mapTextures = texts
, _mapObjects = objs
, _objectProgram = objProgram
}
initHud :: IO GLHud
@ -266,6 +290,16 @@ renderOverview = do
-}
-- | renders an IQM-Model at Position with scaling
renderIQM :: IQM -> L.V3 CFloat -> L.V3 CFloat -> IO ()
renderIQM m p@(L.V3 x y z) s@(L.V3 sx sy sz) = do
return ()
renderObject :: MapObject -> IO ()
renderObject (MapObject model pos@(L.V3 x y z) _{-state-}) =
renderIQM model pos (L.V3 1 1 1)
render :: Pioneers ()
render = do
state <- RWS.get
@ -354,8 +388,15 @@ render = do
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

12
src/Types.hs
View File

@ -8,12 +8,15 @@ import Foreign.C (CFloat)
import qualified Data.HashMap.Strict as Map
import Data.Time (UTCTime)
import Linear.Matrix (M44)
import Linear (V3)
import Control.Monad.RWS.Strict (RWST)
import Control.Lens
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
import Render.Types
import Importer.IQM.Types
import UI.UIBase
data Coord3D a = Coord3D a a a
--Static Read-Only-State
data Env = Env
@ -49,6 +52,7 @@ data CameraState = CameraState
data IOState = IOState
{ _clock :: !UTCTime
, _tessClockFactor :: !Double
}
data GameState = GameState
@ -113,8 +117,16 @@ data GLMapState = GLMapState
, _renderedMapTexture :: !TextureObject --TODO: Probably move to UI?
, _overviewTexture :: !TextureObject
, _mapTextures :: ![TextureObject] --TODO: Fix size on list?
, _objectProgram :: !GL.Program
, _mapObjects :: ![MapObject]
}
data MapObject = MapObject !IQM !MapCoordinates !MapObjectState
data MapObjectState = MapObjectState ()
type MapCoordinates = V3 CFloat
data GLHud = GLHud
{ _hudTexture :: !TextureObject -- ^ HUD-Texture itself
, _hudTexIndex :: !GL.UniformLocation -- ^ Position of Overlay-Texture in Shader