Remove duplicated creature movement code

package.yaml

@@ -11,8 +11,8 @@ extra-source-files:
 - ChangeLog.md
 
 # Metadata used when publishing your package
-# synopsis:            Short description of your package
+# synopsis:            A basic game loop
-# category:            Web
+# category:            Graphics
 
 # To avoid duplicated efforts in documentation and dealing with the
 # complications of embedding Haddock markup inside cabal files, it is
@@ -52,7 +52,8 @@ library:
   source-dirs: src
 
 executables:
-  loop-exe:
+    #  loop-exe:
+  dodge:
     main:                Main.hs
     source-dirs:         app
     ghc-options:

src/Dodge/Creature/Action.hs

@@ -29,176 +29,6 @@ import System.Random
 import qualified Data.IntMap.Strict as IM
 --import qualified Data.Map as M
 
-crStrafeLeft
-    :: Float    -- ^ Speed
-    -> Creature 
-    -> Creature
-crStrafeLeft speed cr = advanceStepCounter s2 $ over crPos (+.+ p) cr
-  where 
-    p = s2 *.* unitVectorAtAngle (_crDir cr + pi/2)
-    equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
-    s2 = speed * equipFactor
-
-crStrafeRight 
-    :: Float    -- ^ Speed
-    -> Creature 
-    -> Creature
-crStrafeRight speed cr = advanceStepCounter s2 $ over crPos (+.+ p) cr
-  where 
-    p =  s2 *.* unitVectorAtAngle (_crDir cr - pi/2)
-    equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
-    s2 = speed * equipFactor
-
-turnTo 
-    :: Point2   -- ^ Target point
-    -> Int      -- ^ Creature id
-    -> World 
-    -> World
-turnTo p n w = set (creatures . ix n . crDir) dirToTarget w
-  where 
-    cr = _creatures w IM.! n
-    dirToTarget = argV (p -.- _crPos cr)
-
-turnTowardRandomise
-    :: Point2   -- ^ Target point
-    -> Int      -- ^ Creature id
-    -> World 
-    -> World
-turnTowardRandomise p n w 
-    | isLeftOfA dirToTarget (_crDir cr)
-                = f $ over (creatures . ix n . crDir) 
-                           (normalizeAngle . (+ (0.03 + r*m))) w
-    | otherwise = f $ over (creatures . ix n . crDir) 
-                           (\x->normalizeAngle (x - (0.03 + r*m))) w
-  where 
-    cr          = _creatures w IM.! n
-    dirToTarget = argV (p -.- _crPos cr)
-    (r,g)       = randomR (-0.1,0.1) (_randGen w)
-    m           = diffAngles dirToTarget (_crDir cr)
-    f           = set randGen g
-
-turnTowardAngle 
-    :: Float    -- ^ Angle
-    -> Int      -- ^ Creature id
-    -> World 
-    -> World
-turnTowardAngle a n w 
-    | isLeftOfA a (_crDir cr) = f $ over (creatures . ix n . crDir) 
-                                        (normalizeAngle . (+ (0.03 + r*m))) w
-    | otherwise = f $ over (creatures . ix n . crDir) 
-                                        (\x->normalizeAngle (x - (0.03 + r*m))) w
-  where 
-    cr      = _creatures w IM.! n
-    (r,g)   = randomR (-0.1,0.1) (_randGen w)
-    m       = diffAngles a (_crDir cr)
-    f       = set randGen g
-
-turnTowardWithSpeed 
-    :: Float    -- ^ Turn speed
-    -> Point2   -- ^ Target point
-    -> Int      -- ^ Creature id
-    -> World 
-    -> World
-turnTowardWithSpeed turnSpeed p n w 
-    | isLeftOfA dirToTarget (_crDir cr)
-                = f $ over (creatures . ix n . crDir) (normalizeAngle. (+ (turnSpeed + r))) w
-    | otherwise = f $ over (creatures . ix n . crDir) (\x->normalizeAngle (x - (turnSpeed + r))) w
-  where 
-    cr          = _creatures w IM.! n
-    dirToTarget = argV (p -.- _crPos cr)
-    (r,g)       = randomR (-0.1,0.1) (_randGen w)
-    f           = set randGen g
-
-crTurnAndStrafeIn 
-    :: Float    -- ^ Strafe speed
-    -> Float    -- ^ Turn speed
-    -> Point2   -- ^ Target position
-    -> Creature 
-    -> Creature
-crTurnAndStrafeIn strafeSpeed turnSpeed p cr
-    | vToTarg == (0,0) = cr -- this should deal with the angleVV error
-    | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
-                = set crDir dirToTarget cr
-    | isLeftOfA dirToTarget (_crDir cr)
-                = over crDir (normalizeAngle . (+ turnAmount ))
-                      $ crStrafeLeft strafeSpeed cr
-    | otherwise = over crDir (\x->normalizeAngle (x - turnAmount))
-                      $ crStrafeRight strafeSpeed cr
-  where 
-    vToTarg = p -.- _crPos cr
-    dirToTarget = argV vToTarg
-    turnAmount  = turnSpeed
-
-crTurnTo 
-    :: Point2   -- ^ Target position
-    -> Creature 
-    -> Creature
-crTurnTo p cr = set crDir dirToTarget cr
-    where dirToTarget = argV (p -.- _crPos cr)
-
-crRandomTurn
-    :: RandomGen g
-    => Float    -- ^ Max possible angle, supposed to be positive
-    -> Creature
-    -> g
-    -> (Creature, g)
-crRandomTurn a cr g = 
-    let (r, g') = randomR (negate a, a) g
-    in (cr & crDir +~ r, g')
-
-crTurnTowardSpeed 
-    :: Float    -- ^ Turn speed
-    -> Point2   -- ^ Target position
-    -> Creature 
-    -> Creature
-crTurnTowardSpeed turnSpeed p cr
-    | vToTarg == (0,0) = cr -- this should deal with the angleVV error
-    | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
-                = set crDir dirToTarget cr
-    | isLeftOfA dirToTarget (_crDir cr)
-                = over crDir (normalizeAngle . (+ turnAmount )) cr
-    | otherwise = over crDir (\x->normalizeAngle (x - turnAmount)) cr
-                    where vToTarg = p -.- _crPos cr
-                          dirToTarget = argV vToTarg
-                          turnAmount  = turnSpeed
-
-turnTowardSpeed 
-    :: Float    -- ^ Turn speed
-    -> Point2   -- ^ Target position
-    -> Int      -- ^ Creature id
-    -> World 
-    -> World
-turnTowardSpeed turnSpeed p n w 
-    | vToTarg == (0,0) = w -- this should deal with the angleVV error
-    | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
-                = set (creatures . ix n . crDir) dirToTarget w
-    | isLeftOfA dirToTarget (_crDir cr)
-                = over (creatures . ix n . crDir) (normalizeAngle . (+ turnAmount )) w
-    | otherwise = over (creatures . ix n . crDir) (\x->normalizeAngle (x - turnAmount)) w
-                    where cr          = _creatures w IM.! n
-                          vToTarg = p -.- _crPos cr
-                          dirToTarget = argV vToTarg
-                          turnAmount  = turnSpeed
-
-turnToward 
-    :: Point2   -- ^ Target position
-    -> Int      -- ^ Creature id
-    -> World 
-    -> World
-turnToward p n w 
-    | isLeftOfA dirToTarget (_crDir cr) = over (creatures . ix n . crDir) (+ 0.03) w
-    | otherwise = over (creatures . ix n . crDir) (\x-> x - 0.03) w
-  where 
-    cr          = _creatures w IM.! n
-    dirToTarget = argV (p -.- _crPos cr)
-{- | Translate a creature. -}
-moveBy 
-    :: Int      -- ^ Creature id
-    -> Point2   -- ^ Translation
-    -> World 
-    -> World
-moveBy n v = over (creatures . ix n . crPos) (+.+ v)
-
 startReloadingWeapon 
     :: Int      -- ^ Creature id
     -> World 
@@ -212,7 +42,6 @@ startReloadingWeapon cid w =
             | lA < maxA && rS == 0 -> Just $ set ( itRef . wpLoadedAmmo) maxA
                                             $ set ( itRef . wpReloadState) rT w
         _                          -> Nothing
-
 {- | Start reloading if clip is empty. -}
 crAutoReload :: Creature -> Creature
 crAutoReload cr = case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of
@@ -223,7 +52,6 @@ crAutoReload cr = case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of
   where 
     reloadT = cr ^? crInv . ix (_crInvSel cr) . wpReloadTime
     maxA    = cr ^? crInv . ix (_crInvSel cr) . wpMaxAmmo
-
 {- | Teleport a creature to the mouse position -}
 blinkAction 
     :: Int      -- ^ Creature id
@@ -256,18 +84,6 @@ moveAmountToward
 moveAmountToward p1 am p2
     = p1 +.+ am *.* errorNormalizeV 44 (p2 -.- p1)
 
-reverseDir 
-    :: Int      -- ^ Creature id
-    -> World 
-    -> World
-reverseDir n = over (creatures . ix n . crDir) (+ pi)
-
-turnBy 
-    :: Float    -- ^ Angle change
-    -> Int      -- ^ Creature id
-    -> World 
-    -> World
-turnBy a n = over (creatures . ix n . crDir) (+ a)
 {- | Get your creature to drop the item under the cursor.  -}
 youDropItem :: World -> World
 youDropItem w = case yourItem w of
@@ -317,56 +133,4 @@ pickUpItem cid flit w = case maybeInvSlot of
     updateItLocation invid w' = case _itID it of 
         Nothing -> w'
         Just j  -> w' & itemPositions . ix j .~ InInv 0 invid
-{- | Creature attempts to moves under its own steam.
-The idea is that this may or may not work, depending on the status of the creature. 
-For now, though, this cannot fail. -}
-crMvBy 
-    :: Point2   -- ^ Movement translation vector
-    -> Creature 
-    -> Creature
-crMvBy p' cr = advanceStepCounter (magV p) $ over crPos (+.+ p) cr
-  where 
-    p =  (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p'
-    equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
-    aimingFactor 
-        | _posture (_crStance cr) == Aiming = fromMaybe 1 $ it ^? itAimingSpeed
-        | otherwise = 1
-    it = _crInv cr IM.! _crInvSel cr
-
-crMvForward 
-    :: Float    -- ^ Speed
-    -> Creature 
-    -> Creature
-crMvForward speed = crMvBy (speed,0)
-
-advanceStepCounter
-    :: Float    -- ^ Speed
-    -> Creature 
-    -> Creature
-advanceStepCounter speed = crStance . carriage %~ f
-  where 
-    f w@Walking{} = w{_stepToAdd = ceiling speed}
-    f s = s
-
-creatureTurn :: Float -> Creature -> Creature
-creatureTurn a = crDir +~ a
-
-creatureTurnTo :: Point2 -> Creature -> Creature
-creatureTurnTo p cr 
-    | vToTarg == (0,0)  = cr -- this should deal with the angleVV error
-    | otherwise         = cr & crDir .~ dirToTarget
-  where
-    vToTarg = p -.- _crPos cr
-    dirToTarget = argV vToTarg
-
-creatureTurnToward :: Point2 -> Float -> Creature -> Creature
-creatureTurnToward p turnSpeed cr 
-    | vToTarg == (0,0) = cr -- this should deal with the angleVV error
-    | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
-                                        = cr & crDir .~ dirToTarget
-    | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed
-    | otherwise                         = cr & crDir -~ turnSpeed
-  where
-    vToTarg = p -.- _crPos cr
-    dirToTarget = argV vToTarg
 

src/Dodge/Creature/Action/Movement.hs

@@ -1,22 +1,73 @@
 module Dodge.Creature.Action.Movement
     where
 import Dodge.Data
+import Dodge.Creature.Stance.Data
 import Geometry
 
+import Data.Maybe
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
-strafeTo :: Float -> Point2 -> Int -> World -> World
+{- | Creature attempts to moves under its own steam.
-strafeTo speed targPos cid w = over (creatures . ix cid . crPos) (+.+ q) w
+The idea is that this may or may not work, depending on the status of the creature. 
-    where q =  (*.*) (speed * equipFactor * wpFactor) 
+For now, though, this cannot fail. -}
-                      $ safeNormalizeV $ targPos -.- _crPos cr
+crMvBy 
-          equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid
+    :: Point2   -- ^ Movement translation vector
-          cr = _creatures w IM.! cid
+    -> Creature 
-          wpFactor = _itAimingSpeed (_crInv cr IM.! _crInvSel cr)
+    -> Creature
+crMvBy p' cr = advanceStepCounter (magV p) $ over crPos (+.+ p) cr
+  where 
+    p =  (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p'
+    equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
+    aimingFactor 
+        | _posture (_crStance cr) == Aiming = fromMaybe 1 $ it ^? itAimingSpeed
+        | otherwise = 1
+    it = _crInv cr IM.! _crInvSel cr
 
-{- Determine the speed modifier of an item. -}
+crMvForward 
+    :: Float    -- ^ Speed
+    -> Creature 
+    -> Creature
+crMvForward speed = crMvBy (speed,0)
+
+advanceStepCounter
+    :: Float    -- ^ Speed
+    -> Creature 
+    -> Creature
+advanceStepCounter speed = crStance . carriage %~ f
+  where 
+    f w@Walking{} = w{_stepToAdd = ceiling speed}
+    f s = s
+
+creatureTurn :: Float -> Creature -> Creature
+creatureTurn a = crDir +~ a
+
+creatureTurnTo :: Point2 -> Creature -> Creature
+creatureTurnTo p cr 
+    | vToTarg == (0,0)  = cr -- this should deal with the angleVV error
+    | otherwise         = cr & crDir .~ dirToTarget
+  where
+    vToTarg = p -.- _crPos cr
+    dirToTarget = argV vToTarg
+
+creatureTurnToward :: Point2 -> Float -> Creature -> Creature
+creatureTurnToward p turnSpeed cr 
+    | vToTarg == (0,0) = cr -- this should deal with the angleVV error
+    | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
+                                        = cr & crDir .~ dirToTarget
+    | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed
+    | otherwise                         = cr & crDir -~ turnSpeed
+  where
+    vToTarg = p -.- _crPos cr
+    dirToTarget = argV vToTarg
+
+{- | Speed modifier of an item when not aiming. -}
 equipSpeed :: Item -> Float
-equipSpeed NoItem = 1
+equipSpeed _ = 1
-equipSpeed it | _itIdentity it == FrontArmour = 0.75
+{- | Speed modifier of an item when aiming. -}
+equipAimSpeed :: Item -> Float
+equipAimSpeed NoItem = 1
+equipAimSpeed it 
+    | _itIdentity it == FrontArmour = 0.75
     | _itIdentity it == FlameShield = 0.75
     | otherwise                     = 1

src/Dodge/Creature/ArmourChase.hs

@@ -3,6 +3,7 @@ module Dodge.Creature.ArmourChase
 import Dodge.Data
 import Dodge.Default
 import Dodge.Creature.State
+import Dodge.Creature.State.Data
 import Dodge.Creature.Rationality
 import Dodge.Creature.ReaderUpdate
 import Dodge.Creature.AlertLevel
@@ -32,4 +33,5 @@ armourChaseCrit = defaultCreature
         [(0,frontArmour)
         ,(1,medkit 200)
         ]
+    , _crGroup = ShieldGroup
     }

src/Dodge/Creature/State/Data.hs

@@ -40,5 +40,6 @@ data CrGroup
         , _crGroupID :: Int
         }
     | CrGroupID { _crGroupID :: Int }
+    | ShieldGroup
 makeLenses ''CreatureState
 makeLenses ''CrSpState

src/Dodge/Default.hs

@@ -105,7 +105,7 @@ defaultState = CrSt
     { _crDamage = []
     , _crPastDamage = []
     , _crSpState = GenCr
-    , _crDropsOnDeath = DropAmount 1
+    , _crDropsOnDeath = DropAll
     }
 defaultEquipment :: Item
 defaultEquipment = Equipment

src/Dodge/Floor.hs

@@ -8,7 +8,7 @@ module Dodge.Floor
 import Dodge.Data
 --import Dodge.Room
 import Dodge.Creature.State.Data
-import Dodge.Creature.SwarmCrit
+--import Dodge.Creature.SwarmCrit
 import Dodge.Room.Procedural
 import Dodge.Room.RoadBlock
 import Dodge.Room.Data
@@ -31,7 +31,7 @@ import Dodge.Creature
 --import Dodge.RandomHelp
 --import Dodge.LightSources
 import Dodge.LevelGen.Data
-import Dodge.LevelGen.SwarmPlacement
+--import Dodge.LevelGen.SwarmPlacement
 import Dodge.Item.Weapon
 
 --import Data.Tree
@@ -52,12 +52,14 @@ roomTreex = do
             ,[Corridor]
             ,[Corridor]
             ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
-                & rmPS %~ ([sPS (0,50) 0 $ PutCrit armourChaseCrit ]++)
+                & rmPS %~ ([sPS (0,50) 0 $ PutCrit armourChaseCrit 
-             ]
+                            ,sPS (50,25) 0 $ PutCrit armourChaseCrit 
-            ,[Corridor]
+                            ]++)
-            ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
-                & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
              ]
