diff --git a/.gitignore b/.gitignore index 925f33a..0df715f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,11 @@ /.dist-buildwrapper /.project /.settings +.cabal-sandbox +*.trace +cabal.sandbox.config +deps/hsSDL2* +deps/*.deb +dist/* +*.swp + diff --git a/Pioneers.cabal b/Pioneers.cabal index e7901ba..c8e8c83 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -16,14 +16,15 @@ executable Pioneers Map.Graphics, Map.Creation, Map.StaticMaps, - IQM.Types, - IQM.TestMain, - IQM.Parser, + Importer.IQM.Types, + Importer.IQM.TestMain, + Importer.IQM.Parser, Render.Misc, Render.Render, Render.RenderObject, + Render.Types, UI.Callbacks, - Types, + UI.Types, UI.SurfaceOverlay Types main-is: Main.hs @@ -47,7 +48,7 @@ executable Pioneers SDL2 >= 0.1.0, time >=1.4.0, GLUtil >= 0.7, - attoparsec >= 0.11.2 - other-modules: Render.Types + attoparsec >= 0.11.2, + attoparsec-binary >= 0.1 Default-Language: Haskell2010 diff --git a/README b/README deleted file mode 100644 index a831599..0000000 --- a/README +++ /dev/null @@ -1,4 +0,0 @@ -Pioneers -======== - -A Settlers II inspired game written in Haskell diff --git a/README.md b/README.md new file mode 100644 index 0000000..39048e9 --- /dev/null +++ b/README.md @@ -0,0 +1,39 @@ +# Pioneers + +A Settlers II inspired game written in Haskell + +## Development-Status + +Bugtracker/Wiki: http://redmine.pwning.de/projects/pioneers + +## Compiling + +1. Clone this repository +2. Set up cabal-sandbox + ``` + $ cabal sandbox init + $ cd deps + $ ./getDeps.sh + $ cd .. + $ cabal sandbox add-source deps/hsSDL2 + ``` +3. install libraries `sudo apt-get install libsdl2` - make sure libsdl2 is in version 2.0.1+ (shipped with Ubuntu since 14.04) +4. install dependencies `cabal install --only-dependencies` +5. build `cabal build` +6. run `./Pioneers` + +Step 2 is likely to break in the future due to restructuring in hsSDL2. This will be updated accordingly then. + +## Features + +Note, that most of it is just planned and due to change. + +- modern OpenGL3.x-Engine +- themeable with different Cultures +- rock-solid Multiplayer (no desync, just slightly more lag in case of resync) + +## Why Haskell? + +- There are not enough good games written in functional languages. +- More robust and easier to reason about lateron + diff --git a/shaders/map/tessEval.shader b/shaders/map/tessEval.shader index 87a5598..51cc5b3 100644 --- a/shaders/map/tessEval.shader +++ b/shaders/map/tessEval.shader @@ -2,6 +2,101 @@ #extension GL_ARB_tessellation_shader : require +//#include "shaders/3rdParty/noise.glsl" + +vec3 mod289(vec3 x) { + return x - floor(x * (1.0 / 289.0)) * 289.0; +} + +vec4 mod289(vec4 x) { + return x - floor(x * (1.0 / 289.0)) * 289.0; +} + +vec4 permute(vec4 x) { + return mod289(((x*34.0)+1.0)*x); +} + +vec4 taylorInvSqrt(vec4 r) +{ + return 1.79284291400159 - 0.85373472095314 * r; +} + +float snoise(vec3 v) + { + const vec2 C = vec2(1.0/6.0, 1.0/3.0) ; + const vec4 D = vec4(0.0, 0.5, 1.0, 2.0); + +// First corner + vec3 i = floor(v + dot(v, C.yyy) ); + vec3 x0 = v - i + dot(i, C.xxx) ; + +// Other corners + vec3 g = step(x0.yzx, x0.xyz); + vec3 l = 1.0 - g; + vec3 i1 = min( g.xyz, l.zxy ); + vec3 i2 = max( g.xyz, l.zxy ); + + // x0 = x0 - 0.0 + 0.0 * C.xxx; + // x1 = x0 - i1 + 1.0 * C.xxx; + // x2 = x0 - i2 + 2.0 * C.xxx; + // x3 = x0 - 1.0 + 3.0 * C.xxx; + vec3 x1 = x0 - i1 + C.xxx; + vec3 x2 = x0 - i2 + C.yyy; // 2.0*C.x = 1/3 = C.y + vec3 x3 = x0 - D.yyy; // -1.0+3.0*C.x = -0.5 = -D.y + +// Permutations + i = mod289(i); + vec4 p = permute( permute( permute( + i.z + vec4(0.0, i1.z, i2.z, 1.0 )) + + i.y + vec4(0.0, i1.y, i2.y, 1.0 )) + + i.x + vec4(0.0, i1.x, i2.x, 1.0 )); + +// Gradients: 7x7 points over a square, mapped onto an octahedron. +// The ring size 17*17 = 289 is close to a multiple of 49 (49*6 = 294) + float n_ = 0.142857142857; // 1.0/7.0 + vec3 ns = n_ * D.wyz - D.xzx; + + vec4 j = p - 49.0 * floor(p * ns.z * ns.z); // mod(p,7*7) + + vec4 x_ = floor(j * ns.z); + vec4 y_ = floor(j - 7.0 * x_ ); // mod(j,N) + + vec4 x = x_ *ns.x + ns.yyyy; + vec4 y = y_ *ns.x + ns.yyyy; + vec4 h = 1.0 - abs(x) - abs(y); + + vec4 b0 = vec4( x.xy, y.xy ); + vec4 b1 = vec4( x.zw, y.zw ); + + //vec4 s0 = vec4(lessThan(b0,0.0))*2.0 - 1.0; + //vec4 s1 = vec4(lessThan(b1,0.0))*2.0 - 1.0; + vec4 s0 = floor(b0)*2.0 + 1.0; + vec4 s1 = floor(b1)*2.0 + 1.0; + vec4 sh = -step(h, vec4(0.0)); + + vec4 a0 = b0.xzyw + s0.xzyw*sh.xxyy ; + vec4 a1 = b1.xzyw + s1.xzyw*sh.zzww ; + + vec3 p0 = vec3(a0.xy,h.x); + vec3 p1 = vec3(a0.zw,h.y); + vec3 p2 = vec3(a1.xy,h.z); + vec3 p3 = vec3(a1.zw,h.w); + +//Normalise gradients + vec4 norm = taylorInvSqrt(vec4(dot(p0,p0), dot(p1,p1), dot(p2, p2), dot(p3,p3))); + p0 *= norm.x; + p1 *= norm.y; + p2 *= norm.z; + p3 *= norm.w; + +// Mix final noise value + vec4 m = max(0.6 - vec4(dot(x0,x0), dot(x1,x1), dot(x2,x2), dot(x3,x3)), 0.0); + m = m * m; + return 42.0 * dot( m*m, vec4( dot(p0,x0), dot(p1,x1), + dot(p2,x2), dot(p3,x3) ) ); + } + + layout(triangles, equal_spacing, cw) in; in vec3 tcPosition[]; in vec4 tcColor[]; @@ -38,6 +133,7 @@ void main() float i2 = (1-gl_TessCoord.z)*gl_TessCoord.z * length(cross(tcNormal[2],tessNormal)); float standout = i0+i1+i2; tePosition = tePosition+tessNormal*standout; + tePosition = tePosition+0.05*snoise(tePosition); gl_Position = ProjectionMatrix * ViewMatrix * vec4(tePosition, 1); fogDist = gl_Position.z; diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs index cd777c0..1d5b9fe 100644 --- a/src/Importer/IQM/Parser.hs +++ b/src/Importer/IQM/Parser.hs @@ -8,84 +8,98 @@ module Importer.IQM.Parser (parseIQM) where import Importer.IQM.Types import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.ByteString +import Data.Attoparsec.Binary import Data.ByteString.Char8 (pack) -import Data.ByteString (split, null) +import Data.ByteString (split, null, ByteString) +import Data.ByteString.Unsafe (unsafeUseAsCString) +import qualified Data.ByteString as B import Data.Word import Data.Int import Unsafe.Coerce import Control.Monad.Trans.State import Control.Monad.Trans.Class import Control.Monad +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils import Prelude as P hiding (take, null) -- | helper-function for creating an integral out of [8-Bit Ints] -w8ToInt :: Integral a => a -> a -> a -w8ToInt i add = 256*i + add +_w8ToInt :: Integral a => a -> a -> a +_w8ToInt i add = 256*i + add -- | shorthand-function for parsing Word8 into Integrals -parseNum :: (Integral a, Integral b) => [a] -> b -parseNum = (foldl1 w8ToInt) . map fromIntegral +_parseNum :: (Integral a, Integral b) => [a] -> b +_parseNum = foldl1 _w8ToInt . map fromIntegral -- | read a 16-Bit Int from Parsing-Input and log 2 bytes in our Parsing-Monad -- -- begins with _ to defeat ghc-warnings. Rename if used! -_int16 :: CParser Int16 +_int16 :: CParser Word16 _int16 = do ret <- lift $ do a <- anyWord8 :: Parser Word8 b <- anyWord8 :: Parser Word8 - return $ parseNum [b,a] + return $ _parseNum [b,a] modify (+2) return ret -- | read a 32-Bit Int from Parsing-Input and log 4 bytes in our Parsing-Monad -int32 :: CParser Int32 -int32 = do +_int32 :: CParser Int32 +_int32 = do ret <- lift $ do a <- anyWord8 :: Parser Word8 b <- anyWord8 :: Parser Word8 c <- anyWord8 :: Parser Word8 d <- anyWord8 :: Parser Word8 - return $ parseNum [d,c,b,a] + return $ _parseNum [d,c,b,a] modify (+4) - return $ ret + return ret + +w32leCParser :: CParser Word32 +w32leCParser = do + ret <- lift anyWord32le + modify (+4) + return ret -- | Parser for the header readHeader :: CParser IQMHeader readHeader = do _ <- lift $ string (pack "INTERQUAKEMODEL\0") - v <- int32 - -- when v /= 2 then --TODO: error something - size' <- int32 - flags' <- int32 - num_text' <- int32 - ofs_text' <- int32 - num_meshes' <- int32 - ofs_meshes' <- int32 - num_vertexarrays' <- int32 - num_vertexes' <- int32 - ofs_vertexarrays' <- int32 - num_triangles' <- int32 - ofs_triangles' <- int32 - ofs_adjacency' <- int32 - num_joints' <- int32 - ofs_joints' <- int32 - num_poses' <- int32 - ofs_poses' <- int32 - num_anims' <- int32 - ofs_anims' <- int32 - num_frames' <- int32 - num_framechannels' <- int32 - ofs_frames' <- int32 - ofs_bounds' <- int32 - num_comment' <- int32 - ofs_comment' <- int32 - num_extensions' <- int32 - ofs_extensions' <- int32 + modify (+16) + v <- w32leCParser + lift $ when (v /= 2) $ fail "Version /= 2.\nThis Parser only supports Version 2 of the InterQuake-Model IQM" + -- when v /= 2 then fail parsing. + size' <- w32leCParser + flags' <- w32leCParser + num_text' <- w32leCParser + ofs_text' <- w32leCParser + num_meshes' <- w32leCParser + ofs_meshes' <- w32leCParser + num_vertexarrays' <- w32leCParser + num_vertexes' <- w32leCParser + ofs_vertexarrays' <- w32leCParser + num_triangles' <- w32leCParser + ofs_triangles' <- w32leCParser + ofs_adjacency' <- w32leCParser + num_joints' <- w32leCParser + ofs_joints' <- w32leCParser + num_poses' <- w32leCParser + ofs_poses' <- w32leCParser + num_anims' <- w32leCParser + ofs_anims' <- w32leCParser + num_frames' <- w32leCParser + num_framechannels' <- w32leCParser + ofs_frames' <- w32leCParser + ofs_bounds' <- w32leCParser + num_comment' <- w32leCParser + ofs_comment' <- w32leCParser + num_extensions' <- w32leCParser + ofs_extensions' <- w32leCParser return IQMHeader { version = v , filesize = size' - , flags = flags' + , flags = fromIntegral flags' , num_text = num_text' , ofs_text = ofs_text' , num_meshes = num_meshes' @@ -115,12 +129,12 @@ readHeader = do -- | Parser for Mesh-Structure readMesh :: CParser IQMMesh readMesh = do - name <- int32 - mat <- int32 - fv <- int32 - nv <- int32 - ft <- int32 - nt <- int32 + name <- w32leCParser + mat <- w32leCParser + fv <- w32leCParser + nv <- w32leCParser + ft <- w32leCParser + nt <- w32leCParser return IQMMesh { meshName = if name == 0 then Nothing else Just (Mesh name) , meshMaterial = mat @@ -140,12 +154,32 @@ readMeshes n = do ms <- readMeshes (n-1) return $ m:ms +-- | Parser for Mesh-Structure +readVAF :: CParser IQMVertexArray +readVAF = do + vat <- rawEnumToVAT =<< w32leCParser + flags' <- w32leCParser + format <- rawEnumToVAF =<< w32leCParser + size <- w32leCParser + offset <- w32leCParser + return $ IQMVertexArray vat (fromIntegral flags') format (fromIntegral size) offset nullPtr + +-- | helper to read n consecutive Meshes tail-recursive +readVAFs :: Int -> CParser [IQMVertexArray] +readVAFs 1 = do + f <- readVAF + return [f] +readVAFs n = do + f <- readVAF + fs <- readVAFs (n-1) + return $ f:fs + -- | helper-Notation for subtracting 2 integral values of different kind in the precision -- of the target-kind (.-) :: forall a a1 a2. (Num a, Integral a2, Integral a1) => a1 -> a2 -> a -(.-) a b = (fromIntegral a) - (fromIntegral b) +(.-) a b = fromIntegral a - fromIntegral b infix 5 .- @@ -162,18 +196,69 @@ skipToCounter a = do put d -- | Parses an IQM-File and handles back the Haskell-Structure -parseIQM :: CParser IQM -parseIQM = do - put 0 --start at offset 0 - h <- readHeader --read header - skipToCounter $ ofs_text h --skip 0-n bytes to get to text - text <- lift . take . fromIntegral $ num_text h --read texts - modify . (+) . fromIntegral $ num_text h --put offset forward - skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes - meshes' <- readMeshes (fromIntegral (num_meshes h)) --read meshes - return IQM - { header = h - , texts = filter (not.null) (split (unsafeCoerce '\0') text) - , meshes = meshes' - } +-- +-- Does a 2-Pass-Parsing. Reads in Structure on first pass (O(n))and +-- fills the Structure in a 2nd Pass from Offsets (O(memcpy'd bytes)). +parseIQM :: String -> IO IQM +parseIQM a = + do + f <- B.readFile a + -- Parse Headers/Offsets + let result = parse doIQMparse f + raw <- case result of + Done _ x -> return x + y -> error $ show y + -- Fill Vertex-Arrays with data of Offsets + let va = vertexArrays raw + va' <- mapM (readInVAO f) va + return $ raw { + vertexArrays = va' + } +-- | Allocates memory for the Vertex-data and copies it over there +-- from the given input-String +-- +-- Note: The String-Operations are O(1), so only O(numberOfCopiedBytes) +-- is needed in term of computation. +readInVAO :: ByteString -> IQMVertexArray -> IO IQMVertexArray +readInVAO d (IQMVertexArray type' a format num offset ptr) = + do + let + byteLen = fromIntegral num * vaSize format + data' = skipDrop (fromIntegral offset) byteLen d + + unless (ptr == nullPtr) $ error $ "Error reading Vertex-Array: Double Read of " ++ show type' + p <- mallocBytes byteLen + putStrLn $ concat ["Allocating ", show byteLen, " Bytes at ", show p] + unsafeUseAsCString data' (\s -> copyBytes p s byteLen) + return $ IQMVertexArray type' a format num offset $ castPtr p + +-- | Real internal Parser. +-- +-- Consumes the String only once, thus in O(n). But all Data-Structures are +-- not allocated and copied. readInVAO has to be called on each one. +doIQMparse :: Parser IQM +doIQMparse = + flip evalStateT 0 $ --evaluate parser with state starting at 0 + do + h <- readHeader --read header + skipToCounter $ ofs_text h --skip 0-n bytes to get to text + text <- lift . take . fromIntegral $ num_text h --read texts + modify . (+) . fromIntegral $ num_text h --put offset forward + skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes + meshes' <- readMeshes $ fromIntegral $ num_meshes h --read meshes + skipToCounter $ ofs_vertexarrays h --skip 0-n bytes to get to Vertex-Arrays + vaf <- readVAFs $ fromIntegral $ num_vertexarrays h --read Vertex-Arrays + return IQM + { header = h + , texts = filter (not.null) (split (unsafeCoerce '\0') text) + , meshes = meshes' + , vertexArrays = vaf + } + +-- | Helper-Function for Extracting a random substring out of a Bytestring +-- by the Offsets provided. +-- +-- O(1). +skipDrop :: Int -> Int -> ByteString -> ByteString +skipDrop a b= B.drop b . B.take a diff --git a/src/Importer/IQM/Types.hs b/src/Importer/IQM/Types.hs index 1054767..847320f 100644 --- a/src/Importer/IQM/Types.hs +++ b/src/Importer/IQM/Types.hs @@ -1,19 +1,39 @@ --- | Int32 or Int64 - depending on implementation. Format just specifies "uint". --- 4-Byte in the documentation indicates Int32 - but not specified! +-- {-# LANGUAGE ExistentialQuantification, RankNTypes, CPP, BangPatterns #-} +-- | Word32 or Word64 - depending on implementation. Format just specifies "uint". +-- 4-Byte in the documentation indicates Word32 - but not specified! module Importer.IQM.Types where +import Control.Monad.Trans.State.Lazy (StateT) import Data.Int +import Data.Word import Data.ByteString import Data.Attoparsec.ByteString.Char8 -import Control.Monad.Trans.State.Lazy (StateT) +import Foreign.Ptr +import Graphics.Rendering.OpenGL.Raw.Types +import Prelude as P +import Foreign.Storable +import Foreign.C.Types -- | Mesh-Indices to distinguish the meshes referenced -newtype Mesh = Mesh Int32 deriving (Show, Eq) +newtype Mesh = Mesh Word32 deriving (Show, Eq) -- | State-Wrapped Parser-Monad which is capable of counting the -- Bytes read for offset-gap reasons type CParser a = StateT Int64 Parser a +-- | Alias +type Flags = GLbitfield -- ^ Alias for UInt32 +-- | Alias +type Offset = Word32 -- ^ Alias for UInt32 + +-- | Alias +type Index = GLuint -- ^ Alias for UInt32 + +-- | Alias +type NumComponents = GLsizei -- ^ Alias for UInt32 + +-- | Data-BLOB inside IQM +type IQMData = Ptr IQMVertexArrayFormat -- ^ Pointer for Data -- | Header of IQM-Format. -- @@ -23,33 +43,33 @@ type CParser a = StateT Int64 Parser a -- -- ofs_* fields are aligned at 4-byte-boundaries data IQMHeader = IQMHeader - { version :: Int32 -- ^ Must be 2 - , filesize :: Int32 - , flags :: Int32 - , num_text :: Int32 - , ofs_text :: Int32 - , num_meshes :: Int32 - , ofs_meshes :: Int32 - , num_vertexarrays :: Int32 - , num_vertexes :: Int32 - , ofs_vertexarrays :: Int32 - , num_triangles :: Int32 - , ofs_triangles :: Int32 - , ofs_adjacency :: Int32 - , num_joints :: Int32 - , ofs_joints :: Int32 - , num_poses :: Int32 - , ofs_poses :: Int32 - , num_anims :: Int32 - , ofs_anims :: Int32 - , num_frames :: Int32 - , num_framechannels :: Int32 - , ofs_frames :: Int32 - , ofs_bounds :: Int32 - , num_comment :: Int32 - , ofs_comment :: Int32 - , num_extensions :: Int32 -- ^ stored as linked list, not as array. - , ofs_extensions :: Int32 + { version :: !Word32 -- ^ Must be 2 + , filesize :: !Word32 + , flags :: !Flags + , num_text :: !Word32 + , ofs_text :: !Offset + , num_meshes :: !Word32 + , ofs_meshes :: !Offset + , num_vertexarrays :: !Word32 + , num_vertexes :: !Word32 + , ofs_vertexarrays :: !Offset + , num_triangles :: !Word32 + , ofs_triangles :: !Offset + , ofs_adjacency :: !Offset + , num_joints :: !Word32 + , ofs_joints :: !Offset + , num_poses :: !Word32 + , ofs_poses :: !Offset + , num_anims :: !Word32 + , ofs_anims :: !Offset + , num_frames :: !Word32 + , num_framechannels :: !Word32 + , ofs_frames :: !Offset + , ofs_bounds :: !Offset + , num_comment :: !Word32 + , ofs_comment :: !Offset + , num_extensions :: !Word32 -- ^ stored as linked list, not as array. + , ofs_extensions :: !Offset } deriving (Show, Eq) -- | Format of an IQM-Mesh Structure. @@ -57,13 +77,29 @@ data IQMHeader = IQMHeader -- Read it like a Header of the Meshes lateron in the Format data IQMMesh = IQMMesh { meshName :: Maybe Mesh - , meshMaterial :: Int32 - , meshFirstVertex :: Int32 - , meshNumVertexes :: Int32 - , meshFirstTriangle :: Int32 - , meshNumTriangles :: Int32 + , meshMaterial :: Word32 + , meshFirstVertex :: Word32 + , meshNumVertexes :: Word32 + , meshFirstTriangle :: Word32 + , meshNumTriangles :: Word32 } deriving (Show, Eq) +-- | Format of IQM-Triangle Structure +data IQMTriangle = IQMTriangle VertexIndex VertexIndex VertexIndex + +-- | Type-Alias for Word32 indicating an index on vertices in IQMMesh +type VertexIndex = Word32 + +-- | Type-Alias for Word32 indicating an index on IQMTriangle +type TriangleIndex = Word32 + +-- | From the IQM-Format-Description: +-- +-- each value is the index of the adjacent triangle for edge 0, 1, and 2, where ~0 (= -1) +-- indicates no adjacent triangle indexes are relative to the iqmheader.ofs_triangles array +-- and span all meshes, where 0 is the first triangle, 1 is the second, 2 is the third, etc. +data IQMAdjacency = IQMAdjacency TriangleIndex TriangleIndex TriangleIndex + -- | Format of a whole IQM-File -- -- still unfinished! @@ -71,5 +107,97 @@ data IQM = IQM { header :: IQMHeader , texts :: [ByteString] , meshes :: [IQMMesh] + , vertexArrays :: [IQMVertexArray] } deriving (Show, Eq) +-- | Different Vertex-Array-Types in IQM +-- +-- Custom Types have to be > 0x10 as of specification +data IQMVertexArrayType = IQMPosition + | IQMTexCoord + | IQMNormal + | IQMTangent + | IQMBlendIndexes + | IQMBlendWeights + | IQMColor + | IQMCustomVAT Word32 + deriving (Show, Eq) + +-- | Lookup-Function for internal enum to VertexArrayFormat +rawEnumToVAT :: Word32 -> CParser IQMVertexArrayType +rawEnumToVAT 0 = return IQMPosition +rawEnumToVAT 1 = return IQMTexCoord +rawEnumToVAT 2 = return IQMNormal +rawEnumToVAT 3 = return IQMTangent +rawEnumToVAT 4 = return IQMBlendIndexes +rawEnumToVAT 5 = return IQMBlendWeights +rawEnumToVAT 6 = return IQMColor +rawEnumToVAT a = return $ IQMCustomVAT a + +-- | Vetrex-Array-Format of the data found at offset +data IQMVertexArrayFormat = IQMbyte + | IQMubyte + | IQMshort + | IQMushort + | IQMint + | IQMuint + | IQMhalf + | IQMfloat + | IQMdouble +-- | Unknown Word32 + deriving (Show, Eq) + +-- | Get the Size (in Bytes) of the given IQMVertexArrayFormat-Struct +vaSize :: IQMVertexArrayFormat -> Int +vaSize IQMbyte = sizeOf (undefined :: CSChar) +vaSize IQMubyte = sizeOf (undefined :: CUChar) +vaSize IQMshort = sizeOf (undefined :: CShort) +vaSize IQMushort = sizeOf (undefined :: CUShort) +vaSize IQMint = sizeOf (undefined :: CInt) +vaSize IQMuint = sizeOf (undefined :: CUInt) +vaSize IQMhalf = sizeOf (undefined :: Word16) --TODO: Find 16-Bit-Float-Datatype FIXME! +vaSize IQMfloat = sizeOf (undefined :: CFloat) +vaSize IQMdouble = sizeOf (undefined :: CDouble) + +--mallocVArray :: Storable a => IQMVertexArrayFormat -> Int -> IO (Ptr a) +--mallocVArray IQMbyte n = mallocArray n :: IO (Ptr CSChar) +--mallocVArray IQMubyte n = mallocArray n :: IO (Ptr CUChar) + +-- | Lookup-Function for internal enum to VertexArrayFormat +rawEnumToVAF :: Word32 -> CParser IQMVertexArrayFormat +rawEnumToVAF 0 = return IQMbyte +rawEnumToVAF 1 = return IQMubyte +rawEnumToVAF 2 = return IQMshort +rawEnumToVAF 3 = return IQMushort +rawEnumToVAF 4 = return IQMint +rawEnumToVAF 5 = return IQMuint +rawEnumToVAF 6 = return IQMhalf +rawEnumToVAF 7 = return IQMfloat +rawEnumToVAF 8 = return IQMdouble +--rawEnumToVAF a = return $ Unknown a +rawEnumToVAF a = fail $ P.concat ["unrecognized enum(",show a,") in VertexArrayFormat"] + + +-- | A Vertex-Array-Definiton. +-- +-- The Vertex starts at Offset and has num_vertexes * NumComponents entries. +-- +-- All Vertex-Arrays seem to have the same number of components, just differ in Type, Format +-- and Flags +data IQMVertexArray = IQMVertexArray + IQMVertexArrayType + Flags + IQMVertexArrayFormat + NumComponents + Offset + IQMData + deriving (Eq) +instance Show IQMVertexArray where + show (IQMVertexArray t fl fo nc off dat) = "IQMVertexArray (Type: " ++ show t ++ + ", Flags: " ++ show fl ++ + ", Format: " ++ show fo ++ + ", NumComponents: " ++ show nc ++ + ", Offset: " ++ show off ++ + ", Data at: " ++ show dat ++ + ")" + diff --git a/src/Main.hs b/src/Main.hs index d8b23b7..935f2ec 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -16,7 +16,6 @@ import Control.Concurrent.STM (TQueue, newTQueueIO) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) -import Control.Monad.Trans.State (evalStateT) import Data.Functor ((<$>)) import Data.Monoid (mappend) @@ -46,17 +45,21 @@ import UI.Callbacks import Map.Graphics import Types import Importer.IQM.Parser -import Data.Attoparsec.Char8 (parseTest) -import qualified Data.ByteString as B +--import Data.Attoparsec.Char8 (parseTest) +--import qualified Data.ByteString as B -- import qualified Debug.Trace as D (trace) -------------------------------------------------------------------------------- -testParser :: IO () -testParser = do - f <- B.readFile "sample.iqm" - parseTest (evalStateT parseIQM 0) f +testParser :: String -> IO () +testParser a = putStrLn . show =<< parseIQM a +{-do + f <- B.readFile a + putStrLn "reading in:" + putStrLn $ show f + putStrLn "parsed:" + parseTest parseIQM f-} -------------------------------------------------------------------------------- @@ -82,9 +85,7 @@ main = (Size fbWidth fbHeight) <- glGetDrawableSize window' initRendering --generate map vertices - (mapBuffer, vert) <- getMapBufferObject - (mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader - overTex <- GL.genObjectName + glMap' <- initMapShader 4 =<< getMapBufferObject print window' eventQueue <- newTQueueIO :: IO (TQueue Event) putStrLn "foo" @@ -110,23 +111,6 @@ main = , _left = False , _right = False } - glMap' = GLMapState - { _shdrVertexIndex = vi - , _shdrNormalIndex = ni - , _shdrColorIndex = ci - , _shdrProjMatIndex = pri - , _shdrViewMatIndex = vii - , _shdrModelMatIndex = mi - , _shdrNormalMatIndex = nmi - , _shdrTessInnerIndex = tli - , _shdrTessOuterIndex = tlo - , _stateTessellationFactor = 4 - , _stateMap = mapBuffer - , _mapVert = vert - , _mapProgram = mapprog - , _mapTexture = mapTex - , _overviewTexture = overTex - } env = Env { _eventsChan = eventQueue , _windowObject = window' @@ -305,7 +289,7 @@ adjustWindow = do let hudtexid = state ^. gl.glHud.hudTexture - maptexid = state ^. gl.glMap.mapTexture + maptexid = state ^. gl.glMap.renderedMapTexture allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do --default to ugly pink to see if --somethings go wrong. diff --git a/src/Map/Combinators.hs b/src/Map/Combinators.hs new file mode 100644 index 0000000..9dabb89 --- /dev/null +++ b/src/Map/Combinators.hs @@ -0,0 +1,46 @@ +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) diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 949fd97..d677cdd 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -2,15 +2,59 @@ module Map.Creation where import Map.Types +import Map.Map + +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) + + random gen1 = let (a, gen2) = random gen1 + (b, gen3) = random gen2 in ((a,b), gen3) -- | Generate a new Map of given Type and Size -- -- TODO: -- 1. Should take Size -> Type -> Playmap -- 2. plug together helper-functions for that terraintype -newMap :: Int -> Int -> PlayMap +newMap :: MapType -> (Int, Int) -> PlayMap newMap = undefined +aplByPlace :: (Node -> Node) -> ((Int,Int) -> Bool) -> PlayMap -> PlayMap +aplByPlace f g mp = array (bounds mp) (map (\(ab,c) -> if g ab then (ab, f c) else (ab,c)) (assocs mp)) + +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 + +-- general 3D-Gaussian +gauss3Dgeneral :: Floating q => + q -- ^ Amplitude + -> q -- ^ Origin on X-Achsis + -> q -- ^ Origin on Z-Achsis + -> q -- ^ Sigma on X + -> q -- ^ Sigma on Z + -> 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) -- | Basic Terrain-Generator. Will not implement "abnormal" Stuff for given Biome -- (like Deserts on Grass-Islands or Grass on Deserts) @@ -24,11 +68,3 @@ heightToTerrain GrassIslandMap y | y < 10 = Hill | otherwise = Mountain heightToTerrain _ _ = undefined - -type Seed = (XCoord, ZCoord) - --- | Add lakes on generated Map from (possible) Seeds noted before. --- --- TODO: implement and erode terrain on the way down. -addLakes :: PlayMap -> [Seed] -> PlayMap -addLakes m s = undefined diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index d551790..5cc198a 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -27,9 +27,12 @@ import Foreign.Storable (sizeOf) import Foreign.Ptr (Ptr, nullPtr, plusPtr) import Render.Misc (checkError) import Linear +import Control.Arrow ((***)) import Map.Types import Map.StaticMaps +import Map.Creation +import Map.Combinators type Height = Float @@ -41,7 +44,7 @@ type GraphicsMap = Array (Int, Int) MapEntry -- converts from classical x/z to striped version of a map convertToStripeMap :: PlayMap -> PlayMap -convertToStripeMap mp = array (stripify l, stripify u) (map (\(i,e) -> (stripify i,strp e)) (assocs mp)) +convertToStripeMap mp = array (stripify l, stripify u) (map (stripify *** strp) (assocs mp)) where (l,u) = bounds mp @@ -57,7 +60,7 @@ convertToGraphicsMap :: PlayMap -> GraphicsMap convertToGraphicsMap mp = array (bounds mp) [(i, graphicsyfy (mp ! i))| i <- indices mp] where graphicsyfy :: Node -> MapEntry - graphicsyfy (Minimal _ ) = (0, Grass) + graphicsyfy (Minimal _ ) = (1.0, Grass) graphicsyfy (Full _ y t _ _ _ _ _ ) = (y, t) lineHeight :: GLfloat @@ -75,7 +78,7 @@ bufferObjectPtr = plusPtr (nullPtr :: Ptr GLfloat) . fromIntegral mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor GLfloat mapVertexArrayDescriptor count' offset = - VertexArrayDescriptor count' Float mapStride (bufferObjectPtr ((fromIntegral offset)*sizeOf (0 :: GLfloat)) ) --(fromIntegral numComponents * offset)) + VertexArrayDescriptor count' Float mapStride (bufferObjectPtr (fromIntegral offset * sizeOf (0 :: GLfloat)) ) --(fromIntegral numComponents * offset)) fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 0) --color first @@ -88,7 +91,8 @@ fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal getMapBufferObject :: IO (BufferObject, NumArrayIndices) getMapBufferObject = do - myMap' <- return $ convertToGraphicsMap $ convertToStripeMap mapNoise + mountains <- mnt + myMap' <- return $ convertToGraphicsMap $ convertToStripeMap $ aplAll mountains mapEmpty ! myMap <- return $ generateTriangles myMap' len <- return $ fromIntegral $ P.length myMap `div` numComponents putStrLn $ P.unwords ["num verts in map:",show len] diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 0abaf38..e358cee 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -2,12 +2,43 @@ module Map.Map where import Map.Types --- potentially to be expanded to Nodes -giveNeighbours :: (Int, Int) -> [(Int,Int)] -giveNeighbours (x,y) = filter (not . negative) all +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 + -> [(Int,Int)] -- ^ list of neighbours +unsafeGiveNeighbours (x,z) = filter (not . negative) allNs where - all = if even y then [(x+1,y), (x-1,y), (x,y+1), (x,y-1), (x+1,y+1), (x+1,y-1)] - else [(x+1,y), (x-1,y), (x,y+1), (x,y-1), (x-1,y+1), (x-1,y-1)] + allNs = if even z then [(x+1,z), (x-1,z), (x,z+1), (x,z-1), (x+1,z+1), (x+1,z-1)] + else [(x+1,z), (x-1,z), (x,z+1), (x,z-1), (x-1,z+1), (x-1,z-1)] negative :: (Int, Int) -> Bool - negative (x,y) = x < 0 || y < 0 + negative (a,b) = a < 0 || b < 0 + +giveNeighbours :: PlayMap -- ^ Map on which to find neighbours + -> (Int, Int) -- ^ original coordinates + -> [(Int, Int)] -- ^ list of neighbours +giveNeighbours mp (x,z) = filter (not . outOfBounds mp) allNs + where + allNs = if even z then [(x+1,z), (x-1,z), (x,z+1), (x,z-1), (x+1,z+1), (x+1,z-1)] + else [(x+1,z), (x-1,z), (x,z+1), (x,z-1), (x-1,z+1), (x-1,z-1)] + + outOfBounds :: PlayMap -> (Int, Int) -> Bool + outOfBounds mp' (a,b) = let (lo,hi) = bounds mp' in + a < fst lo || b < snd lo || a > fst hi || b > snd hi + +giveNeighbourhood :: PlayMap -- ^ map on which to find neighbourhood + -> Int -- ^ iterative + -> (Int, Int) -- ^ original coordinates + -> [(Int, Int)] -- ^ neighbourhood +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 + +-- 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 diff --git a/src/Map/StaticMaps.hs b/src/Map/StaticMaps.hs index 34c6136..74ea371 100644 --- a/src/Map/StaticMaps.hs +++ b/src/Map/StaticMaps.hs @@ -3,45 +3,21 @@ where import Map.Types import Data.Array -import Map.Creation (heightToTerrain) - --- general 3D-Gaussian -gauss3Dgeneral :: Floating q => - q -- ^ Amplitude - -> q -- ^ Origin on X-Achsis - -> q -- ^ Origin on Z-Achsis - -> q -- ^ Sigma on X - -> q -- ^ Sigma on Z - -> 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) +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]] +mapEmpty = array ((0,0), (199,199)) [((a,b), Minimal (a,b)) | a <- [0..199], b <- [0..199]] --- TODO: Stripify 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] + 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) @@ -52,7 +28,7 @@ mapCenterMountain = array ((0,0),(199,199)) nodes -- 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 +_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 @@ -62,14 +38,13 @@ _noisyMap = \x y -> gauss3Dgeneral 15 100.0 100.0 15.0 15.0 x y 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]] + 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)) + height a b = _noisyMap (fromIntegral a) (fromIntegral b) diff --git a/src/Map/Types.hs b/src/Map/Types.hs index 2599f5c..c62837f 100644 --- a/src/Map/Types.hs +++ b/src/Map/Types.hs @@ -1,7 +1,7 @@ module Map.Types where -import PioneerTypes +import Types import Data.Array @@ -20,7 +20,7 @@ data PlayerInfo = NoPlayer instance Show PlayerInfo where show (NoPlayer) = "not occupied" - show (Occupied i) = "occupied by player " ++ (show i) + show (Occupied i) = "occupied by player " ++ show i -- | Path info, is this node part of a path and if so, where does it lead? data PathInfo = NoPath @@ -34,7 +34,7 @@ data ResInfo = Plain instance Show ResInfo where show (Plain) = "no resources" - show (ResInfo res amt) = "Resource: " ++ (show res) ++ "," ++ (show amt) + show (ResInfo res amt) = "Resource: " ++ show res ++ "," ++ show amt -- | What commodities are currently stored here? type StorInfo = [(Commodity,Amount)] @@ -49,7 +49,7 @@ data BuildInfo = BStruc Structure | BLarge instance Show BuildInfo where - show (BStruc s) = "Structure: " ++ (show s) + show (BStruc s) = "Structure: " ++ show s show (BNothing) = "no Structure possible" show (BFlag) = "only flags possible" show (BMine) = "mines possible" @@ -68,5 +68,5 @@ data TileType = Ocean -- 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 0 + | Minimal (XCoord, ZCoord) -- defaults to empty green grass node on height 1 deriving (Show) diff --git a/src/PioneerTypes.hs b/src/PioneerTypes.hs deleted file mode 100644 index 1e28802..0000000 --- a/src/PioneerTypes.hs +++ /dev/null @@ -1,62 +0,0 @@ -module PioneerTypes -where - -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/Render.hs b/src/Render/Render.hs index 66702aa..6b3e4d3 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -50,22 +50,11 @@ initBuffer varray = checkError "initBuffer" return bufferObject -initMapShader :: IO ( - Program -- the GLSL-Program - , AttribLocation -- color - , AttribLocation -- normal - , AttribLocation -- vertex - , UniformLocation -- ProjectionMat - , UniformLocation -- ViewMat - , UniformLocation -- ModelMat - , UniformLocation -- NormalMat - , UniformLocation -- TessLevelInner - , UniformLocation -- TessLevelOuter - , TextureObject -- Texture where to draw into - ) -- ^ (the GLSL-Program, color, normal, vertex, ProjectionMat, ViewMat, - -- ModelMat, NormalMat, TessLevelInner, TessLevelOuter, - -- Texture where to draw into) -initMapShader = do +initMapShader :: + Int -- ^ initial Tessallation-Factor + -> (BufferObject,NumArrayIndices) -- ^ Buffer with Data and DataDescriptor + -> IO GLMapState +initMapShader tessFac (buf, vertDes) = do ! vertexSource <- B.readFile mapVertexShaderFile ! tessControlSource <- B.readFile mapTessControlShaderFile ! tessEvalSource <- B.readFile mapTessEvalShaderFile @@ -120,9 +109,30 @@ initMapShader = do putStrLn $ unlines $ ["Indices: ", show (colorIndex, normalIndex, vertexIndex)] tex <- genObjectName + overTex <- genObjectName + + texts <- genObjectNames 6 + checkError "initShader" - return (program, colorIndex, normalIndex, vertexIndex, projectionMatrixIndex, viewMatrixIndex, modelMatrixIndex, normalMatrixIndex, tessLevelInner, tessLevelOuter, tex) + return GLMapState + { _mapProgram = program + , _shdrColorIndex = colorIndex + , _shdrNormalIndex = normalIndex + , _shdrVertexIndex = vertexIndex + , _shdrProjMatIndex = projectionMatrixIndex + , _shdrViewMatIndex = viewMatrixIndex + , _shdrModelMatIndex = modelMatrixIndex + , _shdrNormalMatIndex = normalMatrixIndex + , _shdrTessInnerIndex = tessLevelInner + , _shdrTessOuterIndex = tessLevelOuter + , _renderedMapTexture = tex + , _stateTessellationFactor = tessFac + , _stateMap = buf + , _mapVert = vertDes + , _overviewTexture = overTex + , _mapTextures = texts + } initHud :: IO GLHud initHud = do @@ -193,13 +203,13 @@ renderOverview = do DepthAttachment Renderbuffer (state ^. gl.glRenderbuffer) - textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture) + textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D - (state ^. gl.glMap.mapTexture) + (state ^. gl.glMap.renderedMapTexture) 0 -- Render to FrameBufferObject @@ -285,13 +295,13 @@ render = do DepthAttachment Renderbuffer (state ^. gl.glRenderbuffer) - textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture) + textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D - (state ^. gl.glMap.mapTexture) + (state ^. gl.glMap.renderedMapTexture) 0 -- Render to FrameBufferObject @@ -371,7 +381,7 @@ render = do uniform (hud ^. hudTexIndex) $= Index1 (0::GLint) activeTexture $= TextureUnit 1 - textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture) + textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) uniform (hud ^. hudBackIndex) $= Index1 (1::GLint) bindBuffer ArrayBuffer $= Just (hud ^. hudVBO) diff --git a/src/Types.hs b/src/Types.hs index 451c094..115796a 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -76,6 +76,26 @@ data KeyboardState = KeyboardState { _arrowsPressed :: !ArrowKeyState } +-- | State in which all map-related Data is stored +-- +-- The map itself is rendered with mapProgram and the shaders given here directly +-- This does not include any objects on the map - only the map itself +-- +-- _mapTextures must contain the following Textures (in this ordering) after initialisation: +-- +-- 1. Grass +-- +-- 2. Sand +-- +-- 3. Water +-- +-- 4. Stone +-- +-- 5. Snow +-- +-- 6. Dirt (blended on grass) + + data GLMapState = GLMapState { _shdrVertexIndex :: !GL.AttribLocation , _shdrColorIndex :: !GL.AttribLocation @@ -90,8 +110,9 @@ data GLMapState = GLMapState , _stateMap :: !GL.BufferObject , _mapVert :: !GL.NumArrayIndices , _mapProgram :: !GL.Program - , _mapTexture :: !TextureObject + , _renderedMapTexture :: !TextureObject --TODO: Probably move to UI? , _overviewTexture :: !TextureObject + , _mapTextures :: ![TextureObject] --TODO: Fix size on list? } data GLHud = GLHud @@ -147,3 +168,63 @@ $(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) + +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" +