pioneers/src/UI/Callbacks.hs

{-# LANGUAGE DoAndIfThenElse #-}
module UI.Callbacks where


import qualified Graphics.Rendering.OpenGL.GL         as GL
import           Control.Lens                         ((^.), (.~), (%~), (^?), at)
import           Control.Monad                        (liftM, when, unless)
import           Control.Monad.RWS.Strict             (ask, get, modify)
import           Control.Monad.Trans                  (liftIO)
import qualified Data.HashMap.Strict                  as Map
import           Data.List                            (foldl')
import           Data.Maybe
import           Foreign.Marshal.Array                (pokeArray)
import           Foreign.Marshal.Alloc                (allocaBytes)
import qualified Graphics.UI.SDL                      as SDL
import           Control.Concurrent.STM.TVar          (readTVar, readTVarIO, writeTVar)
import           Control.Concurrent.STM               (atomically)


import Render.Misc                                    (curb,genColorData)
import Types
import UI.UIWidgets
import UI.UIOperations

-- TODO: define GUI positions in a file
createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId])
createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0)
                          , (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)
                          ], [UIId 0])
         
getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
getGUI = Map.elems
{-# INLINE getGUI #-}

getRootIds :: Pioneers [UIId]
getRootIds = do
  state <- get
  return $ state ^. ui.uiRoots

getRoots :: Pioneers [GUIWidget Pioneers]
getRoots = do
  state <- get
  rootIds <- getRootIds
  let hMap = state ^. ui.uiMap
  return $ toGUIAnys hMap rootIds

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)
  return w

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

