diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 66cb84c72..e3b241eb4 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -261,8 +261,7 @@ Items you start with. -} startInventory = IM.fromList (zip [0..20] ( - [ - --[pistol + [launcher --,blinkGun --,spawnGun lamp --,poisonSprayer diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs new file mode 100644 index 000000000..b9c6b4331 --- /dev/null +++ b/src/Dodge/Creature/State.hs @@ -0,0 +1,247 @@ +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.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 = let (cr', g'') = updateMovement g cr + in case u w (f,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 + +{- +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 (_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, 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 . 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 diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 6cbfd01ba..020ae8463 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -36,6 +36,9 @@ roomTreex = do let t' = padCorridors struct t = treeTrunk [[StartRoom] + ,[Corridor] + ,[BossAno launcherCrit] + ,[Corridor] ,[OrAno [[DoorAno] ,[Corridor] ,[DoorNumAno 0,AirlockAno]] diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 68c7b3069..3ebcf8fe7 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -334,17 +334,17 @@ launcher = defaultGun } flameLauncher = launcher { _itName = "FLROCKO" - , _wpFire = shoot $ aRocket' makeFlameShellAt + , _wpFire = shoot . aRocket' $ makeShellAt makeFlameExplosionAt } poisonLauncher = launcher { _itName = "POISROCK" - , _wpFire = shoot $ aRocket' makePoisonShellAt + , _wpFire = shoot . aRocket' $ makeShellAt makePoisonExplosionAt } teslaLauncher = launcher { _itName = "TESLROCK" - , _wpFire = shoot $ aRocket' makeTeslaShellAt + , _wpFire = shoot . aRocket' $ makeShellAt makeTeslaExplosionAt } bezierGun = defaultAutoGun @@ -712,7 +712,7 @@ aTractorBeam col cid w dir = _crDir cr itRef = _crInvSel cr --- |The aRocket' function allows us to define the shell to be used +-- | The aRocket' function allows us to define the shell to be used aRocket' :: (Int -> Int -> Point2 -> Float -> Projectile) -> Int -> World -> World aRocket' shell cid w = soundOnce (fromIntegral launcherSound) @@ -723,70 +723,36 @@ aRocket' shell cid w dir = _crDir cr aRocket :: Int -> World -> World -aRocket = aRocket' makeShellAt --- = soundOnce (fromIntegral launcherSound) --- $ over projectiles (IM.insert i (makeShellAt i cid pos dir)) w --- where i = newProjectileKey w --- cr = (_creatures w IM.! cid) --- pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir) --- dir = _crDir cr +aRocket = aRocket' (makeShellAt shellExplosionAt) -makeShellAt :: Int -> Int -> Point2 -> Float -> Projectile -makeShellAt i cid pos dir = Shell +makeShellAt + :: (Point2 -> World -> World) -- ^ Payload + -> Int -- ^ Projectile id + -> Int -- ^ Creature id + -> Point2 -- ^ Start position + -> Float -- ^ Direction + -> Projectile +makeShellAt pl i cid pos dir = Shell { _pjPos = pos , _pjStartPos = pos , _pjVel = rotateV dir (1,0) , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic , _pjID = i - , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) - , _pjPayload = shellExplosionAt - } - -makeFlameShellAt :: Int -> Int -> Point2 -> Float -> Projectile -makeFlameShellAt i cid pos dir = Shell - { _pjPos = pos - , _pjStartPos = pos - , _pjVel = rotateV dir (1,0) - , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic - , _pjID = i - , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) - , _pjPayload = makeFlameExplosionAt - } - -makePoisonShellAt :: Int -> Int -> Point2 -> Float -> Projectile -makePoisonShellAt i cid pos dir = Shell - { _pjPos = pos - , _pjStartPos = pos - , _pjVel = rotateV dir (1,0) - , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic - , _pjID = i - , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) - , _pjPayload = makePoisonExplosionAt - } - -makeTeslaShellAt :: Int -> Int -> Point2 -> Float -> Projectile -makeTeslaShellAt i cid pos dir = Shell - { _pjPos = pos - , _pjStartPos = pos - , _pjVel = rotateV dir (1,0) - , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic - , _pjID = i - , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) - , _pjPayload = makeTeslaExplosionAt + , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (3,0)) + , _pjPayload = pl } moveShell :: Int -> Int -> Int -> Float -> Point2 -> World -> World moveShell time i cid rot accel w | time > 40 = if circOnSomeWall oldPos 4 w - then projectileExplosion oldPos $ over projectiles (IM.delete i) w + then doExplode else over (projectiles . ix i . pjPos) (+.+ vel) $ set (projectiles . ix i . pjPict) piclow $ set (projectiles . ix i . pjUpdate) (moveShell (time-1) i cid rot (rotateV rot accel)) w | time == 35 = case thingHit of - Just p -> projectileExplosion oldPos - $ over projectiles (IM.delete i) w + Just p -> doExplode Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) $ set (projectiles . ix i . pjPict) pic $ set (projectiles . ix i . pjUpdate) @@ -801,9 +767,7 @@ moveShell time i cid rot accel w (moveShell (time-1) i cid rot (rotateV rot accel)) w | time > -99 = case thingHit of - Just p -> projectileExplosion oldPos - $ stopSoundFrom (ShellSound i) - $ over projectiles (IM.delete i) w + Just p -> doExplode Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) $ set randGen g $ set (projectiles . ix i . pjPict) pic @@ -816,18 +780,17 @@ moveShell time i cid rot accel w $ smokeGen w | time > -200 = case thingHit of - Just p -> projectileExplosion oldPos - $ stopSoundFrom (ShellSound i) - $ over projectiles (IM.delete i) w + Just p -> doExplode Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) $ set (projectiles . ix i . pjPict) pic $ set (projectiles . ix i . pjUpdate) (moveShell (time-1) i cid rot (rotateV rot accel)) w - | otherwise = projectileExplosion oldPos - $ stopSoundFrom (ShellSound i) - $ over projectiles (IM.delete i) w + | otherwise = doExplode where + doExplode = projectileExplosion oldPos + $ stopSoundFrom (ShellSound i) + $ over projectiles (IM.delete i) w pj = _projectiles w IM.! i oldPos = _pjPos pj vel = _pjVel pj @@ -843,7 +806,7 @@ moveShell time i cid rot accel w hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w thingHit = hitCr <|> hitWl spin = case w ^? creatures . ix cid of - Just cr -> min 0.1 $ max (-0.1) + Just cr -> min 0.2 $ max (-0.2) $ (normalizeAnglePi (dir - _crDir cr)) / 20 _ -> 0 r1 = _randGen w & evalState (randInCirc 10) diff --git a/src/Dodge/Layout/Tree/Annotate.hs b/src/Dodge/Layout/Tree/Annotate.hs index e50d96f00..e147f410e 100644 --- a/src/Dodge/Layout/Tree/Annotate.hs +++ b/src/Dodge/Layout/Tree/Annotate.hs @@ -3,15 +3,16 @@ Annotating tree structures with desired properties for rooms. -} module Dodge.Layout.Tree.Annotate where +import Dodge.Data import Dodge.RandomHelp import Dodge.Layout.Tree.Polymorphic import Dodge.Layout.Tree.Either import Dodge.Room.Procedural +import Dodge.Room.Boss import Dodge.Room.Link import Dodge.Room.Data import Dodge.Room import Dodge.Room.Teleport ---import Dodge.Floor import Data.Tree import Control.Monad.State @@ -30,6 +31,7 @@ data Annotation g | EndRoom | OrAno [[Annotation g]] | SpecificRoom (State g (Tree (Either Room Room))) + | BossAno Creature addLock :: RandomGen g => Int -> Tree [Annotation g] -> State g (Tree [Annotation g]) addLock i t = do @@ -68,6 +70,7 @@ annoToRoomTree [StartRoom] = do h <- state $ randomR (200,400) fmap (pure . Right) $ randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h) annoToRoomTree (SpecificRoom rt:_) = rt +annoToRoomTree (BossAno cr : _) = branchRectWith . fmap (pure . Left) $ bossRoom cr annoToRoomTree _ = do w <- state $ randomR (100,400) h <- state $ randomR (200,400) diff --git a/src/Dodge/Room/Boss.hs b/src/Dodge/Room/Boss.hs new file mode 100644 index 000000000..a11c3743e --- /dev/null +++ b/src/Dodge/Room/Boss.hs @@ -0,0 +1,40 @@ +{- +Rooms containing particularly challenging creatures. +-} +module Dodge.Room.Boss + where +import Dodge.Data +import Dodge.Room.Data +import Dodge.Room.Placement +import Dodge.LevelGen.Data +import Geometry + +import Control.Monad.State +import Control.Lens +import System.Random +roomOctogon + :: Float -- ^ Size + -> Room +roomOctogon x = Room + { _rmPolys = [rectNSWE x (-x) (-x) x + ,rectNSWE 0 (-(x + 40)) (-20) 20 + ] + , _rmLinks = [((0,x),0),((0,-(x+40)),pi)] + , _rmPath = [((0,x),(0,-(x+40))) + ,((0,-(x+40)),(0,x))] + , _rmPS = + [PS (x-10,x-10) 0 $ putLamp + ,PS (10-x,x-10) 0 $ putLamp + ,PS (10-x,10-x) 0 $ putLamp + ,PS (x-10,10-x) 0 $ putLamp + ,crystalLine (-x,x/2) (negate (x/2), x) + ,crystalLine (x,x/2) (x/2, x) + ,crystalLine (x/2,-x) (x,negate (x/2)) + ,crystalLine (negate $ x/2,-x) (-x,negate (x/2)) + ,blockLine (-40,40-x) (40,40-x) + ] + , _rmBound = rectNSWE x (-x) (-x) x + } + +bossRoom :: RandomGen g => Creature -> State g Room +bossRoom cr = pure $ roomOctogon 300 & rmPS %~ ( PS (0,100) (pi/2) (PutCrit cr) :) diff --git a/src/Dodge/Room/Placement.hs b/src/Dodge/Room/Placement.hs index 980360263..0f6f75896 100644 --- a/src/Dodge/Room/Placement.hs +++ b/src/Dodge/Room/Placement.hs @@ -15,6 +15,10 @@ singleBlock :: Point2 -> [PlacementSpot] singleBlock a = [PS a 0 $ PutBlock [5,20,20] (greyN 0.5) $ reverse $ rectNSWE 10 (-10) (-10) 10] +{- +Places a line of blocks between two points. +Width 9, also extends out from each point by 9. + -} blockLine :: Point2 -> Point2 -> PlacementSpot blockLine a b = PS { _psPos = (0,0) @@ -22,6 +26,10 @@ blockLine a b = PS , _psType = PutLineBlock baseBlockPane 9 9 a b } +{- +Places an breakable window between two points. +Width 8, also extends out from each point by 8. + -} windowLine :: Point2 -> Point2 -> PlacementSpot windowLine a b = PS { _psPos = (0,0) @@ -29,6 +37,26 @@ windowLine a b = PS , _psType = PutLineBlock baseWindowPane 8 8 a b } +{- +Places an unbreakable window between two points. +Width 7, also extends out from each point by 7. + -} +crystalLine :: Point2 -> Point2 -> PlacementSpot +crystalLine a b = PS + { _psPos = (0,0) + , _psRot = 0 + , _psType = PutWindow ps $ withAlpha 0.5 aquamarine + } + where + ps = + [ a +.+ left +.+ up + , (a +.+ left) -.- up + , (b -.- left) -.- up + , (b -.- left) +.+ up + ] + left = 7 *.* normalizeV (a-.-b) + up = vNormal left + windowLineType :: Point2 -> Point2 -> PSType windowLineType a b = PutLineBlock baseWindowPane 8 8 a b