loop/src/Dodge/Creature/Picture.hs

{- |
Drawing of creatures.
Takes into account damage etc.
-}
module Dodge.Creature.Picture (
    basicCrPict,
    deadScalp,
    deadUpperBody,
    deadFeet,
    drawChaseCrit,
    drawHoverCrit,
) where

import Dodge.Base.Collide
import Control.Monad
import Data.Maybe
import Dodge.Data.World
import Linear
import Dodge.Data.Equipment.Misc
import Dodge.Creature.HandPos
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Dodge.Creature.Radius
import Dodge.Creature.Shape
--import Dodge.Creature.Test
import Dodge.Damage
--import Dodge.Data.Creature
import Dodge.Item.Draw
import Dodge.Item.Grammar
import Geometry
import Picture
import qualified Quaternion as Q
import Shape
--import Shape
import ShapePicture

basicCrPict :: IM.IntMap Item -> Creature -> SPic
basicCrPict m cr = drawEquipment m cr <> noPic (basicCrShape cr)

crCamouflage :: Creature -> CamouflageStatus
crCamouflage _ = FullyVisible

basicCrShape :: Creature -> Shape
basicCrShape cr
    | crCamouflage cr == Invisible = mempty
    | otherwise =
        scaleSH (V3 crsize crsize crsize) $
            mconcat
                [ colorSH (_skinHead cskin) . overPosSH (translateToES cr OnHead) $ scalp
                , colorSH (_skinUpper cskin) $ upperBody cr
                , rotmdir $ colorSH (_skinLower cskin) $ feet cr
                ]
  where
    cskin = crShape $ _crType cr
    crsize = 0.1 * crRad (cr ^. crType)
    rotmdir = rotateSH (_crMvDir cr - _crDir cr)

drawHoverCrit :: Creature -> Shape
drawHoverCrit cr = colorSH (_skinHead cskin) 
    (overPosSH (Q.apply tpq) $ upperBoxHalf Medium Typical 1 $ square 4)
    <> colorSH (_skinUpper cskin)
    (mconcat [overPosSH (Q.apply $ f a) $ upperBox Medium Typical 1 $ polyCirc 3 5 | a <- [0,pi/2,pi,1.5*pi]])
  where
    cskin = crShape $ _crType cr
    f a = tpq `Q.comp` (1 & _xy .~ rotateV a 5, Q.qid)
    tpq = (V3 0 0 0, Q.qid)

drawChaseCrit :: World -> Creature -> Shape
drawChaseCrit w cr = mconcat 
    [ chaseUpperBody w cr
    , rotmdir $ colorSH (_skinLower cskin) $ feet cr
    ]
  where
    cskin = crShape $ _crType cr
    rotmdir = rotateSH (_crMvDir cr - _crDir cr)

chaseUpperBody :: World -> Creature -> Shape
chaseUpperBody w cr =  colorSH (_skinUpper cskin)
    (overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI tz $ polyCirc 3 12 
        & each %~ vNormal
        & each . _y *~ 0.6) 
    <> overPosSH (Q.apply neckq) (upperPrismPolyHalfMI 3 $ (+ V2 8 0) . vNormal <$> trapTBH 2 5 8)
    )
    <> colorSH (_skinHead cskin)
        (overPosSH (Q.apply headq) (upperBox Medium Important 2 [V2 0 (-4), V2 9 0, V2 0 4]))
  where
