module Dodge.Creature.State where import Dodge.Data import Dodge.Base import Dodge.SoundLogic import Dodge.RandomHelp import Dodge.WorldEvent import Dodge.WallCreatureCollisions import Dodge.Creature.Action 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 = let (cr', g'') = updateMovement g cr in case u w (f,g'') cr' of ((f',g') , maybeCr) -> ( (invSideEff cr . movementSideEff cr . deathEff . f' , g') , fmap (updateReloadCounter . reducePastDamage . doDamage) $ crOrCorpse =<< maybeCr ) where crOrCorpse cr | cr ^. crHP > 0 = Just cr | otherwise = Nothing deathEff | cr ^.crHP > 0 = id | otherwise = stopSoundFrom (CrWeaponSound (_crID cr)) . over decorations addCorpse . dropByState cr crBeforeDeath = colCrWall w $ cr addCorpse = insertNewKey $ uncurry translate (_crOldPos cr) $ rotate (_crDir cr) (_crCorpse cr) -- | Drop items according to the creature state. dropByState :: Creature -> World -> World dropByState cr w = foldr (copyItemToFloor cr) w is where is :: [Int] is = case cr ^. crState . crDropsOnDeath of DropAll -> IM.keys $ _crInv cr DropSpecific xs -> xs DropAmount n -> take n $ evalState (shuffle $ IM.keys $ _crInv cr) (_randGen w) setOldPos :: Creature -> Creature setOldPos cr = set crOldPos (_crPos cr) cr {- Given a creature and a velocity, applies friction to that creature and evaluates a velocity to carry across frames. -} crFriction :: Creature -> Point2 -> Point2 crFriction cr vel = (0,0) doDamage :: Creature -> Creature doDamage cr = set (crState . crDamage) [] $ over (crState . crPastDamage) (+ hpLost) damagedCr where dams = _crDamage $ _crState cr startHP = _crHP cr damagedCr = snd $ (_crApplyDamage 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, StdGen) updateMovement g cr | isFrictionless cr = (over crPos (+.+ momentum) $ setOldPos cr, g') | otherwise = case cr ^? crState . stance . carriage of Just (Walking x y) -> (set (crState . stance . carriage) (Walking ((x+y)`mod`120) 0) $ setOldPos cr, g) _ -> (set (crState . stance . carriage) (Walking 0 0) $ setOldPos cr, g) where momentum' = 0.98 *.* (_crPos cr -.- _crOldPos cr) momentum'' | magV momentum' > 1 = 1 *.* normalizeV momentum' | otherwise = momentum' momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng (randAng,g') = 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 . itUseTime) decreaseToZero . over (crInv . ix iSel . wpReloadState) decreaseToZero $ cr where iSel = _crInvSel cr decreaseToZero :: Int -> Int decreaseToZero x | x > 0 = x - 1 | otherwise = 0 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