diff --git a/Pioneers.cabal b/Pioneers.cabal index fadfec1..bf7c426 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -16,7 +16,6 @@ executable Pioneers Map.Types, Map.Graphics, Map.Creation, - Map.StaticMaps, Importer.IQM.Types, Importer.IQM.Parser, Render.Misc, diff --git a/shaders/map/fragmentShadow.shader b/shaders/map/fragmentShadow.shader new file mode 100644 index 0000000..3ec66e9 --- /dev/null +++ b/shaders/map/fragmentShadow.shader @@ -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) +{ +} diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs index 1d5b9fe..e68ad95 100644 --- a/src/Importer/IQM/Parser.hs +++ b/src/Importer/IQM/Parser.hs @@ -13,6 +13,8 @@ import Data.ByteString.Char8 (pack) import Data.ByteString (split, null, ByteString) import Data.ByteString.Unsafe (unsafeUseAsCString) import qualified Data.ByteString as B +import Graphics.GLUtil +import Graphics.Rendering.OpenGL.GL.BufferObjects import Data.Word import Data.Int import Unsafe.Coerce @@ -211,10 +213,29 @@ parseIQM a = -- Fill Vertex-Arrays with data of Offsets let va = vertexArrays raw va' <- mapM (readInVAO f) va - return $ raw { - vertexArrays = va' + vbo <- sequence $ map toVBOfromVAO 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 -- from the given input-String -- @@ -254,6 +275,7 @@ doIQMparse = , texts = filter (not.null) (split (unsafeCoerce '\0') text) , meshes = meshes' , vertexArrays = vaf + , vertexArrayObjects = [] --initialized later, after vaf get allocated. } -- | Helper-Function for Extracting a random substring out of a Bytestring diff --git a/src/Importer/IQM/Types.hs b/src/Importer/IQM/Types.hs index 847320f..0692398 100644 --- a/src/Importer/IQM/Types.hs +++ b/src/Importer/IQM/Types.hs @@ -13,6 +13,7 @@ import Graphics.Rendering.OpenGL.Raw.Types import Prelude as P import Foreign.Storable import Foreign.C.Types +import Graphics.Rendering.OpenGL.GL.BufferObjects hiding (Offset) -- | Mesh-Indices to distinguish the meshes referenced newtype Mesh = Mesh Word32 deriving (Show, Eq) @@ -108,6 +109,7 @@ data IQM = IQM , texts :: [ByteString] , meshes :: [IQMMesh] , vertexArrays :: [IQMVertexArray] + , vertexArrayObjects :: [BufferObject] } deriving (Show, Eq) -- | Different Vertex-Array-Types in IQM diff --git a/src/Main.hs b/src/Main.hs index 49b6463..97ecde0 100644 --- a/src/Main.hs +++ b/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 ((<$>)) @@ -43,6 +43,7 @@ import Render.Render (initRendering, import Render.Types import UI.Callbacks import Map.Graphics +import Map.Creation (exportedMap) import Types import qualified UI.UIBase as UI import Importer.IQM.Parser @@ -54,7 +55,7 @@ import Importer.IQM.Parser -------------------------------------------------------------------------------- testParser :: String -> IO () -testParser a = putStrLn . show =<< parseIQM a +testParser a = print =<< parseIQM a {-do f <- B.readFile a putStrLn "reading in:" @@ -86,22 +87,33 @@ main = (SDL.Size fbWidth fbHeight) <- SDL.glGetDrawableSize window' initRendering --generate map vertices - glMap' <- initMapShader 4 =<< getMapBufferObject + curMap <- exportedMap + glMap' <- initMapShader 4 =<< getMapBufferObject curMap eventQueue <- newTQueueIO :: IO (TQueue SDL.Event) now <- getCurrentTime --font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10 --TTF.setFontStyle font TTFNormal --TTF.setFontHinting font TTFHNormal - - glHud' <- initHud - let zDistClosest' = 1 - zDistFarthest' = zDistClosest' + 50 - --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 @@ -121,17 +133,11 @@ main = , _height = fbHeight , _shouldClose = False } - , _camera = CameraState - { _xAngle = pi/6 - , _yAngle = pi/2 - , _zDist = 10 - , _frustum = frust - , _camObject = createFlatCam 25 25 - } , _io = IOState { _clock = now , _tessClockFactor = 0 } + , _camera = cam' , _mouse = MouseState { _isDragging = False , _dragStartX = 0 @@ -152,9 +158,7 @@ main = , _glRenderbuffer = renderBuffer , _glFramebuffer = frameBuffer } - , _game = GameState - { - } + , _game = game' , _ui = UIState { _uiHasChanged = True , _uiMap = guiMap @@ -204,20 +208,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 - let - multc = cos $ state ^. camera.yAngle - mults = sin $ state ^. camera.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))) + liftIO $ atomically $ do + cam <- readTVar (state ^. camera) + game' <- readTVar (state ^. game) + let + 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 + 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. @@ -233,7 +243,7 @@ run = do targetFrametime = 1.0/targetFramerate --targetFrametimeμs = targetFrametime * 1000000.0 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"] ddiff = double diff SDL.setWindowTitle (env ^. windowObject) title @@ -287,7 +297,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 @@ -305,6 +318,7 @@ adjustWindow = do let hudtexid = state ^. gl.glHud.hudTexture maptexid = state ^. gl.glMap.renderedMapTexture + smaptexid = state ^. gl.glMap.shadowMapTexture allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do --default to ugly pink to see if --somethings go wrong. @@ -321,6 +335,13 @@ adjustWindow = do textureFilter Texture2D GL.$= ((Linear', Nothing), Linear') texImage2D Texture2D GL.NoProxy 0 RGBA8 (GL.TextureSize2D fbCWidth fbCHeight) 0 (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" return renderBuffer modify $ gl.glRenderbuffer .~ rb diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 554cb6c..38a49a6 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -2,21 +2,13 @@ module Map.Creation where import Map.Types -import Map.StaticMaps --- 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]] exportedMap :: IO PlayMap exportedMap = do mounts <- mnt @@ -52,18 +44,7 @@ gauss3Dgeneral :: Floating q => -> q -- ^ Coordinate in question on X -> q -- ^ Coordinate in question on Z -> 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))))) - --- 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) +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))))) -- | Basic Terrain-Generator. Will not implement "abnormal" Stuff for given Biome -- (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 GrassIslandMap y | y < 0.1 = Ocean - | y < 1 = Beach - | y < 5 = Grass - | y < 10 = Hill + | y < 0.2 = Beach + | y < 1.5 = Grass + | y < 3 = Hill | otherwise = Mountain heightToTerrain _ _ = undefined @@ -87,26 +68,23 @@ river = undefined mnt :: IO [PlayMap -> PlayMap] mnt = do g <- newStdGen - let seeds = take 10 $ randoms g - return $ map (gaussMountain) seeds + let seeds = take 50 $ 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 + 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) :: (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 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) + liftUp (gx,gz) (Node (x,z) (rx,rz,y) _ b pl pa r s) = let y_neu = max y e + in Node (x,z) (rx, rz, y_neu) (htt GrassIslandMap y_neu) b pl pa r s + where e = gauss3Dgeneral amp (fromIntegral gx) (fromIntegral gz) sig sig rx rz -- | Makes sure the edges of the Map are mountain-free makeIsland :: PlayMap -> PlayMap diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index 858b1f4..6de0cab 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -30,9 +30,8 @@ import Linear import Control.Arrow ((***)) import Map.Types -import Map.Creation -type Height = Float +type Height = Double type MapEntry = ( 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) strp :: Node -> Node -strp (Full xz y tt bi pli p ri si) = Full (stripify xz) y tt bi pli p ri si -strp (Minimal xz ) = Minimal (stripify xz) +strp (Node i (x,z,y) tt bi pli p ri si) = Node (stripify i) (x,z,y) tt bi pli p ri si -- extract graphics information from Playmap convertToGraphicsMap :: PlayMap -> GraphicsMap convertToGraphicsMap mp = array (bounds mp) [(i, graphicsyfy (mp ! i))| i <- indices mp] where graphicsyfy :: Node -> MapEntry - graphicsyfy (Minimal _ ) = (1.0, Grass) - graphicsyfy (Full _ y t _ _ _ _ _ ) = (y, t) + graphicsyfy (Node _ (_,_,y) t _ _ _ _ _ ) = (y, t) lineHeight :: GLfloat lineHeight = 0.8660254 @@ -87,9 +84,8 @@ fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal -getMapBufferObject :: IO (BufferObject, NumArrayIndices) -getMapBufferObject = do - eMap <- exportedMap +getMapBufferObject :: PlayMap -> IO (BufferObject, NumArrayIndices) +getMapBufferObject eMap = do myMap' <- return $ convertToGraphicsMap $ convertToStripeMap eMap ! myMap <- return $ generateTriangles myMap' 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) Desert -> (1.00, 0.87, 0.39) Grass -> (0.30, 0.90, 0.10) - Hill -> (0.80, 0.80, 0.80) - Mountain -> (0.50, 0.50, 0.50) + Mountain -> (0.80, 0.80, 0.80) + Hill -> (0.50, 0.50, 0.50) coordLookup :: (Int,Int) -> GLfloat -> V3 GLfloat coordLookup (x,z) y = diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 7ea3593..b92e926 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -2,8 +2,8 @@ module Map.Map where import Map.Types -import Data.Array (bounds) -import Data.List (sort, group) +import Data.Array (bounds, (!)) +import Data.List (sort, group) -- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet. unsafeGiveNeighbours :: (Int, Int) -- ^ original coordinates @@ -36,6 +36,57 @@ giveNeighbourhood _ 0 (a,b) = [(a,b)] giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in 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 remdups :: Ord a => [a] -> [a] remdups = map head . group . sort diff --git a/src/Map/StaticMaps.hs b/src/Map/StaticMaps.hs deleted file mode 100644 index 5ef9942..0000000 --- a/src/Map/StaticMaps.hs +++ /dev/null @@ -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) diff --git a/src/Map/Types.hs b/src/Map/Types.hs index c62837f..2ca5d61 100644 --- a/src/Map/Types.hs +++ b/src/Map/Types.hs @@ -1,15 +1,15 @@ module Map.Types where -import Types - import Data.Array -type PlayMap = Array (XCoord, ZCoord) Node +type PlayMap = Array (Xindex, Zindex) Node -type XCoord = Int -type ZCoord = Int -type YCoord = Float +type Xindex = Int +type Zindex = Int +type XCoord = Double +type ZCoord = Double +type YCoord = Double data MapType = GrassIslandMap | DesertMap @@ -66,7 +66,67 @@ data TileType = Ocean | Mountain -- ^ Not accessible deriving (Show, Eq) --- TODO: Record Syntax -data Node = Full (XCoord, ZCoord) YCoord TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo - | Minimal (XCoord, ZCoord) -- defaults to empty green grass node on height 1 +-- TODO: Record Syntax? +data Node = Node (Xindex, Zindex) (XCoord, ZCoord, YCoord) TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo 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" + diff --git a/src/Render/Misc.hs b/src/Render/Misc.hs index 48e84f9..a00a408 100644 --- a/src/Render/Misc.hs +++ b/src/Render/Misc.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ForeignFunctionInterface #-} module Render.Misc where 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 (-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 lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat lookAt eye center up' = @@ -128,5 +137,4 @@ tryWithTexture t f fail' = genColorData :: Int -- ^ Amount -> [Int8] -- ^ [r,g,b,a], [r,g,b] - whatever should be repeatet. -> [Int8] -genColorData n c = take ((length c)*n) (cycle c) - +genColorData n c = take (length c*n) (cycle c) diff --git a/src/Render/Render.hs b/src/Render/Render.hs index c6e4369..59fe4ed 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -7,11 +7,13 @@ import Foreign.Storable import Graphics.Rendering.OpenGL.GL import Graphics.Rendering.OpenGL.Raw.Core31 import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader -import Graphics.GLUtil.BufferObjects (offset0) +import Graphics.GLUtil.BufferObjects 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) @@ -24,6 +26,7 @@ import Render.Types import Graphics.GLUtil.BufferObjects (makeBuffer) import Importer.IQM.Parser import Importer.IQM.Types +import Map.Map (giveMapHeight) mapVertexShaderFile :: String mapVertexShaderFile = "shaders/map/vertex.shader" @@ -33,6 +36,8 @@ mapTessEvalShaderFile :: String mapTessEvalShaderFile = "shaders/map/tessEval.shader" mapFragmentShaderFile :: String mapFragmentShaderFile = "shaders/map/fragment.shader" +mapFragmentShaderShadowMapFile :: String +mapFragmentShaderShadowMapFile = "shaders/map/fragmentShadow.shader" objectVertexShaderFile :: String objectVertexShaderFile = "shaders/mapobjects/vertex.shader" @@ -66,6 +71,7 @@ initMapShader tessFac (buf, vertDes) = do ! tessControlSource <- B.readFile mapTessControlShaderFile ! tessEvalSource <- B.readFile mapTessEvalShaderFile ! fragmentSource <- B.readFile mapFragmentShaderFile + ! fragmentShadowSource <- B.readFile mapFragmentShaderShadowMapFile vertexShader <- compileShaderSource VertexShader vertexSource checkError "compile Vertex" tessControlShader <- compileShaderSource TessControlShader tessControlSource @@ -74,7 +80,10 @@ initMapShader tessFac (buf, vertDes) = do checkError "compile TessEval" fragmentShader <- compileShaderSource FragmentShader fragmentSource checkError "compile Frag" + fragmentShadowShader <- compileShaderSource FragmentShader fragmentShadowSource + checkError "compile Frag" program <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShader] + shadowProgram <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShadowShader] checkError "compile Program" currentProgram $= Just program @@ -119,6 +128,8 @@ initMapShader tessFac (buf, vertDes) = do overTex <- genObjectName texts <- genObjectNames 6 + + smap <- genObjectName testobj <- parseIQM "sample.iqm" @@ -137,25 +148,31 @@ initMapShader tessFac (buf, vertDes) = do currentProgram $= Just objProgram 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 { _mapProgram = program - , _shdrColorIndex = colorIndex - , _shdrNormalIndex = normalIndex - , _shdrVertexIndex = vertexIndex - , _shdrProjMatIndex = projectionMatrixIndex - , _shdrViewMatIndex = viewMatrixIndex - , _shdrModelMatIndex = modelMatrixIndex - , _shdrNormalMatIndex = normalMatrixIndex - , _shdrTessInnerIndex = tessLevelInner - , _shdrTessOuterIndex = tessLevelOuter + , _mapShaderData = sdata , _renderedMapTexture = tex , _stateTessellationFactor = tessFac , _stateMap = buf , _mapVert = vertDes , _overviewTexture = overTex , _mapTextures = texts + , _shadowMapTexture = smap , _mapObjects = objs , _objectProgram = objProgram + , _shadowMapProgram = shadowProgram } initHud :: IO GLHud @@ -190,7 +207,7 @@ initHud = do att <- get (activeAttribs program) putStrLn $ unlines $ "Attributes: ":map show att - putStrLn $ unlines $ ["Indices: ", show (texIndex)] + putStrLn $ unlines $ ["Indices: ", show texIndex] checkError "initHud" return GLHud @@ -299,38 +316,126 @@ renderObject :: MapObject -> IO () renderObject (MapObject model pos@(L.V3 x y z) _{-state-}) = 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 = do state <- RWS.get - let xa = state ^. camera.xAngle - ya = state ^. camera.yAngle - (UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex - (UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex - (UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex - (UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex - (UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex - vi = state ^. gl.glMap.shdrVertexIndex - ni = state ^. gl.glMap.shdrNormalIndex - ci = state ^. gl.glMap.shdrColorIndex - 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 + 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 + (UniformLocation vmat) = shdrViewMatIndex d liftIO $ do ---- RENDER MAP IN TEXTURE ------------------------------------------ bindFramebuffer Framebuffer $= (state ^. gl.glFramebuffer) - bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer) + {-bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer) framebufferRenderbuffer Framebuffer DepthAttachment Renderbuffer - (state ^. gl.glRenderbuffer) - textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) + (state ^. gl.glRenderbuffer)-} + + -- 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 Framebuffer (ColorAttachment 0) @@ -371,38 +476,8 @@ render = do checkError "nmat" - 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-} + drawMap --draw map -> put to another function for readability + liftIO $ do ---- COMPOSE RENDERING -------------------------------------------- -- Render to BackBuffer (=Screen) diff --git a/src/Render/Types.hs b/src/Render/Types.hs index e7273b2..5191322 100644 --- a/src/Render/Types.hs +++ b/src/Render/Types.hs @@ -4,6 +4,10 @@ module Render.Types (createFlatCam, createSphereCam, Camera, GLCamera(..)) where import Linear import Foreign.C (CFloat) 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 Pitch = Double @@ -11,30 +15,32 @@ type Yaw = Double class GLCamera a where getCam :: a -> Distance -> Pitch -> Yaw -> M44 CFloat - moveBy :: a -> (Position -> Position) -> a - move :: a -> Position -> a + moveBy :: a -> (Position -> Position) -> PlayMap -> a + move :: a -> Position -> PlayMap -> a type Position = (Double, Double) type Radius = Double -data Camera = Flat Position +type Height = Double + +data Camera = Flat Position Height | Sphere Position Radius -- | create a Flatcam-Camera starting at given x/z-Coordinates -createFlatCam :: Double -> Double -> Camera -createFlatCam x z = Flat (x,z) +createFlatCam :: Double -> Double -> PlayMap -> Camera +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 -createSphereCam p a r = Sphere (p,a) r +createSphereCam p a = Sphere (p,a) instance GLCamera Camera where - getCam (Flat (x',z')) dist' xa' ya' = + getCam (Flat (x',z') y') dist' xa' ya' = lookAt (cpos ^+^ at') at' up where - at' = V3 x 0 z + at' = V3 x (y+2) z cpos = crot !* (V3 0 0 (-dist)) crot = ( (fromQuaternion $ axisAngle upmap (xa::CFloat)) @@ -44,6 +50,7 @@ instance GLCamera Camera where upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat) !* (V3 1 0 0) x = realToFrac x' + y = realToFrac y' z = realToFrac z' dist = realToFrac dist' xa = realToFrac xa' @@ -68,12 +75,15 @@ instance GLCamera Camera where dist = realToFrac dist' xa = realToFrac xa' ya = realToFrac ya' - moveBy (Sphere (inc, az) r) f = undefined - moveBy (Flat (x', z')) f = Flat (f (x',z')) - move c (x', z') = moveBy c (\(x,z) -> (x+x',z+z')) + moveBy (Sphere (inc, az) r) f map = undefined + moveBy (Flat (x', z') y) f map = Flat (x,z) y + 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 r inc az = V3 (r * (sin inc) * (cos az)) (r * (sin inc) * (sin az)) - (r * (cos inc)) \ No newline at end of file + (r * (cos inc)) diff --git a/src/Types.hs b/src/Types.hs index d572db8..0e1800c 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} 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 Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) @@ -9,12 +9,14 @@ 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.Monad.RWS.Strict (RWST, liftIO, get) +import Control.Monad (when) import Control.Lens import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Render.Types import Importer.IQM.Types import UI.UIBase +import Map.Types (PlayMap) data Coord3D a = Coord3D a a a @@ -56,7 +58,7 @@ data IOState = IOState } data GameState = GameState - { + { _currentMap :: !PlayMap } data MouseState = MouseState @@ -100,24 +102,30 @@ data KeyboardState = KeyboardState data GLMapState = GLMapState - { _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 + { _mapShaderData :: !MapShaderData , _stateTessellationFactor :: !Int , _stateMap :: !GL.BufferObject , _mapVert :: !GL.NumArrayIndices , _mapProgram :: !GL.Program , _renderedMapTexture :: !TextureObject --TODO: Probably move to UI? , _overviewTexture :: !TextureObject + , _shadowMapTexture :: !TextureObject , _mapTextures :: ![TextureObject] --TODO: Fix size on list? , _objectProgram :: !GL.Program , _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 @@ -153,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 } @@ -180,63 +188,18 @@ $(makeLenses ''Position) $(makeLenses ''Env) $(makeLenses ''UIState) -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) +-- helper-functions for types -data Amount = Infinite -- Neverending supply - | Finite Int -- Finite supply +-- | atomically change gamestate on condition +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 - | 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" +-- | atomically change gamestate +changeGamestate :: (GameState -> GameState) -> Pioneers () +changeGamestate = changeIfGamestate (const True) diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index e953e24..a13f7bb 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -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) @@ -102,6 +104,7 @@ eventCallback e = do return () SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel mouseMoveHandler (x, y) + SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt case state of SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button @@ -110,8 +113,13 @@ eventCallback e = do SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll do -- TODO: MouseWheelHandler 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] @@ -289,4 +297,4 @@ copyGUI tex (vX, vY) widget = do mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. ---TODO: Maybe queues are better? \ No newline at end of file +--TODO: Maybe queues are better? diff --git a/src/UI/UIWidgets.hs b/src/UI/UIWidgets.hs index 64c954f..dcc6e58 100644 --- a/src/UI/UIWidgets.hs +++ b/src/UI/UIWidgets.hs @@ -2,9 +2,10 @@ module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where +import Control.Concurrent.STM.TVar (readTVarIO) import Control.Lens ((^.), (.~), (%~), (&)) import Control.Monad --- import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (liftIO) import Control.Monad.RWS.Strict (get, modify) import Data.List import Data.Maybe @@ -57,11 +58,12 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP") let press btn' (x, y) _ w = do when (btn == btn') $ do state <- get + cam <- liftIO $ readTVarIO (state ^. camera) modify $ mouse %~ (isDragging .~ True) . (dragStartX .~ fromIntegral x) . (dragStartY .~ fromIntegral y) - . (dragStartXAngle .~ (state ^. camera.xAngle)) - . (dragStartYAngle .~ (state ^. camera.yAngle)) + . (dragStartXAngle .~ (cam ^. xAngle)) + . (dragStartYAngle .~ (cam ^. yAngle)) . (mousePosition.Types._x .~ fromIntegral x) . (mousePosition.Types._y .~ fromIntegral y) return w