loop/src/Dodge/Prop/Gib.hs

module Dodge.Prop.Gib (
    addCrGibs,
) where

import Dodge.Creature.Shape
import Color
import Control.Monad
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
        , _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 = case damageDirection $ _crDamage cr of
    Nothing ->
            addGibAt 25 (_skinHead skin) cpos
            . addGibsAt 3 7 (_skinLower skin) cpos
            . addGibsAt 13 20 (_skinUpper skin) cpos
    Just d ->
            addGibsAtDir d 3 7 (_skinLower skin) cpos
            . addGibsAtDir d 13 20 (_skinUpper skin) cpos
            . addGibAtDir d 25 (_skinHead skin) cpos
  where
    skin = crShape $ _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, QFloat, Float) -> World -> World
addGib4 p col (v, zs, q, h) = cWorld . lWorld . debris
        .:~ DebrisChunk
            { _dbPos = p `v2z` h
            , _dbType = Gib 3 col
            , _dbVel = v `v2z` zs
            , _dbRot = q
            , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) (-0.1)
            }
            
addGib4' :: Point2 -> Color -> (Point2, Float, QFloat, 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 = addGibAtDir d h col p (w & randGen .~ newg)
  where
    (d, newg) = randomR (0, 2 * pi) $ _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 $ DebrisChunk
--            { _dbPos = p `v2z` h
--            , _dbType = Gib 3 col
--            , _dbVel = v `v2z` zs
--            , _dbRot = q
--            , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) (-0.1)
--            }

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
        & cWorld . lWorld . debris .:~ gib
        & randGen .~ newg
  where
    (gib, newg) = runState f $ _randGen w
    f = do
        s <- state $ randomR (1, 4)
        zs <- state $ randomR (-4, 4)
        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
        let v = s *.* unitVectorAtAngle dir
        return $ DebrisChunk
            { _dbPos = (p +.+ (5 *.* normalizeV v)) `v2z` h
            , _dbType = Gib 3 col
            , _dbVel = v `v2z` zs
            , _dbRot = q
            , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) (-0.1)
            }

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