diff --git a/Pioneers.cabal b/Pioneers.cabal index fadfec1..bf7c426 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -16,7 +16,6 @@ executable Pioneers Map.Types, Map.Graphics, Map.Creation, - Map.StaticMaps, Importer.IQM.Types, Importer.IQM.Parser, Render.Misc, diff --git a/src/Main.hs b/src/Main.hs index 0d97808..5187e3d 100644 --- a/src/Main.hs +++ b/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. diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 8ae1717..944d2b9 100644 --- a/src/Map/Creation.hs +++ b/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 - c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) g), (head (randomRs (b,y) g))) - amp = head $ randomRs (2.0, 5.0) g - sig = head $ randomRs (1.0, 5.0) g - fi = fromIntegral + gs = map mkStdGen (map (*seed) [1..]) + 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) :: (Float, Float)) (gs !! 2) + sig = head $ randomRs ((1.0, 15.0) :: (Float, Float)) (gs !! 3) htt = heightToTerrain -- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map liftUp :: (Int, Int) -> Node -> Node - liftUp (gx,gz) (Full (x,z) y _ b pl pa r s) = let y_neu = max y e - in Full (x,z) y_neu (htt GrassIslandMap y_neu) b pl pa r s - where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z) - liftUp (gx, gz) (Minimal (x,z)) = Full (x,z) e (htt GrassIslandMap e) BFlag NoPlayer NoPath Plain [] - where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z) + liftUp (gx,gz) (Node (x,z) (rx,rz,y) _ b pl pa r s) = let y_neu = max y e + in Node (x,z) (rx, rz, y_neu) (htt GrassIslandMap y_neu) b pl pa r s + where e = gauss3Dgeneral amp (fromIntegral gx) (fromIntegral gz) sig sig rx rz -- | Makes sure the edges of the Map are mountain-free makeIsland :: PlayMap -> PlayMap diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index 858b1f4..7c9c93f 100644 --- a/src/Map/Graphics.hs +++ b/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 (Minimal xz ) = Minimal (stripify xz) +strp (Node i (x,z,y) tt bi pli p ri si) = Node (stripify i) (x,z,y) tt bi pli p ri si -- 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 (Full _ y t _ _ _ _ _ ) = (y, t) + graphicsyfy (Node _ (_,_,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 = do - eMap <- exportedMap +getMapBufferObject :: PlayMap -> IO (BufferObject, NumArrayIndices) +getMapBufferObject eMap = do 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.50, 0.50, 0.50) + Mountain -> (0.80, 0.80, 0.80) + Hill -> (0.50, 0.50, 0.50) coordLookup :: (Int,Int) -> GLfloat -> V3 GLfloat coordLookup (x,z) y = diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 7ea3593..53a0976 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -1,9 +1,11 @@ module Map.Map where import Map.Types +import Map.Creation -import Data.Array (bounds) -import Data.List (sort, group) +import Data.Function (on) +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 diff --git a/src/Map/StaticMaps.hs b/src/Map/StaticMaps.hs deleted file mode 100644 index 5ef9942..0000000 --- a/src/Map/StaticMaps.hs +++ /dev/null @@ -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) diff --git a/src/Map/Types.hs b/src/Map/Types.hs index c62837f..cd3f246 100644 --- a/src/Map/Types.hs +++ 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 ZCoord = Int +type Xindex = 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 -data Node = Full (XCoord, ZCoord) YCoord TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo - | Minimal (XCoord, ZCoord) -- defaults to empty green grass node on height 1 +-- TODO: Record Syntax? +data Node = Node (Xindex, Zindex) (XCoord, ZCoord, YCoord) TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo 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" + diff --git a/src/Render/Render.hs b/src/Render/Render.hs index b732045..7863ceb 100644 --- a/src/Render/Render.hs +++ b/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" diff --git a/src/Render/Types.hs b/src/Render/Types.hs index 4eee0c2..0f0affc 100644 --- a/src/Render/Types.hs +++ b/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 - move :: a -> Position -> a + moveBy :: a -> (Position -> Position) -> PlayMap -> 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 x z = Flat (x,z) +createFlatCam :: Double -> Double -> PlayMap -> Camera +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 (Flat (x', z')) f = Flat (f (x',z')) - move c (x', z') = moveBy c (\(x,z) -> (x+x',z+z')) + moveBy (Sphere (inc, az) r) f map = undefined + moveBy (Flat (x', z') y) f map = Flat (x,z) (float2Double y) + 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 diff --git a/src/Types.hs b/src/Types.hs index f16333c..75932ea 100644 --- a/src/Types.hs +++ b/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" - diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index e49b4b1..1f77d10 100644 --- a/src/UI/Callbacks.hs +++ b/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 diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index 0c31527..9ecf55e 100644 --- a/src/UI/UIBase.hs +++ b/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 - -- widget's space ('isInside'). + -- |The function 'onMouseLeave' is invoked when the mouse leaves the + -- 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? breaks if array not of sufficient size -- will be avoided by excluding constructor export +-- TODO: make only fire if press started within widget -- |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 = - if isIn - then a b w p - else return w + release' b p w = do fire <- (w ^. baseProperties.isInside) w p + if fire 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) diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index a0908a5..5c54f27 100644 --- a/src/UI/UIOperations.hs +++ b/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 +