WIP, does not compile.

Pioneers.cabal

@@ -16,7 +16,6 @@ executable Pioneers
                    Map.Types,
                    Map.Graphics,
                    Map.Creation,
-                   Map.StaticMaps,
                    Importer.IQM.Types,
                    Importer.IQM.Parser,
                    Render.Misc,

src/Main.hs

@@ -43,7 +43,9 @@ import           Render.Render                        (initRendering,
 import           Render.Types
 import           UI.Callbacks
 import           Map.Graphics
+import           Map.Creation                          (exportedMap)
 import           Types
+import qualified UI.UIBase as UI
 import           Importer.IQM.Parser
 --import           Data.Attoparsec.Char8 (parseTest)
 --import qualified Data.ByteString as B
@@ -53,7 +55,7 @@ import           Importer.IQM.Parser
 --------------------------------------------------------------------------------
 
 testParser :: String -> IO ()
-testParser a = putStrLn . show  =<< parseIQM a
+testParser a = print  =<< parseIQM a
 {-do
         f <- B.readFile a
         putStrLn "reading in:"
@@ -85,7 +87,8 @@ main =
         (SDL.Size fbWidth fbHeight) <- SDL.glGetDrawableSize window'
         initRendering
         --generate map vertices
-        glMap' <- initMapShader 4 =<< getMapBufferObject
+        curMap <- exportedMap
+        glMap' <- initMapShader 4 =<< getMapBufferObject curMap
         eventQueue <- newTQueueIO :: IO (TQueue SDL.Event)
         now <- getCurrentTime
         --font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
@@ -125,7 +128,7 @@ main =
                         , _yAngle              = pi/2
                         , _zDist               = 10
                         , _frustum             = frust
-                        , _camObject           = createFlatCam 25 25
+                        , _camObject           = createFlatCam 25 25 curMap
                         }
               , _io                  = IOState
                         { _clock               = now
@@ -153,12 +156,13 @@ main =
                         , _glFramebuffer       = frameBuffer
                         }
               , _game                = GameState
-                        {
+                        { _currentMap          = curMap
                         }
               , _ui                  = UIState
                         { _uiHasChanged        = True
                         , _uiMap = guiMap
                         , _uiRoots = guiRoots
+                        , _uiButtonState = UI.UIButtonState 0 Nothing
                         }
               }
 
@@ -216,7 +220,7 @@ run = do
                      - 0.2 * kyrot * mults
         mody y' = y' + 0.2 * kxrot * mults
                      - 0.2 * kyrot * multc
-    modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)))
+    modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (state ^. game.currentMap))
 
     {-
     --modify the state with all that happened in mt time.

src/Map/Creation.hs

@@ -2,7 +2,6 @@ module Map.Creation
 where
 
 import Map.Types
-import Map.StaticMaps
 -- import Map.Map unused (for now)
 
 import Data.Array
@@ -18,6 +17,10 @@ infix 5 -<-
 (-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
 f -<- g = f . g
 
+-- entirely empty map, only uses the minimal constructor
+mapEmpty :: PlayMap
+mapEmpty = array ((0,0), (199,199)) [((a,b), Node (a,b) (fromIntegral a, (if even b then (fromIntegral b) else(fromIntegral b) - 0.5), 1) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199]]
+
 exportedMap :: IO PlayMap
 exportedMap = do mounts <- mnt
                  return $ aplAll mounts mapEmpty
@@ -52,7 +55,7 @@ gauss3Dgeneral :: Floating q =>
                   -> q -- ^ Coordinate in question on X
                   -> q -- ^ Coordinate in question on Z
                   -> q -- ^ elevation on coordinate in question
-gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Integer)/(2 * sX^(2 :: Integer)))+((z-z0)^(2 :: Integer)/(2 * sZ^(2 :: Integer)))))
+gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Int)/(2 * sX^(2 :: Int)))+((z-z0)^(2 :: Int)/(2 * sZ^(2 :: Int)))))
 
 -- specialised 3D gaussian with an origin on 100/100, an amplitude of 15 and two sigmas of 15
 gauss3D :: Floating q =>