+            --,[Corridor]
+            --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
+            --    & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
+            -- ]
             ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
                 & rmPS %~ ([sPS (0,50) 0 $ PutCrit pistolCrit ]++)
              ]
@@ -90,5 +92,8 @@ roomTreex = do
             t'
     shiftExpandTree . expandTreeBy id <$> mapM annoToRoomTree t
 
+--swarmTestRoom :: 
+
+
 levx :: RandomGen g => State g [Room]
 levx = untilJust roomTreex

src/Dodge/Item/Equipment.hs

@@ -16,7 +16,7 @@ magShield = defaultEquipment
     , _itEquipPict = \_ _ -> blank
     , _itID = Nothing
     }
-flameShield, frontArmour :: Item
+flameShield :: Item 
 flameShield = defaultEquipment
     { _itIdentity = FlameShield
     , _itName = "FLAMESHIELD"
@@ -26,8 +26,8 @@ flameShield = defaultEquipment
     , _itEquipPict = \cr _ -> onLayer CrLayer $ pictures [color cyan $ circle (_crRad cr+2)]
     , _itID = Nothing
     }
-{- |
+{- | Slows you down, blocks forward projectiles. -}
-Slows you down, blocks forward projectiles. -}
+frontArmour :: Item
 frontArmour = defaultEquipment
     { _itIdentity = FrontArmour
     , _itName = "FARMOUR"
@@ -44,8 +44,7 @@ frontArmour = defaultEquipment
     , _itEffect = NoItEffect
     , _itID = Nothing
     }
-{- |
+{- | Increases speed, reduces friction, cannot only move forwards. -}
-Increases speed, reduces friction, cannot only move forwards. -}
 jetPack :: Item
 jetPack = defaultEquipment
     { _itIdentity = JetPack