162 lines
5.0 KiB
Haskell
162 lines
5.0 KiB
Haskell
{- |
|
|
Drawing of creatures.
|
|
Takes into account damage etc.
|
|
-}
|
|
module Dodge.Creature.Picture (
|
|
basicCrPict,
|
|
deadScalp,
|
|
deadUpperBody,
|
|
deadFeet,
|
|
drawChaseCrit,
|
|
) where
|
|
|
|
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)
|
|
|
|
drawChaseCrit :: Creature -> Shape
|
|
drawChaseCrit cr = mconcat
|
|
[ chaseUpperBody cr
|
|
, rotmdir $ colorSH (_skinLower cskin) $ feet cr
|
|
]
|
|
where
|
|
cskin = crShape $ _crType cr
|
|
rotmdir = rotateSH (_crMvDir cr - _crDir cr)
|
|
|
|
chaseUpperBody :: Creature -> Shape
|
|
chaseUpperBody 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
|
|
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.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))
|
|
vocaltilt = case cr ^? crVocalization . vcTime of
|
|
Just x | x < 20 -> -pi * 0.05 * (10 - abs (fromIntegral x - 10))
|
|
_ -> 0
|
|
sLen = _strideLength $ _crStance cr
|
|
tbob = 5 * (1 - oneSmooth (abs llegpos))
|
|
llegpos = case cr ^? crStance . carriage of
|
|
Just (Walking sa LeftForward) -> f sa
|
|
Just (Walking sa RightForward) -> -f sa
|
|
_ -> 0
|
|
--tbob = 2 * oneSmooth ((sLen - 2*i) / sLen)
|
|
f i = ((sLen - 2*i) / sLen)
|
|
|
|
|
|
oneSmooth :: Float -> Float
|
|
oneSmooth x = sin (pi * x * 0.5)
|
|
|
|
feet :: Creature -> Shape
|
|
{-# INLINE feet #-}
|
|
feet cr = case cr ^? crStance . carriage of
|
|
Just (Walking sa LeftForward) -> sh (f sa)
|
|
Just (Walking sa 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 $ _crStance 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)
|