@@ -93,20 +96,17 @@ mnt = do g <- newStdGen
 gaussMountain :: Int -> PlayMap -> PlayMap
 gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp
   where
-    g   = mkStdGen seed
+    gs  = map mkStdGen (map (*seed) [1..])
-    c   = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) g), (head (randomRs (b,y) g)))
+    c   = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) (gs !! 0)), (head (randomRs (b,y) (gs !! 1))))
-    amp = head $ randomRs (2.0, 5.0) g
+    amp = head $ randomRs ((2.0, 5.0) :: (Float, Float)) (gs !! 2)
-    sig = head $ randomRs (1.0, 5.0) g
+    sig = head $ randomRs ((1.0, 15.0) :: (Float, Float)) (gs !! 3)
-    fi  = fromIntegral
     htt = heightToTerrain
 
     -- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map
     liftUp :: (Int, Int) -> Node -> Node
-    liftUp (gx,gz) (Full     (x,z) y _ b pl pa r s) = let y_neu = max y e
+    liftUp (gx,gz) (Node (x,z) (rx,rz,y) _ b pl pa r s) = let y_neu = max y e
-                                                      in  Full (x,z) y_neu (htt GrassIslandMap y_neu) b pl pa r s
+                                                          in  Node (x,z) (rx, rz, y_neu) (htt GrassIslandMap y_neu) b pl pa r s
-      where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z)
+      where e = gauss3Dgeneral amp (fromIntegral gx) (fromIntegral gz) sig sig rx rz
-    liftUp (gx, gz) (Minimal (x,z)) = Full (x,z) e (htt GrassIslandMap e) BFlag NoPlayer NoPath Plain []
-      where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z)
 
 -- | Makes sure the edges of the Map are mountain-free
 makeIsland :: PlayMap -> PlayMap

src/Map/Graphics.hs

@@ -50,16 +50,14 @@ stripify :: (Int,Int) -> (Int,Int)
 stripify (x,z) = (if even z then 2*x else 2*x+1, z `div` 2)
 
 strp :: Node -> Node
-strp (Full    xz y tt bi pli p ri si) = Full    (stripify xz) y tt bi pli p ri si
+strp (Node i (x,z,y) tt bi pli p ri si) = Node (stripify i) (x,z,y) tt bi pli p ri si
-strp (Minimal xz                    ) = Minimal (stripify xz)
 
 -- extract graphics information from Playmap
 convertToGraphicsMap :: PlayMap -> GraphicsMap
 convertToGraphicsMap mp = array (bounds mp) [(i, graphicsyfy (mp ! i))| i <- indices mp]
     where
       graphicsyfy :: Node -> MapEntry
-      graphicsyfy (Minimal _               ) = (1.0, Grass)
+      graphicsyfy (Node _ (_,_,y) t _ _ _ _ _ ) = (y, t)
-      graphicsyfy (Full    _ y t _ _ _ _ _ ) = (y, t)
 
 lineHeight :: GLfloat
 lineHeight = 0.8660254
@@ -87,9 +85,8 @@ fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color
 fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
 fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal
 
-getMapBufferObject :: IO (BufferObject, NumArrayIndices)
+getMapBufferObject :: PlayMap -> IO (BufferObject, NumArrayIndices)
-getMapBufferObject = do
+getMapBufferObject eMap = do
-        eMap    <- exportedMap
         myMap'  <- return $ convertToGraphicsMap $ convertToStripeMap eMap
         ! myMap <- return $ generateTriangles myMap'
         len <- return $ fromIntegral $ P.length myMap `div` numComponents
@@ -203,8 +200,8 @@ colorLookup hs t = if inRange (bounds hs) t then c else (0.0, 0.0, 0.0)
                                 Beach           -> (0.90, 0.85, 0.70)
                                 Desert          -> (1.00, 0.87, 0.39)
                                 Grass           -> (0.30, 0.90, 0.10)
-                                Hill            -> (0.80, 0.80, 0.80)
+                                Mountain        -> (0.80, 0.80, 0.80)
-                                Mountain        -> (0.50, 0.50, 0.50)
+                                Hill            -> (0.50, 0.50, 0.50)
 
 coordLookup :: (Int,Int) -> GLfloat -> V3 GLfloat
 coordLookup (x,z) y =

