loop/src/Dodge/Block/Debris.hs

module Dodge.Block.Debris where

import Color
import Data.Foldable
import qualified Data.IntSet as IS
import Data.Maybe
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
        wlids <- w ^? cWorld . lWorld . doors . ix (_drID dr) . drWallIDs
        (wlid, _) <- IS.minView wlids
        wl <- w ^? cWorld . lWorld . walls . ix wlid
        return (_wlMaterial wl, _wlColor wl)

makeBlockDebris :: Block -> World -> World
makeBlockDebris bl w = foldl' (flip $ 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
        wlids <- w ^? cWorld . lWorld . blocks . ix (_blID bl) . blWallIDs
        (wlid, _) <- IS.minView wlids
        wl <- w ^? cWorld . lWorld . walls . ix wlid
        return (_wlMaterial wl, _wlColor wl)

makeDebrisToHeight :: Float -> Material -> Color -> Point2 -> World -> World
makeDebrisToHeight = makeDebrisDirectedHeight 1 2 (2 * pi) 0

makeDebris :: Material -> Color -> Point2 -> World -> World
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
        & flip (foldl' (flip $ plNew (cWorld . lWorld . props) prID)) thedebris
        & randGen .~ newg
        & 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
    f h = do
        v <- rotateV (dir - arcrad / 2) <$> randInArcStrip mindist maxdist arcrad
        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
        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

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 . lWorld . props) prID)) thedebris
        & randGen .~ newg
        & originsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
  where
    (thedebris, newg) = mapM f [35, 55 .. 95] & runState $ _randGen w
    f h = do
        v <- rotateV (dir - arcrad / 2) <$> randInArcStrip mindist maxdist arcrad
        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
        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

debrisSize :: Material -> Float
debrisSize mt = case mt of
    Stone -> 20
    Glass -> 10
    Crystal -> 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
    Crystal -> return crystalDebris
    Dirt -> return dirtDebris
    Wood -> return stoneDebris
    Metal -> do
        sh <- jaggedShape
        return $
            metalDebris
                & prDraw .~ PropDrawMovingShapeCol sh
    Electronics -> baseDebris Metal
    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
        }

dirtDebris :: Prop
dirtDebris =
    stoneDebris
        & prColor .~ dirtColor
        & prUpdate .~ PropFallSmallBounce

dirtColor :: Color
dirtColor = V4 (150 / 256) (75 / 256) 0 (250 / 256)

metalDebris :: Prop
metalDebris =
    stoneDebris
        & prDraw .~ PropDrawMovingShapeCol (shardShape 4)
        & prUpdate .~ PropFallSmallBounceDamage

glassDebris :: Prop
glassDebris =
    stoneDebris
        & prDraw .~ PropDrawMovingShapeCol (shardShape 4)
        & prUpdate .~ PropFallSmallBounce
        & prColor .~ withAlpha 0.5 cyan

crystalDebris :: Prop
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)
            ]

jaggedShape :: State StdGen Shape
jaggedShape = do
    s <- randomR (4, 10) & state
    return $ shardShape s

cubeShape :: Float -> Shape
cubeShape size = translateSHz (- size) $ upperPrismPoly (2 * size) $ square size