From 322894c5134af8a099e3a9e5b7abc65d40501b17 Mon Sep 17 00:00:00 2001 From: jgk Date: Fri, 21 May 2021 14:20:45 +0200 Subject: [PATCH] Remove duplicated creature movement code --- package.yaml | 7 +- src/Dodge/Creature/Action.hs | 236 -------------------------- src/Dodge/Creature/Action/Movement.hs | 75 ++++++-- src/Dodge/Creature/ArmourChase.hs | 2 + src/Dodge/Creature/State/Data.hs | 1 + src/Dodge/Default.hs | 2 +- src/Dodge/Floor.hs | 19 ++- src/Dodge/Item/Equipment.hs | 9 +- 8 files changed, 87 insertions(+), 264 deletions(-) diff --git a/package.yaml b/package.yaml index 4fcc6adff..414eae508 100644 --- a/package.yaml +++ b/package.yaml @@ -11,8 +11,8 @@ extra-source-files: - ChangeLog.md # Metadata used when publishing your package -# synopsis: Short description of your package -# category: Web +# synopsis: A basic game loop +# 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: diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index ae280c3be..3e4c66d26 100644 --- a/src/Dodge/Creature/Action.hs +++ b/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 diff --git a/src/Dodge/Creature/Action/Movement.hs b/src/Dodge/Creature/Action/Movement.hs index 9aa5276d4..373c0a26d 100644 --- a/src/Dodge/Creature/Action/Movement.hs +++ b/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 -strafeTo speed targPos cid w = over (creatures . ix cid . crPos) (+.+ q) w - where q = (*.*) (speed * equipFactor * wpFactor) - $ safeNormalizeV $ targPos -.- _crPos cr - equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid - cr = _creatures w IM.! cid - wpFactor = _itAimingSpeed (_crInv cr IM.! _crInvSel cr) +{- | 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 -{- 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 it | _itIdentity it == FrontArmour = 0.75 - | _itIdentity it == FlameShield = 0.75 - | otherwise = 1 +equipSpeed _ = 1 +{- | 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 diff --git a/src/Dodge/Creature/ArmourChase.hs b/src/Dodge/Creature/ArmourChase.hs index 06c11268e..62095140f 100644 --- a/src/Dodge/Creature/ArmourChase.hs +++ b/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 } diff --git a/src/Dodge/Creature/State/Data.hs b/src/Dodge/Creature/State/Data.hs index 3c77978da..8fff1514c 100644 --- a/src/Dodge/Creature/State/Data.hs +++ b/src/Dodge/Creature/State/Data.hs @@ -40,5 +40,6 @@ data CrGroup , _crGroupID :: Int } | CrGroupID { _crGroupID :: Int } + | ShieldGroup makeLenses ''CreatureState makeLenses ''CrSpState diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index f1ccf3291..6ab25ddd0 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -105,7 +105,7 @@ defaultState = CrSt { _crDamage = [] , _crPastDamage = [] , _crSpState = GenCr - , _crDropsOnDeath = DropAmount 1 + , _crDropsOnDeath = DropAll } defaultEquipment :: Item defaultEquipment = Equipment diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 14d236cdf..5d6d6a35b 100644 --- a/src/Dodge/Floor.hs +++ b/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 ]++) - ] - ,[Corridor] - ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 - & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) + & 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] ]++) + -- ] ,[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 diff --git a/src/Dodge/Item/Equipment.hs b/src/Dodge/Item/Equipment.hs index f0e9609dd..5a86be324 100644 --- a/src/Dodge/Item/Equipment.hs +++ b/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