justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Remove duplicated creature movement code

Browse Source
This commit is contained in:
jgk
2021-05-21 14:20:45 +02:00
parent 114335fdbe
commit 322894c513
8 changed files with 87 additions and 264 deletions
Download Patch File Download Diff File Expand all files Collapse all files
package.yaml
+4 -3
View File
@@ -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:
src/Dodge/Creature/Action.hs
-236
View File
@@ -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
+63 -12
View File
@@ -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
src/Dodge/Creature/ArmourChase.hs
+2
View File
@@ -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
+1
View File
@@ -40,5 +40,6 @@ data CrGroup
, _crGroupID :: Int
}
| CrGroupID { _crGroupID :: Int }
| ShieldGroup
makeLenses ''CreatureState
makeLenses ''CrSpState
src/Dodge/Default.hs
+1 -1
View File
@@ -105,7 +105,7 @@ defaultState = CrSt
{ _crDamage = []
, _crPastDamage = []
, _crSpState = GenCr
, _crDropsOnDeath = DropAmount 1
, _crDropsOnDeath = DropAll
}
defaultEquipment :: Item
defaultEquipment = Equipment
src/Dodge/Floor.hs
+12 -7
View File
@@ -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
src/Dodge/Item/Equipment.hs
+4 -5
View File
@@ -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