Refactor, try to limit dependencies
This commit is contained in:
+131
-105
@@ -1,171 +1,197 @@
|
||||
module Dodge.Block.Debris where
|
||||
import Dodge.Material.Sound
|
||||
import Dodge.WorldEvent.Sound
|
||||
import Dodge.Base
|
||||
import Dodge.Data
|
||||
import Shape
|
||||
import Geometry
|
||||
import Color
|
||||
import LensHelp
|
||||
import RandomHelp
|
||||
import Grid
|
||||
import qualified Quaternion as Q
|
||||
|
||||
import Color
|
||||
import Data.Foldable
|
||||
import qualified Data.IntSet as IS
|
||||
import Data.Maybe
|
||||
import Data.Foldable
|
||||
import Dodge.Base
|
||||
import Dodge.Data.World
|
||||
import Dodge.Material.Sound
|
||||
import Dodge.WorldEvent.Sound
|
||||
import Geometry
|
||||
import Grid
|
||||
import LensHelp
|
||||
import qualified Quaternion as Q
|
||||
import RandomHelp
|
||||
import Shape
|
||||
|
||||
makeDoorDebris :: Door -> World -> World
|
||||
makeDoorDebris dr w = w & makeDebris mt col p
|
||||
where
|
||||
p = uncurry midPoint (_drPos dr)
|
||||
(mt,col) = fromMaybe (Stone,greyN 0.5) $ do
|
||||
(mt, col) = fromMaybe (Stone, greyN 0.5) $ do
|
||||
wlids <- w ^? cWorld . doors . ix (_drID dr) . drWallIDs
|
||||
(wlid,_) <- IS.minView wlids
|
||||
(wlid, _) <- IS.minView wlids
|
||||
wl <- w ^? cWorld . walls . ix wlid
|
||||
return (_wlMaterial wl,_wlColor wl)
|
||||
return (_wlMaterial wl, _wlColor wl)
|
||||
|
||||
makeBlockDebris :: Block -> World -> World
|
||||
--makeBlockDebris bl w = w & makeDebris mt col (_blPos bl)
|
||||
makeBlockDebris bl w = foldr (makeDebris mt col) w ps
|
||||
makeBlockDebris bl w = foldr (makeDebris mt col) w ps
|
||||
where
|
||||
dsize = debrisSize mt
|
||||
ps = gridInPolygon dsize $ shrinkPolyOnEdges dsize $ reverse (_blFootprint bl)
|
||||
(mt,col) = fromMaybe (Stone,greyN 0.5) $ do
|
||||
(mt, col) = fromMaybe (Stone, greyN 0.5) $ do
|
||||
wlids <- w ^? cWorld . blocks . ix (_blID bl) . blWallIDs
|
||||
(wlid,_) <- IS.minView wlids
|
||||
(wlid, _) <- IS.minView wlids
|
||||
wl <- w ^? cWorld . walls . ix wlid
|
||||
return (_wlMaterial wl,_wlColor wl)
|
||||
return (_wlMaterial wl, _wlColor wl)
|
||||
|
||||
makeDebrisToHeight :: Float -> Material -> Color -> Point2 -> World -> World
|
||||
makeDebrisToHeight = makeDebrisDirectedHeight 1 2 (2*pi) 0
|
||||
makeDebrisToHeight = makeDebrisDirectedHeight 1 2 (2 * pi) 0
|
||||
|
||||
makeDebris :: Material -> Color -> Point2 -> World -> World
|
||||
makeDebris = makeDebrisDirected 1 2 (2*pi) 0
|
||||
makeDebris = makeDebrisDirected 1 2 (2 * pi) 0
|
||||
|
||||
makeDebrisDirectedHeight :: Float -> Float -> Float -> Float -> Float -> Material
|
||||
-> Color -> Point2 -> World -> World
|
||||
makeDebrisDirectedHeight mindist maxdist arcrad dir maxh bm col p w = w
|
||||
makeDebrisDirectedHeight ::
|
||||
Float ->
|
||||
Float ->
|
||||
Float ->
|
||||
Float ->
|
||||
Float ->
|
||||
Material ->
|
||||
Color ->
|
||||
Point2 ->
|
||||
World ->
|
||||
World
|
||||
makeDebrisDirectedHeight mindist maxdist arcrad dir maxh bm col p w =
|
||||
w
|
||||
& flip (foldl' (flip $ plNew (cWorld . props) prID)) thedebris
|
||||
& randGen .~ newg
|
||||
& originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p
|
||||
& originsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
|
||||
where
|
||||
dsize = debrisSize bm
|
||||
(thedebris,newg) = mapM f [10,10 + dsize ..maxh+5] & runState $ _randGen w
|
||||
(thedebris, newg) = mapM f [10, 10 + dsize .. maxh + 5] & runState $ _randGen w
|
||||
f h = do
|
||||
v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad
|
||||
v <- rotateV (dir - arcrad / 2) <$> randInArcStrip mindist maxdist arcrad
|
||||
q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
|
||||
spinspeed <- randomR (-0.2,-0.1) & state
|
||||
spinspeed <- randomR (-0.2, -0.1) & state
|
||||
basedebris <- baseDebris bm
|
||||
return $ basedebris
|
||||
& prColor .~ col
|
||||
& prPos .~ p
|
||||
& prVel .~ v
|
||||
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
|
||||
& prQuat .~ q
|
||||
& prVelZ .~ 0
|
||||
& prPosZ .~ h
|
||||
return $
|
||||
basedebris
|
||||
& prColor .~ col
|
||||
& prPos .~ p
|
||||
& prVel .~ v
|
||||
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
|
||||
& prQuat .~ q
|
||||
& prVelZ .~ 0
|
||||
& prPosZ .~ h
|
||||
|
||||
makeDebrisDirected :: Float
|
||||
-> Float
|
||||
-> Float
|
||||
-> Float
|
||||
-> Material
|
||||
-> Color
|
||||
-> Point2
|
||||
-> World -> World
|
||||
makeDebrisDirected mindist maxdist arcrad dir bm col p w = w
|
||||
makeDebrisDirected ::
|
||||
Float ->
|
||||
Float ->
|
||||
Float ->
|
||||
Float ->
|
||||
Material ->
|
||||
Color ->
|
||||
Point2 ->
|
||||
World ->
|
||||
World
|
||||
makeDebrisDirected mindist maxdist arcrad dir bm col p w =
|
||||
w
|
||||
& flip (foldl' (flip $ plNew (cWorld . props) prID)) thedebris
|
||||
& randGen .~ newg
|
||||
& originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p
|
||||
& originsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
|
||||
where
|
||||
(thedebris,newg) = mapM f [35,55..95] & runState $ _randGen w
|
||||
(thedebris, newg) = mapM f [35, 55 .. 95] & runState $ _randGen w
|
||||
f h = do
|
||||
v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad
|
||||
v <- rotateV (dir - arcrad / 2) <$> randInArcStrip mindist maxdist arcrad
|
||||
q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
|
||||
spinspeed <- randomR (-0.2,-0.1) & state
|
||||
spinspeed <- randomR (-0.2, -0.1) & state
|
||||
basedebris <- baseDebris bm
|
||||
return $ basedebris
|
||||
& prColor .~ col
|
||||
& prPos .~ p
|
||||
& prVel .~ v
|
||||
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
|
||||
& prQuat .~ q
|
||||
& prVelZ .~ 0
|
||||
& prPosZ .~ h
|
||||
return $
|
||||
basedebris
|
||||
& prColor .~ col
|
||||
& prPos .~ p
|
||||
& prVel .~ v
|
||||
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
|
||||
& prQuat .~ q
|
||||
& prVelZ .~ 0
|
||||
& prPosZ .~ h
|
||||
|
||||
debrisSize :: Material -> Float
|
||||
debrisSize mt = case mt of
|
||||
Stone -> 20
|
||||
Glass -> 10
|
||||
Stone -> 20
|
||||
Glass -> 10
|
||||
Crystal -> 10
|
||||
Dirt -> 20
|
||||
Wood -> 10
|
||||
Metal -> 10
|
||||
Dirt -> 20
|
||||
Wood -> 10
|
||||
Metal -> 10
|
||||
Electronics -> 10
|
||||
Flesh -> 10
|
||||
|
||||
baseDebris :: Material -> State StdGen Prop
|
||||
baseDebris mt = case mt of
|
||||
Stone -> return stoneDebris
|
||||
Glass -> return glassDebris
|
||||
Stone -> return stoneDebris
|
||||
Glass -> return glassDebris
|
||||
Crystal -> return crystalDebris
|
||||
Dirt -> return dirtDebris
|
||||
Wood -> return stoneDebris
|
||||
Metal -> do
|
||||
Dirt -> return dirtDebris
|
||||
Wood -> return stoneDebris
|
||||
Metal -> do
|
||||
sh <- jaggedShape
|
||||
return $ metalDebris
|
||||
& prDraw .~ PropDrawMovingShapeCol sh
|
||||
return $
|
||||
metalDebris
|
||||
& prDraw .~ PropDrawMovingShapeCol sh
|
||||
Electronics -> baseDebris Metal
|
||||
Flesh -> baseDebris Dirt <&> prColor .~ red
|
||||
Flesh -> baseDebris Dirt <&> prColor .~ red
|
||||
|
||||
stoneDebris :: Prop
|
||||
stoneDebris = PropZ
|
||||
{_prPos = 0
|
||||
,_prStartPos = 0
|
||||
,_prVel = 0
|
||||
,_prDraw = PropDrawMovingShapeCol (cubeShape 4)
|
||||
,_prID = 0
|
||||
,_prUpdate = PropFallSmallBounceDamage
|
||||
,_prPosZ = 10
|
||||
,_prVelZ = 5
|
||||
,_prTimer = 20
|
||||
,_prQuat = Q.axisAngle (V3 1 0 0) 0
|
||||
,_prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
|
||||
,_prColor = greyN 0.5
|
||||
}
|
||||
stoneDebris =
|
||||
PropZ
|
||||
{ _prPos = 0
|
||||
, _prStartPos = 0
|
||||
, _prVel = 0
|
||||
, _prDraw = PropDrawMovingShapeCol (cubeShape 4)
|
||||
, _prID = 0
|
||||
, _prUpdate = PropFallSmallBounceDamage
|
||||
, _prPosZ = 10
|
||||
, _prVelZ = 5
|
||||
, _prTimer = 20
|
||||
, _prQuat = Q.axisAngle (V3 1 0 0) 0
|
||||
, _prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
|
||||
, _prColor = greyN 0.5
|
||||
}
|
||||
|
||||
dirtDebris :: Prop
|
||||
dirtDebris = stoneDebris
|
||||
& prColor .~ dirtColor
|
||||
& prUpdate .~ PropFallSmallBounce
|
||||
dirtDebris =
|
||||
stoneDebris
|
||||
& prColor .~ dirtColor
|
||||
& prUpdate .~ PropFallSmallBounce
|
||||
|
||||
dirtColor :: Color
|
||||
dirtColor = V4 (150/256) ( 75/256) 0 ( 250/256)
|
||||
dirtColor = V4 (150 / 256) (75 / 256) 0 (250 / 256)
|
||||
|
||||
metalDebris :: Prop
|
||||
metalDebris = stoneDebris
|
||||
& prDraw .~ PropDrawMovingShapeCol (shardShape 4)
|
||||
& prUpdate .~ PropFallSmallBounceDamage
|
||||
metalDebris =
|
||||
stoneDebris
|
||||
& prDraw .~ PropDrawMovingShapeCol (shardShape 4)
|
||||
& prUpdate .~ PropFallSmallBounceDamage
|
||||
|
||||
glassDebris :: Prop
|
||||
glassDebris = stoneDebris
|
||||
& prDraw .~ PropDrawMovingShapeCol (shardShape 4)
|
||||
& prUpdate .~ PropFallSmallBounce
|
||||
& prColor .~ withAlpha 0.5 cyan
|
||||
glassDebris =
|
||||
stoneDebris
|
||||
& prDraw .~ PropDrawMovingShapeCol (shardShape 4)
|
||||
& prUpdate .~ PropFallSmallBounce
|
||||
& prColor .~ withAlpha 0.5 cyan
|
||||
|
||||
crystalDebris :: Prop
|
||||
crystalDebris = glassDebris
|
||||
& prColor .~ withAlpha 0.5 aquamarine
|
||||
crystalDebris =
|
||||
glassDebris
|
||||
& prColor .~ withAlpha 0.5 aquamarine
|
||||
|
||||
shardShape :: Float -> Shape
|
||||
shardShape size = translateSHz (-size) $ upperPrismPoly size
|
||||
[V2 size 0
|
||||
,V2 (-size) 1
|
||||
,V2 (-size) (-1)
|
||||
]
|
||||
shardShape size =
|
||||
translateSHz (- size) $
|
||||
upperPrismPoly
|
||||
size
|
||||
[ V2 size 0
|
||||
, V2 (- size) 1
|
||||
, V2 (- size) (-1)
|
||||
]
|
||||
|
||||
jaggedShape :: State StdGen Shape
|
||||
jaggedShape = do
|
||||
s <- randomR (4,10) & state
|
||||
s <- randomR (4, 10) & state
|
||||
return $ shardShape s
|
||||
|
||||
cubeShape :: Float -> Shape
|
||||
cubeShape size = translateSHz (-size) $ upperPrismPoly (2*size) $ square size
|
||||
cubeShape size = translateSHz (- size) $ upperPrismPoly (2 * size) $ square size
|
||||
|
||||
Reference in New Issue
Block a user