--    time = fromIntegral (mod (w ^. unpauseClock) 100) / 5
    tz = 4
    cskin = crShape $ _crType cr
    torsoq = (V3 0 0 (10 + tz + tbob),Q.qid)
    mcool = 1 - min 10 (fromIntegral . _meleeCooldown $ _crType cr) / 10
    neckq = torsoq `Q.comp` (V3 6 0 0, Q.qz aimrot * Q.axisAngle (V3 0 1 0) (-1.8*mcool))
    headq = neckq `Q.comp` (V3 16 0 0, Q.axisAngle (V3 0 1 0) (2*mcool+vocaltilt) * Q.qz aimrot )
    vocaltilt = case cr ^? crVocalization . vcTime of
        Just x | x < 20 -> -pi * 0.05 * (10 - abs (fromIntegral x - 10))
        _ -> 0
    sLen = strideLength cr
    tbob = 5 * (1 - oneSmooth (abs llegpos))
    llegpos = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
        (Just sa, Just LeftForward) -> f sa
        (Just sa, Just RightForward) -> -f sa
        _ -> 0
    --tbob = 2 * oneSmooth ((sLen - 2*i) / sLen)
    f i = (sLen - 2*i) / sLen
    cxy = cr ^. crPos . _xy
    aimrot = fromMaybe pi $ do
        i <- cr ^. crIntention . targetCr
        tcxy <- w ^? cWorld . lWorld . creatures . ix i . crPos . _xy
        guard $ hasLOSIndirect cxy tcxy w
        return . (0.5*) . nearZeroAngle $  argV (tcxy - cxy) - cr ^. crDir

oneSmooth :: Float -> Float
oneSmooth x = sin (pi * x * 0.5)

feet :: Creature -> Shape
{-# INLINE feet #-}
feet cr = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
    (Just sa,Just LeftForward) -> sh (f sa)
    (Just sa,Just RightForward) -> sh (-f sa)
    _ -> sh 0
  where
    sh x = translateSHxy x off aFoot <> translateSHxy (- x) (- off) aFoot
    aFoot = upperPrismPolyST 10 $ polyCirc 3 4
    off = 5
    sLen = strideLength cr
--    f i = 8 * (sLen - 2*i) / sLen
    f i = 8 * oneSmooth ((sLen - 2*i) / sLen)

deadFeet :: Creature -> Shape
{-# INLINE deadFeet #-}
deadFeet = feet

arms :: Creature -> Shape
{-# INLINE arms #-}
arms cr =
    (^. _1) $
        translateToRightHand cr aHand
            <> translateToLeftHand cr aHand
  where
    aHand = noPic $ translateSHz (-2) . upperPrismPolyHalfST 2 $ polyCirc 3 4

deadScalp :: Creature -> Shape
--deadScalp cr = deadRot cr . translateSHz 5 . scalp $ cr
--deadScalp cr = deadRot cr . translateSHz (-5) . scalp $ cr
deadScalp _ = translateSH (V3 (-13) 0 0) scalp

deadRot :: Creature -> Shape -> Shape
deadRot cr = overPosSH (Q.rotateToZ d)
  where
    d =
        maybe
            (V3 1 0 0)
            (addZ 0 . unitVectorAtAngle . subtract (_crDir cr + pi))
            (damageDirection $ _crDamage cr)

scalp :: Shape
{-# INLINE scalp #-}
scalp = (colorSH (greyN 0.9) . upperPrismPolyHalfST 5 $ polyCirc 3 5)
        & each . sfShadowImportance .~ Unimportant

torso :: Creature -> Shape
{-# INLINE torso #-}
torso cr = overPosSH (translateToES cr OnBack) tsh
  where
    tsh = ashoulder 3 (-0.2) <> ashoulder (-3) 0.2
    ashoulder y a = translateSHxy 0 y . rotateSH a $ scaleSH (V3 10 10 1) baseShoulder

deadUpperBody :: Creature -> Shape
deadUpperBody cr = deadRot cr . translateSHz (negate 10) . upperBody $ cr

baseShoulder :: Shape
{-# INLINE baseShoulder #-}
--baseShoulder = translateSHz (-20) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1
baseShoulder = scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1

upperBody :: Creature -> Shape
{-# INLINE upperBody #-}
upperBody cr = arms cr <> torso cr

drawEquipment :: IM.IntMap Item -> Creature -> SPic
{-# INLINE drawEquipment #-}
drawEquipment m cr = foldMap (itemEquipPict cr) (invDT . fmap (\i -> m ^?! ix i) $ _crInv cr)