src/Map/Map.hs

@@ -1,9 +1,11 @@
 module Map.Map where
 
 import Map.Types
+import Map.Creation
 
-import Data.Array (bounds)
+import Data.Function (on)
-import Data.List  (sort, group)
+import Data.Array    (bounds, (!))
+import Data.List     (sort, sortBy, group)
 
 -- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet.
 unsafeGiveNeighbours :: (Int, Int)  -- ^ original coordinates
@@ -36,6 +38,57 @@ giveNeighbourhood _  0 (a,b) = [(a,b)]
 giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in 
                              remdups . concat $ ns : map (giveNeighbourhood mp (n-1)) ns
 
+-- | Calculates the height of any given point on the map.
+-- Does not add camera distance to ground to that.
+-- 
+-- This ueses barycentric coordinate stuff. Wanna read more?
+-- http://en.wikipedia.org/wiki/Barycentric_coordinate_system_%28mathematics%29
+-- http://www.alecjacobson.com/weblog/?p=1596
+--
+giveMapHeight :: PlayMap
+              -> (Float, Float)  -- ^ Coordinates on X/Z-axes 
+              -> Float           -- ^ Terrain Height at that position
+giveMapHeight mp (x,z) = let [a,b,c] = getTrianglePoints [tff,tfc,tcf,tcc]
+                             ar = area (fi a) (fi b) (fi c)
+                             λa = area (fi b) (fi c) (x, z) / ar
+                             λb = area (fi a) (fi c) (x, z) / ar
+                             λc = area (fi a) (fi b) (x, z) / ar
+                         in  (λa * hlu a) + (λb * hlu b) + (λc * hlu c)
+  where
+
+    fi :: (Int, Int) -> (Float, Float)
+    fi (m, n) = (fromIntegral m, fromIntegral n)
+
+    -- Height LookUp
+    hlu :: (Int, Int) -> Float
+    hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mp ! (k,j) in y
+
+    ff  = (floor   x, floor   z) :: (Int, Int)
+    fc  = (floor   x, ceiling z) :: (Int, Int)
+    cf  = (ceiling x, floor   z) :: (Int, Int)
+    cc  = (ceiling x, ceiling z) :: (Int, Int)
+
+    tff = (ff, dist (x,z) ff)
+    tfc = (fc, dist (x,z) fc)
+    tcf = (cf, dist (x,z) cf)
+    tcc = (cc, dist (x,z) cc)
+
+    getTrianglePoints :: [((Int,Int), Float)] -> [(Int,Int)]
+    getTrianglePoints = ((take 3) . (map fst) . (sortBy (compare `on` snd)))
+
+    dist :: (Float, Float) -> (Int, Int) -> Float
+    dist (x1,z1) (x2,z2) = let x' = x1 - fromIntegral x2
+                               z' = z1 - fromIntegral z2
+                           in  sqrt $ x'*x' + z'*z'
+
+    -- Heron's Formula: http://en.wikipedia.org/wiki/Heron%27s_formula
+    area :: (Float, Float) -> (Float, Float) -> (Float, Float) -> Float
+    area (x1,z1) (x2,z2) (x3,z3) = let a = sqrt $ (x1-x2)*(x1-x2) + (z1-z2)*(z1-z2)
+                                       b = sqrt $ (x2-x3)*(x2-x3) + (z2-z3)*(z2-z3)
+                                       c = sqrt $ (x1-x3)*(x1-x3) + (z1-z3)*(z1-z3)
+                                       s = (a+b+c)/2 
+                                   in  sqrt $ s * (s-a) * (s-b) * (s-c)
+
 -- removing duplicates in O(n log n), losing order and adding Ord requirement
 remdups :: Ord a => [a] -> [a]
 remdups = map head . group . sort

src/Map/StaticMaps.hs

