Modularise your control

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)
+        (SDL.cursorVisible $= False >> doPreload >>= resizeSpareFBO sizex sizey)
-        (\x -> cursorVis True >> cleanUpPreload x)
+        (\x -> (SDL.cursorVisible $= True) >> cleanUpPreload x)
         (fmap (setWindowSize sizex sizey keyConfig) firstWorld)
         ( \preData w -> do
-                      startTicks <- SDL.ticks
+            startTicks <- SDL.ticks
-                      clear [ColorBuffer,DepthBuffer]
+            clear [ColorBuffer,DepthBuffer]
-                      (lightTicks,timeSpentPoking) <- renderPicture' (_renderData preData) 
+            (lightTicks,timeSpentPoking) <- renderPicture' (_renderData preData) 
-                                            (_cameraRot w) (_cameraZoom w) 
+                (_cameraRot w) (_cameraZoom w) 
-                                            (_cameraCenter w)
+                (_cameraCenter w)
-                                            (_windowX w,_windowY w) 
+                (_windowX w,_windowY w) 
-                                            (wallsPointsAndCols w)
+                (wallsPointsAndCols w)
-                                            (wallsWindows w)
+                (wallsWindows w)
-                                            (lightsForGloom' w)
+                (lightsForGloom' w)
-                                            (_cameraViewFrom w)
+                (_cameraViewFrom w)
-                                            (worldPictures w)
+                (worldPictures w)
-                      blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+            blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-                      renderFoldable (_renderData preData) (picToLTree Nothing $ fixedCoordPictures w)
+            renderFoldable (_renderData preData) (picToLTree Nothing $ fixedCoordPictures w)
-                      playSoundQueue (_soundData preData) (_soundQueue w)
+            playSoundQueue (_soundData preData) (_soundQueue w)
-                      newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
+            newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
 
-                      endTicks <- SDL.ticks
+            endTicks <- SDL.ticks
-                      let lastFrameTicks = _frameTimer preData
+            let lastFrameTicks = _frameTimer preData
-                      renderFoldable (_renderData preData) 
+            renderFoldable 
-                                     (picToLTree Nothing . setLayer 1 . setDepth (-1) 
+                (_renderData preData) 
-                                       . translate (-0.5) (-0.8) . scale 0.0005 0.0005 
+                (picToLTree Nothing . setLayer 1 . setDepth (-1) 
-                                       . text $ "ms/frame " ++ show (endTicks - lastFrameTicks))
+                    . translate (-0.5) (-0.8) . scale 0.0005 0.0005 
-                      return $ preData & soundData  .~ newSoundData
+                    . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
-                                       & frameTimer .~ endTicks
+                )
+            return $ preData & soundData  .~ newSoundData
+                             & frameTimer .~ endTicks
         )
         (flip $ menuEvents handleEvent)
         (Just . update)

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

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)

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

src/Dodge/Data.hs

@@ -7,7 +7,7 @@ module Dodge.Data
     , Sound (..)
     , soundTime
     )
-    where
+  where
 import Picture.Data
 import Geometry.Data
 import Sound.Preload

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