Merge branch 'master' into iqm
Conflicts: src/Render/Types.hs
This commit is contained in:
commit
481a386e0e
57
src/Main.hs
57
src/Main.hs
@ -12,8 +12,8 @@ import Control.Arrow ((***))
|
||||
|
||||
-- data consistency/conversion
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.STM (TQueue,
|
||||
newTQueueIO)
|
||||
import Control.Concurrent.STM (TQueue, newTQueueIO, atomically)
|
||||
import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVar)
|
||||
|
||||
import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify)
|
||||
import Data.Functor ((<$>))
|
||||
@ -94,16 +94,26 @@ main =
|
||||
--font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
|
||||
--TTF.setFontStyle font TTFNormal
|
||||
--TTF.setFontHinting font TTFHNormal
|
||||
|
||||
glHud' <- initHud
|
||||
let zDistClosest' = 2
|
||||
zDistFarthest' = zDistClosest' + 10
|
||||
--TODO: Move near/far/fov to state for runtime-changability & central storage
|
||||
let
|
||||
fov = 90 --field of view
|
||||
near = 1 --near plane
|
||||
far = 500 --far plane
|
||||
ratio = fromIntegral fbWidth / fromIntegral fbHeight
|
||||
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
|
||||
aks = ArrowKeyState {
|
||||
_up = False
|
||||
@ -123,17 +133,11 @@ main =
|
||||
, _height = fbHeight
|
||||
, _shouldClose = False
|
||||
}
|
||||
, _camera = CameraState
|
||||
{ _xAngle = pi/6
|
||||
, _yAngle = pi/2
|
||||
, _zDist = 10
|
||||
, _frustum = frust
|
||||
, _camObject = createFlatCam 25 25 curMap
|
||||
}
|
||||
, _io = IOState
|
||||
{ _clock = now
|
||||
, _tessClockFactor = 0
|
||||
}
|
||||
, _camera = cam'
|
||||
, _mouse = MouseState
|
||||
{ _isDown = False
|
||||
, _isDragging = False
|
||||
@ -155,9 +159,7 @@ main =
|
||||
, _glRenderbuffer = renderBuffer
|
||||
, _glFramebuffer = frameBuffer
|
||||
}
|
||||
, _game = GameState
|
||||
{ _currentMap = curMap
|
||||
}
|
||||
, _game = game'
|
||||
, _ui = UIState
|
||||
{ _uiHasChanged = True
|
||||
, _uiMap = guiMap
|
||||
@ -207,20 +209,26 @@ run = do
|
||||
| otherwise = newYAngle'
|
||||
newYAngle' = sodya + myrot/100
|
||||
|
||||
modify $ ((camera.xAngle) .~ newXAngle)
|
||||
. ((camera.yAngle) .~ newYAngle)
|
||||
liftIO $ atomically $ do
|
||||
cam <- readTVar (state ^. camera)
|
||||
cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam
|
||||
writeTVar (state ^. camera) cam'
|
||||
|
||||
-- get cursor-keys - if pressed
|
||||
--TODO: Add sin/cos from stateYAngle
|
||||
(kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
|
||||
liftIO $ atomically $ do
|
||||
cam <- readTVar (state ^. camera)
|
||||
game' <- readTVar (state ^. game)
|
||||
let
|
||||
multc = cos $ state ^. camera.yAngle
|
||||
mults = sin $ state ^. camera.yAngle
|
||||
multc = cos $ cam ^. yAngle
|
||||
mults = sin $ cam ^. yAngle
|
||||
modx x' = x' - 0.2 * kxrot * multc
|
||||
- 0.2 * kyrot * mults
|
||||
mody y' = y' + 0.2 * kxrot * mults
|
||||
- 0.2 * kyrot * multc
|
||||
modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (state ^. game.currentMap))
|
||||
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.
|
||||
@ -290,7 +298,10 @@ adjustWindow = do
|
||||
ratio = fromIntegral fbWidth / fromIntegral fbHeight
|
||||
frust = createFrustum fov near far ratio
|
||||
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
|
||||
-- bind ints to CInt for lateron.
|
||||
let fbCWidth = (fromInteger.toInteger) fbWidth
|
||||
|
||||
@ -2,21 +2,10 @@ module Map.Creation
|
||||
where
|
||||
|
||||
import Map.Types
|
||||
-- import Map.Map unused (for now)
|
||||
|
||||
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
|
||||
|
||||
-- entirely empty map, only uses the minimal constructor
|
||||
mapEmpty :: 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]]
|
||||
@ -57,17 +46,6 @@ gauss3Dgeneral :: Floating q =>
|
||||
-> q -- ^ elevation on coordinate in question
|
||||
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
|
||||
-- (like Deserts on Grass-Islands or Grass on Deserts)
|
||||
--
|
||||
@ -76,7 +54,7 @@ heightToTerrain :: MapType -> YCoord -> TileType
|
||||
heightToTerrain GrassIslandMap y
|
||||
| y < 0.1 = Ocean
|
||||
| y < 0.2 = Beach
|
||||
| y < 1 = Grass
|
||||
| y < 1.5 = Grass
|
||||
| y < 3 = Hill
|
||||
| otherwise = Mountain
|
||||
heightToTerrain _ _ = undefined
|
||||
@ -98,8 +76,8 @@ gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp
|
||||
where
|
||||
gs = map mkStdGen (map (*seed) [1..])
|
||||
c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) (gs !! 0)), (head (randomRs (b,y) (gs !! 1))))
|
||||
amp = head $ randomRs ((2.0, 5.0) :: (Float, Float)) (gs !! 2)
|
||||
sig = head $ randomRs ((1.0, 15.0) :: (Float, Float)) (gs !! 3)
|
||||
amp = head $ randomRs ((2.0, 5.0) :: (Double, Double)) (gs !! 2)
|
||||
sig = head $ randomRs ((2.0, 8.0) :: (Double, Double)) (gs !! 3)
|
||||
htt = heightToTerrain
|
||||
|
||||
-- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map
|
||||
|
||||
@ -30,9 +30,8 @@ import Linear
|
||||
import Control.Arrow ((***))
|
||||
|
||||
import Map.Types
|
||||
import Map.Creation
|
||||
|
||||
type Height = Float
|
||||
type Height = Double
|
||||
|
||||
type MapEntry = (
|
||||
Height,
|
||||
|
||||
@ -1,11 +1,9 @@
|
||||
module Map.Map where
|
||||
|
||||
import Map.Types
|
||||
import Map.Creation
|
||||
|
||||
import Data.Function (on)
|
||||
import Data.Array (bounds, (!))
|
||||
import Data.List (sort, sortBy, group)
|
||||
import Data.List (sort, group)
|
||||
|
||||
-- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet.
|
||||
unsafeGiveNeighbours :: (Int, Int) -- ^ original coordinates
|
||||
@ -40,54 +38,54 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in
|
||||
|
||||
-- | Calculates the height of any given point on the map.
|
||||
-- Does not add camera distance to ground to that.
|
||||
--
|
||||
-- This ueses barycentric coordinate stuff. Wanna read more?
|
||||
-- http://en.wikipedia.org/wiki/Barycentric_coordinate_system_%28mathematics%29
|
||||
-- http://www.alecjacobson.com/weblog/?p=1596
|
||||
--
|
||||
giveMapHeight :: PlayMap
|
||||
-> (Float, Float) -- ^ Coordinates on X/Z-axes
|
||||
-> Float -- ^ Terrain Height at that position
|
||||
giveMapHeight mp (x,z) = let [a,b,c] = getTrianglePoints [tff,tfc,tcf,tcc]
|
||||
ar = area (fi a) (fi b) (fi c)
|
||||
λa = area (fi b) (fi c) (x, z) / ar
|
||||
λb = area (fi a) (fi c) (x, z) / ar
|
||||
λc = area (fi a) (fi b) (x, z) / ar
|
||||
in (λa * hlu a) + (λb * hlu b) + (λc * hlu c)
|
||||
-> (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)
|
||||
|
||||
fi :: (Int, Int) -> (Float, Float)
|
||||
fi (m, n) = (fromIntegral m, fromIntegral n)
|
||||
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
|
||||
hlu :: (Int, Int) -> Float
|
||||
hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mp ! (k,j) in y
|
||||
-- Height LookUp on PlayMap
|
||||
hlu :: (Int, Int) -> Double
|
||||
hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y
|
||||
|
||||
ff = (floor x, floor z) :: (Int, Int)
|
||||
fc = (floor x, ceiling z) :: (Int, Int)
|
||||
cf = (ceiling x, floor z) :: (Int, Int)
|
||||
cc = (ceiling x, ceiling z) :: (Int, Int)
|
||||
-- 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)
|
||||
|
||||
tff = (ff, dist (x,z) ff)
|
||||
tfc = (fc, dist (x,z) fc)
|
||||
tcf = (cf, dist (x,z) cf)
|
||||
tcc = (cc, dist (x,z) cc)
|
||||
-- tupels with reference point and distance
|
||||
tups = map (\t -> (t, dist (x,z') t)) refs
|
||||
|
||||
getTrianglePoints :: [((Int,Int), Float)] -> [(Int,Int)]
|
||||
getTrianglePoints = ((take 3) . (map fst) . (sortBy (compare `on` snd)))
|
||||
-- total distance of all for reference point from the point in question
|
||||
totald = sum $ map (\(_,d) -> d) tups
|
||||
|
||||
dist :: (Float, Float) -> (Int, Int) -> Float
|
||||
dist (x1,z1) (x2,z2) = let x' = x1 - fromIntegral x2
|
||||
z' = z1 - fromIntegral z2
|
||||
in sqrt $ x'*x' + z'*z'
|
||||
-- clamp, as she is programmed
|
||||
clamp :: (Ord a) => a -> a -> a -> a
|
||||
clamp mn mx = max mn . min mx
|
||||
|
||||
-- Heron's Formula: http://en.wikipedia.org/wiki/Heron%27s_formula
|
||||
area :: (Float, Float) -> (Float, Float) -> (Float, Float) -> Float
|
||||
area (x1,z1) (x2,z2) (x3,z3) = let a = sqrt $ (x1-x2)*(x1-x2) + (z1-z2)*(z1-z2)
|
||||
b = sqrt $ (x2-x3)*(x2-x3) + (z2-z3)*(z2-z3)
|
||||
c = sqrt $ (x1-x3)*(x1-x3) + (z1-z3)*(z1-z3)
|
||||
s = (a+b+c)/2
|
||||
in sqrt $ s * (s-a) * (s-b) * (s-c)
|
||||
-- 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
|
||||
remdups :: Ord a => [a] -> [a]
|
||||
|
||||
@ -7,9 +7,9 @@ type PlayMap = Array (Xindex, Zindex) Node
|
||||
|
||||
type Xindex = Int
|
||||
type Zindex = Int
|
||||
type XCoord = Float
|
||||
type ZCoord = Float
|
||||
type YCoord = Float
|
||||
type XCoord = Double
|
||||
type ZCoord = Double
|
||||
type YCoord = Double
|
||||
|
||||
data MapType = GrassIslandMap
|
||||
| DesertMap
|
||||
|
||||
@ -12,6 +12,8 @@ import qualified Linear as L
|
||||
import Control.Lens ((^.))
|
||||
import Control.Monad.RWS.Strict (liftIO)
|
||||
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)
|
||||
-- FFI
|
||||
import Foreign (Ptr, castPtr, with)
|
||||
@ -384,11 +386,12 @@ drawMap = do
|
||||
render :: Pioneers ()
|
||||
render = do
|
||||
state <- RWS.get
|
||||
let xa = state ^. camera.xAngle
|
||||
ya = state ^. camera.yAngle
|
||||
frust = state ^. camera.Types.frustum
|
||||
camPos = state ^. camera.camObject
|
||||
zDist' = state ^. camera.zDist
|
||||
cam <- liftIO $ readTVarIO (state ^. camera)
|
||||
let xa = cam ^. xAngle
|
||||
ya = cam ^. yAngle
|
||||
frust = cam ^. Types.frustum
|
||||
camPos = cam ^. camObject
|
||||
zDist' = cam ^. zDist
|
||||
d = state ^. gl.glMap.mapShaderData
|
||||
(UniformLocation proj) = shdrProjMatIndex d
|
||||
(UniformLocation nmat) = shdrNormalMatIndex d
|
||||
|
||||
@ -29,7 +29,7 @@ data Camera = Flat Position Height
|
||||
|
||||
-- | create a Flatcam-Camera starting at given x/z-Coordinates
|
||||
createFlatCam :: Double -> Double -> PlayMap -> Camera
|
||||
createFlatCam x z map' = Flat (x,z) (float2Double $ giveMapHeight map' (double2Float x,double2Float z))
|
||||
createFlatCam x z map' = Flat (x,z) (giveMapHeight map' (x, z))
|
||||
|
||||
-- | create a Flatcam-Camera starting at given pitch/azimuth/radius
|
||||
createSphereCam :: Double -> Double -> Double -> Camera
|
||||
@ -40,7 +40,7 @@ instance GLCamera Camera where
|
||||
getCam (Flat (x',z') y') dist' xa' ya' =
|
||||
lookAt (cpos ^+^ at') at' up
|
||||
where
|
||||
at' = V3 x (y+1) z
|
||||
at' = V3 x (y+2) z
|
||||
cpos = crot !* (V3 0 0 (-dist))
|
||||
crot = (
|
||||
(fromQuaternion $ axisAngle upmap (xa::CFloat))
|
||||
@ -76,11 +76,10 @@ instance GLCamera Camera where
|
||||
xa = realToFrac xa'
|
||||
ya = realToFrac ya'
|
||||
moveBy (Sphere (inc, az) r) f map = undefined
|
||||
moveBy (Flat (x', z') y) f map = Flat (x,z) (float2Double y)
|
||||
moveBy (Flat (x', z') y) f map = Flat (x,z) y
|
||||
where
|
||||
(x,z) = f (x', z')
|
||||
y = giveMapHeight map (fc x,fc z)
|
||||
fc = double2Float
|
||||
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
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Types where
|
||||
|
||||
import Control.Concurrent.STM (TQueue)
|
||||
import Control.Concurrent.STM (TQueue, TVar)
|
||||
import qualified Graphics.Rendering.OpenGL.GL as GL
|
||||
import Graphics.UI.SDL as SDL (Event, Window)
|
||||
import Foreign.C (CFloat)
|
||||
@ -161,12 +161,12 @@ data UIState = UIState
|
||||
|
||||
data State = State
|
||||
{ _window :: !WindowState
|
||||
, _camera :: !CameraState
|
||||
, _camera :: TVar CameraState
|
||||
, _io :: !IOState
|
||||
, _mouse :: !MouseState
|
||||
, _keyboard :: !KeyboardState
|
||||
, _gl :: !GLState
|
||||
, _game :: !GameState
|
||||
, _game :: TVar GameState
|
||||
, _ui :: !UIState
|
||||
}
|
||||
|
||||
|
||||
@ -13,6 +13,8 @@ import Data.Maybe
|
||||
import Foreign.Marshal.Array (pokeArray)
|
||||
import Foreign.Marshal.Alloc (allocaBytes)
|
||||
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)
|
||||
@ -105,11 +107,13 @@ eventCallback e = do
|
||||
state <- get
|
||||
if state ^. mouse.isDown && not (state ^. mouse.isDragging)
|
||||
then
|
||||
do
|
||||
cam <- liftIO $ readTVarIO (state ^. camera)
|
||||
modify $ (mouse.isDragging .~ True)
|
||||
. (mouse.dragStartX .~ fromIntegral x)
|
||||
. (mouse.dragStartY .~ fromIntegral y)
|
||||
. (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
|
||||
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
|
||||
. (mouse.dragStartXAngle .~ (cam ^. xAngle))
|
||||
. (mouse.dragStartYAngle .~ (cam ^. yAngle))
|
||||
else mouseMoveHandler (x, y)
|
||||
modify $ (mouse.mousePosition. Types._x .~ fromIntegral x)
|
||||
. (mouse.mousePosition. Types._y .~ fromIntegral y)
|
||||
@ -134,8 +138,13 @@ eventCallback e = do
|
||||
SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
|
||||
do
|
||||
state <- get
|
||||
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
|
||||
modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
|
||||
liftIO $ atomically $ do
|
||||
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
|
||||
SDL.Quit -> modify $ window.shouldClose .~ True
|
||||
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user