@@ -1,49 +0,0 @@
-module Map.StaticMaps
-where
-
-import Map.Types
-import Data.Array
-
--- entirely empty map, only uses the minimal constructor
-mapEmpty :: PlayMap
-mapEmpty = array ((0,0), (199,199)) [((a,b), Minimal (a,b)) | a <- [0..199], b <- [0..199]]
-
---mapCenterMountain :: PlayMap
---mapCenterMountain = array ((0,0),(199,199)) nodes
---    where
---      nodes    = water ++ beach ++ grass ++ hill ++ mountain
---      water    = [((a,b), Full (a,b) 0.0       Ocean    BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) > 95]
---      beach    = [((a,b), Full (a,b) (g2d a b) Beach    BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 95, m2d (a,b) > 75]
---      grass    = [((a,b), Full (a,b) (g2d a b) Grass    BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 75, m2d (a,b) > 25]
---      hill     = [((a,b), Full (a,b) (g2d a b) Hill     BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 25, m2d (a,b) > 10]
---      mountain = [((a,b), Full (a,b) (g2d a b) Mountain BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 10]
-
---      g2d :: Int -> Int -> Float
---      g2d x y = gauss3D (fromIntegral x) (fromIntegral y)
-
---      m2d :: (Int,Int) -> Int
---      m2d (x,y) = mnh2D (x,y) (100,100)
-
--- small helper for some hills. Should be replaced by multi-layer perlin-noise
--- TODO: Replace as given in comment.
---_noisyMap :: (Floating q) => q -> q -> q
---_noisyMap x y =    gauss3Dgeneral 15 100.0 100.0 15.0 15.0 x y
---                +  gauss3Dgeneral 5  10.0 10.0 10.0 10.0 x y
---                +  gauss3Dgeneral 5  150.0 120.0 10.0 10.0 x y
---                +  gauss3Dgeneral 5  50.0 75.0 10.0 10.0 x y
-
--- generates a noisy map
--- TODO: add real noise to a simple pattern
---mapNoise :: PlayMap
---mapNoise = array ((0,0),(199,199)) nodes
---    where
---      nodes    = [((a,b), Full (a,b)
---                               (height a b)
---                               (heightToTerrain GrassIslandMap $ height a b)
---                               BNothing
---                               NoPlayer
---                               NoPath
---                               Plain
---                               []) | a <- [0..199], b <- [0..199]]
---                 where
---                    height a b = _noisyMap (fromIntegral a) (fromIntegral b)

src/Map/Types.hs

@@ -1,14 +1,14 @@
 module Map.Types
 where
 
-import Types
-
 import Data.Array
 
-type PlayMap = Array (XCoord, ZCoord) Node 
+type PlayMap = Array (Xindex, Zindex) Node 
 
-type XCoord  = Int
+type Xindex  = Int
-type ZCoord  = Int
+type Zindex  = Int
+type XCoord  = Float
+type ZCoord  = Float
 type YCoord  = Float
 
 data MapType    = GrassIslandMap
@@ -66,7 +66,67 @@ data TileType   = Ocean
                 | Mountain -- ^ Not accessible
                 deriving (Show, Eq)
 
--- TODO: Record Syntax
+-- TODO: Record Syntax?
-data Node = Full    (XCoord, ZCoord) YCoord TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo
+data Node = Node (Xindex, Zindex) (XCoord, ZCoord, YCoord) TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo
-          | Minimal (XCoord, ZCoord) -- defaults to empty green grass node on height 1
           deriving (Show)
+
+data Structure = Flag           -- Flag
+               | Woodcutter     -- Huts
+               | Forester
+               | Stonemason
+               | Fisher
+               | Hunter
+               | Barracks
+               | Guardhouse
+               | LookoutTower
+               | Well
+               | Sawmill        -- Houses
+               | Slaughterhouse
+               | Mill
+               | Bakery
+               | IronSmelter
+               | Metalworks
+               | Armory
+               | Mint
+               | Shipyard
+               | Brewery
+               | Storehouse
+               | Watchtower
+               | Catapult
+               | GoldMine       -- Mines
+               | IronMine
+               | GraniteMine
+               | CoalMine
+               | Farm           -- Castles
+               | PigFarm
+               | DonkeyBreeder
+               | Harbor
+               | Fortress
+               deriving (Show, Eq)
+
+data Amount    = Infinite   -- Neverending supply
+               | Finite Int -- Finite supply
+
+-- Extremely preliminary, expand when needed
+data Commodity = WoodPlank
+               | Sword
+               | Fish
+               deriving Eq
+
+data Resource  = Coal
+               | Iron
+               | Gold
+               | Granite
+               | Water
+               | Fishes
+               deriving (Show, Eq)
+
+instance Show Amount where
+    show (Infinite) = "inexhaustable supply"
+    show (Finite n) = show n ++ " left"
+
+instance Show Commodity where
+    show WoodPlank = "wooden plank"
+    show Sword     = "sword"
+    show Fish      = "fish"
+

src/Render/Render.hs

@@ -24,6 +24,7 @@ import           Render.Types
 import           Graphics.GLUtil.BufferObjects              (makeBuffer)
 import		 Importer.IQM.Parser
 import           Importer.IQM.Types
+import           Map.Map                               (giveMapHeight)
 
 mapVertexShaderFile :: String
 mapVertexShaderFile = "shaders/map/vertex.shader"

src/Render/Types.hs

@@ -4,6 +4,10 @@ module Render.Types (createFlatCam, createSphereCam, Camera, GLCamera(..)) where
 import Linear
 import Foreign.C (CFloat)
 import Render.Misc (lookAt)
+import Map.Map (giveMapHeight)
+import Map.Types (PlayMap)
+import GHC.Float
+import qualified Debug.Trace as D
 
 type Distance = Double
 type Pitch = Double
@@ -11,27 +15,29 @@ type Yaw = Double
 
 class GLCamera a where
   getCam :: a -> Distance -> Pitch -> Yaw -> M44 CFloat
-  moveBy :: a -> (Position -> Position) -> a
+  moveBy :: a -> (Position -> Position) -> PlayMap -> a
-  move   :: a -> Position -> a
+  move   :: a -> Position -> PlayMap -> a
 
 type Position = (Double, Double)
 
 type Radius = Double
 
-data Camera = Flat Position
+type Height = Double
+
+data Camera = Flat Position Height
             | Sphere Position Radius
 
 -- | create a Flatcam-Camera starting at given x/z-Coordinates
-createFlatCam :: Double -> Double -> Camera
+createFlatCam :: Double -> Double -> PlayMap -> Camera
-createFlatCam x z = Flat (x,z)
+createFlatCam x z map' = Flat (x,z) (float2Double $ giveMapHeight map' (double2Float x,double2Float z))
 
 -- | create a Flatcam-Camera starting at given pitch/azimuth/radius
 createSphereCam :: Double -> Double -> Double -> Camera
-createSphereCam p a r = Sphere (p,a) r
+createSphereCam p a = Sphere (p,a)
 
 
 instance GLCamera Camera where
-  getCam (Flat (x',z')) dist' xa' ya' =
+  getCam (Flat (x',z') y') dist' xa' ya' =
         lookAt (cpos ^+^ at') at' up
                      where
                         at'   = V3 x (y+1) z
@@ -44,6 +50,7 @@ instance GLCamera Camera where
                         upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat)
                                 !* (V3 1 0 0)
                         x     = realToFrac x'
+                        y     = realToFrac y'
                         z     = realToFrac z'
                         dist  = realToFrac dist'
                         xa    = realToFrac xa'
@@ -68,9 +75,13 @@ instance GLCamera Camera where
                         dist  = realToFrac dist'
                         xa    = realToFrac xa'
                         ya    = realToFrac ya'
-  moveBy (Sphere (inc, az) r) f = undefined
+  moveBy (Sphere (inc, az) r) f map = undefined
-  moveBy (Flat (x', z')) f = Flat (f (x',z'))
+  moveBy (Flat (x', z') y) f map = Flat (x,z) (float2Double y)
-  move c (x', z') = moveBy c (\(x,z) -> (x+x',z+z'))
+				where
+					(x,z) = f (x', z')
+					y = giveMapHeight map (fc x,fc z)
+					fc = double2Float
+  move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map
 
 sphereToCart :: (Floating a) => a -> a -> a -> V3 a
 sphereToCart r inc az = V3

src/Types.hs

@@ -15,6 +15,7 @@ import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
 import Render.Types
 import Importer.IQM.Types
 import UI.UIBase
+import Map.Types (PlayMap)
 
 data Coord3D a = Coord3D a a a
 
@@ -56,7 +57,7 @@ data IOState = IOState
     }
 
 data GameState = GameState
-    {
+    { _currentMap          :: !PlayMap
     }
 
 data MouseState = MouseState
@@ -155,6 +156,7 @@ data UIState = UIState
     { _uiHasChanged        :: !Bool
     , _uiMap               :: Map.HashMap UIId (GUIWidget Pioneers)
     , _uiRoots             :: [UIId]
+    , _uiButtonState       :: UIButtonState
     }
 
 data State = State
@@ -186,63 +188,3 @@ $(makeLenses ''Position)
 $(makeLenses ''Env)
 $(makeLenses ''UIState)
 
-data Structure = Flag           -- Flag
-               | Woodcutter     -- Huts
-               | Forester
-               | Stonemason
-               | Fisher
-               | Hunter
-               | Barracks
-               | Guardhouse
-               | LookoutTower
-               | Well
-               | Sawmill        -- Houses
-               | Slaughterhouse
-               | Mill
-               | Bakery
-               | IronSmelter
-               | Metalworks
-               | Armory
-               | Mint
-               | Shipyard
-               | Brewery
-               | Storehouse
-               | Watchtower
-               | Catapult
-               | GoldMine       -- Mines
-               | IronMine
-               | GraniteMine
-               | CoalMine
-               | Farm           -- Castles
-               | PigFarm
-               | DonkeyBreeder
-               | Harbor
-               | Fortress
-               deriving (Show, Eq)
-
-data Amount    = Infinite   -- Neverending supply
-               | Finite Int -- Finite supply
-
--- Extremely preliminary, expand when needed
-data Commodity = WoodPlank
-               | Sword
-               | Fish
-               deriving Eq
-
-data Resource  = Coal
-               | Iron
-               | Gold
-               | Granite
-               | Water
-               | Fishes
-               deriving (Show, Eq)
-
-instance Show Amount where
-    show (Infinite) = "inexhaustable supply"
-    show (Finite n) = show n ++ " left"
-
-instance Show Commodity where
-    show WoodPlank = "wooden plank"
-    show Sword     = "sword"
-    show Fish      = "fish"
-

src/UI/Callbacks.hs

@@ -134,6 +134,37 @@ eventCallback e = do
             _ ->  liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
 
 
+mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
+                   -> MouseButton -> Pixel -> Pioneers ()
+mouseButtonHandler transFunc btn px = do
+    modify $ ui.uiButtonState %~ (mousePressed %~ (+1)) -- TODO: what happens if released outside window? not reset properly?
+    state <- get
+    let hMap = state ^. ui.uiMap
+        currentWidget = state ^. ui.uiButtonState.mouseCurrentWidget
+    case currentWidget of
+         Just (wui, px') -> do
+             let target = toGUIAny hMap wui
+             target' <- case target ^. eventHandlers.(at MouseEvent) of
+                             Just ma -> transFunc ma btn (px -: px') target -- TODO unsafe fromJust
+                             Nothing  -> return target
+             modify $ ui.uiMap %~ Map.insert wui target'
+             return ()
+         Nothing -> return ()
+         
+mousePressHandler :: MouseButton -> Pixel -> Pioneers ()
+mousePressHandler btn px = do
+    modify $ ui.uiButtonState %~ (mousePressed %~ (+1)) -- TODO: what happens if released outside window? not reset properly?
+    mouseButtonHandler (\ma -> fromJust (ma ^? onMousePress)) btn px
+
+mouseReleaseHandler :: MouseButton -> Pixel -> Pioneers ()
+mouseReleaseHandler btn px = do
+    modify $ ui.uiButtonState %~ (mousePressed %~ flip (-) 1) -- TODO: what happens if pressed outside window? not set properly?
+    mouseButtonHandler (\ma -> fromJust (ma ^? onMouseRelease)) btn px
+    -- TODO: trigger move/enter/leave
+
+mouseMoveHandler :: Pixel -> Pioneers ()
+mouseMoveHandler px = undefined
+
 -- | Handler for UI-Inputs.
 --   Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
 clickHandler :: MouseButton -> Pixel -> Pioneers ()
@@ -154,7 +185,7 @@ clickHandler btn pos@(x,y) = do
                              ++ show prio ++ " at [" ++ show x ++ "," ++ show y ++ "]"
            case w ^. eventHandlers.(at MouseEvent) of
                 Just ma -> do w'  <- fromJust (ma ^? onMousePress) btn pos' w -- TODO unsafe fromJust
-                              w'' <- fromJust (ma ^? onMouseRelease) btn pos' True w' -- TODO unsafe fromJust
+                              w'' <- fromJust (ma ^? onMouseRelease) btn pos' w' -- TODO unsafe fromJust
                               return $ Just (uid, w'')
                 Nothing  -> return Nothing
            ) hits

src/UI/UIBase.hs

@@ -70,6 +70,15 @@ instance Hashable WidgetStateKey where -- TODO: generic deriving creates functio
     hash = fromEnum
     hashWithSalt salt x = (salt * 16777619)  `xor` hash x
 
+-- |Global tracking of mouse actions to determine event handling.
+data UIButtonState = UIButtonState
+    { _mousePressed :: Int              -- ^amount of currently pressed buttons
+    , _mouseCurrentWidget :: Maybe (UIId, Pixel)
+      -- ^the current mouse-active widget and its global coordinates.
+      --  If @_mousePressed == 0@: widget the mouse is hovering over,
+      --  otherwise: widget the first button has been pressed on.
+    } deriving (Show, Eq)
+
 -- |The button dependant state of a 'MouseState'.
 data MouseButtonState = MouseButtonState
     { _mouseIsDragging      :: Bool -- ^firing if pressed but not confirmed
@@ -107,19 +116,22 @@ data EventHandler m =
     MouseHandler
         {
         -- |The function 'onMousePressed' is called when a button is pressed
-        --  while inside a screen coordinate within the widget ('isInside').
+        --  while the widget is mouse-active.
+        -- 
+        --  A widget becomes mouse-active if no other button is currently pressed and the mouse
+        --  coordinates are within the widget's extent ('isInside') until no button is pressed any
+        --  more.
         _onMousePress :: MouseButton       -- ^the pressed button
                       -> Pixel             -- ^screen position
                       -> GUIWidget m       -- ^widget the event is invoked on
                       -> m (GUIWidget m)   -- ^widget after the event and the possibly altered mouse handler
         ,
         -- |The function 'onMouseReleased' is called when a button is released
-        --  while the pressing event occured within the widget ('isInside').
+        --  while the widget is mouse-active.
         --  
         --  Thus, the mouse is either within the widget or outside while still dragging.
         _onMouseRelease :: MouseButton       -- ^the released button
                         -> Pixel             -- ^screen position
-                        -> Bool              -- ^@True@ if the event occured inside the widget
                         -> GUIWidget m       -- ^widget the event is invoked on
                         -> m (GUIWidget m)   -- ^widget after the event and the altered handler
         }
@@ -128,19 +140,22 @@ data EventHandler m =
     MouseMotionHandler
         {
         -- |The function 'onMouseMove' is invoked when the mouse is moved inside the
-        --  widget's space ('isInside').
+        --  widget's extent ('isInside') while no button is pressed or when the mouse is inside the
+        --  widget's extent while another button loses its mouse-active state. Triggered after
+        --  '_onMouseEnter'.
         _onMouseMove :: Pixel             -- ^screen position
                      -> GUIWidget m       -- ^widget the event is invoked on
                      -> m (GUIWidget m)   -- ^widget after the event and the altered handler
         ,
         -- |The function 'onMouseMove' is invoked when the mouse enters the
-        --  widget's space ('isInside').
+        --  widget's extent ('isInside') or when the mouse is inside the
+        --  widget's extent while another button loses its mouse-active state..
         _onMouseEnter :: Pixel           -- ^screen position
                       -> GUIWidget m     -- ^widget the event is invoked on
                       -> m (GUIWidget m) -- ^widget after the event and the altered handler
         ,
-        -- |The function 'onMouseMove' is invoked when the mouse leaves the
+        -- |The function 'onMouseLeave' is invoked when the mouse leaves the
-        --  widget's space ('isInside').
+        --  widget's extent ('isInside') while no other widget is mouse-active.
         _onMouseLeave :: Pixel           -- ^screen position
                       -> GUIWidget m     -- ^widget the event is invoked on
                       -> m (GUIWidget m) -- ^widget after the event and the altered handler
@@ -199,10 +214,9 @@ data GUIBaseProperties m = BaseProperties
 data GUIGraphics m = Graphics 
     {temp :: m Int}
 
-$(makeLenses ''WidgetStateKey)
+$(makeLenses ''UIButtonState)
 $(makeLenses ''WidgetState)
 $(makeLenses ''MouseButtonState)
-$(makeLenses ''EventKey)
 $(makeLenses ''EventHandler)
 $(makeLenses ''GUIWidget)
 $(makeLenses ''GUIBaseProperties)
@@ -221,6 +235,7 @@ initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonSta
 
 -- TODO: combined mouse handler
 
+-- TODO? breaks if button array not of sufficient size -- will be avoided by excluding constructor export
 -- |Creates a 'MouseHandler' that sets a widget's 'MouseButtonState' properties if present,
 --  only fully functional in conjunction with 'setMouseMotionStateActions'.
 setMouseStateActions :: (Monad m) => EventHandler m
@@ -231,7 +246,7 @@ setMouseStateActions = MouseHandler press' release'
         return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b).mouseIsDragging .~ True
 
     -- |Change 'MouseButtonState's '_mouseIsDragging' and '_mouseIsDeferred' to @False@.
-    release' b _ _ w =
+    release' b _ w =
         return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b) %~
                 (mouseIsDragging .~ False) . (mouseIsDeferred .~ False)
 
@@ -260,8 +275,7 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
                          -- following line executed BEFORE above line
                          . (\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsDragging)))
 
-                            
+-- TODO: make only fire if press started within widget                            
--- TODO? breaks if array not of sufficient size -- will be avoided by excluding constructor export
 -- |Creates a MouseHandler that reacts on mouse clicks.
 -- 
 --  Does /not/ update 'WidgetState MouseState'!
@@ -271,10 +285,21 @@ buttonMouseActions a = MouseHandler press' release'
   where 
     press' _ _ = return
 
-    release' b p isIn w =
+    release' b p w = do fire <- (w ^. baseProperties.isInside) w p
-      if isIn
+                        if fire then a b w p else return w
-      then a b w p
+
-      else return w
+-- TODO: make only fire if press started within widget
+-- |Creates a MouseHandler that reacts on mouse clicks.
+-- 
+--  Does /not/ update 'WidgetState MouseState'!
+buttonSingleMouseActions :: (Monad m) => (GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
+                                      -> MouseButton -> EventHandler m
+buttonSingleMouseActions a btn = MouseHandler press' release'
+  where 
+    press' _ _ = return
+
+    release' b p w = do fire <- liftM (b == btn &&) $ (w ^. baseProperties.isInside) w p
+                        if fire then a w p else return w
 
 emptyGraphics :: (Monad m) => GUIGraphics m
 emptyGraphics = Graphics (return 3)

src/UI/UIOperations.hs

@@ -10,7 +10,7 @@ import UI.UIBase
 
 -- TODO: test GUI function to scan for overlapping widgets
 
-toGUIAny :: Map.HashMap UIId (GUIWidget m) -> UIId -> GUIWidget m
+toGUIAny :: Map.HashMap UIId (GUIWidget m) -> UIId -> GUIWidget m -- TODO: what to do if widget not inside map -> inconsistent state
 toGUIAny m uid = fromMaybe (error "map does not contain requested key") (Map.lookup uid m)
 {-# INLINABLE toGUIAny #-}
 
@@ -46,4 +46,8 @@ getInsideId hMap px uid = do
     else return []
 --TODO: Priority queue?
 
-
+getLeadingWidget :: [(UIId, Pixel)]  -- ^widgets and their screen positions
+                 -> Pioneers (Maybe (UIId, Pixel))    -- ^the leading widget
+getLeadingWidget [] = return Nothing
+getLeadingWidget (x:_) = return $ Just x
+