137 lines
4.4 KiB
Haskell
137 lines
4.4 KiB
Haskell
module Dodge.Prop.Gib where
|
|
|
|
import Color
|
|
import Data.Foldable
|
|
import Data.List (zip4)
|
|
import Dodge.Base
|
|
import Dodge.Damage
|
|
import Dodge.Data.World
|
|
import Geometry
|
|
import LensHelp
|
|
import qualified Quaternion as Q
|
|
import RandomHelp
|
|
|
|
aGib :: Prop
|
|
aGib =
|
|
PropZ
|
|
{ _prPos = 0
|
|
, _prStartPos = 0
|
|
, _prVel = 0
|
|
, _prDraw = PropDrawMovingShape (PropDrawGib 3)
|
|
, _prID = 0
|
|
, _prUpdate = PropFallSmallBounce
|
|
, _prPosZ = 10
|
|
, _prVelZ = 5
|
|
, _prTimer = 20
|
|
, _prQuat = Q.axisAngle (V3 1 0 0) 0
|
|
, _prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
|
|
, _prColor = white
|
|
}
|
|
|
|
addCrGibs :: Creature -> World -> World
|
|
addCrGibs cr w = case damageDirection $ _csDamage $ _crState cr of
|
|
Nothing ->
|
|
w
|
|
& addGibAt 25 (_skinHead skin) cpos
|
|
& addGibsAt 3 7 (_skinLower skin) cpos
|
|
& addGibsAt 13 20 (_skinUpper skin) cpos
|
|
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 = _crType cr -- this should be cleaned up
|
|
cpos = _crPos cr
|
|
|
|
addGibsAt :: Float -> Float -> Color -> Point2 -> World -> World
|
|
addGibsAt 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 <$> (randsOnCirc 4 & evalState $ _randGen w)
|
|
vels = zipWith (*.*) speeds dirs
|
|
zspeeds = replicateM 4 (state (randomR (-8, 8))) & evalState $ _randGen w
|
|
quats :: [Q.Quaternion Float]
|
|
quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w
|
|
|
|
-- this is ugly because it is mostly copy-paste from addGibsAt
|
|
addGibsAtDir :: Float -> Float -> Float -> Color -> Point2 -> World -> World
|
|
addGibsAtDir 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 - pi / 4, dir + pi / 4) 4 & evalState $ _randGen w)
|
|
vels = zipWith (*.*) speeds dirs
|
|
zspeeds = replicateM 4 (state (randomR (-8, 8))) & evalState $ _randGen w
|
|
quats :: [Q.Quaternion Float]
|
|
quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w
|
|
|
|
addGib4 ::
|
|
Point2 ->
|
|
Color ->
|
|
(Point2, Float, Q.Quaternion Float, Float) ->
|
|
World ->
|
|
World
|
|
addGib4 p col (v, zs, q, h) =
|
|
plNew
|
|
(cWorld . lWorld . props)
|
|
prID
|
|
( aGib & prPos .~ p +.+ (5 *.* normalizeV v)
|
|
& prColor .~ col
|
|
& prVel .~ v
|
|
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
|
|
& prQuat .~ q
|
|
& prVelZ .~ zs
|
|
& prPosZ .~ h
|
|
)
|
|
|
|
addGibAt :: Float -> Color -> Point2 -> World -> World
|
|
addGibAt h col p w =
|
|
w
|
|
& plNew (cWorld . lWorld . props) prID gib
|
|
& randGen .~ newg
|
|
where
|
|
(gib, newg) = runState f $ _randGen w
|
|
f = do
|
|
s <- state $ randomR (1, 4)
|
|
dir <- unitVectorAtAngle <$> state (randomR (0, 2 * pi))
|
|
zs <- state $ randomR (-8, 8)
|
|
q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
|
|
let v = s *.* dir
|
|
return $
|
|
aGib
|
|
& prPos .~ p
|
|
& prColor .~ col
|
|
& prVel .~ v
|
|
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
|
|
& prQuat .~ q
|
|
& prVelZ .~ zs
|
|
& prPosZ .~ h
|
|
|
|
addGibAtDir :: Float -> Float -> Color -> Point2 -> World -> World
|
|
addGibAtDir dir h col p w =
|
|
w
|
|
& plNew (cWorld . lWorld . props) prID 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
|
|
& prPos .~ p
|
|
& prColor .~ col
|
|
& prVel .~ v
|
|
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
|
|
& prQuat .~ q
|
|
& prVelZ .~ zs
|
|
& prPosZ .~ h
|