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

Merge branch 'testing' into Mapping

Browse Source
This commit is contained in:
Jonas Betzendahl 2014-04-28 23:35:14 +02:00
commit 49518e3006
16 changed files with 886 additions and 375 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 /.dist-buildwrapper
/.project /.project
/.settings /.settings
.cabal-sandbox
*.trace
cabal.sandbox.config
deps/hsSDL2*
deps/*.deb
dist/*
*.swp

47
Pioneers.cabal
View File

@ -11,20 +11,20 @@ executable Pioneers
} else { } else {
ghc-options: -Wall -Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3 -fllvm ghc-options: -Wall -Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3 -fllvm
} }
other-module other-modules:
Map.Map,
Map.Combinators,
Map.Types, Map.Types,
Map.Graphics, Map.Graphics,
Map.Creation, Map.Creation,
Map.StaticMaps, Map.StaticMaps,
IQM.Types, Importer.IQM.Types,
IQM.TestMain, Importer.IQM.Parser,
IQM.Parser,
Render.Misc, Render.Misc,
Render.Render, Render.Render,
Render.RenderObject, Render.RenderObject,
Render.Types,
UI.Callbacks, UI.Callbacks,
Types,
UI.SurfaceOverlay
Types Types
main-is: Main.hs main-is: Main.hs
build-depends: build-depends:
@ -36,6 +36,8 @@ executable Pioneers
array >=0.4, array >=0.4,
random >=1.0.1, random >=1.0.1,
transformers >=0.3.0, transformers >=0.3.0,
unordered-containers >= 0.2.1,
hashable >= 1.0.1.1,
mtl >=2.1.2, mtl >=2.1.2,
stm >=2.4.2, stm >=2.4.2,
vector >=0.10.9 && <0.11, vector >=0.10.9 && <0.11,
@ -45,7 +47,36 @@ 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
test-suite QuickCheckTests
type: exitcode-stdio-1.0
hs-source-dirs: tests, src
main-is: MainTestSuite.hs
build-depends: base,
OpenGL >=2.9,
bytestring >=0.10,
OpenGLRaw >=1.4,
text >=0.11,
array >=0.4,
random >=1.0.1,
transformers >=0.3.0,
unordered-containers >= 0.2.1,
hashable >= 1.0.1.1,
mtl >=2.1.2,
stm >=2.4.2,
vector >=0.10.9 && <0.11,
distributive >=0.3.2,
linear >=1.3.1,
lens >=4.0,
SDL2 >= 0.1.0,
time >=1.4.0,
GLUtil >= 0.7,
attoparsec >= 0.11.2,
attoparsec-binary >= 0.1,
QuickCheck,
test-framework,
test-framework-quickcheck2
Default-Language: Haskell2010

4
README
View File

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

38
README.md Normal file
View File

@ -0,0 +1,38 @@
# 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 libsdl2-dev libghc-llvm-dev` - 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 #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;

207
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,69 @@ 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 = do -- Does a 2-Pass-Parsing. Reads in Structure on first pass (O(n))and
put 0 --start at offset 0 -- fills the Structure in a 2nd Pass from Offsets (O(memcpy'd bytes)).
h <- readHeader --read header parseIQM :: String -> IO IQM
skipToCounter $ ofs_text h --skip 0-n bytes to get to text parseIQM a =
text <- lift . take . fromIntegral $ num_text h --read texts do
modify . (+) . fromIntegral $ num_text h --put offset forward f <- B.readFile a
skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes -- Parse Headers/Offsets
meshes' <- readMeshes (fromIntegral (num_meshes h)) --read meshes let result = parse doIQMparse f
return IQM raw <- case result of
{ header = h Done _ x -> return x
, texts = filter (not.null) (split (unsafeCoerce '\0') text) y -> error $ show y
, meshes = meshes' -- 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". -- {-# 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
-- | 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
-- | 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. -- | Header of IQM-Format.
-- --
@ -23,33 +43,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 +77,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 +107,97 @@ 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)
-- | 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 ++
")"

43
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-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -82,9 +85,7 @@ main =
(Size fbWidth fbHeight) <- glGetDrawableSize window' (Size fbWidth fbHeight) <- glGetDrawableSize window'
initRendering initRendering
--generate map vertices --generate map vertices
(mapBuffer, vert) <- getMapBufferObject glMap' <- initMapShader 4 =<< getMapBufferObject
(mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader
overTex <- GL.genObjectName
print window' print window'
eventQueue <- newTQueueIO :: IO (TQueue Event) eventQueue <- newTQueueIO :: IO (TQueue Event)
putStrLn "foo" putStrLn "foo"
@ -103,29 +104,13 @@ main =
far = 500 --far plane far = 500 --far plane
ratio = fromIntegral fbWidth / fromIntegral fbHeight ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio frust = createFrustum fov near far ratio
(guiMap, guiRoots) = createGUI
aks = ArrowKeyState { aks = ArrowKeyState {
_up = False _up = False
, _down = False , _down = False
, _left = False , _left = False
, _right = 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 env = Env
{ _eventsChan = eventQueue { _eventsChan = eventQueue
, _windowObject = window' , _windowObject = window'
@ -174,6 +159,8 @@ main =
} }
, _ui = UIState , _ui = UIState
{ _uiHasChanged = True { _uiHasChanged = True
, _uiMap = guiMap
, _uiRoots = guiRoots
} }
} }
@ -302,7 +289,7 @@ adjustWindow = do
let hudtexid = state ^. gl.glHud.hudTexture let hudtexid = state ^. gl.glHud.hudTexture
maptexid = state ^. gl.glMap.mapTexture maptexid = state ^. gl.glMap.renderedMapTexture
allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do
--default to ugly pink to see if --default to ugly pink to see if
--somethings go wrong. --somethings go wrong.

2
src/Map/Map.hs
View File

@ -40,5 +40,5 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in
remdups :: Ord a => [a] -> [a] remdups :: Ord a => [a] -> [a]
remdups = map head . group . sort remdups = map head . group . sort
prop_rd_idempot :: Ord a => [a] -> Bool prop_rd_idempot :: [Int] -> Bool
prop_rd_idempot xs = remdups xs == (remdups . remdups) xs prop_rd_idempot xs = remdups xs == (remdups . remdups) xs

54
src/Render/Render.hs
View File

@ -50,22 +50,11 @@ initBuffer varray =
checkError "initBuffer" checkError "initBuffer"
return bufferObject return bufferObject
initMapShader :: IO ( initMapShader ::
Program -- the GLSL-Program Int -- ^ initial Tessallation-Factor
, AttribLocation -- color -> (BufferObject,NumArrayIndices) -- ^ Buffer with Data and DataDescriptor
, AttribLocation -- normal -> IO GLMapState
, AttribLocation -- vertex initMapShader tessFac (buf, vertDes) = do
, 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
! vertexSource <- B.readFile mapVertexShaderFile ! vertexSource <- B.readFile mapVertexShaderFile
! tessControlSource <- B.readFile mapTessControlShaderFile ! tessControlSource <- B.readFile mapTessControlShaderFile
! tessEvalSource <- B.readFile mapTessEvalShaderFile ! tessEvalSource <- B.readFile mapTessEvalShaderFile
@ -120,9 +109,30 @@ initMapShader = do
putStrLn $ unlines $ ["Indices: ", show (colorIndex, normalIndex, vertexIndex)] putStrLn $ unlines $ ["Indices: ", show (colorIndex, normalIndex, vertexIndex)]
tex <- genObjectName tex <- genObjectName
overTex <- genObjectName
texts <- genObjectNames 6
checkError "initShader" 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 :: IO GLHud
initHud = do initHud = do
@ -193,13 +203,13 @@ renderOverview = do
DepthAttachment DepthAttachment
Renderbuffer Renderbuffer
(state ^. gl.glRenderbuffer) (state ^. gl.glRenderbuffer)
textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture) textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
framebufferTexture2D framebufferTexture2D
Framebuffer Framebuffer
(ColorAttachment 0) (ColorAttachment 0)
Texture2D Texture2D
(state ^. gl.glMap.mapTexture) (state ^. gl.glMap.renderedMapTexture)
0 0
-- Render to FrameBufferObject -- Render to FrameBufferObject
@ -285,13 +295,13 @@ render = do
DepthAttachment DepthAttachment
Renderbuffer Renderbuffer
(state ^. gl.glRenderbuffer) (state ^. gl.glRenderbuffer)
textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture) textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
framebufferTexture2D framebufferTexture2D
Framebuffer Framebuffer
(ColorAttachment 0) (ColorAttachment 0)
Texture2D Texture2D
(state ^. gl.glMap.mapTexture) (state ^. gl.glMap.renderedMapTexture)
0 0
-- Render to FrameBufferObject -- Render to FrameBufferObject
@ -371,7 +381,7 @@ render = do
uniform (hud ^. hudTexIndex) $= Index1 (0::GLint) uniform (hud ^. hudTexIndex) $= Index1 (0::GLint)
activeTexture $= TextureUnit 1 activeTexture $= TextureUnit 1
textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture) textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
uniform (hud ^. hudBackIndex) $= Index1 (1::GLint) uniform (hud ^. hudBackIndex) $= Index1 (1::GLint)
bindBuffer ArrayBuffer $= Just (hud ^. hudVBO) bindBuffer ArrayBuffer $= Just (hud ^. hudVBO)

32
src/Types.hs
View File

@ -5,12 +5,14 @@ import Control.Concurrent.STM (TQueue)
import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.GL as GL
import Graphics.UI.SDL as SDL (Event, Window) import Graphics.UI.SDL as SDL (Event, Window)
import Foreign.C (CFloat) import Foreign.C (CFloat)
import qualified Data.HashMap.Strict as Map
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Linear.Matrix (M44) import Linear.Matrix (M44)
import Control.Monad.RWS.Strict (RWST) import Control.Monad.RWS.Strict (RWST)
import Control.Lens import Control.Lens
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
import Render.Types import Render.Types
import UI.UIBaseData
--Static Read-Only-State --Static Read-Only-State
@ -74,6 +76,26 @@ data KeyboardState = KeyboardState
{ _arrowsPressed :: !ArrowKeyState { _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 data GLMapState = GLMapState
{ _shdrVertexIndex :: !GL.AttribLocation { _shdrVertexIndex :: !GL.AttribLocation
, _shdrColorIndex :: !GL.AttribLocation , _shdrColorIndex :: !GL.AttribLocation
@ -88,8 +110,9 @@ data GLMapState = GLMapState
, _stateMap :: !GL.BufferObject , _stateMap :: !GL.BufferObject
, _mapVert :: !GL.NumArrayIndices , _mapVert :: !GL.NumArrayIndices
, _mapProgram :: !GL.Program , _mapProgram :: !GL.Program
, _mapTexture :: !TextureObject , _renderedMapTexture :: !TextureObject --TODO: Probably move to UI?
, _overviewTexture :: !TextureObject , _overviewTexture :: !TextureObject
, _mapTextures :: ![TextureObject] --TODO: Fix size on list?
} }
data GLHud = GLHud data GLHud = GLHud
@ -112,6 +135,8 @@ data GLState = GLState
data UIState = UIState data UIState = UIState
{ _uiHasChanged :: !Bool { _uiHasChanged :: !Bool
, _uiMap :: Map.HashMap UIId (GUIAny Pioneers)
, _uiRoots :: [UIId]
} }
data State = State data State = State
@ -125,6 +150,9 @@ data State = State
, _ui :: !UIState , _ui :: !UIState
} }
type Pioneers = RWST Env () State IO
-- when using TemplateHaskell order of declaration matters
$(makeLenses ''State) $(makeLenses ''State)
$(makeLenses ''GLState) $(makeLenses ''GLState)
$(makeLenses ''GLMapState) $(makeLenses ''GLMapState)
@ -140,8 +168,6 @@ $(makeLenses ''Position)
$(makeLenses ''Env) $(makeLenses ''Env)
$(makeLenses ''UIState) $(makeLenses ''UIState)
type Pioneers = RWST Env () State IO
data Structure = Flag -- Flag data Structure = Flag -- Flag
| Woodcutter -- Huts | Woodcutter -- Huts
| Forester | Forester

120
src/UI/Callbacks.hs
View File

@ -1,52 +1,84 @@
{-# LANGUAGE ExistentialQuantification #-}
module UI.Callbacks where module UI.Callbacks where
import Control.Monad.Trans (liftIO)
import Types
import UI.UITypes
import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.GL as GL
import Control.Lens ((^.), (.~), (%~)) import Control.Lens ((^.), (.~))
import Render.Misc (genColorData) import Control.Monad (liftM)
import Control.Monad.RWS.Strict (get, modify)
import Control.Monad.Trans (liftIO)
import qualified Data.HashMap.Strict as Map
import Data.List (foldl')
import Data.Maybe
import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Alloc (allocaBytes)
import Control.Monad.RWS.Strict (get, liftIO, modify) import Render.Misc (genColorData)
import Types
import UI.UIBaseData
import UI.UIClasses
import UI.UIOperations
data Pixel = Pixel Int Int data Pixel = Pixel Int Int
getGUI :: [GUIAny] createGUI :: (Map.HashMap UIId (GUIAny Pioneers), [UIId])
getGUI = [ toGUIAny $ GUIContainer 0 0 120 80 [] 1 createGUI = (Map.fromList [ (UIId 0, GUIAnyP $ GUIPanel $ GUIContainer 0 0 0 0 [UIId 1, UIId 2] 0)
, toGUIAny $ GUIPanel $ GUIContainer 0 0 0 0 , (UIId 1, GUIAnyC $ GUIContainer 20 50 120 80 [] 1)
[toGUIAny $ GUIContainer 0 80 100 200 [] 4 , (UIId 2, GUIAnyP $ GUIPanel $ GUIContainer 100 140 0 0 [UIId 3, UIId 4] 3)
,toGUIAny $GUIButton 50 400 200 175 2 defaultUIState testMessage , (UIId 3, GUIAnyC $ GUIContainer 100 140 130 200 [] 4 )
] 3 , (UIId 4, GUIAnyB (GUIButton 30 200 60 175 2 defaultUIState ) (ButtonHandler testMessage))
] ], [UIId 0])
testMessage :: (Show w) => w -> ScreenUnit -> ScreenUnit -> IO w getGUI :: Map.HashMap UIId (GUIAny Pioneers) -> [GUIAny Pioneers]
getGUI hmap = Map.elems hmap
getRootIds :: Pioneers [UIId]
getRootIds = do
state <- get
return $ state ^. ui.uiRoots
getRoots :: Pioneers [GUIAny Pioneers]
getRoots = do
state <- get
rootIds <- getRootIds
let hMap = state ^. ui.uiMap
return $ toGUIAnys hMap rootIds
testMessage :: w -> ScreenUnit -> ScreenUnit -> Pioneers w
testMessage w x y = do testMessage w x y = do
putStrLn ("\tclick on " ++ show x ++ "," ++ show y) liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
return w return w
-- | Handler for UI-Inputs. -- | Handler for UI-Inputs.
-- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ... -- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
clickHandler :: Pixel -> Pioneers () clickHandler :: Pixel -> Pioneers ()
clickHandler (Pixel x y) = case concatMap (isInside x y) getGUI of clickHandler (Pixel x y) = do
[] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"] state <- get
hit -> liftIO $ do let hMap = state ^. ui.uiMap
_ <- sequence $ map (\w -> roots <- getRootIds
case w of hits <- liftM concat $ mapM (getInsideId hMap x y) roots
(GUIAnyB b h) -> do case hits of
putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w) [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
++ " at ["++show x++","++show y++"]" _ -> do
(b', h') <- onMousePressed x y b h changes <- sequence $ map (\uid -> do
_ <- onMouseReleased x y b' h' let w = toGUIAny hMap uid
return () short <- getShorthand w
_ -> putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w) bound <- getBoundary w
++ " at ["++show x++","++show y++"]" prio <- getPriority w
) hit liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio
return () ++ " at [" ++ show x ++ "," ++ show y ++ "]"
case w of
(GUIAnyB b h) -> do
(b', h') <- onMousePressed x y b h
(b'', h'') <- onMouseReleased x y b' h'
return $ Just (uid, GUIAnyB b'' h'')
_ -> return Nothing
) $ hits
let newMap :: Map.HashMap UIId (GUIAny Pioneers)
newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
modify $ ui.uiMap .~ newMap
return ()
-- | Handler for UI-Inputs. -- | Handler for UI-Inputs.
@ -67,36 +99,40 @@ alternateClickHandler (Pixel x y) = liftIO $ putStrLn $ unwords ["alternate pres
prepareGUI :: Pioneers () prepareGUI :: Pioneers ()
prepareGUI = do prepareGUI = do
state <- get state <- get
roots <- getRoots
let tex = (state ^. gl.glHud.hudTexture) let tex = (state ^. gl.glHud.hudTexture)
liftIO $ do liftIO $ do
-- bind texture - all later calls work on this one. -- bind texture - all later calls work on this one.
GL.textureBinding GL.Texture2D GL.$= Just tex GL.textureBinding GL.Texture2D GL.$= Just tex
mapM_ (copyGUI tex) getGUI mapM_ (copyGUI tex) roots
modify $ ui.uiHasChanged .~ False modify $ ui.uiHasChanged .~ False
--TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates.. --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
copyGUI :: GL.TextureObject -> GUIAny -> IO () copyGUI :: GL.TextureObject -> GUIAny Pioneers -> Pioneers ()
copyGUI tex widget = do copyGUI tex widget = do
let (xoff, yoff, width, height) = getBoundary widget (xoff, yoff, wWidth, wHeight) <- getBoundary widget
state <- get
let
hMap = state ^. ui.uiMap
int = fromInteger.toInteger --conversion between Int8, GLInt, Int, ... int = fromInteger.toInteger --conversion between Int8, GLInt, Int, ...
--temporary color here. lateron better some getData-function to --temporary color here. lateron better some getData-function to
--get a list of pixel-data or a texture. --get a list of pixel-data or a texture.
color = case widget of color = case widget of
(GUIAnyC _) -> [255,0,0,128] (GUIAnyC _) -> [255,0,0,128]
(GUIAnyB _ _) -> [255,255,0,255] (GUIAnyB _ _) -> [255,255,0,255]
(GUIAnyP _) -> [128,128,128,255] (GUIAnyP _) -> [128,128,128,128]
_ -> [255,0,255,255] _ -> [255,0,255,255]
allocaBytes (width*height*4) $ \ptr -> do liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do
--copy data into C-Array --copy data into C-Array
pokeArray ptr (genColorData (width*height) color) pokeArray ptr (genColorData (wWidth*wHeight) color)
GL.texSubImage2D GL.texSubImage2D
GL.Texture2D GL.Texture2D
0 0
(GL.TexturePosition2D (int xoff) (int yoff)) (GL.TexturePosition2D (int xoff) (int yoff))
(GL.TextureSize2D (int width) (int height)) (GL.TextureSize2D (int wWidth) (int wHeight))
(GL.PixelData GL.RGBA GL.UnsignedByte ptr) (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
mapM_ (copyGUI tex) (getChildren widget) nextChildrenIds <- getChildren widget
copyGUI _ _ = return () mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds
--TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
--TODO: Maybe queues are better? --TODO: Maybe queues are better?

74
src/UI/UIBaseData.hs Normal file
View File

@ -0,0 +1,74 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- data and classes are separated into several modules to avoid cyclic dependencies with the Type module
module UI.UIBaseData where
import Data.Hashable
import Data.Ix
-- |Unit of screen/window
type ScreenUnit = Int
newtype UIId = UIId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable)
-- |The state of a clickable ui widget.
data UIButtonState = UIButtonState
{ _buttonstateIsFiring :: Bool
-- ^firing if pressed but not confirmed
, _buttonstateIsFiringAlt :: Bool
-- ^firing if pressed but not confirmed (secondary mouse button)
, _buttonstateIsDeferred :: Bool -- ^ deferred if e. g. dragging but outside component
, _buttonstateIsDeferredAlt :: Bool
-- ^deferred if e. g. dragging but outside component (secondary mouse button)
, _buttonstateIsReady :: Bool
-- ^ready if mouse is above component
, _buttonstateIsActivated :: Bool
-- ^in activated state (e. g. toggle button)
} deriving (Eq, Show)
-- |Switches primary and secondary mouse actions.
-- "monad type" "widget type" "original handler"
data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show)
-- |A 'UI.UIClasses.MouseHandler' with button behaviour.
data ButtonHandler m w = ButtonHandler
{ _action :: (w -> ScreenUnit -> ScreenUnit -> m w) }
instance Show (ButtonHandler m w) where
show _ = "ButtonHandler ***"
-- |A collection data type that may hold any usable ui element. @m@ is a monad.
data GUIAny m = GUIAnyC GUIContainer
| GUIAnyP GUIPanel
| GUIAnyB GUIButton (ButtonHandler m GUIButton)
deriving (Show)
-- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a
-- functionality itself.
data GUIContainer = GUIContainer { _uiScreenX :: ScreenUnit, _uiScreenY :: ScreenUnit
, _uiWidth :: ScreenUnit, _uiHeight :: ScreenUnit
, _uiChildren :: [UIId]
, _uiPriority :: Int
} deriving (Show)
-- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its
-- children components.
data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show)
-- |A 'GUIButton' is a clickable 'GUIWidget'. Its functinality must be
-- provided by an appropriate 'MouseHanlder'.
data GUIButton = GUIButton { _uiScreenXB :: ScreenUnit, _uiScreenYB :: ScreenUnit
, _uiWidthB :: ScreenUnit, _uiHeightB :: ScreenUnit
, _uiPriorityB :: Int
, _uiButtonState :: UIButtonState
} deriving ()
instance Show GUIButton where
show w = "GUIButton {_screenXB = " ++ show (_uiScreenXB w)
++ " _screenYB = " ++ show (_uiScreenYB w)
++ " _widthB = " ++ show (_uiWidthB w)
++ " _heightB = " ++ show (_uiHeightB w)
++ " _priorityB = " ++ show (_uiScreenYB w)
++ " _buttonState = " ++ show (_uiButtonState w)
++ "}"

235
src/UI/UITypes.hs → src/UI/UIClasses.hs
View File

@ -1,98 +1,54 @@
{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-} {-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
module UI.UITypes where module UI.UIClasses where
import Data.List import Control.Lens ((^.))
import Foreign.C (CFloat) import Control.Monad
import Linear.Matrix (M44) --import Control.Monad.IO.Class -- MonadIO
import Control.Monad.RWS.Strict (get)
import Data.List
import Data.Maybe
import qualified Data.HashMap.Strict as Map
-- |Unit of screen/window import qualified Types as T
type ScreenUnit = Int import UI.UIBaseData
-- |A viewport to an OpenGL scene. class GUIAnyMap m w where
data Viewport = Viewport guiAnyMap :: (w -> b) -> GUIAny m -> b
{ _viewportXAngle :: !Double
, _viewportYAngle :: !Double
, _viewportZDist :: !Double
, _viewportFrustum :: !(M44 CFloat)
, _viewportPositionX :: !ScreenUnit -- ^x position in window
, _viewportPositionY :: !ScreenUnit -- ^y position in window
, _viewportWidth :: !ScreenUnit -- ^viewport width in window
, _viewportHeight :: !ScreenUnit -- ^viewport height in window
} deriving (Eq, Show)
data UIButtonState = UIButtonState class (Monad m) => GUIWidget m uiw where
{ _buttonstateIsFiring :: Bool
-- ^firing if pressed but not confirmed
, _buttonstateIsFiringAlt :: Bool
-- ^firing if pressed but not confirmed (secondary mouse button)
, _buttonstateIsDeferred :: Bool -- ^ deferred if e. g. dragging but outside component
, _buttonstateIsDeferredAlt :: Bool
-- ^deferred if e. g. dragging but outside component (secondary mouse button)
, _buttonstateIsReady :: Bool
-- ^ready if mouse is above component
, _buttonstateIsActivated :: Bool
-- ^in activated state (e. g. toggle button)
} deriving (Eq, Show)
defaultUIState :: UIButtonState
defaultUIState = UIButtonState False False False False False False
class GUIAnyMap w where
guiAnyMap :: (w -> b) -> GUIAny -> b
toGUIAny :: w -> GUIAny
fromGUIAny :: GUIAny -> w
class (GUIAnyMap uiw) => GUIWidget uiw where
-- |The 'getBoundary' function gives the outer extents of the 'UIWidget'. -- |The 'getBoundary' function gives the outer extents of the 'UIWidget'.
-- The bounding box wholly contains all children components. -- The bounding box wholly contains all children components.
getBoundary :: uiw -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates) getBoundary :: uiw -> m (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
-- |The 'getChildren' function returns all children associated with this widget. -- |The 'getChildren' function returns all children associated with this widget.
-- --
-- All children must be wholly inside the parent's bounding box specified by 'getBoundary'. -- All children must be wholly inside the parent's bounding box specified by 'getBoundary'.
getChildren :: uiw -> [GUIAny] getChildren :: uiw -> m [UIId]
getChildren _ = [] getChildren _ = return []
-- |The function 'isInsideSelf' tests whether a point is inside the widget itself. -- |The function 'isInside' tests whether a point is inside the widget itself.
-- A screen position may be inside the bounding box of a widget but not considered part of the -- A screen position may be inside the bounding box of a widget but not considered part of the
-- component. -- component.
-- --
-- The default implementations tests if the point is within the rectangle specified by the -- The default implementations tests if the point is within the rectangle specified by the
-- 'getBoundary' function. -- 'getBoundary' function.
isInsideSelf :: ScreenUnit -- ^screen x coordinate isInside :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate -> ScreenUnit -- ^screen y coordinate
-> uiw -- ^the parent widget -> uiw -- ^the parent widget
-> Bool -> m Bool
isInsideSelf x' y' wg = let (x, y, w, h) = getBoundary wg isInside x' y' wg = do
in (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0) (x, y, w, h) <- getBoundary wg
return $ (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
-- |The function 'isInside' tests whether a point is inside the widget or any child.
-- A screen position may be inside the bounding box of a widget but not considered part of the component.
-- The function returns all hit widgets that have no hit children or 'Nothing' if the point neither hits any
-- component nor the parent widget itself.
isInside :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> uiw -- ^the parent widget
-> [GUIAny]
isInside x' y' wg =
case isInsideSelf x' y' wg of -- test inside parent's bounding box
False -> []
True -> case concat $ map (isInside x' y') (getChildren wg) of
[] -> [toGUIAny wg]
l -> l
--TODO: Priority queue?
-- |The 'getPriority' function returns the priority score of a 'GUIWidget'. -- |The 'getPriority' function returns the priority score of a 'GUIWidget'.
-- A widget with a high score is more in the front than a low scored widget. -- A widget with a high score is more in the front than a low scored widget.
getPriority :: uiw -> Int getPriority :: uiw -> m Int
getPriority _ = 0 getPriority _ = return 0
-- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose. -- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose.
-- The shorthand should be unique for each instance. -- The shorthand should be unique for each instance.
getShorthand :: uiw -> String getShorthand :: uiw -> m String
-- |A 'GUIClickable' represents a widget with a 'UIButtonState'. -- |A 'GUIClickable' represents a widget with a 'UIButtonState'.
-- --
@ -104,13 +60,13 @@ class GUIClickable w where
setButtonState s = updateButtonState (\_ -> s) setButtonState s = updateButtonState (\_ -> s)
getButtonState :: w -> UIButtonState getButtonState :: w -> UIButtonState
class MouseHandler a w where class Monad m => MouseHandler a m w where
-- |The function 'onMousePressed' is called when the primary button is pressed -- |The function 'onMousePressed' is called when the primary button is pressed
-- while inside a screen coordinate within the widget ('isInside'). -- while inside a screen coordinate within the widget ('isInside').
onMousePressed :: ScreenUnit -- ^screen x coordinate onMousePressed :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate -> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on -> w -- ^widget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler -> a -> m (w, a) -- ^widget after the event and the altered handler
onMousePressed _ _ wg a = return (wg, a) onMousePressed _ _ wg a = return (wg, a)
-- |The function 'onMouseReleased' is called when the primary button is released -- |The function 'onMouseReleased' is called when the primary button is released
@ -120,7 +76,7 @@ class MouseHandler a w where
onMouseReleased :: ScreenUnit -- ^screen x coordinate onMouseReleased :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen x coordinate
-> w -- ^wdiget the event is invoked on -> w -- ^wdiget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler -> a -> m (w, a) -- ^widget after the event and the altered handler
onMouseReleased _ _ wg a = return (wg, a) onMouseReleased _ _ wg a = return (wg, a)
-- |The function 'onMousePressed' is called when the secondary button is pressed -- |The function 'onMousePressed' is called when the secondary button is pressed
@ -128,7 +84,7 @@ class MouseHandler a w where
onMousePressedAlt :: ScreenUnit -- ^screen x coordinate onMousePressedAlt :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate -> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on -> w -- ^widget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler -> a -> m (w, a) -- ^widget after the event and the altered handler
onMousePressedAlt _ _ wg a = return (wg, a) onMousePressedAlt _ _ wg a = return (wg, a)
-- |The function 'onMouseReleased' is called when the secondary button is released -- |The function 'onMouseReleased' is called when the secondary button is released
@ -138,7 +94,7 @@ class MouseHandler a w where
onMouseReleasedAlt :: ScreenUnit -- ^screen x coordinate onMouseReleasedAlt :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen x coordinate
-> w -- ^wdiget the event is invoked on -> w -- ^wdiget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler -> a -> m (w, a) -- ^widget after the event and the altered handler
onMouseReleasedAlt _ _ wg a = return (wg, a) onMouseReleasedAlt _ _ wg a = return (wg, a)
-- |The function 'onMouseMove' is invoked when the mouse is moved inside the -- |The function 'onMouseMove' is invoked when the mouse is moved inside the
@ -146,7 +102,7 @@ class MouseHandler a w where
onMouseMove :: ScreenUnit -- ^screen x coordinate onMouseMove :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate -> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on -> w -- ^widget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler -> a -> m (w, a) -- ^widget after the event and the altered handler
onMouseMove _ _ wg a = return (wg, a) onMouseMove _ _ wg a = return (wg, a)
-- |The function 'onMouseMove' is invoked when the mouse enters the -- |The function 'onMouseMove' is invoked when the mouse enters the
@ -154,7 +110,7 @@ class MouseHandler a w where
onMouseEnter :: ScreenUnit -- ^screen x coordinate onMouseEnter :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate -> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on -> w -- ^widget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler -> a -> m (w, a) -- ^widget after the event and the altered handler
onMouseEnter _ _ wg a = return (wg, a) onMouseEnter _ _ wg a = return (wg, a)
-- |The function 'onMouseMove' is invoked when the mouse leaves the -- |The function 'onMouseMove' is invoked when the mouse leaves the
@ -162,20 +118,10 @@ class MouseHandler a w where
onMouseLeave :: ScreenUnit -- ^screen x coordinate onMouseLeave :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate -> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on -> w -- ^widget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler -> a -> m (w, a) -- ^widget after the event and the altered handler
onMouseLeave _ _ wg a = return (wg, a) onMouseLeave _ _ wg a = return (wg, a)
-- |Switches primary and secondary mouse actions. instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch h) m w where
data MouseHandlerSwitch w h = MouseHandlerSwitch h deriving (Eq, Show)
instance Functor (MouseHandlerSwitch w) where
fmap :: (h1 -> h2) -> MouseHandlerSwitch w h1 -> MouseHandlerSwitch w h2
fmap f (MouseHandlerSwitch h) = MouseHandlerSwitch (f h)
instance Monad (MouseHandlerSwitch w) where
(>>=) :: (MouseHandlerSwitch w h1) -> (h1 -> MouseHandlerSwitch w h2) -> MouseHandlerSwitch w h2
(MouseHandlerSwitch h) >>= f = f h
return :: h -> MouseHandlerSwitch w h
return h = MouseHandlerSwitch h
instance (MouseHandler h w) => MouseHandler (MouseHandlerSwitch w h) w where
onMousePressed x y w (MouseHandlerSwitch h) = do onMousePressed x y w (MouseHandlerSwitch h) = do
(w', h') <- onMousePressedAlt x y w h (w', h') <- onMousePressedAlt x y w h
return (w', MouseHandlerSwitch h') return (w', MouseHandlerSwitch h')
@ -198,15 +144,9 @@ instance (MouseHandler h w) => MouseHandler (MouseHandlerSwitch w h) w where
(w', h') <- onMouseLeave x y w h (w', h') <- onMouseLeave x y w h
return (w', MouseHandlerSwitch h') return (w', MouseHandlerSwitch h')
instance (Monad m, GUIClickable w) => MouseHandler (ButtonHandler m w) m w where
-- !!Important: one handler can only handle one single widget!!
data ButtonHandler w = ButtonHandler
{ _action :: (w -> ScreenUnit -> ScreenUnit -> IO w) }
instance Show (ButtonHandler w) where
show _ = "ButtonHandler ***"
instance (GUIClickable w) => MouseHandler (ButtonHandler w) w where
-- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@. -- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@.
onMousePressed _ _ wg h = do onMousePressed _ _ wg h =
return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h) return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h)
-- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and -- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and
@ -243,70 +183,48 @@ instance (GUIClickable w) => MouseHandler (ButtonHandler w) w where
}) wg }) wg
, h) , h)
instance (Monad m) => GUIAnyMap m (GUIAny m) where
data GUIAny = GUIAnyC GUIContainer
| GUIAnyP GUIPanel
| GUIAnyB GUIButton (ButtonHandler GUIButton)
deriving (Show)
instance GUIAnyMap GUIAny where
guiAnyMap f w = f w guiAnyMap f w = f w
toGUIAny = id
fromGUIAny = id
instance GUIWidget GUIAny where instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where
getBoundary (GUIAnyC w) = getBoundary w getBoundary (GUIAnyC w) = getBoundary w
getBoundary (GUIAnyP w) = getBoundary w getBoundary (GUIAnyP w) = getBoundary w
getBoundary (GUIAnyB w _) = getBoundary w getBoundary (GUIAnyB w _) = getBoundary w
getChildren (GUIAnyC w) = getChildren w getChildren (GUIAnyC w) = getChildren w
getChildren (GUIAnyP w) = getChildren w getChildren (GUIAnyP w) = getChildren w
getChildren (GUIAnyB w _) = getChildren w getChildren (GUIAnyB w _) = getChildren w
isInsideSelf x y (GUIAnyC w) = (isInsideSelf x y) w
isInsideSelf x y (GUIAnyP w) = (isInsideSelf x y) w
isInsideSelf x y (GUIAnyB w _) = (isInsideSelf x y) w
isInside x y (GUIAnyC w) = (isInside x y) w isInside x y (GUIAnyC w) = (isInside x y) w
isInside x y (GUIAnyP w) = (isInside x y) w isInside x y (GUIAnyP w) = (isInside x y) w
isInside x y (GUIAnyB w _) = (isInside x y) w isInside x y (GUIAnyB w _) = (isInside x y) w
getPriority (GUIAnyC w) = getPriority w getPriority (GUIAnyC w) = getPriority w
getPriority (GUIAnyP w) = getPriority w getPriority (GUIAnyP w) = getPriority w
getPriority (GUIAnyB w _) = getPriority w getPriority (GUIAnyB w _) = getPriority w
getShorthand (GUIAnyC w) = "A" ++ getShorthand w getShorthand (GUIAnyC w) = do { str <- getShorthand w; return $ "A" ++ str }
getShorthand (GUIAnyP w) = "A" ++ getShorthand w getShorthand (GUIAnyP w) = do { str <- getShorthand w; return $ "A" ++ str }
getShorthand (GUIAnyB w _) = "A" ++ getShorthand w getShorthand (GUIAnyB w _) = do { str <- getShorthand w; return $ "A" ++ str }
-- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a instance (Monad m) => GUIAnyMap m GUIContainer where
-- functionality itself.
data GUIContainer = GUIContainer { _screenX :: ScreenUnit, _screenY :: ScreenUnit
, _width :: ScreenUnit, _height :: ScreenUnit
, _children :: [GUIAny]
, _priority :: Int
} deriving (Show)
instance GUIAnyMap GUIContainer where
guiAnyMap f (GUIAnyC c) = f c guiAnyMap f (GUIAnyC c) = f c
guiAnyMap _ _ = error "invalid types in guiAnyMap" guiAnyMap _ _ = error "invalid types in guiAnyMap"
toGUIAny cnt = GUIAnyC cnt instance (Monad m) => GUIWidget m GUIContainer where
fromGUIAny (GUIAnyC cnt) = cnt getBoundary :: GUIContainer -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
fromGUIAny _ = error "invalid GUIAny type" getBoundary cnt = return (_uiScreenX cnt, _uiScreenY cnt, _uiWidth cnt, _uiHeight cnt)
instance GUIWidget GUIContainer where getChildren cnt = return $ _uiChildren cnt
getBoundary :: GUIContainer -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) getPriority cnt = return $ _uiPriority cnt
getBoundary cnt = (_screenX cnt, _screenY cnt, _width cnt, _height cnt) getShorthand _ = return $ "CNT"
getChildren cnt = _children cnt
getPriority cnt = _priority cnt
getShorthand _ = "CNT"
-- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its instance GUIAnyMap m GUIPanel where
-- children components.
data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show)
instance GUIAnyMap GUIPanel where
guiAnyMap f (GUIAnyP p) = f p guiAnyMap f (GUIAnyP p) = f p
guiAnyMap _ _ = error "invalid types in guiAnyMap" guiAnyMap _ _ = error "invalid types in guiAnyMap"
toGUIAny pnl = GUIAnyP pnl instance GUIWidget T.Pioneers GUIPanel where
fromGUIAny (GUIAnyP pnl) = pnl getBoundary pnl = do
fromGUIAny _ = error "invalid GUIAny type" state <- get
instance GUIWidget GUIPanel where let hmap = state ^. T.ui . T.uiMap
getBoundary pnl = case getChildren $ _panelContainer pnl of case _uiChildren $ _panelContainer pnl of
[] -> getBoundary $ _panelContainer pnl [] -> getBoundary $ _panelContainer pnl
cs -> foldl1' determineSize $ map getBoundary cs cs -> do
let widgets = catMaybes $ map (flip Map.lookup hmap) cs
foldl' (liftM2 determineSize) (getBoundary $ _panelContainer pnl) $ map getBoundary widgets
where where
determineSize :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) determineSize :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
determineSize (x, y, w, h) (x', y', w', h') = determineSize (x, y, w, h) (x', y', w', h') =
@ -318,37 +236,16 @@ instance GUIWidget GUIPanel where
getChildren pnl = getChildren $ _panelContainer pnl getChildren pnl = getChildren $ _panelContainer pnl
getPriority pnl = getPriority $ _panelContainer pnl getPriority pnl = getPriority $ _panelContainer pnl
getShorthand _ = "PNL" getShorthand _ = return $ "PNL"
-- |A 'GUIButton' is a dummy datatype for a clickable 'GUIWidget'. Its functinality must be instance (Monad m) => GUIAnyMap m GUIButton where
-- provided by an appropriate 'MouseHanlder'.
data GUIButton = GUIButton { _screenXB :: ScreenUnit, _screenYB :: ScreenUnit
, _widthB :: ScreenUnit, _heightB :: ScreenUnit
, _priorityB :: Int
, _buttonState :: UIButtonState
, _buttonAction :: (GUIButton -> ScreenUnit -> ScreenUnit -> IO GUIButton)
} deriving ()
instance Show GUIButton where
show w = "GUIButton {_screenXB = " ++ show (_screenXB w)
++ " _screenYB = " ++ show (_screenYB w)
++ " _widthB = " ++ show (_widthB w)
++ " _heightB = " ++ show (_heightB w)
++ " _priorityB = " ++ show (_screenYB w)
++ " _buttonState = " ++ show (_buttonState w)
++ " _buttonAction = " ++ "***"
++ "}"
instance GUIAnyMap GUIButton where
guiAnyMap f (GUIAnyB btn _) = f btn guiAnyMap f (GUIAnyB btn _) = f btn
guiAnyMap _ _ = error "invalid types in guiAnyMap" guiAnyMap _ _ = error "invalid types in guiAnyMap"
toGUIAny btn = GUIAnyB btn $ ButtonHandler $ _buttonAction btn
fromGUIAny (GUIAnyB btn _) = btn
fromGUIAny _ = error "invalid GUIAny type"
instance GUIClickable GUIButton where instance GUIClickable GUIButton where
getButtonState = _buttonState getButtonState = _uiButtonState
updateButtonState f btn = btn {_buttonState = f $ _buttonState btn} updateButtonState f btn = btn {_uiButtonState = f $ _uiButtonState btn}
instance GUIWidget GUIButton where instance (Monad m) => GUIWidget m GUIButton where
getBoundary btn = (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn) getBoundary btn = return (_uiScreenXB btn, _uiScreenYB btn, _uiWidthB btn, _uiHeightB btn)
getChildren _ = [] getChildren _ = return []
getPriority btn = _priorityB btn getPriority btn = return $ _uiPriorityB btn
getShorthand _ = "BTN" getShorthand _ = return "BTN"

79
src/UI/UIOperations.hs Normal file
View File

@ -0,0 +1,79 @@
module UI.UIOperations where
import Control.Monad (liftM)
import qualified Data.HashMap.Strict as Map
import Data.Maybe
import Types
import UI.UIBaseData
import UI.UIClasses
defaultUIState :: UIButtonState
defaultUIState = UIButtonState False False False False False False
toGUIAny :: Map.HashMap UIId (GUIAny m) -> UIId -> GUIAny m
toGUIAny m uid = case Map.lookup uid m of
Just w -> w
Nothing -> error "map does not contain requested key" --TODO: better error handling
{-# INLINE toGUIAny #-}
toGUIAnys :: Map.HashMap UIId (GUIAny m) -> [UIId] -> [GUIAny m]
toGUIAnys m ids = mapMaybe (flip Map.lookup m) ids
{-# INLINE toGUIAnys #-}
-- TODO: check for missing components?
-- |The function 'getInside' returns child widgets that overlap with a specific
-- screen position.
--
-- A screen position may be inside the bounding box of a widget but not
-- considered part of the component. The function returns all hit widgets that
-- have no hit children, which may be the input widget itself,
-- or @[]@ if the point does not hit the widget.
--
-- This function returns the widgets themselves unlike 'getInsideId'.
getInside :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets
-> ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> GUIAny Pioneers -- ^the parent widget
-> Pioneers [GUIAny Pioneers]
getInside hMap x' y' wg = do
inside <- isInside x' y' wg
if inside -- test inside parent's bounding box
then do
childrenIds <- getChildren wg
hitChildren <- liftM concat $ mapM (getInside hMap x' y') (toGUIAnys hMap childrenIds)
case hitChildren of
[] -> return [wg]
_ -> return hitChildren
else return []
--TODO: Priority queue?
-- |The function 'getInsideId' returns child widgets that overlap with a
-- specific screen position.
--
-- A screen position may be inside the bounding box of a widget but not
-- considered part of the component. The function returns all hit widgets that
-- have no hit children, which may be the input widget itself,
-- or @[]@ if the point does not hit the widget.
--
-- This function returns the 'UIId's of the widgets unlike 'getInside'.
getInsideId :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets
-> ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> UIId -- ^the parent widget
-> Pioneers [UIId]
getInsideId hMap x' y' uid = do
let wg = toGUIAny hMap uid
inside <- isInside x' y' wg
if inside -- test inside parent's bounding box
then do
childrenIds <- getChildren wg
hitChildren <- liftM concat $ mapM (getInsideId hMap x' y') childrenIds
case hitChildren of
[] -> return [uid]
_ -> return hitChildren
else return []
--TODO: Priority queue?

20
tests/MainTestSuite.hs Normal file
View File

@ -0,0 +1,20 @@
module Main where
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Map.Map
main :: IO ()
main = defaultMain tests
tests :: [Test]
tests =
[
testGroup "Map.Map"
[
testProperty "remdups idempotency" prop_rd_idempot
]
]