90 lines
3.2 KiB
Haskell
90 lines
3.2 KiB
Haskell
module Dodge.Prop.Gib (addCrGibs) where
|
|
|
|
import Linear
|
|
import Color
|
|
import Control.Monad
|
|
import Data.Foldable
|
|
import Data.List (zip4)
|
|
import Dodge.Creature.Shape
|
|
import Dodge.Damage
|
|
import Dodge.Data.World
|
|
import Dodge.WorldEvent.Cloud
|
|
import Geometry
|
|
import LensHelp
|
|
import qualified Quaternion as Q
|
|
import RandomHelp
|
|
|
|
addCrGibs :: Creature -> World -> World
|
|
addCrGibs cr = case damageDirection $ _crDamage cr of
|
|
Nothing ->
|
|
addGibAt (_skinHead skin) (cpos & _z +~ 25)
|
|
. addGibsAtDir pi 0 3 7 (_skinLower skin) cpos
|
|
. addGibsAtDir pi 0 13 20 (_skinUpper skin) cpos
|
|
. makeDustAt Flesh 50 cpos
|
|
. makeDustAt Flesh 50 cpos
|
|
. makeDustAt Flesh 50 cpos
|
|
. makeDustAt Flesh 50 cpos
|
|
Just d ->
|
|
addGibsAtDir (pi / 4) d 3 7 (_skinLower skin) cpos
|
|
. addGibsAtDir (pi / 4) d 13 20 (_skinUpper skin) cpos
|
|
. addGibAtDir d (_skinHead skin) (cpos & _z +~ 25)
|
|
. makeDustAt Flesh 50 cpos
|
|
. makeDustAt Flesh 50 cpos
|
|
. makeDustAt Flesh 50 cpos
|
|
. makeDustAt Flesh 50 cpos
|
|
where
|
|
skin = crShape $ _crType cr -- this should be cleaned up
|
|
cpos = _crPos cr
|
|
|
|
-- this is ugly because it is mostly copy-paste from addGibsAt
|
|
addGibsAtDir :: Float -> Float -> Float -> Float -> Color -> Point3 -> World -> World
|
|
addGibsAtDir spread dir minh maxh col p w =
|
|
foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs)
|
|
& randGen .~ newg
|
|
where
|
|
(speeds, newg) = replicateM 4 (state (randomR (1, 4))) & runState $ _randGen w
|
|
hs = replicateM 4 (state (randomR (minh, maxh))) & evalState $ _randGen w
|
|
dirs = unitVectorAtAngle <$> (randsSpread (dir - spread, dir + spread) 4 & evalState $ _randGen w)
|
|
vels = zipWith (*.*) speeds dirs
|
|
zspeeds = replicateM 4 (state (randomR (-8, 8))) & evalState $ _randGen w
|
|
quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w
|
|
|
|
addGib4 :: Point3 -> Color -> (Point2, Float, QFloat, Float) -> World -> World
|
|
addGib4 p col (v, zs, q, h) =
|
|
cWorld . lWorld . debris
|
|
.:~ DebrisChunk
|
|
{ _dbPos = p & _z +~ h
|
|
, _dbType = Gib 3 col
|
|
, _dbVel = v `v2z` zs
|
|
, _dbRot = q
|
|
, _dbSpin = Q.axisAngle (vNormal v `v2z` 0) (-0.1)
|
|
}
|
|
|
|
addGibAt :: Color -> Point3 -> World -> World
|
|
--addGibAt h col p w = addGibAtDir d h col p (w & randGen .~ newg)
|
|
addGibAt col p w = addGibAtDir d col p (w & randGen .~ newg)
|
|
where
|
|
(d, newg) = randomR (0, 2 * pi) $ _randGen w
|
|
|
|
addGibAtDir :: Float -> Color -> Point3 -> World -> World
|
|
--addGibAtDir dir h col p w =
|
|
addGibAtDir dir col p w =
|
|
w
|
|
& cWorld . lWorld . debris .:~ gib
|
|
& randGen .~ newg
|
|
where
|
|
(gib, newg) = runState f $ _randGen w
|
|
f = do
|
|
s <- state $ randomR (1, 4)
|
|
zs <- state $ randomR (-4, 4)
|
|
q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
|
|
let v = s *.* unitVectorAtAngle dir
|
|
return $
|
|
DebrisChunk
|
|
{ _dbPos = p
|
|
, _dbType = Gib 3 col
|
|
, _dbVel = v `v2z` zs
|
|
, _dbRot = q
|
|
, _dbSpin = Q.axisAngle (vNormal v `v2z` 0) (-0.1)
|
|
}
|