236 lines
7.6 KiB
Haskell
236 lines
7.6 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
{- |
|
|
Drawing of creatures.
|
|
Takes into account damage etc. -}
|
|
module Dodge.Creature.Picture
|
|
( basicCrPict
|
|
, drawCrEquipment
|
|
, circLine
|
|
, picAtCrPos
|
|
, shapeAtCrPos
|
|
, picAtCrPosNoRot
|
|
-- , basicCrCorpse
|
|
, deadScalp
|
|
, deadUpperBody
|
|
, deadFeet
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.Creature.HandPos (translateToRightHand,translateToLeftHand)
|
|
import Dodge.Creature.Test
|
|
import Dodge.Damage
|
|
import Dodge.Item.Draw
|
|
import Picture
|
|
import Geometry
|
|
import Shape
|
|
import ShapePicture
|
|
import qualified Quaternion as Q
|
|
|
|
import Control.Lens
|
|
|
|
basicCrPict :: Creature -> SPic
|
|
basicCrPict cr = drawCrEquipment cr <> (basicCrShape cr , mempty)
|
|
|
|
drawCrEquipment :: Creature -> SPic
|
|
drawCrEquipment cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr)
|
|
|
|
shapeAtCrPos :: Shape -> Creature -> SPic
|
|
shapeAtCrPos sh cr =
|
|
( uncurryV translateSHf (_crPos cr) $ rotateSH (_crDir cr) sh
|
|
, mempty
|
|
)
|
|
|
|
basicCrShape
|
|
:: Creature
|
|
-> Shape
|
|
basicCrShape cr
|
|
| _crCamouflage cr == Invisible = mempty
|
|
| otherwise = tr . scaleSH (V3 crsize crsize crsize) $ mconcat
|
|
[ --rotdir . _spShape $ drawEquipment cr
|
|
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 translateSHf (_crPos cr)
|
|
rotdir = rotateSH (_crDir cr)
|
|
rotmdir = rotateSH (_crMvDir cr)
|
|
|
|
--damageMod :: Creature -> Picture -> Picture
|
|
--damageMod cr pic = piercingMod $ bluntScale pic
|
|
-- where
|
|
-- cdir = _crDir cr
|
|
-- pastDams = _crPastDamage $ _crState cr
|
|
-- bluntDam :: Maybe Point2
|
|
-- bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
|
|
-- bluntScale = case fmap argV bluntDam of
|
|
-- Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
|
|
-- _ -> id
|
|
-- isBluntDam Blunt{} = True
|
|
-- isBluntDam _ = False
|
|
-- piercingDam = find isPiercingDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
|
|
-- isPiercingDam Piercing{} = True
|
|
-- isPiercingDam _ = False
|
|
-- piercingMod = case fmap argV piercingDam of
|
|
-- Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
|
|
-- _ -> id
|
|
|
|
feet :: Creature -> Shape
|
|
{-# INLINE feet #-}
|
|
feet cr = case cr ^? crStance . carriage of
|
|
Just (Walking sa LeftForward) -> mconcat
|
|
[ translateSHf ( f sa) off aFoot
|
|
, translateSHf (-f sa) (-off) aFoot
|
|
]
|
|
Just (Walking sa RightForward) -> mconcat
|
|
[ translateSHf (-f sa) off aFoot
|
|
, translateSHf ( f sa) (-off) aFoot
|
|
]
|
|
_ -> mconcat
|
|
[ translateSHf 0 off aFoot
|
|
, translateSHf 0 (-off) aFoot
|
|
]
|
|
where
|
|
aFoot :: Shape
|
|
aFoot = upperPrismPoly 10 $ polyCirc 3 4
|
|
off = 5
|
|
sLen = _strideLength $ _crStance cr
|
|
f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
|
|
|
|
deadFeet :: Creature -> Shape
|
|
{-# INLINE deadFeet #-}
|
|
deadFeet cr = case cr ^? crStance . carriage of
|
|
Just (Walking sa LeftForward) -> mconcat
|
|
[ translateSHf ( f sa) off aFoot
|
|
, translateSHf (-f sa) (-off) aFoot
|
|
]
|
|
Just (Walking sa RightForward) -> mconcat
|
|
[ translateSHf (-f sa) off aFoot
|
|
, translateSHf ( f sa) (-off) aFoot
|
|
]
|
|
_ -> mconcat
|
|
[ translateSHf 0 off aFoot
|
|
, translateSHf 0 (-off) aFoot
|
|
]
|
|
where
|
|
aFoot :: Shape
|
|
aFoot = upperPrismPoly 3 $ polyCirc 3 4
|
|
off = 5
|
|
sLen = _strideLength $ _crStance cr
|
|
f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
|
|
|
|
arms :: Creature -> Shape
|
|
{-# INLINE arms #-}
|
|
arms cr = fst $ translateToRightHand cr aHand
|
|
<> translateToLeftHand cr aHand
|
|
--arms cr
|
|
-- | oneH cr = shoulderSH . translateSHf 11 (-3) . rotateSH (-0.5) $ scaleSH (V3 1 1.5 1) aHand
|
|
-- | twists cr = shoulderSH . translateSHf 0 5 . rotateSH (-1) $ mconcat
|
|
-- [ translateSHf 12 4 aHand
|
|
-- , translateSHf 4 (-10) aHand
|
|
-- ]
|
|
-- | twoFlat cr = waistSH $ translateSHf 4 8 aHand
|
|
-- <> translateSHf 4 (-8) aHand
|
|
-- | otherwise = case cr ^? crStance . carriage of
|
|
-- Just (Walking sa LeftForward) -> waistSH $ translateSHf (-f sa) (-off) aHand
|
|
-- Just (Walking sa RightForward) -> waistSH $ translateSHf (-f sa) off aHand
|
|
-- _ -> emptySH
|
|
where
|
|
aHand :: SPic
|
|
aHand = noPic $ translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4
|
|
-- off = 8
|
|
-- sLen = _strideLength $ _crStance cr
|
|
-- f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
|
|
|
|
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 = translateSHf 0 5 . rotateSH (-1) $ translateSHf (negate 2.5) 0.25 fhead
|
|
| oneH cr = rotateSH 0.5 $ translateSHf 2.5 0 fhead
|
|
| otherwise = translateSHf 2.5 0 fhead
|
|
where
|
|
fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 $ polyCirc 4 5
|
|
|
|
--hasAmmo :: Creature -> Bool
|
|
--hasAmmo cr = case cr ^? crInv . ix (_crInvSel cr) . itConsumption . ammoLoaded of
|
|
-- Just x -> x > 0
|
|
-- _ -> False
|
|
|
|
torso :: Creature -> Shape
|
|
{-# INLINE torso #-}
|
|
torso cr
|
|
| oneH cr = rotateSH 0.5 $ mconcat
|
|
[ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder
|
|
, translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
|
|
]
|
|
| twists cr = translateSHf 0 5 . rotateSH (-1) $ mconcat
|
|
[ rotateSH (negate 0.2) . translateSHf 2 3 . rotateSH (negate 0.4) $ aShoulder
|
|
, rotateSH (negate 0.2) . translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
|
|
]
|
|
| otherwise = mconcat
|
|
[ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder
|
|
, translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
|
|
]
|
|
where
|
|
--aShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPoly 10 $ polyCirc 3 crad
|
|
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) . upperPrismPolyHalf 10 $ polyCirc 3 1
|
|
|
|
upperBody :: Creature -> Shape
|
|
{-# INLINE upperBody #-}
|
|
--upperBody col cr = colorSH (light4 col) $ mconcat
|
|
upperBody cr = mconcat
|
|
[ arms cr
|
|
, shoulderSH $ torso cr
|
|
]
|
|
|
|
shoulderSH :: Shape -> Shape
|
|
shoulderSH = translateSHz 20
|
|
--waistSH :: Shape -> Shape
|
|
--waistSH = translateSHz 10
|
|
|
|
|
|
--drawAwakeLevel
|
|
-- :: Creature
|
|
-- -> Picture
|
|
--drawAwakeLevel cr = case cr ^? crAttentionDir of
|
|
-- Just (AttentiveTo [0]) -> setPos . color red $ circleSolid 5
|
|
-- _ -> setPos . color blue $ circleSolid 5
|
|
-- where
|
|
-- setPos = translate 0 (_crRad cr)
|
|
|
|
drawEquipment :: Creature -> SPic
|
|
{-# INLINE drawEquipment #-}
|
|
drawEquipment cr = foldMap (itemEquipPict cr) (_crInv cr)
|
|
--drawEquipment cr = foldMap f (_crInv cr)
|
|
-- where
|
|
-- f itm = _itEquipPict itm cr itm
|
|
|
|
circLine :: Float -> Picture
|
|
circLine x = line [V2 0 0,V2 x 0]
|
|
|
|
picAtCrPos :: Picture -> Creature -> SPic
|
|
--{-# INLINE picAtCrPos #-}
|
|
picAtCrPos thePic cr = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic
|
|
|
|
picAtCrPosNoRot :: Picture -> Creature -> SPic
|
|
--{-# INLINE picAtCrPos #-}
|
|
picAtCrPosNoRot thePic cr = (,) emptySH $ uncurryV translate (_crPos cr) thePic
|
|
|