diff --git a/.gitignore b/.gitignore index 925f33a..0df715f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,11 @@ /.dist-buildwrapper /.project /.settings +.cabal-sandbox +*.trace +cabal.sandbox.config +deps/hsSDL2* +deps/*.deb +dist/* +*.swp + diff --git a/Pioneers.cabal b/Pioneers.cabal index 6bc84b9..633c0c5 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -11,20 +11,20 @@ executable Pioneers } else { 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.Graphics, Map.Creation, Map.StaticMaps, - IQM.Types, - IQM.TestMain, - IQM.Parser, + Importer.IQM.Types, + Importer.IQM.Parser, Render.Misc, Render.Render, Render.RenderObject, + Render.Types, UI.Callbacks, - Types, - UI.SurfaceOverlay Types main-is: Main.hs build-depends: @@ -36,6 +36,8 @@ executable Pioneers 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, @@ -45,7 +47,36 @@ 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 +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 diff --git a/README b/README deleted file mode 100644 index a831599..0000000 --- a/README +++ /dev/null @@ -1,4 +0,0 @@ -Pioneers -======== - -A Settlers II inspired game written in Haskell diff --git a/README.md b/README.md new file mode 100644 index 0000000..b3eccc4 --- /dev/null +++ b/README.md @@ -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 + diff --git a/shaders/map/tessEval.shader b/shaders/map/tessEval.shader index 87a5598..51cc5b3 100644 --- a/shaders/map/tessEval.shader +++ b/shaders/map/tessEval.shader @@ -2,6 +2,101 @@ #extension GL_ARB_tessellation_shader : require +//#include "shaders/3rdParty/noise.glsl" + +vec3 mod289(vec3 x) { + return x - floor(x * (1.0 / 289.0)) * 289.0; +} + +vec4 mod289(vec4 x) { + return x - floor(x * (1.0 / 289.0)) * 289.0; +} + +vec4 permute(vec4 x) { + return mod289(((x*34.0)+1.0)*x); +} + +vec4 taylorInvSqrt(vec4 r) +{ + return 1.79284291400159 - 0.85373472095314 * r; +} + +float snoise(vec3 v) + { + const vec2 C = vec2(1.0/6.0, 1.0/3.0) ; + const vec4 D = vec4(0.0, 0.5, 1.0, 2.0); + +// First corner + vec3 i = floor(v + dot(v, C.yyy) ); + vec3 x0 = v - i + dot(i, C.xxx) ; + +// Other corners + vec3 g = step(x0.yzx, x0.xyz); + vec3 l = 1.0 - g; + vec3 i1 = min( g.xyz, l.zxy ); + vec3 i2 = max( g.xyz, l.zxy ); + + // x0 = x0 - 0.0 + 0.0 * C.xxx; + // x1 = x0 - i1 + 1.0 * C.xxx; + // x2 = x0 - i2 + 2.0 * C.xxx; + // x3 = x0 - 1.0 + 3.0 * C.xxx; + vec3 x1 = x0 - i1 + C.xxx; + vec3 x2 = x0 - i2 + C.yyy; // 2.0*C.x = 1/3 = C.y + vec3 x3 = x0 - D.yyy; // -1.0+3.0*C.x = -0.5 = -D.y + +// Permutations + i = mod289(i); + vec4 p = permute( permute( permute( + i.z + vec4(0.0, i1.z, i2.z, 1.0 )) + + i.y + vec4(0.0, i1.y, i2.y, 1.0 )) + + i.x + vec4(0.0, i1.x, i2.x, 1.0 )); + +// Gradients: 7x7 points over a square, mapped onto an octahedron. +// The ring size 17*17 = 289 is close to a multiple of 49 (49*6 = 294) + float n_ = 0.142857142857; // 1.0/7.0 + vec3 ns = n_ * D.wyz - D.xzx; + + vec4 j = p - 49.0 * floor(p * ns.z * ns.z); // mod(p,7*7) + + vec4 x_ = floor(j * ns.z); + vec4 y_ = floor(j - 7.0 * x_ ); // mod(j,N) + + vec4 x = x_ *ns.x + ns.yyyy; + vec4 y = y_ *ns.x + ns.yyyy; + vec4 h = 1.0 - abs(x) - abs(y); + + vec4 b0 = vec4( x.xy, y.xy ); + vec4 b1 = vec4( x.zw, y.zw ); + + //vec4 s0 = vec4(lessThan(b0,0.0))*2.0 - 1.0; + //vec4 s1 = vec4(lessThan(b1,0.0))*2.0 - 1.0; + vec4 s0 = floor(b0)*2.0 + 1.0; + vec4 s1 = floor(b1)*2.0 + 1.0; + vec4 sh = -step(h, vec4(0.0)); + + vec4 a0 = b0.xzyw + s0.xzyw*sh.xxyy ; + vec4 a1 = b1.xzyw + s1.xzyw*sh.zzww ; + + vec3 p0 = vec3(a0.xy,h.x); + vec3 p1 = vec3(a0.zw,h.y); + vec3 p2 = vec3(a1.xy,h.z); + vec3 p3 = vec3(a1.zw,h.w); + +//Normalise gradients + vec4 norm = taylorInvSqrt(vec4(dot(p0,p0), dot(p1,p1), dot(p2, p2), dot(p3,p3))); + p0 *= norm.x; + p1 *= norm.y; + p2 *= norm.z; + p3 *= norm.w; + +// Mix final noise value + vec4 m = max(0.6 - vec4(dot(x0,x0), dot(x1,x1), dot(x2,x2), dot(x3,x3)), 0.0); + m = m * m; + return 42.0 * dot( m*m, vec4( dot(p0,x0), dot(p1,x1), + dot(p2,x2), dot(p3,x3) ) ); + } + + layout(triangles, equal_spacing, cw) in; in vec3 tcPosition[]; in vec4 tcColor[]; @@ -38,6 +133,7 @@ void main() float i2 = (1-gl_TessCoord.z)*gl_TessCoord.z * length(cross(tcNormal[2],tessNormal)); float standout = i0+i1+i2; tePosition = tePosition+tessNormal*standout; + tePosition = tePosition+0.05*snoise(tePosition); gl_Position = ProjectionMatrix * ViewMatrix * vec4(tePosition, 1); fogDist = gl_Position.z; diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs index cd777c0..1d5b9fe 100644 --- a/src/Importer/IQM/Parser.hs +++ b/src/Importer/IQM/Parser.hs @@ -8,84 +8,98 @@ module Importer.IQM.Parser (parseIQM) where import Importer.IQM.Types import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.ByteString +import Data.Attoparsec.Binary import Data.ByteString.Char8 (pack) -import Data.ByteString (split, null) +import Data.ByteString (split, null, ByteString) +import Data.ByteString.Unsafe (unsafeUseAsCString) +import qualified Data.ByteString as B import Data.Word import Data.Int import Unsafe.Coerce import Control.Monad.Trans.State import Control.Monad.Trans.Class import Control.Monad +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils import Prelude as P hiding (take, null) -- | helper-function for creating an integral out of [8-Bit Ints] -w8ToInt :: Integral a => a -> a -> a -w8ToInt i add = 256*i + add +_w8ToInt :: Integral a => a -> a -> a +_w8ToInt i add = 256*i + add -- | shorthand-function for parsing Word8 into Integrals -parseNum :: (Integral a, Integral b) => [a] -> b -parseNum = (foldl1 w8ToInt) . map fromIntegral +_parseNum :: (Integral a, Integral b) => [a] -> b +_parseNum = foldl1 _w8ToInt . map fromIntegral -- | read a 16-Bit Int from Parsing-Input and log 2 bytes in our Parsing-Monad -- -- begins with _ to defeat ghc-warnings. Rename if used! -_int16 :: CParser Int16 +_int16 :: CParser Word16 _int16 = do ret <- lift $ do a <- anyWord8 :: Parser Word8 b <- anyWord8 :: Parser Word8 - return $ parseNum [b,a] + return $ _parseNum [b,a] modify (+2) return ret -- | read a 32-Bit Int from Parsing-Input and log 4 bytes in our Parsing-Monad -int32 :: CParser Int32 -int32 = do +_int32 :: CParser Int32 +_int32 = do ret <- lift $ do a <- anyWord8 :: Parser Word8 b <- anyWord8 :: Parser Word8 c <- anyWord8 :: Parser Word8 d <- anyWord8 :: Parser Word8 - return $ parseNum [d,c,b,a] + return $ _parseNum [d,c,b,a] modify (+4) - return $ ret + return ret + +w32leCParser :: CParser Word32 +w32leCParser = do + ret <- lift anyWord32le + modify (+4) + return ret -- | Parser for the header readHeader :: CParser IQMHeader readHeader = do _ <- lift $ string (pack "INTERQUAKEMODEL\0") - v <- int32 - -- when v /= 2 then --TODO: error something - size' <- int32 - flags' <- int32 - num_text' <- int32 - ofs_text' <- int32 - num_meshes' <- int32 - ofs_meshes' <- int32 - num_vertexarrays' <- int32 - num_vertexes' <- int32 - ofs_vertexarrays' <- int32 - num_triangles' <- int32 - ofs_triangles' <- int32 - ofs_adjacency' <- int32 - num_joints' <- int32 - ofs_joints' <- int32 - num_poses' <- int32 - ofs_poses' <- int32 - num_anims' <- int32 - ofs_anims' <- int32 - num_frames' <- int32 - num_framechannels' <- int32 - ofs_frames' <- int32 - ofs_bounds' <- int32 - num_comment' <- int32 - ofs_comment' <- int32 - num_extensions' <- int32 - ofs_extensions' <- int32 + modify (+16) + v <- w32leCParser + lift $ when (v /= 2) $ fail "Version /= 2.\nThis Parser only supports Version 2 of the InterQuake-Model IQM" + -- when v /= 2 then fail parsing. + size' <- w32leCParser + flags' <- w32leCParser + num_text' <- w32leCParser + ofs_text' <- w32leCParser + num_meshes' <- w32leCParser + ofs_meshes' <- w32leCParser + num_vertexarrays' <- w32leCParser + num_vertexes' <- w32leCParser + ofs_vertexarrays' <- w32leCParser + num_triangles' <- w32leCParser + ofs_triangles' <- w32leCParser + ofs_adjacency' <- w32leCParser + num_joints' <- w32leCParser + ofs_joints' <- w32leCParser + num_poses' <- w32leCParser + ofs_poses' <- w32leCParser + num_anims' <- w32leCParser + ofs_anims' <- w32leCParser + num_frames' <- w32leCParser + num_framechannels' <- w32leCParser + ofs_frames' <- w32leCParser + ofs_bounds' <- w32leCParser + num_comment' <- w32leCParser + ofs_comment' <- w32leCParser + num_extensions' <- w32leCParser + ofs_extensions' <- w32leCParser return IQMHeader { version = v , filesize = size' - , flags = flags' + , flags = fromIntegral flags' , num_text = num_text' , ofs_text = ofs_text' , num_meshes = num_meshes' @@ -115,12 +129,12 @@ readHeader = do -- | Parser for Mesh-Structure readMesh :: CParser IQMMesh readMesh = do - name <- int32 - mat <- int32 - fv <- int32 - nv <- int32 - ft <- int32 - nt <- int32 + name <- w32leCParser + mat <- w32leCParser + fv <- w32leCParser + nv <- w32leCParser + ft <- w32leCParser + nt <- w32leCParser return IQMMesh { meshName = if name == 0 then Nothing else Just (Mesh name) , meshMaterial = mat @@ -140,12 +154,32 @@ readMeshes n = do ms <- readMeshes (n-1) return $ m:ms +-- | Parser for Mesh-Structure +readVAF :: CParser IQMVertexArray +readVAF = do + vat <- rawEnumToVAT =<< w32leCParser + flags' <- w32leCParser + format <- rawEnumToVAF =<< w32leCParser + size <- w32leCParser + offset <- w32leCParser + return $ IQMVertexArray vat (fromIntegral flags') format (fromIntegral size) offset nullPtr + +-- | helper to read n consecutive Meshes tail-recursive +readVAFs :: Int -> CParser [IQMVertexArray] +readVAFs 1 = do + f <- readVAF + return [f] +readVAFs n = do + f <- readVAF + fs <- readVAFs (n-1) + return $ f:fs + -- | helper-Notation for subtracting 2 integral values of different kind in the precision -- of the target-kind (.-) :: forall a a1 a2. (Num a, Integral a2, Integral a1) => a1 -> a2 -> a -(.-) a b = (fromIntegral a) - (fromIntegral b) +(.-) a b = fromIntegral a - fromIntegral b infix 5 .- @@ -162,18 +196,69 @@ skipToCounter a = do put d -- | Parses an IQM-File and handles back the Haskell-Structure -parseIQM :: CParser IQM -parseIQM = do - put 0 --start at offset 0 - h <- readHeader --read header - skipToCounter $ ofs_text h --skip 0-n bytes to get to text - text <- lift . take . fromIntegral $ num_text h --read texts - modify . (+) . fromIntegral $ num_text h --put offset forward - skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes - meshes' <- readMeshes (fromIntegral (num_meshes h)) --read meshes - return IQM - { header = h - , texts = filter (not.null) (split (unsafeCoerce '\0') text) - , meshes = meshes' - } +-- +-- Does a 2-Pass-Parsing. Reads in Structure on first pass (O(n))and +-- fills the Structure in a 2nd Pass from Offsets (O(memcpy'd bytes)). +parseIQM :: String -> IO IQM +parseIQM a = + do + f <- B.readFile a + -- Parse Headers/Offsets + let result = parse doIQMparse f + raw <- case result of + Done _ x -> return x + y -> error $ show y + -- Fill Vertex-Arrays with data of Offsets + let va = vertexArrays raw + va' <- mapM (readInVAO f) va + return $ raw { + vertexArrays = va' + } +-- | Allocates memory for the Vertex-data and copies it over there +-- from the given input-String +-- +-- Note: The String-Operations are O(1), so only O(numberOfCopiedBytes) +-- is needed in term of computation. +readInVAO :: ByteString -> IQMVertexArray -> IO IQMVertexArray +readInVAO d (IQMVertexArray type' a format num offset ptr) = + do + let + byteLen = fromIntegral num * vaSize format + data' = skipDrop (fromIntegral offset) byteLen d + + unless (ptr == nullPtr) $ error $ "Error reading Vertex-Array: Double Read of " ++ show type' + p <- mallocBytes byteLen + putStrLn $ concat ["Allocating ", show byteLen, " Bytes at ", show p] + unsafeUseAsCString data' (\s -> copyBytes p s byteLen) + return $ IQMVertexArray type' a format num offset $ castPtr p + +-- | Real internal Parser. +-- +-- Consumes the String only once, thus in O(n). But all Data-Structures are +-- not allocated and copied. readInVAO has to be called on each one. +doIQMparse :: Parser IQM +doIQMparse = + flip evalStateT 0 $ --evaluate parser with state starting at 0 + do + h <- readHeader --read header + skipToCounter $ ofs_text h --skip 0-n bytes to get to text + text <- lift . take . fromIntegral $ num_text h --read texts + modify . (+) . fromIntegral $ num_text h --put offset forward + skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes + meshes' <- readMeshes $ fromIntegral $ num_meshes h --read meshes + skipToCounter $ ofs_vertexarrays h --skip 0-n bytes to get to Vertex-Arrays + vaf <- readVAFs $ fromIntegral $ num_vertexarrays h --read Vertex-Arrays + return IQM + { header = h + , texts = filter (not.null) (split (unsafeCoerce '\0') text) + , meshes = meshes' + , vertexArrays = vaf + } + +-- | Helper-Function for Extracting a random substring out of a Bytestring +-- by the Offsets provided. +-- +-- O(1). +skipDrop :: Int -> Int -> ByteString -> ByteString +skipDrop a b= B.drop b . B.take a diff --git a/src/Importer/IQM/Types.hs b/src/Importer/IQM/Types.hs index 1054767..847320f 100644 --- a/src/Importer/IQM/Types.hs +++ b/src/Importer/IQM/Types.hs @@ -1,19 +1,39 @@ --- | Int32 or Int64 - depending on implementation. Format just specifies "uint". --- 4-Byte in the documentation indicates Int32 - but not specified! +-- {-# LANGUAGE ExistentialQuantification, RankNTypes, CPP, BangPatterns #-} +-- | Word32 or Word64 - depending on implementation. Format just specifies "uint". +-- 4-Byte in the documentation indicates Word32 - but not specified! module Importer.IQM.Types where +import Control.Monad.Trans.State.Lazy (StateT) import Data.Int +import Data.Word import Data.ByteString import Data.Attoparsec.ByteString.Char8 -import Control.Monad.Trans.State.Lazy (StateT) +import Foreign.Ptr +import Graphics.Rendering.OpenGL.Raw.Types +import Prelude as P +import Foreign.Storable +import Foreign.C.Types -- | Mesh-Indices to distinguish the meshes referenced -newtype Mesh = Mesh Int32 deriving (Show, Eq) +newtype Mesh = Mesh Word32 deriving (Show, Eq) -- | State-Wrapped Parser-Monad which is capable of counting the -- Bytes read for offset-gap reasons type CParser a = StateT Int64 Parser a +-- | Alias +type Flags = GLbitfield -- ^ Alias for UInt32 +-- | Alias +type Offset = Word32 -- ^ Alias for UInt32 + +-- | Alias +type Index = GLuint -- ^ Alias for UInt32 + +-- | Alias +type NumComponents = GLsizei -- ^ Alias for UInt32 + +-- | Data-BLOB inside IQM +type IQMData = Ptr IQMVertexArrayFormat -- ^ Pointer for Data -- | Header of IQM-Format. -- @@ -23,33 +43,33 @@ type CParser a = StateT Int64 Parser a -- -- ofs_* fields are aligned at 4-byte-boundaries data IQMHeader = IQMHeader - { version :: Int32 -- ^ Must be 2 - , filesize :: Int32 - , flags :: Int32 - , num_text :: Int32 - , ofs_text :: Int32 - , num_meshes :: Int32 - , ofs_meshes :: Int32 - , num_vertexarrays :: Int32 - , num_vertexes :: Int32 - , ofs_vertexarrays :: Int32 - , num_triangles :: Int32 - , ofs_triangles :: Int32 - , ofs_adjacency :: Int32 - , num_joints :: Int32 - , ofs_joints :: Int32 - , num_poses :: Int32 - , ofs_poses :: Int32 - , num_anims :: Int32 - , ofs_anims :: Int32 - , num_frames :: Int32 - , num_framechannels :: Int32 - , ofs_frames :: Int32 - , ofs_bounds :: Int32 - , num_comment :: Int32 - , ofs_comment :: Int32 - , num_extensions :: Int32 -- ^ stored as linked list, not as array. - , ofs_extensions :: Int32 + { version :: !Word32 -- ^ Must be 2 + , filesize :: !Word32 + , flags :: !Flags + , num_text :: !Word32 + , ofs_text :: !Offset + , num_meshes :: !Word32 + , ofs_meshes :: !Offset + , num_vertexarrays :: !Word32 + , num_vertexes :: !Word32 + , ofs_vertexarrays :: !Offset + , num_triangles :: !Word32 + , ofs_triangles :: !Offset + , ofs_adjacency :: !Offset + , num_joints :: !Word32 + , ofs_joints :: !Offset + , num_poses :: !Word32 + , ofs_poses :: !Offset + , num_anims :: !Word32 + , ofs_anims :: !Offset + , num_frames :: !Word32 + , num_framechannels :: !Word32 + , ofs_frames :: !Offset + , ofs_bounds :: !Offset + , num_comment :: !Word32 + , ofs_comment :: !Offset + , num_extensions :: !Word32 -- ^ stored as linked list, not as array. + , ofs_extensions :: !Offset } deriving (Show, Eq) -- | Format of an IQM-Mesh Structure. @@ -57,13 +77,29 @@ data IQMHeader = IQMHeader -- Read it like a Header of the Meshes lateron in the Format data IQMMesh = IQMMesh { meshName :: Maybe Mesh - , meshMaterial :: Int32 - , meshFirstVertex :: Int32 - , meshNumVertexes :: Int32 - , meshFirstTriangle :: Int32 - , meshNumTriangles :: Int32 + , meshMaterial :: Word32 + , meshFirstVertex :: Word32 + , meshNumVertexes :: Word32 + , meshFirstTriangle :: Word32 + , meshNumTriangles :: Word32 } deriving (Show, Eq) +-- | Format of IQM-Triangle Structure +data IQMTriangle = IQMTriangle VertexIndex VertexIndex VertexIndex + +-- | Type-Alias for Word32 indicating an index on vertices in IQMMesh +type VertexIndex = Word32 + +-- | Type-Alias for Word32 indicating an index on IQMTriangle +type TriangleIndex = Word32 + +-- | From the IQM-Format-Description: +-- +-- each value is the index of the adjacent triangle for edge 0, 1, and 2, where ~0 (= -1) +-- indicates no adjacent triangle indexes are relative to the iqmheader.ofs_triangles array +-- and span all meshes, where 0 is the first triangle, 1 is the second, 2 is the third, etc. +data IQMAdjacency = IQMAdjacency TriangleIndex TriangleIndex TriangleIndex + -- | Format of a whole IQM-File -- -- still unfinished! @@ -71,5 +107,97 @@ data IQM = IQM { header :: IQMHeader , texts :: [ByteString] , meshes :: [IQMMesh] + , vertexArrays :: [IQMVertexArray] } deriving (Show, Eq) +-- | Different Vertex-Array-Types in IQM +-- +-- Custom Types have to be > 0x10 as of specification +data IQMVertexArrayType = IQMPosition + | IQMTexCoord + | IQMNormal + | IQMTangent + | IQMBlendIndexes + | IQMBlendWeights + | IQMColor + | IQMCustomVAT Word32 + deriving (Show, Eq) + +-- | Lookup-Function for internal enum to VertexArrayFormat +rawEnumToVAT :: Word32 -> CParser IQMVertexArrayType +rawEnumToVAT 0 = return IQMPosition +rawEnumToVAT 1 = return IQMTexCoord +rawEnumToVAT 2 = return IQMNormal +rawEnumToVAT 3 = return IQMTangent +rawEnumToVAT 4 = return IQMBlendIndexes +rawEnumToVAT 5 = return IQMBlendWeights +rawEnumToVAT 6 = return IQMColor +rawEnumToVAT a = return $ IQMCustomVAT a + +-- | Vetrex-Array-Format of the data found at offset +data IQMVertexArrayFormat = IQMbyte + | IQMubyte + | IQMshort + | IQMushort + | IQMint + | IQMuint + | IQMhalf + | IQMfloat + | IQMdouble +-- | Unknown Word32 + deriving (Show, Eq) + +-- | Get the Size (in Bytes) of the given IQMVertexArrayFormat-Struct +vaSize :: IQMVertexArrayFormat -> Int +vaSize IQMbyte = sizeOf (undefined :: CSChar) +vaSize IQMubyte = sizeOf (undefined :: CUChar) +vaSize IQMshort = sizeOf (undefined :: CShort) +vaSize IQMushort = sizeOf (undefined :: CUShort) +vaSize IQMint = sizeOf (undefined :: CInt) +vaSize IQMuint = sizeOf (undefined :: CUInt) +vaSize IQMhalf = sizeOf (undefined :: Word16) --TODO: Find 16-Bit-Float-Datatype FIXME! +vaSize IQMfloat = sizeOf (undefined :: CFloat) +vaSize IQMdouble = sizeOf (undefined :: CDouble) + +--mallocVArray :: Storable a => IQMVertexArrayFormat -> Int -> IO (Ptr a) +--mallocVArray IQMbyte n = mallocArray n :: IO (Ptr CSChar) +--mallocVArray IQMubyte n = mallocArray n :: IO (Ptr CUChar) + +-- | Lookup-Function for internal enum to VertexArrayFormat +rawEnumToVAF :: Word32 -> CParser IQMVertexArrayFormat +rawEnumToVAF 0 = return IQMbyte +rawEnumToVAF 1 = return IQMubyte +rawEnumToVAF 2 = return IQMshort +rawEnumToVAF 3 = return IQMushort +rawEnumToVAF 4 = return IQMint +rawEnumToVAF 5 = return IQMuint +rawEnumToVAF 6 = return IQMhalf +rawEnumToVAF 7 = return IQMfloat +rawEnumToVAF 8 = return IQMdouble +--rawEnumToVAF a = return $ Unknown a +rawEnumToVAF a = fail $ P.concat ["unrecognized enum(",show a,") in VertexArrayFormat"] + + +-- | A Vertex-Array-Definiton. +-- +-- The Vertex starts at Offset and has num_vertexes * NumComponents entries. +-- +-- All Vertex-Arrays seem to have the same number of components, just differ in Type, Format +-- and Flags +data IQMVertexArray = IQMVertexArray + IQMVertexArrayType + Flags + IQMVertexArrayFormat + NumComponents + Offset + IQMData + deriving (Eq) +instance Show IQMVertexArray where + show (IQMVertexArray t fl fo nc off dat) = "IQMVertexArray (Type: " ++ show t ++ + ", Flags: " ++ show fl ++ + ", Format: " ++ show fo ++ + ", NumComponents: " ++ show nc ++ + ", Offset: " ++ show off ++ + ", Data at: " ++ show dat ++ + ")" + diff --git a/src/Main.hs b/src/Main.hs index a361524..935f2ec 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -16,7 +16,6 @@ import Control.Concurrent.STM (TQueue, newTQueueIO) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) -import Control.Monad.Trans.State (evalStateT) import Data.Functor ((<$>)) import Data.Monoid (mappend) @@ -46,17 +45,21 @@ import UI.Callbacks import Map.Graphics import Types import Importer.IQM.Parser -import Data.Attoparsec.Char8 (parseTest) -import qualified Data.ByteString as B +--import Data.Attoparsec.Char8 (parseTest) +--import qualified Data.ByteString as B -- import qualified Debug.Trace as D (trace) -------------------------------------------------------------------------------- -testParser :: IO () -testParser = do - f <- B.readFile "sample.iqm" - parseTest (evalStateT parseIQM 0) f +testParser :: String -> IO () +testParser a = putStrLn . show =<< parseIQM a +{-do + f <- B.readFile a + putStrLn "reading in:" + putStrLn $ show f + putStrLn "parsed:" + parseTest parseIQM f-} -------------------------------------------------------------------------------- @@ -82,9 +85,7 @@ main = (Size fbWidth fbHeight) <- glGetDrawableSize window' initRendering --generate map vertices - (mapBuffer, vert) <- getMapBufferObject - (mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader - overTex <- GL.genObjectName + glMap' <- initMapShader 4 =<< getMapBufferObject print window' eventQueue <- newTQueueIO :: IO (TQueue Event) putStrLn "foo" @@ -103,29 +104,13 @@ main = far = 500 --far plane ratio = fromIntegral fbWidth / fromIntegral fbHeight frust = createFrustum fov near far ratio + (guiMap, guiRoots) = createGUI aks = ArrowKeyState { _up = False , _down = False , _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' @@ -174,6 +159,8 @@ main = } , _ui = UIState { _uiHasChanged = True + , _uiMap = guiMap + , _uiRoots = guiRoots } } @@ -302,7 +289,7 @@ adjustWindow = do let hudtexid = state ^. gl.glHud.hudTexture - maptexid = state ^. gl.glMap.mapTexture + maptexid = state ^. gl.glMap.renderedMapTexture allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do --default to ugly pink to see if --somethings go wrong. diff --git a/src/Map/Map.hs b/src/Map/Map.hs index e358cee..ba697c0 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -40,5 +40,5 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in remdups :: Ord a => [a] -> [a] 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 diff --git a/src/Render/Render.hs b/src/Render/Render.hs index 66702aa..6b3e4d3 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -50,22 +50,11 @@ initBuffer varray = checkError "initBuffer" return bufferObject -initMapShader :: IO ( - Program -- the GLSL-Program - , AttribLocation -- color - , AttribLocation -- normal - , AttribLocation -- vertex - , UniformLocation -- ProjectionMat - , UniformLocation -- ViewMat - , UniformLocation -- ModelMat - , UniformLocation -- NormalMat - , UniformLocation -- TessLevelInner - , UniformLocation -- TessLevelOuter - , TextureObject -- Texture where to draw into - ) -- ^ (the GLSL-Program, color, normal, vertex, ProjectionMat, ViewMat, - -- ModelMat, NormalMat, TessLevelInner, TessLevelOuter, - -- Texture where to draw into) -initMapShader = do +initMapShader :: + Int -- ^ initial Tessallation-Factor + -> (BufferObject,NumArrayIndices) -- ^ Buffer with Data and DataDescriptor + -> IO GLMapState +initMapShader tessFac (buf, vertDes) = do ! vertexSource <- B.readFile mapVertexShaderFile ! tessControlSource <- B.readFile mapTessControlShaderFile ! tessEvalSource <- B.readFile mapTessEvalShaderFile @@ -120,9 +109,30 @@ initMapShader = do putStrLn $ unlines $ ["Indices: ", show (colorIndex, normalIndex, vertexIndex)] tex <- genObjectName + overTex <- genObjectName + + texts <- genObjectNames 6 + checkError "initShader" - return (program, colorIndex, normalIndex, vertexIndex, projectionMatrixIndex, viewMatrixIndex, modelMatrixIndex, normalMatrixIndex, tessLevelInner, tessLevelOuter, tex) + return GLMapState + { _mapProgram = program + , _shdrColorIndex = colorIndex + , _shdrNormalIndex = normalIndex + , _shdrVertexIndex = vertexIndex + , _shdrProjMatIndex = projectionMatrixIndex + , _shdrViewMatIndex = viewMatrixIndex + , _shdrModelMatIndex = modelMatrixIndex + , _shdrNormalMatIndex = normalMatrixIndex + , _shdrTessInnerIndex = tessLevelInner + , _shdrTessOuterIndex = tessLevelOuter + , _renderedMapTexture = tex + , _stateTessellationFactor = tessFac + , _stateMap = buf + , _mapVert = vertDes + , _overviewTexture = overTex + , _mapTextures = texts + } initHud :: IO GLHud initHud = do @@ -193,13 +203,13 @@ renderOverview = do DepthAttachment Renderbuffer (state ^. gl.glRenderbuffer) - textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture) + textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D - (state ^. gl.glMap.mapTexture) + (state ^. gl.glMap.renderedMapTexture) 0 -- Render to FrameBufferObject @@ -285,13 +295,13 @@ render = do DepthAttachment Renderbuffer (state ^. gl.glRenderbuffer) - textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture) + textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D - (state ^. gl.glMap.mapTexture) + (state ^. gl.glMap.renderedMapTexture) 0 -- Render to FrameBufferObject @@ -371,7 +381,7 @@ render = do uniform (hud ^. hudTexIndex) $= Index1 (0::GLint) activeTexture $= TextureUnit 1 - textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture) + textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) uniform (hud ^. hudBackIndex) $= Index1 (1::GLint) bindBuffer ArrayBuffer $= Just (hud ^. hudVBO) diff --git a/src/Types.hs b/src/Types.hs index 64e7f17..115796a 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -5,12 +5,14 @@ import Control.Concurrent.STM (TQueue) import qualified Graphics.Rendering.OpenGL.GL as GL import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) +import qualified Data.HashMap.Strict as Map import Data.Time (UTCTime) import Linear.Matrix (M44) import Control.Monad.RWS.Strict (RWST) import Control.Lens import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Render.Types +import UI.UIBaseData --Static Read-Only-State @@ -74,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 @@ -88,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 @@ -112,6 +135,8 @@ data GLState = GLState data UIState = UIState { _uiHasChanged :: !Bool + , _uiMap :: Map.HashMap UIId (GUIAny Pioneers) + , _uiRoots :: [UIId] } data State = State @@ -125,6 +150,9 @@ data State = State , _ui :: !UIState } +type Pioneers = RWST Env () State IO + +-- when using TemplateHaskell order of declaration matters $(makeLenses ''State) $(makeLenses ''GLState) $(makeLenses ''GLMapState) @@ -140,8 +168,6 @@ $(makeLenses ''Position) $(makeLenses ''Env) $(makeLenses ''UIState) -type Pioneers = RWST Env () State IO - data Structure = Flag -- Flag | Woodcutter -- Huts | Forester diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index ad7a825..58e2e59 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -1,52 +1,84 @@ -{-# LANGUAGE ExistentialQuantification #-} - module UI.Callbacks where -import Control.Monad.Trans (liftIO) -import Types -import UI.UITypes import qualified Graphics.Rendering.OpenGL.GL as GL -import Control.Lens ((^.), (.~), (%~)) -import Render.Misc (genColorData) +import Control.Lens ((^.), (.~)) +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.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 -getGUI :: [GUIAny] -getGUI = [ toGUIAny $ GUIContainer 0 0 120 80 [] 1 - , toGUIAny $ GUIPanel $ GUIContainer 0 0 0 0 - [toGUIAny $ GUIContainer 0 80 100 200 [] 4 - ,toGUIAny $GUIButton 50 400 200 175 2 defaultUIState testMessage - ] 3 - ] +createGUI :: (Map.HashMap UIId (GUIAny Pioneers), [UIId]) +createGUI = (Map.fromList [ (UIId 0, GUIAnyP $ GUIPanel $ GUIContainer 0 0 0 0 [UIId 1, UIId 2] 0) + , (UIId 1, GUIAnyC $ GUIContainer 20 50 120 80 [] 1) + , (UIId 2, GUIAnyP $ GUIPanel $ GUIContainer 100 140 0 0 [UIId 3, UIId 4] 3) + , (UIId 3, GUIAnyC $ GUIContainer 100 140 130 200 [] 4 ) + , (UIId 4, GUIAnyB (GUIButton 30 200 60 175 2 defaultUIState ) (ButtonHandler testMessage)) + ], [UIId 0]) + +getGUI :: Map.HashMap UIId (GUIAny Pioneers) -> [GUIAny Pioneers] +getGUI hmap = Map.elems hmap -testMessage :: (Show w) => w -> ScreenUnit -> ScreenUnit -> IO w +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 - putStrLn ("\tclick on " ++ show x ++ "," ++ show y) - return w + liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y) + return w -- | Handler for UI-Inputs. -- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ... clickHandler :: Pixel -> Pioneers () -clickHandler (Pixel x y) = case concatMap (isInside x y) getGUI of - [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"] - hit -> liftIO $ do - _ <- sequence $ map (\w -> - case w of - (GUIAnyB b h) -> do - putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w) - ++ " at ["++show x++","++show y++"]" - (b', h') <- onMousePressed x y b h - _ <- onMouseReleased x y b' h' - return () - _ -> putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w) - ++ " at ["++show x++","++show y++"]" - ) hit - return () +clickHandler (Pixel x y) = do + state <- get + let hMap = state ^. ui.uiMap + roots <- getRootIds + hits <- liftM concat $ mapM (getInsideId hMap x y) roots + case hits of + [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"] + _ -> do + changes <- sequence $ map (\uid -> do + let w = toGUIAny hMap uid + short <- getShorthand w + bound <- getBoundary w + prio <- getPriority w + liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio + ++ " 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. @@ -67,36 +99,40 @@ alternateClickHandler (Pixel x y) = liftIO $ putStrLn $ unwords ["alternate pres prepareGUI :: Pioneers () prepareGUI = do state <- get + roots <- getRoots let tex = (state ^. gl.glHud.hudTexture) liftIO $ do -- bind texture - all later calls work on this one. GL.textureBinding GL.Texture2D GL.$= Just tex - mapM_ (copyGUI tex) getGUI + mapM_ (copyGUI tex) roots modify $ ui.uiHasChanged .~ False --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 - 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, ... --temporary color here. lateron better some getData-function to --get a list of pixel-data or a texture. color = case widget of (GUIAnyC _) -> [255,0,0,128] (GUIAnyB _ _) -> [255,255,0,255] - (GUIAnyP _) -> [128,128,128,255] + (GUIAnyP _) -> [128,128,128,128] _ -> [255,0,255,255] - allocaBytes (width*height*4) $ \ptr -> do + liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do --copy data into C-Array - pokeArray ptr (genColorData (width*height) color) + pokeArray ptr (genColorData (wWidth*wHeight) color) GL.texSubImage2D GL.Texture2D 0 (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) - mapM_ (copyGUI tex) (getChildren widget) -copyGUI _ _ = return () + nextChildrenIds <- getChildren widget + mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. ---TODO: Maybe queues are better? +--TODO: Maybe queues are better? \ No newline at end of file diff --git a/src/UI/UIBaseData.hs b/src/UI/UIBaseData.hs new file mode 100644 index 0000000..c21008f --- /dev/null +++ b/src/UI/UIBaseData.hs @@ -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) + ++ "}" diff --git a/src/UI/UITypes.hs b/src/UI/UIClasses.hs similarity index 52% rename from src/UI/UITypes.hs rename to src/UI/UIClasses.hs index 7a2a14c..377e463 100644 --- a/src/UI/UITypes.hs +++ b/src/UI/UIClasses.hs @@ -1,98 +1,54 @@ {-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-} -module UI.UITypes where +module UI.UIClasses where -import Data.List -import Foreign.C (CFloat) -import Linear.Matrix (M44) +import Control.Lens ((^.)) +import Control.Monad +--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 -type ScreenUnit = Int +import qualified Types as T +import UI.UIBaseData --- |A viewport to an OpenGL scene. -data Viewport = Viewport - { _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) +class GUIAnyMap m w where + guiAnyMap :: (w -> b) -> GUIAny m -> b -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) - - -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 +class (Monad m) => GUIWidget m uiw where -- |The 'getBoundary' function gives the outer extents of the 'UIWidget'. -- 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. -- -- All children must be wholly inside the parent's bounding box specified by 'getBoundary'. - getChildren :: uiw -> [GUIAny] - getChildren _ = [] + getChildren :: uiw -> m [UIId] + 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 -- component. -- -- The default implementations tests if the point is within the rectangle specified by the -- 'getBoundary' function. - isInsideSelf :: ScreenUnit -- ^screen x coordinate + isInside :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen y coordinate -> uiw -- ^the parent widget - -> Bool - isInsideSelf x' y' wg = let (x, y, w, h) = getBoundary wg - in (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? + -> m Bool + isInside x' y' wg = do + (x, y, w, h) <- getBoundary wg + return $ (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0) -- |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. - getPriority :: uiw -> Int - getPriority _ = 0 + getPriority :: uiw -> m Int + getPriority _ = return 0 -- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose. -- The shorthand should be unique for each instance. - getShorthand :: uiw -> String + getShorthand :: uiw -> m String -- |A 'GUIClickable' represents a widget with a 'UIButtonState'. -- @@ -104,13 +60,13 @@ class GUIClickable w where setButtonState s = updateButtonState (\_ -> s) 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 -- while inside a screen coordinate within the widget ('isInside'). onMousePressed :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen y coordinate -> 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) -- |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 -> ScreenUnit -- ^screen x coordinate -> 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) -- |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 -> ScreenUnit -- ^screen y coordinate -> 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) -- |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 -> ScreenUnit -- ^screen x coordinate -> 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) -- |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 -> ScreenUnit -- ^screen y coordinate -> 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) -- |The function 'onMouseMove' is invoked when the mouse enters the @@ -154,7 +110,7 @@ class MouseHandler a w where onMouseEnter :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen y coordinate -> 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) -- |The function 'onMouseMove' is invoked when the mouse leaves the @@ -162,20 +118,10 @@ class MouseHandler a w where onMouseLeave :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen y coordinate -> 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) --- |Switches primary and secondary mouse actions. -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 +instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch h) m w where onMousePressed x y w (MouseHandlerSwitch h) = do (w', h') <- onMousePressedAlt x y w 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 return (w', MouseHandlerSwitch h') - --- !!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 +instance (Monad m, GUIClickable w) => MouseHandler (ButtonHandler m w) m w where -- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@. - onMousePressed _ _ wg h = do + onMousePressed _ _ wg h = return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h) -- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and @@ -243,70 +183,48 @@ instance (GUIClickable w) => MouseHandler (ButtonHandler w) w where }) wg , h) - -data GUIAny = GUIAnyC GUIContainer - | GUIAnyP GUIPanel - | GUIAnyB GUIButton (ButtonHandler GUIButton) - deriving (Show) -instance GUIAnyMap GUIAny where +instance (Monad m) => GUIAnyMap m (GUIAny m) where 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 (GUIAnyP w) = getBoundary w getBoundary (GUIAnyB w _) = getBoundary w getChildren (GUIAnyC w) = getChildren w getChildren (GUIAnyP 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 (GUIAnyP w) = (isInside x y) w isInside x y (GUIAnyB w _) = (isInside x y) w getPriority (GUIAnyC w) = getPriority w getPriority (GUIAnyP w) = getPriority w getPriority (GUIAnyB w _) = getPriority w - getShorthand (GUIAnyC w) = "A" ++ getShorthand w - getShorthand (GUIAnyP w) = "A" ++ getShorthand w - getShorthand (GUIAnyB w _) = "A" ++ getShorthand w + getShorthand (GUIAnyC w) = do { str <- getShorthand w; return $ "A" ++ str } + getShorthand (GUIAnyP w) = do { str <- getShorthand w; return $ "A" ++ str } + 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 --- functionality itself. -data GUIContainer = GUIContainer { _screenX :: ScreenUnit, _screenY :: ScreenUnit - , _width :: ScreenUnit, _height :: ScreenUnit - , _children :: [GUIAny] - , _priority :: Int - } deriving (Show) - -instance GUIAnyMap GUIContainer where +instance (Monad m) => GUIAnyMap m GUIContainer where guiAnyMap f (GUIAnyC c) = f c guiAnyMap _ _ = error "invalid types in guiAnyMap" - toGUIAny cnt = GUIAnyC cnt - fromGUIAny (GUIAnyC cnt) = cnt - fromGUIAny _ = error "invalid GUIAny type" -instance GUIWidget GUIContainer where - getBoundary :: GUIContainer -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) - getBoundary cnt = (_screenX cnt, _screenY cnt, _width cnt, _height cnt) - getChildren cnt = _children cnt - getPriority cnt = _priority cnt - getShorthand _ = "CNT" +instance (Monad m) => GUIWidget m GUIContainer where + getBoundary :: GUIContainer -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) + getBoundary cnt = return (_uiScreenX cnt, _uiScreenY cnt, _uiWidth cnt, _uiHeight cnt) + getChildren cnt = return $ _uiChildren cnt + getPriority cnt = return $ _uiPriority cnt + getShorthand _ = return $ "CNT" --- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its --- children components. -data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show) -instance GUIAnyMap GUIPanel where +instance GUIAnyMap m GUIPanel where guiAnyMap f (GUIAnyP p) = f p guiAnyMap _ _ = error "invalid types in guiAnyMap" - toGUIAny pnl = GUIAnyP pnl - fromGUIAny (GUIAnyP pnl) = pnl - fromGUIAny _ = error "invalid GUIAny type" -instance GUIWidget GUIPanel where - getBoundary pnl = case getChildren $ _panelContainer pnl of +instance GUIWidget T.Pioneers GUIPanel where + getBoundary pnl = do + state <- get + let hmap = state ^. T.ui . T.uiMap + case _uiChildren $ _panelContainer pnl of [] -> 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 determineSize :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) determineSize (x, y, w, h) (x', y', w', h') = @@ -318,37 +236,16 @@ instance GUIWidget GUIPanel where getChildren pnl = getChildren $ _panelContainer pnl getPriority pnl = getPriority $ _panelContainer pnl - getShorthand _ = "PNL" - --- |A 'GUIButton' is a dummy datatype for a clickable 'GUIWidget'. Its functinality must be --- 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 () + getShorthand _ = return $ "PNL" -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 +instance (Monad m) => GUIAnyMap m GUIButton where guiAnyMap f (GUIAnyB btn _) = f btn 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 - getButtonState = _buttonState - updateButtonState f btn = btn {_buttonState = f $ _buttonState btn} -instance GUIWidget GUIButton where - getBoundary btn = (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn) - getChildren _ = [] - getPriority btn = _priorityB btn - getShorthand _ = "BTN" \ No newline at end of file + getButtonState = _uiButtonState + updateButtonState f btn = btn {_uiButtonState = f $ _uiButtonState btn} +instance (Monad m) => GUIWidget m GUIButton where + getBoundary btn = return (_uiScreenXB btn, _uiScreenYB btn, _uiWidthB btn, _uiHeightB btn) + getChildren _ = return [] + getPriority btn = return $ _uiPriorityB btn + getShorthand _ = return "BTN" \ No newline at end of file diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs new file mode 100644 index 0000000..a6085d0 --- /dev/null +++ b/src/UI/UIOperations.hs @@ -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? + + diff --git a/tests/MainTestSuite.hs b/tests/MainTestSuite.hs new file mode 100644 index 0000000..9c46a05 --- /dev/null +++ b/tests/MainTestSuite.hs @@ -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 + ] + ] + +