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

Merge branch 'tessallation' of pwning.de:/pioneers into tessallation

Browse Source
This commit is contained in:
Nicole Dresselhaus 2014-04-26 13:56:58 +02:00
commit bd701dde65
11 changed files with 430 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
Pioneers.cabal
View File

@ -16,14 +16,15 @@ executable Pioneers
Map.Graphics, Map.Graphics,
Map.Creation, Map.Creation,
Map.StaticMaps, Map.StaticMaps,
IQM.Types, Importer.IQM.Types,
IQM.TestMain, Importer.IQM.TestMain,
IQM.Parser, Importer.IQM.Parser,
Render.Misc, Render.Misc,
Render.Render, Render.Render,
Render.RenderObject, Render.RenderObject,
Render.Types,
UI.Callbacks, UI.Callbacks,
Types, UI.Types,
UI.SurfaceOverlay UI.SurfaceOverlay
Types Types
main-is: Main.hs main-is: Main.hs
@ -45,7 +46,7 @@ executable Pioneers
SDL2 >= 0.1.0, SDL2 >= 0.1.0,
time >=1.4.0, time >=1.4.0,
GLUtil >= 0.7, GLUtil >= 0.7,
attoparsec >= 0.11.2 attoparsec >= 0.11.2,
other-modules: Render.Types attoparsec-binary >= 0.1
Default-Language: Haskell2010 Default-Language: Haskell2010

96
shaders/map/tessEval.shader
View File

@ -2,6 +2,101 @@
#extension GL_ARB_tessellation_shader : require #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; layout(triangles, equal_spacing, cw) in;
in vec3 tcPosition[]; in vec3 tcPosition[];
in vec4 tcColor[]; in vec4 tcColor[];
@ -38,6 +133,7 @@ void main()
float i2 = (1-gl_TessCoord.z)*gl_TessCoord.z * length(cross(tcNormal[2],tessNormal)); float i2 = (1-gl_TessCoord.z)*gl_TessCoord.z * length(cross(tcNormal[2],tessNormal));
float standout = i0+i1+i2; float standout = i0+i1+i2;
tePosition = tePosition+tessNormal*standout; tePosition = tePosition+tessNormal*standout;
tePosition = tePosition+0.05*snoise(tePosition);
gl_Position = ProjectionMatrix * ViewMatrix * vec4(tePosition, 1); gl_Position = ProjectionMatrix * ViewMatrix * vec4(tePosition, 1);
fogDist = gl_Position.z; fogDist = gl_Position.z;

191
src/Importer/IQM/Parser.hs
View File

