Merge branch 'testing' into Mapping

.gitignore

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

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,
+                   Importer.IQM.Types,
-                   IQM.TestMain,
+                   Importer.IQM.Parser,
-                   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
+                   attoparsec >= 0.11.2,
-  other-modules:   Render.Types
+                   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

README

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

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
+

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;
 

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 :: Integral a => a -> a -> a
-w8ToInt i add = 256*i + add
+_w8ToInt i add = 256*i + add
 
 -- | 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
 --
 --   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 :: CParser Int32
-int32 = do
+_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
+         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
                 , 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
+        name <- w32leCParser
-        mat <- int32
+        mat <- w32leCParser
-        fv <- int32
+        fv <- w32leCParser
-        nv <- int32
+        nv <- w32leCParser
-        ft <- int32
+        ft <- w32leCParser
-        nt <- int32
+        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
+--   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)).
+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
+	        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

src/Importer/IQM/Types.hs

@@ -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
 
+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
+                { 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)
 
 -- | 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
+                , meshMaterial          :: Word32
-                , meshFirstVertex       :: Int32
+                , meshFirstVertex       :: Word32
-                , meshNumVertexes       :: Int32
+                , meshNumVertexes       :: Word32
-                , meshFirstTriangle     :: Int32
+                , meshFirstTriangle     :: Word32
-                , meshNumTriangles      :: Int32
+                , 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 ++ 
+                                                        ")"
+

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           Data.Attoparsec.Char8 (parseTest)
-import qualified Data.ByteString as B
+--import qualified Data.ByteString as B
 
 -- 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'
         initRendering
         --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'
         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.

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

src/Render/Render.hs

@@ -50,22 +50,11 @@ initBuffer varray =
            checkError "initBuffer"
            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
    ! 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)

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

src/UI/Callbacks.hs

@@ -1,54 +1,86 @@
-{-# 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           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.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]
+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
-    putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
+  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
+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,")"]
-    hit -> liftIO $ do
+       _  -> do
-        _ <- sequence $ map (\w ->
+         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
-                      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'
+                    (b'', h'') <- onMouseReleased x y b' h'
-                      return ()
+                    return $ Just (uid, GUIAnyB b'' h'')
-                 _ -> putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w)
+                _ -> return Nothing
-                          ++ " at ["++show x++","++show y++"]"
+           ) $ hits
-            ) hit
+         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.
 --   Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...
 alternateClickHandler :: Pixel -> Pioneers ()
@@ -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)
+                        nextChildrenIds <- getChildren widget
-copyGUI _ _ = return ()
+                        mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds
 
 --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
 --TODO: Maybe queues are better?

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

src/UI/UIClasses.hs

@@ -1,98 +1,54 @@
 {-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
 
-module UI.UITypes where
+module UI.UIClasses where
 
+import           Control.Lens                         ((^.))
+import           Control.Monad
+--import           Control.Monad.IO.Class -- MonadIO
+import           Control.Monad.RWS.Strict             (get)
 import           Data.List
-import Foreign.C                            (CFloat)
+import           Data.Maybe
-import Linear.Matrix (M44)
+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 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 :: 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
     --  component.
     --  
     --  The default implementations tests if the point is within the rectangle specified by the 
     --  'getBoundary' function.
-    isInsideSelf :: 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]
+                 -> m Bool
-    isInside x' y' wg =
+    isInside x' y' wg = do
-        case isInsideSelf x' y' wg of -- test inside parent's bounding box
+        (x, y, w, h) <- getBoundary wg
-            False -> []
+        return $ (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
-            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'.
     --  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 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.
+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
         (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')
 
-
+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@.
-    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)
 
-
+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
-    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 (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 _ _ = 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 _ _ = 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
-                           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"
+    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 _ _ = 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
+    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"

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?
+
+

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