2014-02-05 21:06:19 +01:00
|
|
|
module UI.Callbacks where
|
|
|
|
|
|
|
|
|
2014-04-05 23:09:57 +02:00
|
|
|
import qualified Graphics.Rendering.OpenGL.GL as GL
|
2014-05-08 23:36:53 +02:00
|
|
|
import Control.Lens ((^.), (.~), (%~), (^?), at)
|
2014-05-01 20:31:15 +02:00
|
|
|
import Control.Monad (liftM, when, unless)
|
|
|
|
import Control.Monad.RWS.Strict (ask, get, modify)
|
2014-04-26 19:16:53 +02:00
|
|
|
import Control.Monad.Trans (liftIO)
|
|
|
|
import qualified Data.HashMap.Strict as Map
|
|
|
|
import Data.List (foldl')
|
|
|
|
import Data.Maybe
|
2014-05-02 01:28:40 +02:00
|
|
|
import Foreign.Marshal.Array (pokeArray)
|
|
|
|
import Foreign.Marshal.Alloc (allocaBytes)
|
2014-05-01 20:31:15 +02:00
|
|
|
import qualified Graphics.UI.SDL as SDL
|
2014-04-26 19:16:53 +02:00
|
|
|
|
2014-05-03 14:51:24 +02:00
|
|
|
|
|
|
|
import Render.Misc (curb,genColorData)
|
2014-04-26 19:16:53 +02:00
|
|
|
import Types
|
2014-05-03 14:51:24 +02:00
|
|
|
import UI.UIWidgets
|
2014-04-26 19:16:53 +02:00
|
|
|
import UI.UIOperations
|
2014-04-05 23:09:57 +02:00
|
|
|
|
2014-05-03 22:40:49 +02:00
|
|
|
-- TODO: define GUI positions in a file
|
2014-05-02 01:28:40 +02:00
|
|
|
createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId])
|
|
|
|
createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0)
|
2014-05-03 22:40:49 +02:00
|
|
|
, (UIId 1, createContainer (30, 215, 100, 80) [] 1)
|
|
|
|
, (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3)
|
|
|
|
, (UIId 3, createContainer (80, 15, 130, 90) [] 4 )
|
|
|
|
, (UIId 4, createButton (10, 40, 60, 130) 2 testMessage)
|
2014-04-26 19:16:53 +02:00
|
|
|
], [UIId 0])
|
|
|
|
|
2014-05-02 01:28:40 +02:00
|
|
|
getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
|
2014-05-01 19:12:01 +02:00
|
|
|
getGUI = Map.elems
|
|
|
|
{-# INLINE getGUI #-}
|
2014-04-26 19:16:53 +02:00
|
|
|
|
|
|
|
getRootIds :: Pioneers [UIId]
|
|
|
|
getRootIds = do
|
|
|
|
state <- get
|
|
|
|
return $ state ^. ui.uiRoots
|
|
|
|
|
2014-05-02 01:28:40 +02:00
|
|
|
getRoots :: Pioneers [GUIWidget Pioneers]
|
2014-04-26 19:16:53 +02:00
|
|
|
getRoots = do
|
|
|
|
state <- get
|
|
|
|
rootIds <- getRootIds
|
|
|
|
let hMap = state ^. ui.uiMap
|
|
|
|
return $ toGUIAnys hMap rootIds
|
2014-04-03 20:05:49 +02:00
|
|
|
|
2014-05-02 01:28:40 +02:00
|
|
|
testMessage :: MouseButton -> w -> Pixel -> Pioneers w
|
|
|
|
testMessage btn w (x, y) = do
|
|
|
|
case btn of
|
|
|
|
LeftButton -> liftIO $ putStrLn ("\tleft click on " ++ show x ++ "," ++ show y)
|
|
|
|
RightButton -> liftIO $ putStrLn ("\tright click on " ++ show x ++ "," ++ show y)
|
|
|
|
MiddleButton -> liftIO $ putStrLn ("\tmiddle click on " ++ show x ++ "," ++ show y)
|
|
|
|
MouseX1 -> liftIO $ putStrLn ("\tX1 click on " ++ show x ++ "," ++ show y)
|
|
|
|
MouseX2 -> liftIO $ putStrLn ("\tX2 click on " ++ show x ++ "," ++ show y)
|
2014-04-26 19:16:53 +02:00
|
|
|
return w
|
2014-03-09 13:46:49 +01:00
|
|
|
|
2014-05-02 01:28:40 +02:00
|
|
|
transformButton :: SDL.MouseButton -> Maybe MouseButton
|
|
|
|
transformButton SDL.LeftButton = Just LeftButton
|
|
|
|
transformButton SDL.RightButton = Just RightButton
|
|
|
|
transformButton SDL.MiddleButton = Just MiddleButton
|
|
|
|
transformButton SDL.MouseX1 = Just MouseX1
|
|
|
|
transformButton SDL.MouseX2 = Just MouseX2
|
|
|
|
transformButton _ = Nothing
|
|
|
|
|
2014-05-01 20:31:15 +02:00
|
|
|
eventCallback :: SDL.Event -> Pioneers ()
|
|
|
|
eventCallback e = do
|
|
|
|
env <- ask
|
|
|
|
case SDL.eventData e of
|
2014-05-02 01:28:40 +02:00
|
|
|
SDL.Window _ _ -> -- windowID event
|
2014-05-01 20:31:15 +02:00
|
|
|
-- TODO: resize GUI
|
|
|
|
return ()
|
|
|
|
SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym
|
|
|
|
-- need modifiers? use "keyModifiers key" to get them
|
|
|
|
let aks = keyboard.arrowsPressed in
|
|
|
|
case SDL.keyScancode key of
|
|
|
|
SDL.R ->
|
|
|
|
liftIO $ do
|
|
|
|
r <- SDL.getRenderer $ env ^. windowObject
|
|
|
|
putStrLn $ unwords ["Renderer: ",show r]
|
|
|
|
SDL.Escape ->
|
|
|
|
modify $ window.shouldClose .~ True
|
|
|
|
SDL.Left ->
|
|
|
|
modify $ aks.left .~ (movement == SDL.KeyDown)
|
|
|
|
SDL.Right ->
|
|
|
|
modify $ aks.right .~ (movement == SDL.KeyDown)
|
|
|
|
SDL.Up ->
|
|
|
|
modify $ aks.up .~ (movement == SDL.KeyDown)
|
|
|
|
SDL.Down ->
|
|
|
|
modify $ aks.down .~ (movement == SDL.KeyDown)
|
|
|
|
SDL.KeypadPlus ->
|
|
|
|
when (movement == SDL.KeyDown) $ do
|
2014-05-03 22:40:49 +02:00
|
|
|
modify $ gl.glMap.stateTessellationFactor %~ (min 5) . (+1)
|
2014-05-01 20:31:15 +02:00
|
|
|
state <- get
|
|
|
|
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
|
|
|
|
SDL.KeypadMinus ->
|
|
|
|
when (movement == SDL.KeyDown) $ do
|
2014-05-03 22:40:49 +02:00
|
|
|
modify $ gl.glMap.stateTessellationFactor %~ (max 1) . (+(-1))
|
2014-05-01 20:31:15 +02:00
|
|
|
state <- get
|
|
|
|
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
|
|
|
|
_ ->
|
|
|
|
return ()
|
|
|
|
SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
|
|
|
|
do
|
|
|
|
state <- get
|
|
|
|
when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
|
|
|
|
modify $ (mouse.isDragging .~ True)
|
2014-05-03 22:40:49 +02:00
|
|
|
. (mouse.dragStartX .~ fromIntegral x)
|
|
|
|
. (mouse.dragStartY .~ fromIntegral y)
|
2014-05-01 20:31:15 +02:00
|
|
|
. (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
|
|
|
|
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
|
|
|
|
|
2014-05-03 22:40:49 +02:00
|
|
|
modify $ (mouse.mousePosition. Types._x .~ fromIntegral x)
|
|
|
|
. (mouse.mousePosition. Types._y .~ fromIntegral y)
|
2014-05-01 20:31:15 +02:00
|
|
|
SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
|
|
|
|
case button of
|
|
|
|
SDL.LeftButton -> do
|
|
|
|
let pressed = state == SDL.Pressed
|
|
|
|
modify $ mouse.isDown .~ pressed
|
|
|
|
unless pressed $ do
|
|
|
|
st <- get
|
|
|
|
if st ^. mouse.isDragging then
|
|
|
|
modify $ mouse.isDragging .~ False
|
|
|
|
else
|
2014-05-02 01:28:40 +02:00
|
|
|
clickHandler LeftButton (x, y)
|
2014-05-03 22:40:49 +02:00
|
|
|
_ -> when (state == SDL.Released)
|
2014-05-02 01:28:40 +02:00
|
|
|
$ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button
|
2014-05-01 20:31:15 +02:00
|
|
|
SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
|
|
|
|
do
|
|
|
|
state <- get
|
|
|
|
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
|
2014-05-08 23:38:47 +02:00
|
|
|
modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
|
2014-05-01 20:31:15 +02:00
|
|
|
-- there is more (joystic, touchInterface, ...), but currently ignored
|
|
|
|
SDL.Quit -> modify $ window.shouldClose .~ True
|
|
|
|
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
|
2014-05-02 01:28:40 +02:00
|
|
|
|
2014-05-01 20:31:15 +02:00
|
|
|
|
2014-02-05 21:06:19 +01:00
|
|
|
-- | Handler for UI-Inputs.
|
|
|
|
-- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
|
2014-05-02 01:28:40 +02:00
|
|
|
clickHandler :: MouseButton -> Pixel -> Pioneers ()
|
|
|
|
clickHandler btn pos@(x,y) = do
|
2014-04-26 19:16:53 +02:00
|
|
|
state <- get
|
|
|
|
let hMap = state ^. ui.uiMap
|
|
|
|
roots <- getRootIds
|
2014-05-01 20:31:15 +02:00
|
|
|
hits <- liftM concat $ mapM (getInsideId hMap pos) roots
|
2014-04-26 19:16:53 +02:00
|
|
|
case hits of
|
2014-05-02 01:28:40 +02:00
|
|
|
[] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"]
|
2014-04-26 19:16:53 +02:00
|
|
|
_ -> do
|
2014-05-09 00:17:31 +02:00
|
|
|
changes <- mapM (\(uid, pos') -> do
|
2014-04-26 19:16:53 +02:00
|
|
|
let w = toGUIAny hMap uid
|
2014-05-02 01:28:40 +02:00
|
|
|
short = w ^. baseProperties.shorthand
|
|
|
|
bound <- w ^. baseProperties.boundary
|
|
|
|
prio <- w ^. baseProperties.priority
|
2014-05-08 23:36:53 +02:00
|
|
|
liftIO $ putStrLn $ "hitting(" ++ show btn ++ ") " ++ short ++ ": " ++ show bound ++ " "
|
|
|
|
++ show prio ++ " at [" ++ show x ++ "," ++ show y ++ "]"
|
|
|
|
case w ^. eventHandlers.(at MouseEvent) of
|
2014-05-09 00:17:31 +02:00
|
|
|
Just ma -> do w' <- fromJust (ma ^? onMousePress) btn pos' w -- TODO unsafe fromJust
|
|
|
|
w'' <- fromJust (ma ^? onMouseRelease) btn pos' True w' -- TODO unsafe fromJust
|
2014-05-02 01:28:40 +02:00
|
|
|
return $ Just (uid, w'')
|
|
|
|
Nothing -> return Nothing
|
2014-05-08 23:38:47 +02:00
|
|
|
) hits
|
2014-05-02 01:28:40 +02:00
|
|
|
let newMap :: Map.HashMap UIId (GUIWidget Pioneers)
|
2014-04-26 19:16:53 +02:00
|
|
|
newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
|
|
|
|
modify $ ui.uiMap .~ newMap
|
|
|
|
return ()
|
|
|
|
|
2014-04-03 20:05:49 +02:00
|
|
|
|
2014-04-05 23:09:57 +02:00
|
|
|
-- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture
|
2014-03-24 08:21:30 +01:00
|
|
|
--
|
|
|
|
--TODO: should be done asynchronously at one point.
|
2014-04-05 23:09:57 +02:00
|
|
|
-- -> can't. if 2 Threads bind Textures its not sure
|
|
|
|
-- on which one the GPU will work.
|
|
|
|
-- "GL.textureBinding GL.Texture2D" is a State set
|
|
|
|
-- to the texture all following works on.
|
|
|
|
--
|
|
|
|
-- https://www.opengl.org/wiki/GLAPI/glTexSubImage2D for copy
|
2014-03-24 08:21:30 +01:00
|
|
|
prepareGUI :: Pioneers ()
|
|
|
|
prepareGUI = do
|
2014-04-05 23:09:57 +02:00
|
|
|
state <- get
|
2014-04-26 19:16:53 +02:00
|
|
|
roots <- getRoots
|
2014-05-08 23:38:47 +02:00
|
|
|
let tex = state ^. gl.glHud.hudTexture
|
2014-04-05 23:09:57 +02:00
|
|
|
liftIO $ do
|
|
|
|
-- bind texture - all later calls work on this one.
|
|
|
|
GL.textureBinding GL.Texture2D GL.$= Just tex
|
2014-05-03 22:40:49 +02:00
|
|
|
mapM_ (copyGUI tex (0, 0)) roots
|
2014-04-05 23:09:57 +02:00
|
|
|
modify $ ui.uiHasChanged .~ False
|
|
|
|
|
|
|
|
--TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
|
2014-05-03 22:40:49 +02:00
|
|
|
copyGUI :: GL.TextureObject -> Pixel -- ^current view's offset
|
|
|
|
-> GUIWidget Pioneers -- ^the widget to draw
|
|
|
|
-> Pioneers ()
|
|
|
|
copyGUI tex (vX, vY) widget = do
|
2014-05-02 01:28:40 +02:00
|
|
|
(xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary
|
2014-04-26 19:16:53 +02:00
|
|
|
state <- get
|
|
|
|
let
|
|
|
|
hMap = state ^. ui.uiMap
|
2014-04-05 23:09:57 +02:00
|
|
|
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.
|
2014-05-02 01:28:40 +02:00
|
|
|
color = case widget ^. baseProperties.shorthand of
|
|
|
|
"CNT" -> [255,0,0,128]
|
|
|
|
"BTN" -> [255,255,0,255]
|
|
|
|
"PNL" -> [128,128,128,128]
|
|
|
|
_ -> [255,0,255,255]
|
2014-04-26 19:16:53 +02:00
|
|
|
liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do
|
2014-04-05 23:09:57 +02:00
|
|
|
--copy data into C-Array
|
2014-04-26 19:16:53 +02:00
|
|
|
pokeArray ptr (genColorData (wWidth*wHeight) color)
|
2014-04-05 23:09:57 +02:00
|
|
|
GL.texSubImage2D
|
|
|
|
GL.Texture2D
|
|
|
|
0
|
2014-05-03 22:40:49 +02:00
|
|
|
(GL.TexturePosition2D (int (vX + xoff)) (int (vY + yoff)))
|
2014-04-26 19:16:53 +02:00
|
|
|
(GL.TextureSize2D (int wWidth) (int wHeight))
|
2014-04-05 23:09:57 +02:00
|
|
|
(GL.PixelData GL.RGBA GL.UnsignedByte ptr)
|
2014-05-02 01:28:40 +02:00
|
|
|
nextChildrenIds <- widget ^. baseProperties.children
|
2014-05-03 22:40:49 +02:00
|
|
|
mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds
|
2014-03-24 08:21:30 +01:00
|
|
|
|
2014-02-05 21:06:19 +01:00
|
|
|
--TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
|
2014-04-26 19:16:53 +02:00
|
|
|
--TODO: Maybe queues are better?
|