eventCallback :: SDL.Event -> Pioneers ()
eventCallback e = do
        env <- ask
        case SDL.eventData e of
            SDL.Window _ _ -> -- windowID event
                -- 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
                            modify $ gl.glMap.stateTessellationFactor %~ (min 5) . (+1)
                            state <- get
                            liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
                    SDL.KeypadMinus ->
                        when (movement == SDL.KeyDown) $ do
                            modify $ gl.glMap.stateTessellationFactor %~ (max 1) . (+(-1))
                            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
                if state ^. mouse.isDown && not (state ^. mouse.isDragging)
                  then
                    do
                    cam <- liftIO $ readTVarIO (state ^. camera)
                    modify $ (mouse.isDragging .~ True)
                           . (mouse.dragStartX .~ fromIntegral x)
                           . (mouse.dragStartY .~ fromIntegral y)
                           . (mouse.dragStartXAngle .~ (cam ^. xAngle))
                           . (mouse.dragStartYAngle .~ (cam ^. yAngle))
                    else mouseMoveHandler (x, y)
                modify $ (mouse.mousePosition. Types._x .~ fromIntegral x)
                       . (mouse.mousePosition. Types._y .~ fromIntegral y)
            SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
             do 
                case button of
                     SDL.LeftButton -> do
                         let pressed = state == SDL.Pressed
                         modify $ mouse.isDown .~ pressed
                         if pressed 
                           then mouseReleaseHandler LeftButton (x, y)
                           else do
                             st <- get
                             if st ^. mouse.isDragging then
                                 modify $ mouse.isDragging .~ False
                             else do
                                 mousePressHandler LeftButton (x, y)
                     _ -> case state of
                               SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button
                               SDL.Released -> maybe (return ()) (`mouseReleaseHandler` (x, y)) $ transformButton button
                               _ -> return ()
            SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
                do
                state <- get
                liftIO $ atomically $ do
                    cam <- readTVar (state ^. camera)
                    let zDist' = (cam ^. zDist) + realToFrac (negate vscroll)
                        zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
                    cam' <- return $ zDist .~ zDist'' $ cam
                    writeTVar (state ^. camera) cam'
                  
            -- there is more (joystic, touchInterface, ...), but currently ignored
            SDL.Quit -> modify $ window.shouldClose .~ True
            _ ->  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
    state <- get
    let hMap = state ^. ui.uiMap
        currentWidget = state ^. ui.uiButtonState.mouseCurrentWidget
    case currentWidget of
         Just (wid, px') -> do
             let target = toGUIAny hMap wid
             target' <- case target ^. eventHandlers.(at MouseEvent) of
                             Just ma -> transFunc ma btn (px -: px') target
                             Nothing  -> return target
             modify $ ui.uiMap %~ Map.insert wid 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
    state <- get
    unless (state ^. ui.uiButtonState.mousePressed > 0) $ do
      case state ^. ui.uiButtonState.mouseCurrentWidget of
           Just (wid, px') -> do
               let target = toGUIAny (state ^. ui.uiMap) wid
               -- debug
               let short = target ^. baseProperties.shorthand
               bound <- target ^. baseProperties.boundary
               prio <- target ^. baseProperties.priority
               liftIO $ putStrLn $ "releasing(" ++ show btn ++ ") " ++ short ++ ": " ++ show bound ++ " "
                                ++ show prio ++ " at [" ++ show (fst px) ++ "," ++ show (snd px) ++ "]"
               -- /debug
               target' <- case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
                               Just ma -> do
                                    target_ <- fromJust (ma ^? onMouseEnter) px' target -- TODO unsafe fromJust
                                    fromJust (ma ^? onMouseMove) px' target_ -- TODO unsafe fromJust
                               Nothing  -> return target
               modify $ ui.uiMap %~ Map.insert wid target'
           Nothing -> return ()
      mouseSetMouseActive px -- TODO leave current

mouseSetMouseActiveTargeted :: (UIId, Pixel) -- ^ (target widget, local coorinates)
                               -> Pixel         -- ^ global coordinates
                               -> Pioneers ()
mouseSetMouseActiveTargeted (wid, px') px = do
    state <- get
    --liftIO $ putStrLn $ "new target: " ++ show wid
    let hMap = state ^. ui.uiMap
        target = toGUIAny hMap wid
    modify $ ui.uiButtonState %~ (mouseCurrentWidget .~ Just (wid, px -: px')) . (mouseInside .~ True)
    target' <- case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
                    Just ma -> do
                         target_ <- fromJust (ma ^? onMouseEnter) px' target -- TODO unsafe fromJust
                         fromJust (ma ^? onMouseMove) px' target_ -- TODO unsafe fromJust
                    Nothing  -> return target
    modify $ ui.uiMap %~ Map.insert wid target'
    
mouseSetMouseActive :: Pixel -- ^global coordinates
                       -> Pioneers ()
mouseSetMouseActive px = do
    roots <- getRootIds
    hits <- liftM concat $ mapM (getInsideId px) roots
    leading <- getLeadingWidget hits
    case leading of
         Just hit -> mouseSetMouseActiveTargeted hit px
         Nothing -> modify $ ui.uiButtonState %~ (mouseCurrentWidget .~ Nothing) . (mouseInside .~ False)
        
mouseSetLeaving :: UIId -> Pixel -> Pioneers ()
mouseSetLeaving wid px = do
    state <- get
    let target = toGUIAny (state ^. ui.uiMap) wid
    modify $ ui.uiButtonState.mouseInside .~ False
    case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
         Just ma -> do
             target' <- fromJust (ma ^? onMouseLeave) px target --TODO unsafe fromJust
             modify $ ui.uiMap %~ Map.insert wid target'
         Nothing -> return ()
        
mouseMoveHandler :: Pixel -> Pioneers ()
mouseMoveHandler px = do
    state <- get
    --liftIO $ print $ state ^. ui.uiButtonState
    case state ^. ui.uiButtonState.mouseCurrentWidget of -- existing mouse-active widget?
         Just (wid, px') -> do
             let target = toGUIAny (state ^. ui.uiMap) wid
             inTest <- isHittingChild (px -: px') target
             case inTest of
                  Left b -> -- no child hit
                      if b == state ^. ui.uiButtonState.mouseInside then -- > moving inside or outside
                        case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
                             Just ma -> do target' <- fromJust (ma ^? onMouseMove) px' target
                                           modify $ ui.uiMap %~ Map.insert wid target'
                             Nothing -> return () 
                      else if b then -- && not mouseInside --> entering
                        do modify $ ui.uiButtonState.mouseInside .~ True
                           case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
                                Just ma -> do
                                    target_ <- fromJust (ma ^? onMouseEnter) (px -: px') target --TODO unsafe fromJust
                                    target' <- fromJust (ma ^? onMouseMove) (px -: px') target_ --TODO unsafe fromJust
                                    modify $ ui.uiMap %~ Map.insert wid target'
                                Nothing -> return ()
                      else -- not b && mouseInside --> leaving
                        do mouseSetLeaving wid (px -: px')
                           when (state ^. ui.uiButtonState.mousePressed <= 0)  -- change mouse-active widget?
                               $ mouseSetMouseActive px

                  Right childHit -> do
                      mouseSetLeaving wid (px -: px')
                      when (state ^. ui.uiButtonState.mousePressed <= 0)  -- change mouse-active widget?
                          $ mouseSetMouseActiveTargeted childHit px
         Nothing -> do
             mouseSetMouseActive px
             

-- | Handler for UI-Inputs.
--   Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
clickHandler :: MouseButton -> Pixel -> Pioneers ()
clickHandler btn pos@(x,y) = do
  roots <- getRootIds
  hits <- liftM concat $ mapM (getInsideId pos) roots
  case hits of
       [] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"]
       _  -> do
         changes <- mapM (\(uid, pos') -> do
           state <- get
           let w = toGUIAny (state ^. ui.uiMap) uid
               short = w ^. baseProperties.shorthand
           bound <- w ^. baseProperties.boundary
           prio <- w ^. baseProperties.priority
           liftIO $ putStrLn $ "hitting(" ++ show btn ++ ") " ++ short ++ ": " ++ show bound ++ " "
                             ++ 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' w' -- TODO unsafe fromJust
                              return $ Just (uid, w'')
                Nothing  -> return Nothing
           ) hits
         state <- get
         let hMap = state ^. ui.uiMap
             newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
         modify $ ui.uiMap .~ newMap
         return ()
         

-- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture
--
--TODO: should be done asynchronously at one point.
--        -> 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
prepareGUI :: Pioneers ()
prepareGUI = do
                state <- get
                roots <- getRoots
                let tex = state ^. gl.glHud.hudTexture
                liftIO $ do
                    -- bind texture - all later calls work on this one.
                    GL.textureBinding GL.Texture2D GL.$= Just tex
                mapM_ (copyGUI tex (0, 0)) roots
                modify $ ui.uiHasChanged .~ False

--TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
copyGUI :: GL.TextureObject -> Pixel -- ^current view's offset
        -> GUIWidget Pioneers -- ^the widget to draw
        -> Pioneers ()
copyGUI tex (vX, vY) widget = do
                        (xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary
                        state <- get
                        let 
                            hMap = state ^. ui.uiMap
                            int = fromInteger.toInteger --conversion between Int8, GLInt, Int, ...
                            --temporary color here. lateron better some getData-function to
                            --get a list of pixel-data or a texture.
                            color = case widget ^. baseProperties.shorthand of
                                "CNT" -> [255,0,0,128]
                                "BTN" -> [255,255,0,255]
                                "PNL" -> [128,128,128,128]
                                _     -> [255,0,255,255]
                        liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do
                                --copy data into C-Array
                                pokeArray ptr (genColorData (wWidth*wHeight) color)
                                GL.texSubImage2D
                                        GL.Texture2D
                                        0
                                        (GL.TexturePosition2D (int (vX + xoff)) (int (vY + yoff)))
                                        (GL.TextureSize2D (int wWidth) (int wHeight))
                                        (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
                        nextChildrenIds <- widget ^. baseProperties.children
                        mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds

--TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
--TODO: Maybe queues are better?