From e6a57653b3867791575d774496e411513a538b47 Mon Sep 17 00:00:00 2001 From: jgk Date: Sat, 27 Mar 2021 00:13:11 +0100 Subject: [PATCH] Modularise your control --- app/Main.hs | 57 ++++++++--------- src/Dodge/AIs.hs | 81 ------------------------ src/Dodge/Creature/YourControl.hs | 102 ++++++++++++++++++++++++++++++ src/Dodge/Critters.hs | 1 + src/Dodge/Data.hs | 2 +- src/Sound.hs | 2 +- 6 files changed, 132 insertions(+), 113 deletions(-) create mode 100644 src/Dodge/Creature/YourControl.hs diff --git a/app/Main.hs b/app/Main.hs index 3788cc0fc..3b73e7975 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -36,45 +36,42 @@ import qualified SDL import qualified SDL.Mixer as Mix import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate) -import LoadConfig - -cursorVis :: Bool -> IO () -cursorVis b = SDL.cursorVisible $= b - main :: IO () main = do (sizex,sizey) <- loadConfig keyConfig <- loadKeyConfig setupLoop (sizex,sizey) - (cursorVis False >> doPreload >>= resizeSpareFBO sizex sizey) - (\x -> cursorVis True >> cleanUpPreload x) + (SDL.cursorVisible $= False >> doPreload >>= resizeSpareFBO sizex sizey) + (\x -> (SDL.cursorVisible $= True) >> cleanUpPreload x) (fmap (setWindowSize sizex sizey keyConfig) firstWorld) ( \preData w -> do - startTicks <- SDL.ticks - clear [ColorBuffer,DepthBuffer] - (lightTicks,timeSpentPoking) <- renderPicture' (_renderData preData) - (_cameraRot w) (_cameraZoom w) - (_cameraCenter w) - (_windowX w,_windowY w) - (wallsPointsAndCols w) - (wallsWindows w) - (lightsForGloom' w) - (_cameraViewFrom w) - (worldPictures w) - blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - renderFoldable (_renderData preData) (picToLTree Nothing $ fixedCoordPictures w) - playSoundQueue (_soundData preData) (_soundQueue w) - newSoundData <- playAndUpdate (_sounds w) (_soundData preData) + startTicks <- SDL.ticks + clear [ColorBuffer,DepthBuffer] + (lightTicks,timeSpentPoking) <- renderPicture' (_renderData preData) + (_cameraRot w) (_cameraZoom w) + (_cameraCenter w) + (_windowX w,_windowY w) + (wallsPointsAndCols w) + (wallsWindows w) + (lightsForGloom' w) + (_cameraViewFrom w) + (worldPictures w) + blendFunc $= (SrcAlpha,OneMinusSrcAlpha) + renderFoldable (_renderData preData) (picToLTree Nothing $ fixedCoordPictures w) + playSoundQueue (_soundData preData) (_soundQueue w) + newSoundData <- playAndUpdate (_sounds w) (_soundData preData) - endTicks <- SDL.ticks - let lastFrameTicks = _frameTimer preData - renderFoldable (_renderData preData) - (picToLTree Nothing . setLayer 1 . setDepth (-1) - . translate (-0.5) (-0.8) . scale 0.0005 0.0005 - . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)) - return $ preData & soundData .~ newSoundData - & frameTimer .~ endTicks + endTicks <- SDL.ticks + let lastFrameTicks = _frameTimer preData + renderFoldable + (_renderData preData) + (picToLTree Nothing . setLayer 1 . setDepth (-1) + . translate (-0.5) (-0.8) . scale 0.0005 0.0005 + . text $ "ms/frame " ++ show (endTicks - lastFrameTicks) + ) + return $ preData & soundData .~ newSoundData + & frameTimer .~ endTicks ) (flip $ menuEvents handleEvent) (Just . update) diff --git a/src/Dodge/AIs.hs b/src/Dodge/AIs.hs index 086c7cc26..23ae88708 100644 --- a/src/Dodge/AIs.hs +++ b/src/Dodge/AIs.hs @@ -8,7 +8,6 @@ import Dodge.CreatureAction import Dodge.Event import Dodge.RandomHelp import Dodge.WorldEvent -import Dodge.CreatureState import Dodge.Update.UsingInput @@ -1874,86 +1873,6 @@ splitCritCorpse :: Float -> Picture splitCritCorpse x = color (greyN 0.2) $ circleSolid x spCrRadFac = 8^2 -yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -yourControl w (f,g) cr = ( (updateUsingInput . f, g) - , Just . crAutoReload . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr - ) - where strafeSpeed = 8 * equipFactor * (fromMaybe 1 $ yourItem w ^? itAimingSpeed) - speed = 3 * equipFactor - equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! 0 - -wasdWithAiming :: World -> Float -> Float -> Int -> Creature -> Creature -wasdWithAiming w speed aimSpeed i cr - | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving && isAiming - && diffAngles mouseDir (argV mov) < pi/3 - = over crPos (+.+ (0.2 *.* mov)) --- $ set ( creatures . ix i . crDir) (argV mov) - $ set crDir mouseDir - $ set (crState . stance . carriage) (Boosting mov) - cr - | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving && isAiming - = set crDir mouseDir - $ set (crState . stance . carriage) Floating - cr - | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving - = over crPos (+.+ (0.2 *.* mov)) --- $ set ( creatures . ix i . crDir) (argV mov) - -- $ set ( creatures . ix i . crDir) mouseDir - $ over crDir (flip fromMaybe dir) - $ set (crState . stance . carriage) (Boosting mov) - cr - | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isAiming - = set (crState . stance . carriage) Floating - $ set crDir mouseDir - cr - | any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr - = set (crState . stance . carriage) Floating - cr - | isAiming - = -- stopSoundFrom (CrSound i) $ - stepForward' aimSpeed - $ over crPos (+.+ (aimSpeed *.* mov)) - $ set crDir mouseDir - cr - | isMoving - = -- continueOrLoopFrom (CrSound i) twoStepSound $ - stepForward' speed - $ over ( crPos) (+.+ (speed *.* mov)) - $ over ( crDir) (flip fromMaybe dir) - cr - | otherwise - = -- stopSoundFrom (CrSound i) $ - over ( crDir) (flip fromMaybe dir) - cr - where (mov',dir') = wasdComp (view keys w) w - (mov,dir) = (rotateV (_cameraRot w) mov',fmap (_cameraRot w +) dir') - isMoving = mov' /= (0,0) - isAiming = (_posture $ _stance $ _crState cr) == Aiming - mouseDir = case w ^? creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment of - Just (Just (ItScope {_scopePos = p})) -> normalizeAngle $ argV - $ p +.+ 2 / _cameraZoom w - *.* rotateV (_cameraRot w) (_mousePos w) - _ -> normalizeAngle $ argV (_mousePos w) + _cameraRot w - - -wasdM :: World -> SDL.Scancode -> Point2 -wasdM w scancode - | scancode == moveUpKey (_keyConfig w) = (0,1) - | scancode == moveDownKey (_keyConfig w) = (0,-1) - | scancode == moveRightKey (_keyConfig w) = (1,0) - | scancode == moveLeftKey (_keyConfig w) = (-1,0) -wasdM _ _ = (0,0) ---wasdM SDL.ScancodeW = (0,1) ---wasdM SDL.ScancodeS = (0,-1) ---wasdM SDL.ScancodeD = (1,0) ---wasdM SDL.ScancodeA = (-1,0) ---wasdM _ = (0,0) - -wasdComp :: S.Set SDL.Scancode -> World -> (Point2,Maybe Float) -wasdComp ks w = f $ foldr ( (+.+) . wasdM w ) (0,0) ks - where f (0,0) = ((0,0), Nothing) - f p = (errorNormalizeV 46 p, Just $ argV p) ---------------- circLine x = line [(0,0),(x,0)] diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs new file mode 100644 index 000000000..2e7c9c268 --- /dev/null +++ b/src/Dodge/Creature/YourControl.hs @@ -0,0 +1,102 @@ +module Dodge.Creature.YourControl + where + +import Dodge.Data +import Dodge.Base +import Dodge.CreatureAction +import Dodge.Update.UsingInput +import Dodge.Event +import Dodge.CreatureState + +import Geometry + +import Control.Lens +import qualified SDL +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import System.Random + +import Data.Maybe + +import LoadConfig + +yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +yourControl w (f,g) cr = ( (updateUsingInput . f, g) + , Just . crAutoReload . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr + ) + where strafeSpeed = 8 * equipFactor * (fromMaybe 1 $ yourItem w ^? itAimingSpeed) + speed = 3 * equipFactor + equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! 0 + +wasdWithAiming :: World -> Float -> Float -> Int -> Creature -> Creature +wasdWithAiming w speed aimSpeed i cr + | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving && isAiming + && diffAngles mouseDir (argV mov) < pi/3 + = over crPos (+.+ (0.2 *.* mov)) +-- $ set ( creatures . ix i . crDir) (argV mov) + $ set crDir mouseDir + $ set (crState . stance . carriage) (Boosting mov) + cr + | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving && isAiming + = set crDir mouseDir + $ set (crState . stance . carriage) Floating + cr + | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving + = over crPos (+.+ (0.2 *.* mov)) +-- $ set ( creatures . ix i . crDir) (argV mov) + -- $ set ( creatures . ix i . crDir) mouseDir + $ over crDir (flip fromMaybe dir) + $ set (crState . stance . carriage) (Boosting mov) + cr + | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isAiming + = set (crState . stance . carriage) Floating + $ set crDir mouseDir + cr + | any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr + = set (crState . stance . carriage) Floating + cr + | isAiming + = -- stopSoundFrom (CrSound i) $ + stepForward' aimSpeed + $ over crPos (+.+ (aimSpeed *.* mov)) + $ set crDir mouseDir + cr + | isMoving + = -- continueOrLoopFrom (CrSound i) twoStepSound $ + stepForward' speed + $ over ( crPos) (+.+ (speed *.* mov)) + $ over ( crDir) (flip fromMaybe dir) + cr + | otherwise + = -- stopSoundFrom (CrSound i) $ + over ( crDir) (flip fromMaybe dir) + cr + where (mov',dir') = wasdComp (view keys w) w + (mov,dir) = (rotateV (_cameraRot w) mov',fmap (_cameraRot w +) dir') + isMoving = mov' /= (0,0) + isAiming = (_posture $ _stance $ _crState cr) == Aiming + mouseDir = case w ^? creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment of + Just (Just (ItScope {_scopePos = p})) -> normalizeAngle $ argV + $ p +.+ 2 / _cameraZoom w + *.* rotateV (_cameraRot w) (_mousePos w) + _ -> normalizeAngle $ argV (_mousePos w) + _cameraRot w + + +wasdM :: World -> SDL.Scancode -> Point2 +wasdM w scancode + | scancode == moveUpKey (_keyConfig w) = (0,1) + | scancode == moveDownKey (_keyConfig w) = (0,-1) + | scancode == moveRightKey (_keyConfig w) = (1,0) + | scancode == moveLeftKey (_keyConfig w) = (-1,0) +wasdM _ _ = (0,0) +--wasdM SDL.ScancodeW = (0,1) +--wasdM SDL.ScancodeS = (0,-1) +--wasdM SDL.ScancodeD = (1,0) +--wasdM SDL.ScancodeA = (-1,0) +--wasdM _ = (0,0) + +wasdComp :: S.Set SDL.Scancode -> World -> (Point2,Maybe Float) +wasdComp ks w = f $ foldr ( (+.+) . wasdM w ) (0,0) ks + where f (0,0) = ((0,0), Nothing) + f p = (errorNormalizeV 46 p, Just $ argV p) diff --git a/src/Dodge/Critters.hs b/src/Dodge/Critters.hs index a35fa0f3c..2f1d14aca 100644 --- a/src/Dodge/Critters.hs +++ b/src/Dodge/Critters.hs @@ -8,6 +8,7 @@ import Dodge.Base import Dodge.Item.Weapon import Dodge.Item.Consumable import Dodge.WorldEvent.Cloud +import Dodge.Creature.YourControl import Picture import Geometry diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index bf1cd0043..bab1d2c66 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -7,7 +7,7 @@ module Dodge.Data , Sound (..) , soundTime ) - where + where import Picture.Data import Geometry.Data import Sound.Preload diff --git a/src/Sound.hs b/src/Sound.hs index 60d207d35..2d049d6aa 100644 --- a/src/Sound.hs +++ b/src/Sound.hs @@ -21,7 +21,7 @@ playIfFree c times = do mayChan <- Mix.getAvailable Mix.DefaultGroup case mayChan of Nothing -> return Nothing - Just i -> fmap Just $ Mix.playOn i times c + Just i -> Just <$> Mix.playOn i times c haltMaybe :: Maybe Mix.Channel -> IO (Maybe Sound) haltMaybe (Just x) = Mix.halt x >> return Nothing