@ -8,84 +8,98 @@ module Importer.IQM.Parser (parseIQM) where
import Importer.IQM.Types import Importer.IQM.Types
import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.ByteString import Data.Attoparsec.ByteString
import Data.Attoparsec.Binary
import Data.ByteString.Char8 (pack) 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.Word
import Data.Int import Data.Int
import Unsafe.Coerce import Unsafe.Coerce
import Control.Monad.Trans.State import Control.Monad.Trans.State
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad import Control.Monad
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Prelude as P hiding (take, null) import Prelude as P hiding (take, null)
-- | helper-function for creating an integral out of [8-Bit Ints] -- | helper-function for creating an integral out of [8-Bit Ints]
w8ToInt :: Integral a => a -> a -> a _w8ToInt :: Integral a => a -> a -> a
w8ToInt i add = 256*i + add _w8ToInt i add = 256*i + add
-- | shorthand-function for parsing Word8 into Integrals -- | shorthand-function for parsing Word8 into Integrals
parseNum :: (Integral a, Integral b) => [a] -> b _parseNum :: (Integral a, Integral b) => [a] -> b
parseNum = (foldl1 w8ToInt) . map fromIntegral _parseNum = foldl1 _w8ToInt . map fromIntegral
-- | read a 16-Bit Int from Parsing-Input and log 2 bytes in our Parsing-Monad -- | 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! -- begins with _ to defeat ghc-warnings. Rename if used!
_int16 :: CParser Int16 _int16 :: CParser Word16
_int16 = do _int16 = do
ret <- lift $ do ret <- lift $ do
a <- anyWord8 :: Parser Word8 a <- anyWord8 :: Parser Word8
b <- anyWord8 :: Parser Word8 b <- anyWord8 :: Parser Word8
return $ parseNum [b,a] return $ _parseNum [b,a]
modify (+2) modify (+2)
return ret return ret
-- | read a 32-Bit Int from Parsing-Input and log 4 bytes in our Parsing-Monad -- | read a 32-Bit Int from Parsing-Input and log 4 bytes in our Parsing-Monad
int32 :: CParser Int32 _int32 :: CParser Int32
int32 = do _int32 = do
ret <- lift $ do ret <- lift $ do
a <- anyWord8 :: Parser Word8 a <- anyWord8 :: Parser Word8
b <- anyWord8 :: Parser Word8 b <- anyWord8 :: Parser Word8
c <- anyWord8 :: Parser Word8 c <- anyWord8 :: Parser Word8
d <- anyWord8 :: Parser Word8 d <- anyWord8 :: Parser Word8
return $ parseNum [d,c,b,a] return $ _parseNum [d,c,b,a]
modify (+4) modify (+4)
return $ ret return ret
w32leCParser :: CParser Word32
w32leCParser = do
ret <- lift anyWord32le
modify (+4)
return ret
-- | Parser for the header -- | Parser for the header
readHeader :: CParser IQMHeader readHeader :: CParser IQMHeader
readHeader = do readHeader = do
_ <- lift $ string (pack "INTERQUAKEMODEL\0") _ <- lift $ string (pack "INTERQUAKEMODEL\0")
v <- int32 modify (+16)
-- when v /= 2 then --TODO: error something v <- w32leCParser
size' <- int32 lift $ when (v /= 2) $ fail "Version /= 2.\nThis Parser only supports Version 2 of the InterQuake-Model IQM"
flags' <- int32 -- when v /= 2 then fail parsing.
num_text' <- int32 size' <- w32leCParser
ofs_text' <- int32 flags' <- w32leCParser
num_meshes' <- int32 num_text' <- w32leCParser
ofs_meshes' <- int32 ofs_text' <- w32leCParser
num_vertexarrays' <- int32 num_meshes' <- w32leCParser
num_vertexes' <- int32 ofs_meshes' <- w32leCParser
ofs_vertexarrays' <- int32 num_vertexarrays' <- w32leCParser
num_triangles' <- int32 num_vertexes' <- w32leCParser
ofs_triangles' <- int32 ofs_vertexarrays' <- w32leCParser
ofs_adjacency' <- int32 num_triangles' <- w32leCParser
num_joints' <- int32 ofs_triangles' <- w32leCParser
ofs_joints' <- int32 ofs_adjacency' <- w32leCParser
num_poses' <- int32 num_joints' <- w32leCParser
ofs_poses' <- int32 ofs_joints' <- w32leCParser
num_anims' <- int32 num_poses' <- w32leCParser
ofs_anims' <- int32 ofs_poses' <- w32leCParser
num_frames' <- int32 num_anims' <- w32leCParser
num_framechannels' <- int32 ofs_anims' <- w32leCParser
ofs_frames' <- int32 num_frames' <- w32leCParser
ofs_bounds' <- int32 num_framechannels' <- w32leCParser
num_comment' <- int32 ofs_frames' <- w32leCParser
ofs_comment' <- int32 ofs_bounds' <- w32leCParser
num_extensions' <- int32 num_comment' <- w32leCParser
ofs_extensions' <- int32 ofs_comment' <- w32leCParser
num_extensions' <- w32leCParser
ofs_extensions' <- w32leCParser
return IQMHeader { version = v return IQMHeader { version = v
, filesize = size' , filesize = size'
, flags = flags' , flags = fromIntegral flags'
, num_text = num_text' , num_text = num_text'
, ofs_text = ofs_text' , ofs_text = ofs_text'
, num_meshes = num_meshes' , num_meshes = num_meshes'
@ -115,12 +129,12 @@ readHeader = do
-- | Parser for Mesh-Structure -- | Parser for Mesh-Structure
readMesh :: CParser IQMMesh readMesh :: CParser IQMMesh
readMesh = do readMesh = do
name <- int32 name <- w32leCParser
mat <- int32 mat <- w32leCParser
fv <- int32 fv <- w32leCParser
nv <- int32 nv <- w32leCParser
ft <- int32 ft <- w32leCParser
nt <- int32 nt <- w32leCParser
return IQMMesh return IQMMesh
{ meshName = if name == 0 then Nothing else Just (Mesh name) { meshName = if name == 0 then Nothing else Just (Mesh name)
, meshMaterial = mat , meshMaterial = mat
@ -140,12 +154,32 @@ readMeshes n = do
ms <- readMeshes (n-1) ms <- readMeshes (n-1)
return $ m:ms 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 -- | helper-Notation for subtracting 2 integral values of different kind in the precision
-- of the target-kind -- of the target-kind
(.-) :: forall a a1 a2. (.-) :: forall a a1 a2.
(Num a, Integral a2, Integral a1) => (Num a, Integral a2, Integral a1) =>
a1 -> a2 -> a a1 -> a2 -> a
(.-) a b = (fromIntegral a) - (fromIntegral b) (.-) a b = fromIntegral a - fromIntegral b
infix 5 .- infix 5 .-
@ -162,18 +196,53 @@ skipToCounter a = do
put d put d
-- | Parses an IQM-File and handles back the Haskell-Structure -- | Parses an IQM-File and handles back the Haskell-Structure
parseIQM :: CParser IQM parseIQM :: String -> IO IQM
parseIQM = do parseIQM a =
put 0 --start at offset 0 do
h <- readHeader --read header f <- B.readFile a
skipToCounter $ ofs_text h --skip 0-n bytes to get to text putStrLn "Before Parse:"
text <- lift . take . fromIntegral $ num_text h --read texts putStrLn $ show f
modify . (+) . fromIntegral $ num_text h --put offset forward putStrLn "Real Parse:"
skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes r <- return $ parse doIQMparse f
meshes' <- readMeshes (fromIntegral (num_meshes h)) --read meshes raw <- case r of
return IQM Done _ x -> return x
{ header = h y -> error $ show y
, texts = filter (not.null) (split (unsafeCoerce '\0') text) let ret = raw
, meshes = meshes' 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

195
src/Importer/IQM/Types.hs
View File

@ -1,19 +1,31 @@
-- | Int32 or Int64 - depending on implementation. Format just specifies "uint". {-# LANGUAGE ExistentialQuantification, RankNTypes, CPP, BangPatterns #-}
-- 4-Byte in the documentation indicates Int32 - but not specified! -- | 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 module Importer.IQM.Types where
import Control.Monad.Trans.State.Lazy (StateT)
import Data.Int import Data.Int
import Data.Word
import Data.ByteString import Data.ByteString
import Data.Attoparsec.ByteString.Char8 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 -- | 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 -- | State-Wrapped Parser-Monad which is capable of counting the
-- Bytes read for offset-gap reasons -- Bytes read for offset-gap reasons
type CParser a = StateT Int64 Parser a 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. -- | Header of IQM-Format.
-- --
@ -23,33 +35,33 @@ type CParser a = StateT Int64 Parser a
-- --
-- ofs_* fields are aligned at 4-byte-boundaries -- ofs_* fields are aligned at 4-byte-boundaries
data IQMHeader = IQMHeader data IQMHeader = IQMHeader
{ version :: Int32 -- ^ Must be 2 { version :: !Word32 -- ^ Must be 2
, filesize :: Int32 , filesize :: !Word32
, flags :: Int32 , flags :: !Flags
, num_text :: Int32 , num_text :: !Word32
, ofs_text :: Int32 , ofs_text :: !Offset
, num_meshes :: Int32 , num_meshes :: !Word32
, ofs_meshes :: Int32 , ofs_meshes :: !Offset
, num_vertexarrays :: Int32 , num_vertexarrays :: !Word32
, num_vertexes :: Int32 , num_vertexes :: !Word32
, ofs_vertexarrays :: Int32 , ofs_vertexarrays :: !Offset
, num_triangles :: Int32 , num_triangles :: !Word32
, ofs_triangles :: Int32 , ofs_triangles :: !Offset
, ofs_adjacency :: Int32 , ofs_adjacency :: !Offset
, num_joints :: Int32 , num_joints :: !Word32
, ofs_joints :: Int32 , ofs_joints :: !Offset
, num_poses :: Int32 , num_poses :: !Word32
, ofs_poses :: Int32 , ofs_poses :: !Offset
, num_anims :: Int32 , num_anims :: !Word32
, ofs_anims :: Int32 , ofs_anims :: !Offset
, num_frames :: Int32 , num_frames :: !Word32
, num_framechannels :: Int32 , num_framechannels :: !Word32
, ofs_frames :: Int32 , ofs_frames :: !Offset
, ofs_bounds :: Int32 , ofs_bounds :: !Offset
, num_comment :: Int32 , num_comment :: !Word32
, ofs_comment :: Int32 , ofs_comment :: !Offset
, num_extensions :: Int32 -- ^ stored as linked list, not as array. , num_extensions :: !Word32 -- ^ stored as linked list, not as array.
, ofs_extensions :: Int32 , ofs_extensions :: !Offset
} deriving (Show, Eq) } deriving (Show, Eq)
-- | Format of an IQM-Mesh Structure. -- | 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 -- Read it like a Header of the Meshes lateron in the Format
data IQMMesh = IQMMesh data IQMMesh = IQMMesh
{ meshName :: Maybe Mesh { meshName :: Maybe Mesh
, meshMaterial :: Int32 , meshMaterial :: Word32
, meshFirstVertex :: Int32 , meshFirstVertex :: Word32
, meshNumVertexes :: Int32 , meshNumVertexes :: Word32
, meshFirstTriangle :: Int32 , meshFirstTriangle :: Word32
, meshNumTriangles :: Int32 , meshNumTriangles :: Word32
} deriving (Show, Eq) } 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 -- | Format of a whole IQM-File
-- --
-- still unfinished! -- still unfinished!
@ -71,5 +99,98 @@ data IQM = IQM
{ header :: IQMHeader { header :: IQMHeader
, texts :: [ByteString] , texts :: [ByteString]
, meshes :: [IQMMesh] , meshes :: [IQMMesh]
, vertexArrays :: [IQMVertexArray]
} deriving (Show, Eq) } 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 ++
")"

17
src/Main.hs
View File

@ -16,7 +16,6 @@ import Control.Concurrent.STM (TQueue,
newTQueueIO) newTQueueIO)
import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify)
import Control.Monad.Trans.State (evalStateT)
import Data.Functor ((<$>)) import Data.Functor ((<$>))
import Data.Monoid (mappend) import Data.Monoid (mappend)
@ -46,17 +45,21 @@ import UI.Callbacks
import Map.Graphics import Map.Graphics
import Types import Types
import Importer.IQM.Parser import Importer.IQM.Parser
import Data.Attoparsec.Char8 (parseTest) --import Data.Attoparsec.Char8 (parseTest)
import qualified Data.ByteString as B --import qualified Data.ByteString as B
-- import qualified Debug.Trace as D (trace) -- import qualified Debug.Trace as D (trace)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
testParser :: IO () testParser :: String -> IO ()
testParser = do testParser a = putStrLn . show =<< parseIQM a
f <- B.readFile "sample.iqm" {-do
parseTest (evalStateT parseIQM 0) f f <- B.readFile a
putStrLn "reading in:"
putStrLn $ show f
putStrLn "parsed:"
parseTest parseIQM f-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

10
src/Map/Combinators.hs
View File

@ -8,13 +8,13 @@ import System.Random
-- preliminary -- preliminary
infix 5 ->- infix 5 ->-
(->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) (->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
f ->- g = (g . f) f ->- g = g . f
-- also preliminary -- also preliminary
infix 5 -<- infix 5 -<-
(-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) (-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
f -<- g = (f . g) f -<- g = f . g
lake :: Int -> PlayMap -> PlayMap lake :: Int -> PlayMap -> PlayMap
lake = undefined 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 -- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map
liftUp :: (Int, Int) -> Node -> Node liftUp :: (Int, Int) -> Node -> Node
liftUp (gx,gz) (Full (x,z) y _ b pl pa r s) = let y_neu = max y e 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) 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 [] 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) where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z)

3
src/Map/Creation.hs
View File

@ -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)) 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 :: [a -> a] -> a -> a
aplAll [] m = m aplAll fs m = foldl (\ m f -> f m) m fs
aplAll (f:fs) m = aplAll fs $ f m
-- general 3D-Gaussian -- general 3D-Gaussian
gauss3Dgeneral :: Floating q => gauss3Dgeneral :: Floating q =>

5
src/Map/Graphics.hs
View File

@ -27,6 +27,7 @@ import Foreign.Storable (sizeOf)
import Foreign.Ptr (Ptr, nullPtr, plusPtr) import Foreign.Ptr (Ptr, nullPtr, plusPtr)
import Render.Misc (checkError) import Render.Misc (checkError)
import Linear import Linear
import Control.Arrow ((***))
import Map.Types import Map.Types
import Map.StaticMaps import Map.StaticMaps
@ -43,7 +44,7 @@ type GraphicsMap = Array (Int, Int) MapEntry
-- converts from classical x/z to striped version of a map -- converts from classical x/z to striped version of a map
convertToStripeMap :: PlayMap -> PlayMap 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 where
(l,u) = bounds mp (l,u) = bounds mp
@ -77,7 +78,7 @@ bufferObjectPtr = plusPtr (nullPtr :: Ptr GLfloat) . fromIntegral
mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor GLfloat mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor GLfloat
mapVertexArrayDescriptor count' offset = 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 :: (IntegerHandling, VertexArrayDescriptor GLfloat)
fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 0) --color first fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 0) --color first

