pioneers/src/UI/Callbacks.hs

{-# LANGUAGE ExistentialQuantification #-}

module UI.Callbacks where

import Control.Monad.Trans (liftIO)
import Types
import UI.UIBaseData
import UI.UIClasses
import UI.UIOperations

import qualified Graphics.Rendering.OpenGL.GL         as GL
import           Control.Lens                         ((^.), (.~), (%~))
import           Render.Misc                          (genColorData)
import           Foreign.Marshal.Array (pokeArray)
import           Foreign.Marshal.Alloc (allocaBytes)
import           Control.Monad.RWS.Strict             (get, liftIO, modify)


data Pixel = Pixel Int Int

getGUI :: [GUIAny]
getGUI = [ toGUIAny $ GUIContainer 0 0 120 80 [] 1
         , toGUIAny $ GUIPanel $ GUIContainer 0 0 0 0
             [toGUIAny $ GUIContainer  0 80 100 200 [] 4
             ,toGUIAny $GUIButton 50 400 200 175 2 defaultUIState testMessage
             ] 3
         ]

testMessage :: (Show w) => w -> ScreenUnit -> ScreenUnit -> IO w
testMessage w x y = do
    putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
    return w

-- | Handler for UI-Inputs.
--   Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
clickHandler :: Pixel -> Pioneers ()
clickHandler (Pixel x y) = case concatMap (isInside x y) getGUI of
    [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
    hit -> liftIO $ do
        _ <- sequence $ map (\w ->
            case w of
                 (GUIAnyB b h) -> do
                      putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w)
                          ++ " at ["++show x++","++show y++"]"
                      (b', h') <- onMousePressed x y b h
                      _ <- onMouseReleased x y b' h'
                      return ()
                 _ -> putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w)
                          ++ " at ["++show x++","++show y++"]"
            ) hit
        return ()


-- | Handler for UI-Inputs.
--   Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...
alternateClickHandler :: Pixel -> Pioneers ()
alternateClickHandler (Pixel x y) = liftIO $ putStrLn $ unwords ["alternate press on (",show x,",",show y,")"]


-- | 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
                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) getGUI
                modify $ ui.uiHasChanged .~ False

--TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
copyGUI :: GL.TextureObject -> GUIAny -> IO ()
copyGUI tex widget = do
                        let (xoff, yoff, width, height) = getBoundary widget
                            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 of
                                (GUIAnyC _)   -> [255,0,0,128]
                                (GUIAnyB _ _) -> [255,255,0,255]
                                (GUIAnyP _)   -> [128,128,128,255]
                                _             -> [255,0,255,255]
                        allocaBytes (width*height*4) $ \ptr -> do
                                --copy data into C-Array
                                pokeArray ptr (genColorData (width*height) color)
                                GL.texSubImage2D
                                        GL.Texture2D
                                        0
                                        (GL.TexturePosition2D (int xoff) (int yoff))
                                        (GL.TextureSize2D (int width) (int height))
                                        (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
                        mapM_ (copyGUI tex) (getChildren widget)
copyGUI _ _ = return ()

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