tracer/src/Menu/Connect.hs

407 lines
13 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)
2019-02-11 23:11:53 +00:00
import Linear hiding (rotate, translation)
2018-10-12 12:26:06 +00:00
import qualified Data.Set as S
import qualified Data.Map.Strict as M
import Data.Maybe (isNothing, isJust)
2019-10-28 17:20:34 +00:00
import Data.String
2018-10-12 12:26:06 +00:00
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
2019-02-11 09:49:23 +00:00
let (Subsystems _ m k j t) = subsystems ud
2018-10-12 12:26:06 +00:00
uu1 <- partSubscribe j joystickConnect
uu2 <- partSubscribe j joystickDisconnect
2019-02-11 09:49:23 +00:00
uu3 <- partSubscribe j emitJoyActionMessage
2019-02-11 23:11:53 +00:00
uu4 <- partSubscribe k emitKbdActionMessage
uu5 <- partSubscribe t handleActionMessages
uu6 <- partSubscribe m handleClicks
2019-02-11 15:11:27 +00:00
-- uu6 <- partSubscribe k emitKbdActionMessage
2018-10-12 12:26:06 +00:00
partUnSubscribe j (joyUUID ud)
putAffection ud
2019-02-11 23:11:53 +00:00
{ uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
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
2019-02-11 15:11:27 +00:00
when (controls ud == NoController) $ do
2018-10-12 12:26:06 +00:00
mjoy <- joystickAutoConnect msg
maybe (return ()) (\joy -> do
ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
2019-10-28 17:20:34 +00:00
liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show ident)
2018-10-12 12:26:06 +00:00
putAffection ud
2019-02-11 15:11:27 +00:00
{ controls = Joystick joy
2019-02-11 23:11:53 +00:00
, translation = JoyTranslation defaultJoyTranslation
2018-10-12 12:26:06 +00:00
}
) mjoy
joystickDisconnect :: JoystickMessage -> Affection UserData ()
joystickDisconnect msg = do
ud <- getAffection
2019-02-11 15:11:27 +00:00
case controls ud of
Joystick joy -> do
njoys <- joystickAutoDisconnect [joy] msg
when (null njoys) $ do
liftIO $ logIO A.Debug $ "Joystick disconnected"
putAffection ud
2019-02-11 23:11:53 +00:00
{ controls = NoController
, translation = NoTranslation
2019-02-11 15:11:27 +00:00
}
_ -> return ()
2018-10-12 12:26:06 +00:00
handleActionMessages :: ActionMessage -> Affection UserData ()
2019-02-11 23:11:53 +00:00
handleActionMessages (ActionMessage ActActivate _) = do
2018-10-12 12:26:06 +00:00
ud <- getAffection
putAffection ud
{ stateData = (stateData ud)
{ activate = 0.5
}
}
2019-02-11 23:11:53 +00:00
handleActionMessages (ActionMessage ActSwitchMap _) = do
2018-10-13 18:12:10 +00:00
ud <- getAffection
putAffection ud
{ stateData = (stateData ud)
{ switchMap = 0.5
}
}
2019-02-11 23:11:53 +00:00
handleActionMessages (ActionMessage (ActUp f) _) = do
2018-10-12 12:26:06 +00:00
ud <- getAffection
let V2 vx _ = velocity $ stateData ud
putAffection ud
{ stateData = (stateData ud)
2019-02-11 23:11:53 +00:00
{ velocity = (V2 vx (-f))
2018-10-12 12:26:06 +00:00
}
}
2019-02-11 23:11:53 +00:00
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
2018-10-12 12:26:06 +00:00
ud <- getAffection
let V2 _ vy = velocity $ stateData ud
putAffection ud
{ stateData = (stateData ud)
2019-02-11 23:11:53 +00:00
{ 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)
2018-10-12 12:26:06 +00:00
}
}
handleClicks :: MouseMessage -> Affection UserData ()
handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
2019-02-11 15:11:27 +00:00
ud <- getAffection
2019-02-11 23:11:53 +00:00
rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
2019-02-11 15:11:27 +00:00
case controls ud of
2019-02-11 23:11:53 +00:00
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
2018-10-12 12:26:06 +00:00
where
2019-02-11 23:11:53 +00:00
adjustKbdUp = do
2018-10-12 19:40:16 +00:00
fullClean
2019-02-11 23:11:53 +00:00
loadAdjust (ActUp 1) Keyboard loadMenu
adjustKbdDown = do
2018-10-12 19:40:16 +00:00
fullClean
2019-02-11 23:11:53 +00:00
loadAdjust (ActDown 1) Keyboard loadMenu
adjustKbdLeft = do
2018-10-12 19:40:16 +00:00
fullClean
2019-02-11 23:11:53 +00:00
loadAdjust (ActLeft 1) Keyboard loadMenu
adjustKbdRight = do
2018-10-12 19:40:16 +00:00
fullClean
2019-02-11 23:11:53 +00:00
loadAdjust (ActRight 1) Keyboard loadMenu
adjustKbdActivate = do
2018-10-12 19:40:16 +00:00
fullClean
2019-02-11 23:11:53 +00:00
loadAdjust ActActivate Keyboard loadMenu
adjustKbdSwitchMap = do
2018-10-13 18:12:10 +00:00
fullClean
2019-02-11 23:11:53 +00:00
loadAdjust ActSwitchMap Keyboard 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
2019-02-11 23:11:53 +00:00
kbdIcon (V2 rx ry) =
rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 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
2019-02-11 09:49:23 +00:00
controller = controls ud
2018-10-12 12:26:06 +00:00
save ctx
beginPath ctx
2019-02-11 15:11:27 +00:00
cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.!
case controller of
2019-02-11 23:11:53 +00:00
Joystick _ -> IconContrGreen
_ -> IconContrBlue
2019-02-11 15:11:27 +00:00
) 1
2019-02-11 23:11:53 +00:00
rect ctx 550 620 80 80
2019-02-11 15:11:27 +00:00
fillPaint ctx cpaint
2019-02-11 23:11:53 +00:00
closePath ctx
2019-02-11 15:11:27 +00:00
fill ctx
beginPath ctx
cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud M.!
case controller of
Keyboard -> IconKbdGreen
_ -> IconKbdBlue
2018-10-12 22:07:19 +00:00
) 1
2019-02-11 23:11:53 +00:00
rect ctx 650 620 80 80
2019-02-11 15:11:27 +00:00
fillPaint ctx cpaint
2019-02-11 23:11:53 +00:00
closePath ctx
2018-10-12 12:26:06 +00:00
fill ctx
2019-02-11 15:11:27 +00:00
when (controller /= NoController) $ do
2018-10-12 22:07:19 +00:00
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
2019-02-11 23:11:53 +00:00
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
2018-10-12 22:07:19 +00:00
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
2019-02-11 23:11:53 +00:00
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
2018-10-12 22:07:19 +00:00
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
2019-02-11 23:11:53 +00:00
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
2018-10-12 22:07:19 +00:00
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
2019-02-11 23:11:53 +00:00
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
2018-10-12 22:07:19 +00:00
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
_ ->
return ()
beginPath ctx
2019-02-11 15:11:27 +00:00
apaint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
2018-10-12 22:07:19 +00:00
rect ctx 0 0 100 100
2019-02-11 15:11:27 +00:00
fillPaint ctx apaint
2018-10-12 22:07:19 +00:00
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
2019-02-11 23:11:53 +00:00
Menu (Adjust ActActivate _) -> do
2018-10-12 22:07:19 +00:00
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
2019-02-11 23:11:53 +00:00
Menu (Adjust ActSwitchMap _) -> do
2018-10-13 18:12:10 +00:00
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 ()