246 lines
10 KiB
Haskell
246 lines
10 KiB
Haskell
module Dodge.CreatureState where
|
|
-- imports {{{
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Dodge.SoundLogic
|
|
import Dodge.RandomHelp
|
|
import Dodge.WorldEvent
|
|
import Dodge.WallCreatureCollisions
|
|
import Dodge.CreatureAction
|
|
|
|
import Geometry
|
|
import Picture
|
|
|
|
import Data.List
|
|
import Data.Char
|
|
import Data.Maybe
|
|
import Data.Function
|
|
import Data.Graph.Inductive.Graph
|
|
import Data.Graph.Inductive.PatriciaTree
|
|
import Data.Graph.Inductive.Query.SP
|
|
import Codec.BMP
|
|
import qualified Data.ByteString as B
|
|
import Control.Lens
|
|
import Control.Applicative
|
|
import Control.Monad.State
|
|
import Control.Monad
|
|
import qualified SDL as SDL
|
|
import qualified SDL.Mixer as Mix
|
|
import System.Random
|
|
import qualified Data.Set as S
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.Map as M
|
|
|
|
import Foreign.ForeignPtr
|
|
import Control.Concurrent
|
|
---}
|
|
|
|
type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
|
|
|
|
-- the movement is updated before the ai in order to correctly set the oldpos
|
|
-- the whole of this update cycle could do with a rethink, it is becoming
|
|
-- convoluted
|
|
stateUpdate :: CRUpdate -> CRUpdate
|
|
stateUpdate u w (f,g) cr = case u w (f,g) (updateMovement g cr) of
|
|
((f',g') , maybeCr) -> ( (invSideEff cr . movementSideEff cr . dropifdead . f'
|
|
, g')
|
|
, fmap (updateReloadCounter . reducePastDamage . doDamage)
|
|
$ crOrCorpse =<< maybeCr
|
|
)
|
|
where
|
|
crOrCorpse cr | cr ^. crHP > 0 = Just cr
|
|
| otherwise = Nothing
|
|
dropifdead | cr ^.crHP > 0 = id
|
|
| otherwise = stopSoundFrom (CrWeaponSound (_crID cr))
|
|
. over decorations addCorpse
|
|
. insertIt
|
|
crBeforeDeath = colCrWall w $ cr
|
|
addCorpse = insertNewKey $ uncurry translate (_crOldPos cr)
|
|
$ rotate (_crDir cr)
|
|
(_crCorpse cr)
|
|
maybeIt = evalState (maybeTakeOne $ IM.elems (_crInv cr)) (_randGen w)
|
|
insertIt = case maybeIt of
|
|
-- Just it -> createItemAt (offset +.+ _crPos crBeforeDeath)
|
|
Just it -> createItemAt (offset +.+ _crOldPos cr)
|
|
(FlIt {_flIt=it,_flItPos=(0,0),_flItRot=rot,_flItID=0})
|
|
Nothing -> id
|
|
offset = _crRad cr *.* unitVectorAtAngle rot
|
|
(rot,_) = randomR (-pi,pi) g
|
|
|
|
|
|
setOldPos :: Creature -> Creature
|
|
setOldPos cr = set crOldPos (_crPos cr) cr
|
|
|
|
doDamage :: Creature -> Creature
|
|
doDamage cr = set (crState . crDamage) [] $ over (crState . crPastDamage) (+ hpLost)
|
|
damagedCr
|
|
where dams = _crDamage $ _crState cr
|
|
startHP = _crHP cr
|
|
damagedCr = snd $ (_crApplyDamage (_crState cr)) dams cr
|
|
afterHP = _crHP damagedCr
|
|
hpLost = startHP - afterHP -- note this can be negative
|
|
|
|
sumDamage :: Creature -> DamageType -> Int -> Int
|
|
sumDamage cr dm x = x + _dmAmount dm
|
|
|
|
reducePastDamage :: Creature -> Creature
|
|
reducePastDamage = over (crState . crPastDamage) rdpdam
|
|
where rdpdam x | x > 500 = x - 55
|
|
| x > 200 = x - 25
|
|
| x > 20 = x - 5
|
|
| x > 0 = x - 1
|
|
| otherwise = 0
|
|
|
|
movementSideEff :: Creature -> World -> World
|
|
movementSideEff cr w
|
|
| hasJetPack
|
|
= case cr ^? crState . stance . carriage of
|
|
Just (Boosting v)
|
|
-> makeFlameletTimed
|
|
(oldPos +.+ (_crRad cr + 3) *.* (unitVectorAtAngle $ _crDir cr + pi))
|
|
(momentum +.+ 1 *.* rotateV randDir (vInverse v))
|
|
Nothing
|
|
1
|
|
20
|
|
$ set randGen g
|
|
w
|
|
_ -> w
|
|
| otherwise = case cr ^? crState . stance . carriage of
|
|
Just (Walking x y) -> takeStep x y w
|
|
_ -> w
|
|
where hasJetPack = any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr
|
|
oldPos = _crOldPos cr
|
|
momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr)
|
|
momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum'
|
|
| otherwise = momentum'
|
|
momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng
|
|
(randDir,g) = randomR (-0.5,0.5) $ _randGen w
|
|
(randAng,_) = randomR (0,2*pi) $ _randGen w
|
|
|
|
(v1:v2:v3:_) = fst $ runState ((sequence . repeat . randInCirc) 0.1) $ _randGen w
|
|
(r1:r2:r3:_) = map ((*.*) 100) (v2:v3:v1:[])
|
|
|
|
crHasMoved = dist (_crPos cr) (_crOldPos cr) > 0.5
|
|
takeStep x y | crHasMoved && x < 20 && x + y >= 20 = soundMultiFrom footor 22 3 0
|
|
| crHasMoved && x < 80 && x + y >= 80 = soundMultiFrom footor 23 3 0
|
|
| otherwise = id
|
|
footor = [FootstepSound 0,FootstepSound 1]
|
|
|
|
invSideEff :: Creature -> World -> World
|
|
invSideEff cr w = weaponReloadSounds cr $ IM.foldrWithKey f w (_crInv cr)
|
|
where f i it w' = case it ^? itEffect . itInvEffect of
|
|
Nothing -> w'
|
|
Just g -> g cr i w'
|
|
|
|
weaponReloadSounds :: Creature -> World -> World
|
|
weaponReloadSounds cr w = case _crInv cr IM.!? _crInvSel cr of
|
|
Just (Weapon {_wpReloadState = 0})
|
|
-> w
|
|
Just (Weapon {_wpReloadState = 1})
|
|
-> stopSoundFrom (CrReloadSound cid) w
|
|
Just (Weapon {})
|
|
-> soundFrom (CrReloadSound cid) reloadSound (1) 0 w
|
|
_
|
|
-> w
|
|
where cid = _crID cr
|
|
|
|
updateMovement :: StdGen -> Creature -> Creature
|
|
updateMovement g cr
|
|
| isFrictionless cr = over crPos (+.+ momentum)
|
|
$ setOldPos
|
|
cr
|
|
| otherwise
|
|
= case cr ^? crState . stance . carriage of
|
|
Just (Walking x y)
|
|
-> set (crState . stance . carriage) (Walking ((x+y)`mod`120) 0)
|
|
$ setOldPos
|
|
cr
|
|
_ -> set (crState . stance . carriage) (Walking 0 0)
|
|
$ setOldPos
|
|
cr
|
|
where
|
|
momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr)
|
|
momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum'
|
|
| otherwise = momentum'
|
|
momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng
|
|
(randAng,_) = randomR (0,2*pi) g
|
|
|
|
isFrictionless :: Creature -> Bool
|
|
isFrictionless cr = case cr ^? crState . stance . carriage of
|
|
Just (Boosting _) -> True
|
|
Just (Floating) -> True
|
|
_ -> False
|
|
|
|
updateReloadCounter :: Creature -> Creature
|
|
updateReloadCounter cr = over (crInv . ix iSel . wpFireState) decreaseToZero
|
|
. over (crInv . ix iSel . wpReloadState) decreaseToZero
|
|
$ cr
|
|
where iSel = _crInvSel cr
|
|
|
|
decreaseToZero :: Int -> Int
|
|
decreaseToZero x | x > 0 = x - 1
|
|
| otherwise = 0
|
|
|
|
|
|
--comb :: (StdGen -> Creature -> World -> World) -> (StdGen -> Creature -> Maybe Creature)
|
|
-- -> CRUpdate
|
|
--comb
|
|
|
|
onDeath :: (Creature -> World -> World) -> CRUpdate -> CRUpdate
|
|
onDeath h u w (f,g) cr
|
|
| _crHP cr > 0 = u w (f,g) cr
|
|
| otherwise = ( ( h cr . f, g ) , Nothing )
|
|
|
|
updateBarrel ::
|
|
World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature)
|
|
updateBarrel w (f,g) cr | _crHP cr > 0 = ((f, g), newCr)
|
|
| otherwise = ((f, g), Nothing)
|
|
where damages = _crDamage $ _crState cr
|
|
newCr = Just $ doDamage cr
|
|
|
|
-- it is easy to leave off the "f" here
|
|
-- should find some better way of doing all this that is less prone to error
|
|
updateExpBarrel ::
|
|
World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature)
|
|
updateExpBarrel w (f,g) cr
|
|
| _crHP cr > 0 = ((f . foldr (.) id pierceSparks . hiss, g'), newCr)
|
|
| otherwise = ((f . makeExplosionAt (_crPos cr) . stopSounds , g'), Nothing)
|
|
where damages = _crDamage $ _crState cr
|
|
pierceSparks :: [World -> World]
|
|
pierceSparks
|
|
= zipWith4 (\p a colid time-> (createBarrelSpark time colid (_crPos cr +.+ p) (a + argV p))
|
|
(Just $ _crID cr))
|
|
poss as colids times
|
|
as = randomRs (-0.7,0.7) $ g
|
|
colids = randomRs (0,11) $ g
|
|
times = randomRs (2,5) $ g
|
|
(g',_) = split g
|
|
poss = _piercedPoints $ _crSpState $ _crState cr
|
|
--newCr = Just $ doDamage $ applyFuseDamage cr -- $ foldr perforate cr damages
|
|
newCr = Just $ applyFuseDamage $ set (crState . crDamage) [] $ damToExpBarrel damages cr
|
|
perforate :: DamageType -> Creature -> Creature
|
|
perforate (Piercing amount sp int ep) cr = over (crState . crSpState . piercedPoints)
|
|
((:) $ int -.- _crPos cr) cr
|
|
perforate _ cr = cr
|
|
applyFuseDamage cr = over crHP (\hp -> hp - length (_piercedPoints
|
|
$ _crSpState $ _crState cr))
|
|
cr
|
|
hiss | poss == [] = id
|
|
| otherwise = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1
|
|
stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1)
|
|
|
|
damToExpBarrel :: [DamageType] -> Creature -> Creature
|
|
damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam) otherDam
|
|
where (pierceDam,otherDam) = partition isPierce ds
|
|
isPierce (Piercing {}) = True
|
|
isPierce _ = False
|
|
|
|
damToExpBarrel' :: DamageType -> Creature -> Creature
|
|
damToExpBarrel' (Piercing amount sp int ep) cr
|
|
= over (crState . crSpState . piercedPoints) ((:) $ int -.- _crPos cr)
|
|
$ over crHP (\hp -> hp - div amount 200) cr
|
|
damToExpBarrel' (PoisonDam {}) cr = cr
|
|
damToExpBarrel' (SparkDam {}) cr = cr
|
|
damToExpBarrel' (PushDam {_dmPushBack = v}) cr = cr Control.Lens.& crPos %~ (+.+) (1 / _crMass cr *.* v)
|
|
damToExpBarrel' dt cr = cr Control.Lens.& crHP -~ _dmAmount dt
|