tracer/src/Menu/Connect.hs
2019-10-28 18:20:34 +01:00

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 ()