loop/src/Dodge/Block/Debris.hs

module Dodge.Block.Debris (
    cubeShape,
    --    dirtColor,
    makeDoorDebris,
    makeBlockDebris,
    makeDebris,
    makeDebrisDirected,
    makeMachineDebris,
) where

import Control.Monad
import Dodge.Machine.Draw
import Color
import Data.Foldable
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import Data.Maybe
import Dodge.Data.World
import Dodge.Material.Sound
import Dodge.ShiftPoint
import Dodge.WorldEvent.Sound
import Geometry
import Grid
import LensHelp
import qualified Quaternion as Q
import RandomHelp
import Shape

makeMachineDebris :: Machine -> World -> World
makeMachineDebris mc w = foldl' (flip $ makeDebrisZ 20 (MetalDebris $ mcColor mc) mt) w ps
  where
    pa = (mc ^. mcPos, mc ^. mcDir)
    dsize = debrisSize mt
    ps = fmap (shiftPointBy pa) 
        . gridInPolygon dsize 
        . shrinkPolyOnEdges dsize 
        $ reverse (fst <$> mc ^.. mcFootPrint . each)
    mt = mc ^. mcSkin


makeDoorDebris :: Door -> World -> World
makeDoorDebris dr w = w & makeDebris (BlockDebris drcol) mt p
  where
    p2a = lerpP2A (dr ^. drZeroPos) (dr ^. drOnePos) (dr ^. drLerp)
    p = centroid . fmap fst $ (dr ^. drFootPrint) & each . each %~ shiftPointBy p2a
    mt = fromMaybe Stone $ do
        wlids <- w ^? cWorld . lWorld . doors . ix (_drID dr) . drFootPrint
        ((wlid, _), _) <- IM.minViewWithKey wlids
        w ^? cWorld . lWorld . walls . ix wlid . wlMaterial
    drcol = case dr ^. drTrigger of
        WdBlCrFilterNearPoint {} -> yellow
        _ -> red

blColor :: Block -> Color
blColor _ = orange

makeBlockDebris :: Block -> World -> World
makeBlockDebris bl w = foldl' (flip $ makeDebris (blockDebrisType mwl bl) mt) w ps
  where
    dsize = debrisSize mt
    ps = gridInPolygon dsize $ shrinkPolyOnEdges dsize $ reverse (_blFootprint bl)
    mt = fromMaybe Stone $ mwl ^? _Just . wlMaterial
    mwl = do
        wlids <- w ^? cWorld . lWorld . blocks . ix (_blID bl) . blWallIDs
        (wlid, _) <- IS.minView wlids
        w ^? cWorld . lWorld . walls . ix wlid

blockDebrisType :: Maybe Wall -> Block -> DebrisType
blockDebrisType wl bl = case wl ^? _Just . wlMaterial of
    Just Glass -> GlassDebris
    Just Metal -> MetalDebris red
    _ -> BlockDebris $ blColor bl

-- makeDebris :: Material -> Color -> Point2 -> World -> World
makeDebris :: DebrisType -> Material -> Point2 -> World -> World
makeDebris = makeDebrisDirected (2 * pi) 0

makeDebrisZ :: Float -> DebrisType -> Material -> Point2 -> World -> World
makeDebrisZ = makeDebrisDirectedZ (2 * pi) 0

makeDebrisDirectedZ :: Float -> Float -> Float -> DebrisType -> Material -> Point2 -> World -> World
makeDebrisDirectedZ arcrad dir z dt bm p w =
    w
        & cWorld . lWorld . debris <>~ thedebris
        & randGen .~ newg
        & soundOriginsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
  where
    (thedebris, newg) = replicateM 4 f & runState $ _randGen w
    f = do
        v <- rotateV (dir - arcrad / 2) <$> randInArcStrip 1 2 arcrad
        spinspeed <- randomR (-0.2, -0.1) & state
        return $
            DebrisChunk
                { _dbPos = p `v2z` z
                , _dbType = dt
                , _dbVel = v `v2z` 0
                , _dbRot = Q.qid
                , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed
                }

makeDebrisDirected :: Float -> Float -> DebrisType -> Material -> Point2 -> World -> World
makeDebrisDirected arcrad dir dt bm p w =
    w
        & cWorld . lWorld . debris <>~ thedebris
        & randGen .~ newg
        & soundOriginsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
  where
    (thedebris, newg) = mapM f [35, 55, 75, 95] & runState $ _randGen w
    f h = do
        v <- rotateV (dir - arcrad / 2) <$> randInArcStrip 1 2 arcrad
        spinspeed <- randomR (-0.2, -0.1) & state
        --        basedebris <- baseDebris bm
        return $
            DebrisChunk
                { _dbPos = p `v2z` h
                , _dbType = dt
                , _dbVel = v `v2z` 0
                , _dbRot = Q.qid
                , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed
                }

--            basedebris
--                & prColor .~ col
--                & prPos .~ p
--                & prVel .~ v
--                & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
--                & prQuat .~ Q.qid
--                & 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
    ForceField -> 10
    Photovoltaic -> 10
    LightningRod -> 10
    Pyroelectric -> 10
    Piezoelectric -> 10

-- shardShape :: Float -> Shape
-- shardShape size =
--    translateSHz (- size) $
--        upperPrismPolySU
--            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) $ upperPrismPolySU (2 * size) $ square size