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

WIP, does not compile.

Browse Source
This commit is contained in:
Nicole Dresselhaus 2014-05-15 21:18:28 +02:00
commit e37832371c
No known key found for this signature in database
GPG Key ID: BC16D887851A1A80
13 changed files with 254 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Pioneers.cabal
View File

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

14
src/Main.hs
View File

@ -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.

24
src/Map/Creation.hs
View File

@ -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

15
src/Map/Graphics.hs
View File

@ -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 =

57
src/Map/Map.hs
View File

@ -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

49
src/Map/StaticMaps.hs
View File

@ -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)

76
src/Map/Types.hs
View File

@ -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"

1
src/Render/Render.hs
View File

@ -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"

31
src/Render/Types.hs
View File

@ -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

64
src/Types.hs
View File

@ -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"

33
src/UI/Callbacks.hs
View File

@ -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

57
src/UI/UIBase.hs
View File

@ -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)

6
src/UI/UIOperations.hs
View File

@ -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