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

Make many death events just leave corpses (no gore)

Browse Source
This commit is contained in:
justin
2022-06-04 17:55:24 +01:00
parent 582881ca66
commit 62ccf8fad3
5 changed files with 84 additions and 8 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Color.hs
+15
View File
@@ -61,6 +61,12 @@ paletteToColor pc = case pc of
WHITE -> white
BLACK -> black
normalizeColor :: Color -> Color
{-# INLINE normalizeColor #-}
normalizeColor (V4 r g b a) = V4 (f r) (f g) (f b) (f a)
where
f = min 1 . max 0
mixColors :: Float -> Float -> Color -> Color -> Color
{-# INLINE mixColors #-}
mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) =
@@ -70,6 +76,15 @@ mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) =
f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int)
in V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2)
mixColorsLinear :: Float -> Float -> Color -> Color -> Color
{-# INLINE mixColorsLinear #-}
mixColorsLinear rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) =
let fullrat = rata + ratb
normrata = rata / fullrat
normratb = ratb / fullrat
f x y = normrata * x + normratb * y
in V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2)
light :: Color -> Color
{-# INLINE light #-}
light (V4 r g b a) = V4 (r+0.2) (g+0.2) (b+0.2) a
src/Dodge/Creature/State.hs
+24 -4
View File
@@ -3,6 +3,7 @@ module Dodge.Creature.State
, doDamage
) where
import Dodge.Data
import Dodge.Damage
import Dodge.Hammer
import Dodge.Reloading
import Dodge.Prop.Gib
@@ -19,9 +20,11 @@ import Dodge.Creature.Action
--import Dodge.Hammer
import Geometry
import Picture
import Shape
import ShapePicture
import qualified IntMapHelp as IM
--import StrictHelp
import FoldableHelp
--import FoldableHelp
--import qualified Data.IntSet as IS
@@ -82,12 +85,15 @@ checkDeath cr w
. (creatures . ix (_crID cr) . crPict .~ const mempty)
| otherwise = creatures . at (_crID cr) .~ Nothing
corpseOrGib :: Creature -> World -> World
corpseOrGib cr w
| _crPastDamage cr > 200 = w & addCrGibs cr
corpseOrGib cr w = case maxDamageType (_crDamage (_crState cr)) of
Just (FLAMING,_) -> w & plNew corpses cpID (thecorpse & cpPict %~ fmap scorchSPic)
Just (ELECTRICAL,_) -> w & plNew corpses cpID thecorpse
Just (POISONDAM,_) -> w & plNew corpses cpID (thecorpse & cpPict %~ fmap poisonSPic)
_ | _crPastDamage cr > 200 -> w & addCrGibs cr
& bloodPuddleAt cpos
& bloodPuddleAt cpos
& bloodPuddleAt cpos
| otherwise = w
_ -> w
& bloodPuddleAt cpos
& bloodPuddleAt cpos
& plNew corpses cpID thecorpse
@@ -101,6 +107,20 @@ corpseOrGib cr w
, _cpRes = Nothing
}
scorchSPic :: SPic -> SPic
scorchSPic = over _1 $
overColSH (mixColors 0.9 0.1 black . normalizeColor)
poisonSPic :: SPic -> SPic
poisonSPic = over _1 $
overColSH (mixColors 0.5 0.5 green . normalizeColor)
--scorchSPic :: World -> SPic -> SPic
--scorchSPic w sp = evalState (scorchSPic' sp) (_randGen w)
--
--scorchSPic' :: SPic -> State StdGen SPic
--scorchSPic' = _1 $ overColSHM $ \col -> takeOne [col,black]
---- (return . mixColorsLinear 0.9 0.1 black)
bloodPuddleAt :: Point2 -> World -> World
bloodPuddleAt p w = w
src/Dodge/Damage.hs
+10
View File
@@ -5,6 +5,8 @@ import FoldableHelp
import Geometry.Vector
import LensHelp
import qualified Data.Map.Strict as M
damageCrWall :: Damage -> Either Creature Wall -> World -> World
damageCrWall dt (Left cr) = creatures . ix (_crID cr) . crState . crDamage .:~ dt
damageCrWall dt (Right wl) = damageWall dt wl
@@ -13,3 +15,11 @@ damageDirection :: [Damage] -> Maybe Float
damageDirection ds = do
dm <- safeMinimumOn (negate . _dmAmount) ds
safeArgV (_dmTo dm -.- _dmFrom dm)
collectDamageTypes :: [Damage] -> M.Map DamageType Int
collectDamageTypes = foldr f M.empty
where
f dm = M.insertWith (+) (_dmType dm) (_dmAmount dm)
maxDamageType :: [Damage] -> Maybe (DamageType,Int)
maxDamageType = safeMinimumOn (negate . snd) . M.assocs . collectDamageTypes
src/Dodge/Prop/Gib.hs
+21
View File
@@ -82,6 +82,7 @@ addCrGibs cr w = case damageDirection $ _crDamage $ _crState cr of
Just d -> w
& addGibsAtDir d 3 7 (_skinLower skin) cpos
& addGibsAtDir d 13 20 (_skinUpper skin) cpos
& addGibAtDir d 25 (_skinHead skin) cpos
where
skin = _crSkin cr
cpos = _crPos cr
@@ -147,3 +148,23 @@ addGibAt h col p w = w
& pjQuat .~ q
& pjVelZ .~ zs
& pjPosZ .~ h
addGibAtDir :: Float -> Float -> Color -> Point2 -> World -> World
addGibAtDir dir h col p w = w
& plNew props pjID gib
& randGen .~ newg
where
(gib,newg) = runState f $ _randGen w
f = do
s <- state $ randomR (1,4)
zs <- state $ randomR (-8,8)
q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
let v = s *.* unitVectorAtAngle dir
return $ aGib
& pjPos .~ p
& pjColor .~ col
& pjVel .~ v
& pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
& pjQuat .~ q
& pjVelZ .~ zs
& pjPosZ .~ h
src/Shape.hs
+14 -4
View File
@@ -14,6 +14,8 @@ module Shape
, polyCircx
, scaleSH
, colorSH
, overColSH
, overColSHM
, overPosSH
) where
import Geometry
@@ -79,11 +81,15 @@ upperPrismPolyHalf h ps = [ShapeObj (TopPrism n) (f upps downps)]
colorSH :: Color -> Shape -> Shape
{-# INLINE colorSH #-}
colorSH = overCol . const
colorSH = overColSH . const
overCol :: (Point4 -> Point4) -> Shape -> Shape
{-# INLINE overCol #-}
overCol = fmap . overColObj
overColSH :: (Point4 -> Point4) -> Shape -> Shape
{-# INLINE overColSH #-}
overColSH = fmap . overColObj
overColSHM :: Monad m => (Point4 -> m Point4) -> Shape -> m Shape
{-# INLINE overColSHM #-}
overColSHM = mapM . overColObjM
overPosSHI :: (Point3 -> Point3) -> Shape -> Shape
{-# INLINE overPosSHI #-}
@@ -121,6 +127,10 @@ overColObj :: (Point4 -> Point4) -> ShapeObj -> ShapeObj
{-# INLINE overColObj #-}
overColObj f (ShapeObj st vs) = ShapeObj st (map (overColVertex f) vs)
overColObjM :: Monad m => (Point4 -> m Point4) -> ShapeObj -> m ShapeObj
{-# INLINE overColObjM #-}
overColObjM f (ShapeObj st vs) = ShapeObj st <$> (mapM (svCol f) vs)
overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV
{-# INLINE overColVertex #-}
overColVertex f (ShapeV a b) = ShapeV a (f b)