392 lines
13 KiB
Haskell
392 lines
13 KiB
Haskell
module Menu.Connect where
|
|
|
|
import Affection as A
|
|
|
|
import qualified SDL hiding (V2)
|
|
|
|
import NanoVG hiding (V2)
|
|
|
|
import Linear hiding (rotate, translation)
|
|
|
|
import qualified Data.Set as S
|
|
import qualified Data.Map.Strict as M
|
|
import Data.String
|
|
|
|
import Control.Concurrent.MVar
|
|
|
|
import Control.Monad
|
|
|
|
-- internal imports
|
|
|
|
import Types
|
|
import Util
|
|
import Menu.Adjust
|
|
import MainGame.WorldMap
|
|
|
|
loadMenu :: UserData -> Affection ()
|
|
loadMenu ud = do
|
|
let (Subsystems _ m k j t) = subsystems ud
|
|
uu1 <- partSubscribe j (joystickConnect ud)
|
|
uu2 <- partSubscribe j (joystickDisconnect ud)
|
|
uu3 <- partSubscribe j (emitJoyActionMessage ud)
|
|
uu4 <- partSubscribe k (emitKbdActionMessage ud)
|
|
uu5 <- partSubscribe t (handleActionMessages ud)
|
|
uu6 <- partSubscribe m (handleClicks ud)
|
|
-- uu6 <- partSubscribe k emitKbdActionMessage
|
|
juuid <- liftIO $ readMVar (joyUUID ud)
|
|
partUnSubscribe j juuid
|
|
cache <- liftIO $ readMVar (joyCache ud)
|
|
void $ liftIO $ swapMVar (uuid ud) [ uu1, uu2, uu3, uu4, uu5, uu6 ]
|
|
void $ liftIO $ swapMVar (state ud) (Menu Connect)
|
|
void $ liftIO $ swapMVar (stateData ud) (MenuData (V2 0 0) S 0 0)
|
|
void $ liftIO $ swapMVar (joyCache ud) []
|
|
mapM_ (partEmit j) cache
|
|
|
|
joystickConnect :: UserData -> JoystickMessage -> Affection ()
|
|
joystickConnect ud msg = do
|
|
ctrls <- liftIO $ readMVar (controls ud)
|
|
when (ctrls == NoController) $ do
|
|
mjoy <- joystickAutoConnect msg
|
|
maybe (return ()) (\joy -> do
|
|
ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
|
|
liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show (ident :: Int))
|
|
void $ liftIO $ swapMVar (controls ud) (Joystick joy)
|
|
void $ liftIO $ swapMVar (translation ud) (JoyTranslation defaultJoyTranslation)
|
|
) mjoy
|
|
|
|
joystickDisconnect :: UserData -> JoystickMessage -> Affection ()
|
|
joystickDisconnect ud msg = do
|
|
ctrls <- liftIO $ readMVar (controls ud)
|
|
case ctrls of
|
|
Joystick joy -> do
|
|
njoys <- joystickAutoDisconnect [joy] msg
|
|
when (null njoys) $ do
|
|
liftIO $ logIO A.Debug $ "Joystick disconnected"
|
|
void $ liftIO $ swapMVar (controls ud) NoController
|
|
void $ liftIO $ swapMVar (translation ud) NoTranslation
|
|
_ -> return ()
|
|
|
|
handleActionMessages :: UserData -> ActionMessage -> Affection ()
|
|
handleActionMessages ud (ActionMessage ActActivate _) = do
|
|
liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
|
|
{ activate = 0.5
|
|
}
|
|
)
|
|
handleActionMessages ud (ActionMessage ActSwitchMap _) = do
|
|
liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
|
|
{ switchMap = 0.5
|
|
}
|
|
)
|
|
handleActionMessages ud (ActionMessage (ActUp f) _) = do
|
|
liftIO $ modifyMVar_ (stateData ud) (\dat ->
|
|
let V2 vx _ = velocity dat
|
|
in return dat
|
|
{ velocity = (V2 vx (-f))
|
|
}
|
|
)
|
|
handleActionMessages ud (ActionMessage (ActDown f) _) = do
|
|
liftIO $ modifyMVar_ (stateData ud) (\dat ->
|
|
let V2 vx _ = velocity dat
|
|
in return dat
|
|
{ velocity = (V2 vx f)
|
|
}
|
|
)
|
|
handleActionMessages ud (ActionMessage (ActLeft f) _) = do
|
|
liftIO $ modifyMVar_ (stateData ud) (\dat ->
|
|
let V2 _ vy = velocity dat
|
|
in return dat
|
|
{ velocity = (V2 (-f) vy)
|
|
}
|
|
)
|
|
handleActionMessages ud (ActionMessage (ActRight f) _) = do
|
|
liftIO $ modifyMVar_ (stateData ud) (\dat ->
|
|
let V2 _ vy = velocity dat
|
|
in return dat
|
|
{ velocity = (V2 f vy)
|
|
}
|
|
)
|
|
|
|
handleClicks :: UserData -> MouseMessage -> Affection ()
|
|
handleClicks ud (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 cpos) = do
|
|
rels <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords cpos)
|
|
ctrls <- liftIO $ readMVar (controls ud)
|
|
case ctrls of
|
|
Joystick _ -> do
|
|
when (arrowUp rels) adjustKbdUp
|
|
when (arrowDown rels) adjustKbdDown
|
|
when (arrowLeft rels) adjustKbdLeft
|
|
when (arrowRight rels) adjustKbdRight
|
|
when (buttonActivate rels) adjustKbdActivate
|
|
when (buttonSwitchMap rels) adjustKbdSwitchMap
|
|
when (buttonPlay rels) enterGame
|
|
NoController -> do
|
|
when (kbdIcon rels) $ do
|
|
void $ liftIO $ swapMVar (controls ud) Keyboard
|
|
void $ liftIO $ swapMVar (translation ud) (KbdTranslation defaultKbdTranslation)
|
|
Keyboard -> do
|
|
when (kbdIcon rels) $ do
|
|
void $ liftIO $ swapMVar (controls ud) NoController
|
|
void $ liftIO $ swapMVar (translation ud) NoTranslation
|
|
when (buttonPlay rels) enterGame
|
|
where
|
|
adjustKbdUp = do
|
|
fullClean ud
|
|
loadAdjust ud (ActUp 1) Keyboard (loadMenu ud)
|
|
adjustKbdDown = do
|
|
fullClean ud
|
|
loadAdjust ud (ActDown 1) Keyboard (loadMenu ud)
|
|
adjustKbdLeft = do
|
|
fullClean ud
|
|
loadAdjust ud (ActLeft 1) Keyboard (loadMenu ud)
|
|
adjustKbdRight = do
|
|
fullClean ud
|
|
loadAdjust ud (ActRight 1) Keyboard (loadMenu ud)
|
|
adjustKbdActivate = do
|
|
fullClean ud
|
|
loadAdjust ud ActActivate Keyboard (loadMenu ud)
|
|
adjustKbdSwitchMap = do
|
|
fullClean ud
|
|
loadAdjust ud ActSwitchMap Keyboard (loadMenu ud)
|
|
enterGame = do
|
|
fullClean ud
|
|
loadMap ud
|
|
arrowUp (V2 rx ry) =
|
|
rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
|
|
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
|
|
buttonSwitchMap (V2 rx ry) =
|
|
rx > 650 / 1280 && rx < 800 / 1280 && ry > 220 / 720 && ry < 270 / 720
|
|
buttonPlay (V2 rx ry) =
|
|
rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720
|
|
kbdIcon (V2 rx ry) =
|
|
rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 720
|
|
handleClicks _ _ = return ()
|
|
|
|
updateMenu :: UserData -> Double -> Affection ()
|
|
updateMenu ud dt = do
|
|
sData <- liftIO $ readMVar (stateData ud)
|
|
case sData of
|
|
MenuData _ _ _ _ ->
|
|
void $ liftIO $ swapMVar (stateData ud) (
|
|
MenuData
|
|
(velocity sData)
|
|
(rotation sData)
|
|
(max 0 ((activate sData) - dt))
|
|
(max 0 ((switchMap sData) - dt))
|
|
)
|
|
_ -> return ()
|
|
|
|
drawMenu :: UserData -> Affection ()
|
|
drawMenu ud = do
|
|
sData <- liftIO $ readMVar (stateData ud)
|
|
curState <- liftIO $ readMVar (state ud)
|
|
aIcons <- liftIO $ readMVar (assetIcons ud)
|
|
case sData of
|
|
MenuData _ _ _ _ ->
|
|
liftIO $ do
|
|
let ctx = nano ud
|
|
controller <- readMVar (controls ud)
|
|
save ctx
|
|
beginPath ctx
|
|
cpaint <- imagePattern ctx 550 620 80 80 0 (aIcons M.!
|
|
case controller of
|
|
Joystick _ -> IconContrGreen
|
|
_ -> IconContrBlue
|
|
) 1
|
|
rect ctx 550 620 80 80
|
|
fillPaint ctx cpaint
|
|
closePath ctx
|
|
fill ctx
|
|
beginPath ctx
|
|
cpaint2 <- imagePattern ctx 650 620 80 80 0 (aIcons M.!
|
|
case controller of
|
|
Keyboard -> IconKbdGreen
|
|
_ -> IconKbdBlue
|
|
) 1
|
|
rect ctx 650 620 80 80
|
|
fillPaint ctx cpaint2
|
|
closePath ctx
|
|
fill ctx
|
|
when (controller /= NoController) $ do
|
|
let V2 vx vy = velocity sData
|
|
beginPath ctx
|
|
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 = 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 curState of
|
|
Menu (Adjust (ActUp _) _) -> do
|
|
beginPath ctx
|
|
fillColor ctx (rgb 0 255 0)
|
|
roundedRect ctx 0 0 100 100 10
|
|
closePath ctx
|
|
fill ctx
|
|
Menu (Adjust (ActDown _) _) -> 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 curState of
|
|
Menu (Adjust (ActLeft _) _) -> do
|
|
beginPath ctx
|
|
fillColor ctx (rgb 0 255 0)
|
|
roundedRect ctx 0 0 100 100 10
|
|
closePath ctx
|
|
fill ctx
|
|
Menu (Adjust (ActRight _) _) -> 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 curState of
|
|
Menu (Adjust (ActUp _) _) -> do
|
|
beginPath ctx
|
|
fillColor ctx (rgb 0 255 0)
|
|
roundedRect ctx 0 0 100 100 10
|
|
closePath ctx
|
|
fill ctx
|
|
Menu (Adjust (ActDown _) _) -> 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 curState of
|
|
Menu (Adjust (ActLeft _) _) -> do
|
|
beginPath ctx
|
|
fillColor ctx (rgb 0 255 0)
|
|
roundedRect ctx 0 0 100 100 10
|
|
closePath ctx
|
|
fill ctx
|
|
Menu (Adjust (ActRight _) _) -> do
|
|
beginPath ctx
|
|
fillColor ctx (rgb 0 255 0)
|
|
roundedRect ctx 0 0 100 100 10
|
|
closePath ctx
|
|
fill ctx
|
|
_ ->
|
|
return ()
|
|
beginPath ctx
|
|
apaint <- imagePattern ctx 0 0 100 100 0 (aIcons M.! IconArrow) 1
|
|
rect ctx 0 0 100 100
|
|
fillPaint ctx apaint
|
|
closePath ctx
|
|
fill ctx
|
|
restore ctx
|
|
) [0, 90, 180, 270]
|
|
when (activate sData > 0) $ do
|
|
beginPath ctx
|
|
fillColor ctx (rgb 255 128 0)
|
|
roundedRect ctx 650 160 150 50 10
|
|
fill ctx
|
|
closePath ctx
|
|
case curState of
|
|
Menu (Adjust ActActivate _) -> do
|
|
beginPath ctx
|
|
fillColor ctx (rgb 0 255 0)
|
|
roundedRect ctx 650 160 150 50 10
|
|
closePath ctx
|
|
fill ctx
|
|
_ ->
|
|
return ()
|
|
beginPath 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 (rgb 255 255 255)
|
|
textBox ctx 650 175 150 "Activate"
|
|
closePath ctx
|
|
when (switchMap sData > 0) $ do
|
|
beginPath ctx
|
|
fillColor ctx (rgb 255 128 0)
|
|
roundedRect ctx 650 220 150 50 10
|
|
fill ctx
|
|
closePath ctx
|
|
case curState of
|
|
Menu (Adjust ActSwitchMap _) -> 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
|
|
roundedRect ctx 650 560 150 50 10
|
|
strokeWidth ctx 5
|
|
stroke ctx
|
|
closePath ctx
|
|
fontSize ctx 25
|
|
fontFace ctx "bedstead"
|
|
textAlign ctx (S.fromList [AlignCenter, AlignTop])
|
|
textBox ctx 650 575 150 "Play"
|
|
restore ctx
|
|
_ -> return ()
|