tracer/src/Menu/Connect.hs

334 lines
10 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
2018-10-12 19:40:16 +00:00
import Menu.Adjust
2018-10-12 22:07:19 +00:00
import MainGame.WorldMap
2018-10-12 12:26:06 +00:00
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
2018-10-12 19:40:16 +00:00
{ uuid = [ uu1, uu2, uu3, uu4, uu5 ]
2018-10-12 12:26:06 +00:00
, state = Menu Connect
2018-10-13 18:12:10 +00:00
, stateData = MenuData (V2 0 0) S 0 0
2018-10-12 12:26:06 +00:00
, 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
}
}
2018-10-13 18:12:10 +00:00
handleActionMessages (ActionMessage SwitchMap _) = do
ud <- getAffection
putAffection ud
{ stateData = (stateData ud)
{ switchMap = 0.5
}
}
2018-10-12 12:26:06 +00:00
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)
2018-10-12 19:40:16 +00:00
when (arrowUp rels || arrowDown rels) (adjustUpDown rels)
when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels)
when (buttonActivate rels) (adjustActivate)
2018-10-13 18:12:10 +00:00
when (buttonSwitchMap rels) (adjustSwitchMap)
2018-10-12 22:07:19 +00:00
when (buttonPlay rels) (enterGame)
2018-10-12 12:26:06 +00:00
where
2018-10-12 19:40:16 +00:00
adjustUpDown rels = do
if arrowUp rels
then do
fullClean
loadAdjust (UpDown 1) loadMenu
else do
fullClean
loadAdjust (UpDown (-1)) loadMenu
adjustLeftRight rels = do
if arrowLeft rels
then do
fullClean
loadAdjust (LeftRight 1) loadMenu
else do
fullClean
loadAdjust (LeftRight (-1)) loadMenu
adjustActivate = do
fullClean
loadAdjust Activate loadMenu
2018-10-13 18:12:10 +00:00
adjustSwitchMap = do
fullClean
loadAdjust SwitchMap loadMenu
2018-10-12 22:07:19 +00:00
enterGame = do
fullClean
loadMap
2018-10-12 12:59:09 +00:00
arrowUp (V2 rx ry) =
rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
2018-10-12 19:40:16 +00:00
arrowDown (V2 rx ry) =
rx > 310 / 1280 && rx < 410 / 1280 && ry > 430 / 720 && ry < 530 / 720
arrowLeft (V2 rx ry) =
rx > 190 / 1280 && rx < 290 / 1280 && ry > 310 / 720 && ry < 410 / 720
arrowRight (V2 rx ry) =
rx > 430 / 1280 && rx < 530 / 1280 && ry > 310 / 720 && ry < 410 / 720
buttonActivate (V2 rx ry) =
rx > 650 / 1280 && rx < 800 / 1280 && ry > 160 / 720 && ry < 210 / 720
2018-10-13 18:12:10 +00:00
buttonSwitchMap (V2 rx ry) =
rx > 650 / 1280 && rx < 800 / 1280 && ry > 220 / 720 && ry < 270 / 720
2018-10-12 22:07:19 +00:00
buttonPlay (V2 rx ry) =
rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720
2018-10-12 12:26:06 +00:00
handleClicks _ = return ()
updateMenu :: Double -> Affection UserData ()
updateMenu dt = do
ud <- getAffection
2018-10-12 22:07:19 +00:00
case stateData ud of
2018-10-13 18:12:10 +00:00
MenuData _ _ _ _ ->
2018-10-12 22:07:19 +00:00
putAffection ud
{ stateData = MenuData
(velocity $ stateData ud)
(rotation $ stateData ud)
(max 0 ((activate $ stateData ud) - dt))
2018-10-13 18:12:10 +00:00
(max 0 ((switchMap $ stateData ud) - dt))
2018-10-12 22:07:19 +00:00
}
_ -> return ()
2018-10-12 12:26:06 +00:00
drawMenu :: Affection UserData ()
drawMenu = do
ud <- getAffection
2018-10-12 22:07:19 +00:00
case stateData ud of
2018-10-13 18:12:10 +00:00
MenuData _ _ _ _ ->
2018-10-12 22:07:19 +00:00
liftIO $ do
let ctx = nano ud
controller = joystick ud
2018-10-12 12:26:06 +00:00
save ctx
beginPath ctx
2018-10-12 22:07:19 +00:00
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
2018-10-12 12:26:06 +00:00
fillPaint ctx paint
fill ctx
2018-10-12 22:07:19 +00:00
when (isJust controller) $ do
let V2 vx vy = velocity $ stateData ud
2018-10-12 19:40:16 +00:00
beginPath ctx
2018-10-12 22:07:19 +00:00
roundedRect ctx 140 110 1000 500 25
strokeWidth ctx 5
fillColor ctx (rgba 255 255 255 64)
strokeColor ctx (rgb 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 -> do
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 (UpDown _)) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
_ ->
return ()
90 -> do
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 (LeftRight _)) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
_ ->
return ()
180 -> do
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 (UpDown _)) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
_ ->
return ()
270 -> do
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 (LeftRight _)) -> do
beginPath ctx
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]
when (activate (stateData ud) > 0) $ do
2018-10-13 18:12:10 +00:00
beginPath ctx
2018-10-12 22:07:19 +00:00
fillColor ctx (rgb 255 128 0)
roundedRect ctx 650 160 150 50 10
fill ctx
2018-10-13 18:12:10 +00:00
closePath ctx
2018-10-12 22:07:19 +00:00
case state ud of
Menu (Adjust Activate) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 650 160 150 50 10
closePath ctx
fill ctx
_ ->
return ()
2018-10-13 18:12:10 +00:00
beginPath ctx
2018-10-12 19:40:16 +00:00
roundedRect ctx 650 160 150 50 10
2018-10-12 22:07:19 +00:00
strokeWidth ctx 2
stroke ctx
fontSize ctx 25
fontFace ctx "bedstead"
textAlign ctx (S.fromList [AlignCenter, AlignTop])
2018-10-13 18:12:10 +00:00
fillColor ctx (rgb 255 255 255)
2018-10-12 22:07:19 +00:00
textBox ctx 650 175 150 "Activate"
2018-10-12 19:40:16 +00:00
closePath ctx
2018-10-13 18:12:10 +00:00
when (switchMap (stateData ud) > 0) $ do
beginPath ctx
fillColor ctx (rgb 255 128 0)
roundedRect ctx 650 220 150 50 10
fill ctx
closePath ctx
case state ud of
Menu (Adjust SwitchMap) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 650 220 150 50 10
closePath ctx
fill ctx
_ ->
return ()
beginPath ctx
roundedRect ctx 650 220 150 50 10
strokeWidth ctx 2
stroke ctx
fontSize ctx 25
fontFace ctx "bedstead"
fillColor ctx (rgb 255 255 255)
textAlign ctx (S.fromList [AlignCenter, AlignTop])
textBox ctx 650 235 150 "Switch Map"
closePath ctx
beginPath ctx
2018-10-12 22:07:19 +00:00
roundedRect ctx 650 560 150 50 10
strokeWidth ctx 5
stroke ctx
2018-10-13 18:12:10 +00:00
closePath ctx
2018-10-12 22:07:19 +00:00
fontSize ctx 25
fontFace ctx "bedstead"
textAlign ctx (S.fromList [AlignCenter, AlignTop])
textBox ctx 650 575 150 "Play"
restore ctx
_ -> return ()