Refactor, try to limit dependencies
This commit is contained in:
+98
-81
@@ -1,119 +1,136 @@
|
||||
module Dodge.Prop.Gib where
|
||||
import Dodge.Base
|
||||
import Dodge.Data
|
||||
import Dodge.Damage
|
||||
import Geometry
|
||||
|
||||
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
|
||||
|
||||
import qualified Quaternion as Q
|
||||
import Data.List (zip4)
|
||||
import Data.Foldable
|
||||
|
||||
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
|
||||
}
|
||||
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
|
||||
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
|
||||
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
|
||||
(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
|
||||
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
|
||||
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)
|
||||
(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
|
||||
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 . 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
|
||||
)
|
||||
|
||||
addGib4 ::
|
||||
Point2 ->
|
||||
Color ->
|
||||
(Point2, Float, Q.Quaternion Float, Float) ->
|
||||
World ->
|
||||
World
|
||||
addGib4 p col (v, zs, q, h) =
|
||||
plNew
|
||||
(cWorld . 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 . props) prID gib
|
||||
& randGen .~ newg
|
||||
addGibAt h col p w =
|
||||
w
|
||||
& plNew (cWorld . props) prID gib
|
||||
& randGen .~ newg
|
||||
where
|
||||
(gib,newg) = runState f $ _randGen w
|
||||
(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)
|
||||
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
|
||||
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 . props) prID gib
|
||||
& randGen .~ newg
|
||||
addGibAtDir dir h col p w =
|
||||
w
|
||||
& plNew (cWorld . props) prID gib
|
||||
& randGen .~ newg
|
||||
where
|
||||
(gib,newg) = runState f $ _randGen w
|
||||
(gib, newg) = runState f $ _randGen w
|
||||
f = do
|
||||
s <- state $ randomR (1,4)
|
||||
zs <- state $ randomR (-8,8)
|
||||
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
|
||||
return $
|
||||
aGib
|
||||
& prPos .~ p
|
||||
& prColor .~ col
|
||||
& prVel .~ v
|
||||
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
|
||||
& prQuat .~ q
|
||||
& prVelZ .~ zs
|
||||
& prPosZ .~ h
|
||||
|
||||
Reference in New Issue
Block a user