130 lines
3.7 KiB
Haskell
130 lines
3.7 KiB
Haskell
{- |
|
|
Drawing of creatures.
|
|
Takes into account damage etc.
|
|
-}
|
|
module Dodge.Creature.Picture (
|
|
basicCrPict,
|
|
deadScalp,
|
|
deadUpperBody,
|
|
deadFeet,
|
|
) where
|
|
|
|
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) $ scalp cr
|
|
, 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)
|
|
|
|
feet :: Creature -> Shape
|
|
{-# INLINE feet #-}
|
|
feet cr = case cr ^? crStance . carriage of
|
|
Just (Walking sa LeftForward) ->
|
|
translateSHxy (f sa) off aFoot
|
|
<> translateSHxy (- f sa) (- off) aFoot
|
|
Just (Walking sa RightForward) ->
|
|
translateSHxy (- f sa) off aFoot
|
|
<> translateSHxy (f sa) (- off) aFoot
|
|
_ -> translateSHxy 0 off aFoot <> translateSHxy 0 (- off) aFoot
|
|
where
|
|
aFoot = upperPrismPolyST 10 $ polyCirc 3 4
|
|
off = 5
|
|
sLen = _strideLength $ _crStance cr
|
|
--f i = 6 * (sLen - i) / sLen
|
|
f i = 8 * (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 (-4) . upperPrismPolyHalfST 4 $ polyCirc 3 4
|
|
|
|
deadScalp :: Creature -> Shape
|
|
deadScalp cr = deadRot cr . translateSHz 10 . scalp $ cr
|
|
|
|
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 :: Creature -> Shape
|
|
{-# INLINE scalp #-}
|
|
scalp cr = overPosSH (translateToES cr OnHead) fhead
|
|
-- | twists cr = translateSHxy 0 5 . rotateSH (-1) $ translateSHxy (negate 2.5) 0.25 fhead
|
|
-- | oneH cr = rotateSH 0.5 $ translateSHxy 2.5 0 fhead
|
|
-- | otherwise = translateSHxy 2.5 0 fhead
|
|
where
|
|
fhead = colorSH (greyN 0.9) . upperPrismPolyHalfST 5 $ polyCirc 3 5
|
|
|
|
torso :: Creature -> Shape
|
|
{-# INLINE torso #-}
|
|
torso cr = overPosSH (translateToES cr OnBack) tsh
|
|
where
|
|
tsh =
|
|
mconcat
|
|
[ translateSHxy 0 3 . rotateSH (negate 0.2) $ aShoulder
|
|
, translateSHxy 0 (negate 3) . rotateSH 0.2 $ aShoulder
|
|
]
|
|
aShoulder = 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
|
|
|
|
upperBody :: Creature -> Shape
|
|
{-# INLINE upperBody #-}
|
|
upperBody cr = arms cr <> shoulderSH (torso cr)
|
|
|
|
shoulderSH :: Shape -> Shape
|
|
shoulderSH = translateSHz 20
|
|
|
|
drawEquipment :: IM.IntMap Item -> Creature -> SPic
|
|
{-# INLINE drawEquipment #-}
|
|
drawEquipment m cr = foldMap (itemEquipPict cr) (invDT . fmap (\i -> m ^?! ix i) $ _crInv cr)
|