Modularise your control
This commit is contained in:
+27
-30
@@ -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)
|
||||
|
||||
@@ -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)]
|
||||
|
||||
@@ -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)
|
||||
@@ -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
|
||||
|
||||
+1
-1
@@ -7,7 +7,7 @@ module Dodge.Data
|
||||
, Sound (..)
|
||||
, soundTime
|
||||
)
|
||||
where
|
||||
where
|
||||
import Picture.Data
|
||||
import Geometry.Data
|
||||
import Sound.Preload
|
||||
|
||||
+1
-1
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user