2
src/Map/Map.hs
View File

@ -34,7 +34,7 @@ giveNeighbourhood :: PlayMap -- ^ map on which to find neighbourhood
-> [(Int, Int)] -- ^ neighbourhood -> [(Int, Int)] -- ^ neighbourhood
giveNeighbourhood _ 0 (a,b) = [(a,b)] giveNeighbourhood _ 0 (a,b) = [(a,b)]
giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in 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 -- removing duplicates in O(n log n), losing order and adding Ord requirement
remdups :: Ord a => [a] -> [a] remdups :: Ord a => [a] -> [a]

33
src/Map/StaticMaps.hs
View File

@ -7,17 +7,17 @@ import Map.Creation
-- entirely empty map, only uses the minimal constructor -- entirely empty map, only uses the minimal constructor
mapEmpty :: PlayMap 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 :: PlayMap
mapCenterMountain = array ((0,0),(199,199)) nodes mapCenterMountain = array ((0,0),(199,199)) nodes
where where
nodes = water ++ beach ++ grass ++ hill ++ mountain 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] 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] 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] 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] 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] 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 :: Int -> Int -> Float
g2d x y = gauss3D (fromIntegral x) (fromIntegral y) 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 -- small helper for some hills. Should be replaced by multi-layer perlin-noise
-- TODO: Replace as given in comment. -- TODO: Replace as given in comment.
_noisyMap :: (Floating q) => q -> q -> q _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 10.0 10.0 10.0 10.0 x y
+ gauss3Dgeneral 5 150.0 120.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 + 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 :: PlayMap
mapNoise = array ((0,0),(199,199)) nodes mapNoise = array ((0,0),(199,199)) nodes
where where
nodes = [((a,b), (Full nodes = [((a,b), Full (a,b)
(a,b) (height a b)
(height a b) (heightToTerrain GrassIslandMap $ height a b)
(heightToTerrain GrassIslandMap $ height a b) BNothing
BNothing NoPlayer
NoPlayer NoPath
NoPath Plain
Plain []) | a <- [0..199], b <- [0..199]]
[])) | a <- [0..199], b <- [0..199]]
where where
height a b = (_noisyMap (fromIntegral a) (fromIntegral b)) height a b = _noisyMap (fromIntegral a) (fromIntegral b)

6
src/Map/Types.hs
View File

@ -20,7 +20,7 @@ data PlayerInfo = NoPlayer
instance Show PlayerInfo where instance Show PlayerInfo where
show (NoPlayer) = "not occupied" 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? -- | Path info, is this node part of a path and if so, where does it lead?
data PathInfo = NoPath data PathInfo = NoPath
@ -34,7 +34,7 @@ data ResInfo = Plain
instance Show ResInfo where instance Show ResInfo where
show (Plain) = "no resources" 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? -- | What commodities are currently stored here?
type StorInfo = [(Commodity,Amount)] type StorInfo = [(Commodity,Amount)]
@ -49,7 +49,7 @@ data BuildInfo = BStruc Structure
| BLarge | BLarge
instance Show BuildInfo where instance Show BuildInfo where
show (BStruc s) = "Structure: " ++ (show s) show (BStruc s) = "Structure: " ++ show s
show (BNothing) = "no Structure possible" show (BNothing) = "no Structure possible"
show (BFlag) = "only flags possible" show (BFlag) = "only flags possible"
show (BMine) = "mines possible" show (BMine) = "mines possible"