263 lines
8.2 KiB
Haskell
263 lines
8.2 KiB
Haskell
{- |
|
|
Drawing of creatures.
|
|
Takes into account damage etc. -}
|
|
module Dodge.Creature.Picture
|
|
( basicCrPict
|
|
, circLine
|
|
, picAtCrPos
|
|
, picAtCrPosNoRot
|
|
) where
|
|
import Dodge.Data
|
|
--import Dodge.Data.DamageType
|
|
--import Dodge.Base
|
|
--import Dodge.Creature.Stance.Data
|
|
import Dodge.Creature.Perception.Data
|
|
--import Dodge.Creature.State.Data
|
|
import Dodge.Creature.Stance.Data
|
|
--import Dodge.Creature.Memory.Data
|
|
import Dodge.Creature.Test
|
|
--import Dodge.Creature.AlertLevel.Data
|
|
--import Dodge.Picture.Layer
|
|
import Dodge.Item.Data
|
|
import Dodge.Clock
|
|
import Picture
|
|
import Geometry
|
|
import Shape
|
|
import ShapePicture
|
|
--import Geometry.Vector3D
|
|
|
|
import Control.Lens
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.Vector as V
|
|
basicCrPict
|
|
:: Color -- ^ Creature color
|
|
-> Creature
|
|
-> World
|
|
-> SPic
|
|
basicCrPict col cr w = SPic (basicCrShape col cr) $ pictures $
|
|
targetingPic ++
|
|
[ creatureDisplayText w cr
|
|
, tr . rotdir $ _spPicture $ drawEquipment cr
|
|
]
|
|
where
|
|
targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr
|
|
f invid it = fmap ((\g -> g invid it cr w) . snd) (it ^? itTargeting . _Just)
|
|
tr = uncurryV translate (_crPos cr)
|
|
rotdir = rotate (_crDir cr)
|
|
|
|
basicCrShape
|
|
:: Color -- ^ Creature color
|
|
-> Creature
|
|
-> Shape
|
|
basicCrShape col cr = tr $ mconcat
|
|
[ rotdir $ _spShape $ drawEquipment cr
|
|
, translateSHz 25 . dm . rotdir $ scalp cr
|
|
, dm . rotmdir $ feet cr
|
|
, dm . rotdir $ upperBody col cr
|
|
]
|
|
where
|
|
dm = damageModSH cr
|
|
tr = uncurryV translateSHf (_crPos cr)
|
|
rotdir = rotateSH (_crDir cr)
|
|
rotmdir = rotateSH (_crMvDir cr)
|
|
. colorSH (greyN 0.3)
|
|
|
|
creatureDisplayText :: World -> Creature -> Picture
|
|
creatureDisplayText w cr
|
|
= setLayer 4
|
|
. setDepth 50
|
|
. translate x y
|
|
. color white
|
|
. rotate a
|
|
. scale theScale theScale
|
|
. text
|
|
$ clockCycle 50 (V.fromList [crDisplayAwake, crDisplayAlert]) w cr
|
|
where
|
|
campos = _cameraViewFrom w
|
|
theScale = 0.15 / _cameraZoom w
|
|
cpos = _crPos cr
|
|
v = cpos -.- campos
|
|
a = argV v - 0.5 * pi
|
|
(V2 x y) = campos +.+ v +.+ _crRad cr *.* normalizeV v
|
|
|
|
|
|
crDisplayAlert :: Creature -> String
|
|
crDisplayAlert cr
|
|
| isSuspicious = "?"
|
|
| isCognizant = "!"
|
|
| otherwise = "."
|
|
where
|
|
imAwarenesses = _crAwarenessLevel (_crPerception cr)
|
|
isSuspicious = any f imAwarenesses && not (null imAwarenesses)
|
|
isCognizant = any g imAwarenesses && not (null imAwarenesses)
|
|
f (Suspicious _) = True
|
|
f _ = False
|
|
g (Cognizant _) = True
|
|
g _ = False
|
|
|
|
crDisplayAwake :: Creature -> String
|
|
crDisplayAwake cr = case _crAwakeLevel (_crPerception cr) of
|
|
Comatose -> "-"
|
|
Asleep -> "Z"
|
|
Lethargic -> "L"
|
|
Vigilant -> "V"
|
|
Overstrung -> "O"
|
|
|
|
--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
|
|
damageModSH :: Creature -> Shape -> Shape
|
|
damageModSH _ = id
|
|
|
|
feet :: Creature -> Shape
|
|
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
|
|
|
|
arms :: Creature -> Shape
|
|
arms cr
|
|
| oneH cr = shoulderSH . translateSHf 11 (-3) . rotateSH (-0.5) $ scaleSH (V3 1 1.5 1) aHand
|
|
| twists cr = shoulderSH . translateSHf 0 (0.5* crad) . rotateSH (-1) $ mconcat
|
|
[ translateSHf 12 4 aHand
|
|
, translateSHf 4 (-10) 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 :: Shape
|
|
aHand = translateSHz (-4) . upperPrismPoly 4 $ polyCirc 3 4
|
|
crad = _crRad cr
|
|
off = 8
|
|
sLen = _strideLength $ _crStance cr
|
|
f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
|
|
|
|
scalp :: Creature -> Shape
|
|
scalp cr
|
|
| twists cr = translateSHf 0 (0.5*crad) . rotateSH (-1) $ translateSHf (negate 0.25 * crad) 0.25 fhead
|
|
| oneH cr = rotateSH 0.5 $ translateSHf (0.25 * crad) 0 fhead
|
|
| otherwise = translateSHf (0.25 * crad) 0 fhead
|
|
where
|
|
fhead = colorSH (greyN 0.9) . upperPrismPoly 5 . polyCirc 3 $ crad * 0.5
|
|
crad = _crRad cr
|
|
|
|
oneH :: Creature -> Bool
|
|
oneH cr = crIsAiming' cr && crIt ^? itAimStance == Just OneHand
|
|
where
|
|
crIt = _crInv cr IM.! _crInvSel cr
|
|
|
|
twists :: Creature -> Bool
|
|
twists cr = crIsAiming' cr && crIt ^? itAimStance == Just TwoHandTwist
|
|
where
|
|
crIt = _crInv cr IM.! _crInvSel cr
|
|
|
|
torso :: Creature -> Shape
|
|
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 (0.5* crad) . 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 crad crad 1) baseShoulder
|
|
crad = _crRad cr
|
|
|
|
baseShoulder :: Shape
|
|
baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPoly 10 $ polyCirc 3 1
|
|
|
|
|
|
|
|
upperBody :: Color -> Creature -> Shape
|
|
upperBody col cr = colorSH (light4 col) $ mconcat
|
|
[ arms cr
|
|
, shoulderSH $ torso cr
|
|
]
|
|
|
|
--naked :: Color -> Creature -> Picture
|
|
--naked _ cr
|
|
-- | strikeMelee = shoulderH . color white $ circleSolid $ _crRad cr
|
|
-- | pdam > 200 = shoulderH . color red $ circleSolid $ _crRad cr
|
|
-- | pdam > 99 = shoulderH . color white $ circleSolid $ _crRad cr
|
|
-- | otherwise = []
|
|
-- where
|
|
-- strikeMelee = _crMeleeCooldown cr > 5
|
|
-- pdam = sum $ concatMap (map _dmAmount) pastDams
|
|
-- pastDams = _crPastDamage $ _crState cr
|
|
|
|
shoulderSH :: Shape -> Shape
|
|
shoulderSH = translateSHz 20
|
|
waistSH :: Shape -> Shape
|
|
waistSH = translateSHz 10
|
|
|
|
light4 :: Color -> Color
|
|
light4 = light . light . light . light
|
|
|
|
--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
|
|
drawEquipment cr = mconcat $ map f $ IM.toList (_crInv cr)
|
|
where
|
|
f (i,it) = case it ^? itEquipPict of
|
|
Just g -> g cr i
|
|
_ -> emptyBlank
|
|
|
|
circLine :: Float -> Picture
|
|
circLine x = line [V2 0 0,V2 x 0]
|
|
|
|
picAtCrPos :: Picture -> Creature -> World -> SPic
|
|
--{-# INLINE picAtCrPos #-}
|
|
picAtCrPos thePic cr _ = SPic emptySH $ tranRot (_crPos cr) (_crDir cr) thePic
|
|
|
|
picAtCrPosNoRot :: Picture -> Creature -> World -> SPic
|
|
--{-# INLINE picAtCrPos #-}
|
|
picAtCrPosNoRot thePic cr _ = SPic emptySH $ uncurryV translate (_crPos cr) thePic
|