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

Merge branch 'master' into ui

Browse Source 
Conflicts:
	src/Types.hs
This commit is contained in:
tpajenka 2014-04-26 20:02:01 +02:00
commit 106f50c08d
17 changed files with 744 additions and 286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
.gitignore vendored
View File

@ -1,3 +1,11 @@
/.dist-buildwrapper
/.project
/.settings
.cabal-sandbox
*.trace
cabal.sandbox.config
deps/hsSDL2*
deps/*.deb
dist/*
*.swp

13
Pioneers.cabal
View File

@ -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

4
README
View File

@ -1,4 +0,0 @@
Pioneers
========
A Settlers II inspired game written in Haskell

39
README.md Normal file
View File

@ -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

96
shaders/map/tessEval.shader
View File

@ -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;

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

@ -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

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

@ -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 ++
")"

40
src/Main.hs
View File

@ -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.

46
src/Map/Combinators.hs Normal file
View File

@ -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)

54
src/Map/Creation.hs
View File

@ -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

12
src/Map/Graphics.hs
View File

@ -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]

43
src/Map/Map.hs
View File

@ -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

59
src/Map/StaticMaps.hs
View File

@ -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)

10
src/Map/Types.hs
View File

@ -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)

62
src/PioneerTypes.hs
View File

@ -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"

54
src/Render/Render.hs
View File

@ -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)

83
src/Types.hs
View File

@ -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"