diff --git a/Pioneers.cabal b/Pioneers.cabal index 6bc84b9..916f8bd 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 @@ -45,7 +46,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/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..e330f19 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,53 @@ 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' - } +parseIQM :: String -> IO IQM +parseIQM a = + do + f <- B.readFile a + putStrLn "Before Parse:" + putStrLn $ show f + putStrLn "Real Parse:" + r <- return $ parse doIQMparse f + raw <- case r of + Done _ x -> return x + y -> error $ show y + let ret = raw + return ret +readInVAO :: IQMVertexArray -> ByteString -> IO IQMVertexArray +readInVAO (IQMVertexArray type' a format num offset ptr) d = + do + let + byteLen = (fromIntegral num)*(vaSize format) + data' = skipDrop (fromIntegral offset) byteLen d + + when (not (ptr == nullPtr)) $ error $ "Error reading Vertex-Array: Double Read of " ++ show type' + p <- mallocBytes byteLen + unsafeUseAsCString data' (\s -> copyBytes p s byteLen) + p' <- unsafeCoerce p + return (IQMVertexArray type' a format num offset p') + +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 + + _ <- lift takeByteString + return IQM + { header = h + , texts = filter (not.null) (split (unsafeCoerce '\0') text) + , meshes = meshes' + , vertexArrays = vaf + } + +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..3558660 100644 --- a/src/Importer/IQM/Types.hs +++ b/src/Importer/IQM/Types.hs @@ -1,19 +1,31 @@ --- | 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 +import Foreign.Marshal.Array -- | 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 - +type Flags = GLbitfield -- ^ Alias for UInt32 +type Offset = Word32 -- ^ Alias for UInt32 +type Index = GLuint -- ^ Alias for UInt32 +type NumComponents = GLsizei -- ^ Alias for UInt32 +type IQMData = Ptr IQMVertexArrayFormat -- ^ Pointer for Data -- | Header of IQM-Format. -- @@ -23,33 +35,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 +69,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 +99,98 @@ 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) + +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 +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 _) = "IQMVertexArray (Type: " ++ show t ++ + ", Flags: " ++ show fl ++ + ", Format: " ++ show fo ++ + ", NumComponents: " ++ show nc ++ + ", Offset: " ++ show off ++ + ")" + diff --git a/src/Main.hs b/src/Main.hs index e00587e..932142b 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-} -------------------------------------------------------------------------------- diff --git a/src/Map/Combinators.hs b/src/Map/Combinators.hs index 3e143c2..9dabb89 100644 --- a/src/Map/Combinators.hs +++ b/src/Map/Combinators.hs @@ -8,13 +8,13 @@ import System.Random -- preliminary infix 5 ->- -(->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -f ->- g = (g . f) +(->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap +f ->- g = g . f -- also preliminary infix 5 -<- -(-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -f -<- g = (f . g) +(-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap +f -<- g = f . g lake :: Int -> PlayMap -> PlayMap lake = undefined @@ -40,7 +40,7 @@ gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp -- 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) + 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 04d018d..d677cdd 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -31,8 +31,7 @@ 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 [] m = m -aplAll (f:fs) m = aplAll fs $ f m +aplAll fs m = foldl (\ m f -> f m) m fs -- general 3D-Gaussian gauss3Dgeneral :: Floating q => diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index bf1dcfe..5cc198a 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -27,6 +27,7 @@ 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 @@ -43,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 @@ -77,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 diff --git a/src/Map/Map.hs b/src/Map/Map.hs index b88a3b8..e358cee 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -34,7 +34,7 @@ giveNeighbourhood :: PlayMap -- ^ map on which to find neighbourhood -> [(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) + 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] diff --git a/src/Map/StaticMaps.hs b/src/Map/StaticMaps.hs index 9507a82..74ea371 100644 --- a/src/Map/StaticMaps.hs +++ b/src/Map/StaticMaps.hs @@ -7,17 +7,17 @@ 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]] 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) @@ -28,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 @@ -38,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 66ddb4a..c62837f 100644 --- a/src/Map/Types.hs +++ b/src/Map/Types.hs @@ -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"