145 lines
4.2 KiB
Haskell
145 lines
4.2 KiB
Haskell
{- |
|
|
Drawing of creatures.
|
|
Takes into account damage etc.
|
|
-}
|
|
module Dodge.Creature.Picture (
|
|
basicCrPict,
|
|
deadScalp,
|
|
deadUpperBody,
|
|
deadFeet,
|
|
) where
|
|
|
|
import Control.Lens
|
|
import Dodge.Creature.HandPos (translateToLeftHand, translateToRightHand)
|
|
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 :: Creature -> SPic
|
|
basicCrPict cr =
|
|
uncurryV translateSPxy (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr)
|
|
<> noPic (basicCrShape cr)
|
|
|
|
crCamouflage :: Creature -> CamouflageStatus
|
|
crCamouflage _ = FullyVisible
|
|
|
|
basicCrShape ::
|
|
Creature ->
|
|
Shape
|
|
basicCrShape cr
|
|
| crCamouflage cr == Invisible = mempty
|
|
| otherwise =
|
|
tr . scaleSH (V3 crsize crsize crsize) $
|
|
mconcat
|
|
[ rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
|
|
, rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
|
|
, rotmdir $ colorSH (_skinLower cskin) $ feet cr
|
|
]
|
|
where
|
|
cskin = _crType cr
|
|
crsize = 0.1 * _crRad cr
|
|
tr = uncurryV translateSHxy (_crPos cr)
|
|
rotdir = rotateSH (_crDir cr)
|
|
rotmdir = rotateSH (_crMvDir 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 * fromIntegral (sLen - i) / fromIntegral 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 . _csDamage $ _crState cr)
|
|
|
|
scalp :: Creature -> Shape
|
|
{-# INLINE scalp #-}
|
|
scalp cr
|
|
| 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
|
|
| oneH cr =
|
|
rotateSH 0.5 $
|
|
mconcat
|
|
[ translateSHxy 0 3 . rotateSH (negate 0.2) $ aShoulder
|
|
, translateSHxy 0 (negate 3) . rotateSH 0.2 $ aShoulder
|
|
]
|
|
| twists cr =
|
|
translateSHxy 0 5 . rotateSH (-1) $
|
|
mconcat
|
|
[ rotateSH (negate 0.2) . translateSHxy 2 3 . rotateSH (negate 0.4) $ aShoulder
|
|
, rotateSH (negate 0.2) . translateSHxy 0 (negate 3) . rotateSH 0.2 $ aShoulder
|
|
]
|
|
| otherwise =
|
|
mconcat
|
|
[ translateSHxy 0 3 . rotateSH (negate 0.2) $ aShoulder
|
|
, translateSHxy 0 (negate 3) . rotateSH 0.2 $ aShoulder
|
|
]
|
|
where
|
|
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 (-10) . 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 :: Creature -> SPic
|
|
{-# INLINE drawEquipment #-}
|
|
drawEquipment cr = foldMap (itemEquipPict cr) (invLDT $ _crInv cr)
|