406 lines
13 KiB
Haskell
406 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.Maybe (isNothing, isJust)
|
|
import Data.String
|
|
|
|
import Control.Monad
|
|
|
|
-- internal imports
|
|
|
|
import Types
|
|
import Util
|
|
import Menu.Adjust
|
|
import MainGame.WorldMap
|
|
|
|
loadMenu :: Affection UserData ()
|
|
loadMenu = do
|
|
ud <- getAffection
|
|
ad <- get
|
|
let (Subsystems _ m k j t) = subsystems ud
|
|
uu1 <- partSubscribe j joystickConnect
|
|
uu2 <- partSubscribe j joystickDisconnect
|
|
uu3 <- partSubscribe j emitJoyActionMessage
|
|
uu4 <- partSubscribe k emitKbdActionMessage
|
|
uu5 <- partSubscribe t handleActionMessages
|
|
uu6 <- partSubscribe m handleClicks
|
|
-- uu6 <- partSubscribe k emitKbdActionMessage
|
|
partUnSubscribe j (joyUUID ud)
|
|
putAffection ud
|
|
{ uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
|
|
, state = Menu Connect
|
|
, stateData = MenuData (V2 0 0) S 0 0
|
|
, joyCache = []
|
|
}
|
|
mapM_ (partEmit j) (joyCache ud)
|
|
|
|
joystickConnect :: JoystickMessage -> Affection UserData ()
|
|
joystickConnect msg = do
|
|
ud <- getAffection
|
|
when (controls ud == NoController) $ do
|
|
mjoy <- joystickAutoConnect msg
|
|
maybe (return ()) (\joy -> do
|
|
ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
|
|
liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show ident)
|
|
putAffection ud
|
|
{ controls = Joystick joy
|
|
, translation = JoyTranslation defaultJoyTranslation
|
|
}
|
|
) mjoy
|
|
|
|
joystickDisconnect :: JoystickMessage -> Affection UserData ()
|
|
joystickDisconnect msg = do
|
|
ud <- getAffection
|
|
case controls ud of
|
|
Joystick joy -> do
|
|
njoys <- joystickAutoDisconnect [joy] msg
|
|
when (null njoys) $ do
|
|
liftIO $ logIO A.Debug $ "Joystick disconnected"
|
|
putAffection ud
|
|
{ controls = NoController
|
|
, translation = NoTranslation
|
|
}
|
|
_ -> return ()
|
|
|
|
handleActionMessages :: ActionMessage -> Affection UserData ()
|
|
handleActionMessages (ActionMessage ActActivate _) = do
|
|
ud <- getAffection
|
|
putAffection ud
|
|
{ stateData = (stateData ud)
|
|
{ activate = 0.5
|
|
}
|
|
}
|
|
handleActionMessages (ActionMessage ActSwitchMap _) = do
|
|
ud <- getAffection
|
|
putAffection ud
|
|
{ stateData = (stateData ud)
|
|
{ switchMap = 0.5
|
|
}
|
|
}
|
|
handleActionMessages (ActionMessage (ActUp f) _) = do
|
|
ud <- getAffection
|
|
let V2 vx _ = velocity $ stateData ud
|
|
putAffection ud
|
|
{ stateData = (stateData ud)
|
|
{ velocity = (V2 vx (-f))
|
|
}
|
|
}
|
|
handleActionMessages (ActionMessage (ActDown f) _) = do
|
|
ud <- getAffection
|
|
let V2 vx _ = velocity $ stateData ud
|
|
putAffection ud
|
|
{ stateData = (stateData ud)
|
|
{ velocity = (V2 vx f)
|
|
}
|
|
}
|
|
handleActionMessages (ActionMessage (ActLeft f) _) = do
|
|
ud <- getAffection
|
|
let V2 _ vy = velocity $ stateData ud
|
|
putAffection ud
|
|
{ stateData = (stateData ud)
|
|
{ velocity = (V2 (-f) vy)
|
|
}
|
|
}
|
|
handleActionMessages (ActionMessage (ActRight f) _) = do
|
|
ud <- getAffection
|
|
let V2 _ vy = velocity $ stateData ud
|
|
putAffection ud
|
|
{ stateData = (stateData ud)
|
|
{ velocity = (V2 f vy)
|
|
}
|
|
}
|
|
|
|
handleClicks :: MouseMessage -> Affection UserData ()
|
|
handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
|
|
ud <- getAffection
|
|
rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
|
|
case controls ud 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) $
|
|
putAffection ud
|
|
{ controls = Keyboard
|
|
, translation = KbdTranslation defaultKbdTranslation
|
|
}
|
|
Keyboard -> do
|
|
when (kbdIcon rels) $
|
|
putAffection ud
|
|
{ controls = NoController
|
|
, translation = NoTranslation
|
|
}
|
|
when (buttonPlay rels) enterGame
|
|
where
|
|
adjustKbdUp = do
|
|
fullClean
|
|
loadAdjust (ActUp 1) Keyboard loadMenu
|
|
adjustKbdDown = do
|
|
fullClean
|
|
loadAdjust (ActDown 1) Keyboard loadMenu
|
|
adjustKbdLeft = do
|
|
fullClean
|
|
loadAdjust (ActLeft 1) Keyboard loadMenu
|
|
adjustKbdRight = do
|
|
fullClean
|
|
loadAdjust (ActRight 1) Keyboard loadMenu
|
|
adjustKbdActivate = do
|
|
fullClean
|
|
loadAdjust ActActivate Keyboard loadMenu
|
|
adjustKbdSwitchMap = do
|
|
fullClean
|
|
loadAdjust ActSwitchMap Keyboard loadMenu
|
|
enterGame = do
|
|
fullClean
|
|
loadMap
|
|
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 :: Double -> Affection UserData ()
|
|
updateMenu dt = do
|
|
ud <- getAffection
|
|
case stateData ud of
|
|
MenuData _ _ _ _ ->
|
|
putAffection ud
|
|
{ stateData = MenuData
|
|
(velocity $ stateData ud)
|
|
(rotation $ stateData ud)
|
|
(max 0 ((activate $ stateData ud) - dt))
|
|
(max 0 ((switchMap $ stateData ud) - dt))
|
|
}
|
|
_ -> return ()
|
|
|
|
drawMenu :: Affection UserData ()
|
|
drawMenu = do
|
|
ud <- getAffection
|
|
case stateData ud of
|
|
MenuData _ _ _ _ ->
|
|
liftIO $ do
|
|
let ctx = nano ud
|
|
controller = controls ud
|
|
save ctx
|
|
beginPath ctx
|
|
cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.!
|
|
case controller of
|
|
Joystick _ -> IconContrGreen
|
|
_ -> IconContrBlue
|
|
) 1
|
|
rect ctx 550 620 80 80
|
|
fillPaint ctx cpaint
|
|
closePath ctx
|
|
fill ctx
|
|
beginPath ctx
|
|
cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud M.!
|
|
case controller of
|
|
Keyboard -> IconKbdGreen
|
|
_ -> IconKbdBlue
|
|
) 1
|
|
rect ctx 650 620 80 80
|
|
fillPaint ctx cpaint
|
|
closePath ctx
|
|
fill ctx
|
|
when (controller /= NoController) $ 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 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 (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 state ud 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 state ud 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 state ud 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 (assetIcons ud M.! IconArrow) 1
|
|
rect ctx 0 0 100 100
|
|
fillPaint ctx apaint
|
|
closePath ctx
|
|
fill ctx
|
|
restore ctx
|
|
) [0, 90, 180, 270]
|
|
when (activate (stateData ud) > 0) $ do
|
|
beginPath ctx
|
|
fillColor ctx (rgb 255 128 0)
|
|
roundedRect ctx 650 160 150 50 10
|
|
fill ctx
|
|
closePath ctx
|
|
case state ud 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 (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 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 ()
|