tracer/src/Menu/Connect.hs

225 lines
6.5 KiB
Haskell
Raw Normal View History

2018-10-12 12:26:06 +00:00
module Menu.Connect where
import Affection as A
import qualified SDL hiding (V2)
import NanoVG hiding (V2)
import Linear hiding (rotate)
import qualified Data.Set as S
import qualified Data.Map.Strict as M
import Data.Maybe (isNothing, isJust)
import Control.Monad
-- internal imports
import Types
import Util
loadMenu :: Affection UserData ()
loadMenu = do
ud <- getAffection
ad <- get
let (Subsystems _ m _ j t) = subsystems ud
uu1 <- partSubscribe j joystickConnect
uu2 <- partSubscribe j joystickDisconnect
uu3 <- partSubscribe j emitActionMessage
uu4 <- partSubscribe t handleActionMessages
uu5 <- partSubscribe m handleClicks
partUnSubscribe j (joyUUID ud)
putAffection ud
{ uuid = [ uu1, uu2, uu3, uu4 ]
, state = Menu Connect
, stateData = MenuData (V2 0 0) S 0
, joyCache = []
}
mapM_ (partEmit j) (joyCache ud)
joystickConnect :: JoystickMessage -> Affection UserData ()
joystickConnect msg = do
ud <- getAffection
when (isNothing $ joystick ud) $ do
mjoy <- joystickAutoConnect msg
maybe (return ()) (\joy -> do
ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident
putAffection ud
{ joystick = Just joy
}
) mjoy
joystickDisconnect :: JoystickMessage -> Affection UserData ()
joystickDisconnect msg = do
ud <- getAffection
maybe (return ()) (\joy -> do
njoys <- joystickAutoDisconnect [joy] msg
when (null njoys) $ do
liftIO $ logIO A.Debug $ "Joystick disconnected"
putAffection ud
{ joystick = Nothing
}
) (joystick ud)
handleActionMessages :: ActionMessage -> Affection UserData ()
handleActionMessages (ActionMessage Activate _) = do
ud <- getAffection
putAffection ud
{ stateData = (stateData ud)
{ activate = 0.5
}
}
handleActionMessages (ActionMessage (UpDown f) _) = do
ud <- getAffection
let V2 vx _ = velocity $ stateData ud
putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 vx (fromIntegral f / 32768))
}
}
handleActionMessages (ActionMessage (LeftRight f) _) = do
ud <- getAffection
let V2 _ vy = velocity $ stateData ud
putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 (fromIntegral f / 32768) vy)
}
}
handleClicks :: MouseMessage -> Affection UserData ()
handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
when (arrowUp rels) adjustUpDown
where
2018-10-12 12:59:09 +00:00
adjustUpDown = liftIO $ logIO A.Debug "TODO: adjustUpDown"
arrowUp (V2 rx ry) =
rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
2018-10-12 12:26:06 +00:00
handleClicks _ = return ()
updateMenu :: Double -> Affection UserData ()
updateMenu dt = do
ud <- getAffection
putAffection ud
{ stateData = MenuData
(velocity $ stateData ud)
(rotation $ stateData ud)
(max 0 ((activate $ stateData ud) - dt))
}
drawMenu :: Affection UserData ()
drawMenu = do
ud <- getAffection
liftIO $ do
let ctx = nano ud
controller = joystick ud
save ctx
beginPath ctx
paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.!
if isNothing controller
then IconContrBlue
else IconContrGreen
) 1
rect ctx 600 620 80 80
fillPaint ctx paint
fill ctx
when (isJust controller) $ do
let V2 vx vy = velocity $ stateData ud
beginPath ctx
roundedRect ctx 140 110 1000 500 25
strokeWidth ctx 5
fillColor ctx (rgba 255 255 255 128)
strokeColor ctx (rgba 255 255 255 255)
stroke ctx
fill ctx
mapM_ (\deg -> do
let V2 px py = fmap realToFrac $
V2 360 360 - V2 50 50 + fmap realToFrac rot
rot@(V2 rx ry) = fmap (fromIntegral . floor) $
V2 0 120 `rotVec` deg :: V2 Int
save ctx
translate ctx (px + 50) (py + 50)
rotate ctx (dtor deg)
translate ctx (-50) (-50)
case deg of
0 -> when (vx < 0) $ do
beginPath ctx
fillColor ctx (rgb 255 128 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
case state ud of
Menu (Adjust (UpDown _)) -> do
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
_ ->
return ()
90 -> when (vy > 0) $ do
beginPath ctx
fillColor ctx (rgb 255 128 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
case state ud of
Menu (Adjust (LeftRight _)) -> do
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
_ ->
return ()
180 -> when (vx > 0) $ do
beginPath ctx
fillColor ctx (rgb 255 128 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
case state ud of
Menu (Adjust (UpDown _)) -> do
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
_ ->
return ()
270 -> when (vy < 0) $ do
beginPath ctx
fillColor ctx (rgb 255 128 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
case state ud of
Menu (Adjust (LeftRight _)) -> do
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
_ ->
return ()
beginPath ctx
paint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
rect ctx 0 0 100 100
fillPaint ctx paint
closePath ctx
fill ctx
restore ctx
) [0, 90, 180, 270]
beginPath ctx
when (activate (stateData ud) > 0) $ do
fillColor ctx (rgb 255 128 0)
roundedRect ctx 650 160 150 50 10
fill ctx
roundedRect ctx 650 160 150 50 10
strokeWidth ctx 2
stroke ctx
fontSize ctx 25
fontFace ctx "bedstead"
textAlign ctx (S.fromList [AlignCenter, AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 650 175 150 "Activate"
closePath ctx
restore ctx