386 lines
14 KiB
Haskell
386 lines
14 KiB
Haskell
{- |
|
|
Drawing of creatures.
|
|
Takes into account damage etc.
|
|
-}
|
|
module Dodge.Creature.Picture (
|
|
makeCorpse,
|
|
drawCreature,
|
|
) where
|
|
|
|
import Data.Foldable
|
|
import qualified Data.Strict.Tuple as ST
|
|
import RandomHelp
|
|
import Dodge.Base.Collide
|
|
import Control.Monad
|
|
import Data.Maybe
|
|
import Dodge.Data.World
|
|
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
|
|
|
|
drawCreature :: World -> IM.IntMap Item -> Creature -> SPic
|
|
drawCreature w m cr = translateSP (_crPos cr) . fallrot . rotateSP (_crDir cr) $
|
|
case cr ^. crType of
|
|
_ | CrIsCorpse sp <- cr ^. crHP -> sp
|
|
_ | null (cr ^? crHP . _HP) -> mempty
|
|
BarrelCrit{} -> barrelShape
|
|
LampCrit{_lampHeight = h} -> lampCrSPic h
|
|
ChaseCrit {} -> noPic $ drawChaseCrit w cr
|
|
Avatar {} -> basicCrPict m cr
|
|
SwarmCrit -> basicCrPict m cr
|
|
AutoCrit -> basicCrPict m cr
|
|
CrabCrit {} -> noPic $ drawCrabCrit w cr
|
|
HoverCrit{} -> noPic $ drawHoverCrit cr
|
|
SlinkCrit{} -> noPic $ drawSlinkCrit cr
|
|
SlimeCrit{} -> noPic $ drawSlimeCrit cr
|
|
where
|
|
fallrot = case cr ^? crStance . carriage . carDir of
|
|
Just q -> _1 . each . sfVs . each %~ Q.rotate q
|
|
_ -> id
|
|
|
|
drawSlimeCrit :: Creature -> Shape
|
|
drawSlimeCrit cr = colorSH green $ upperPrismPolyHalf Medium Undesired r $ polyCirc 6 r
|
|
& each %~ scaleAlong d s
|
|
& each %~ scaleAlong (vNormal d) (1 / s)
|
|
& each %~ rotateV (-cr ^. crDir)
|
|
where
|
|
r = cr ^?! crType . slimeRad
|
|
p = cr ^?! crType . slimeCompression
|
|
d = normalize p
|
|
s = norm p / r
|
|
|
|
-- assumes d is a unit vector
|
|
scaleAlong :: Point2 -> Float -> Point2 -> Point2
|
|
scaleAlong d s p = ((s - 1) * dot d p) *^ d + p
|
|
|
|
|
|
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)
|
|
|
|
drawSlinkCrit :: Creature -> Shape
|
|
drawSlinkCrit cr = snd (foldl' f ((V3 0 0 0,Q.qid), mempty) $ cr ^?! crType . slinkSpine)
|
|
& each . sfColor .~ cskin ^?! skinUpper
|
|
where
|
|
cskin = crShape $ _crType cr
|
|
f ((p,q),sh) (p',q') = ((p,q) `Q.comp` (p',q'), sh <> (g p' & each . sfVs . each %~ Q.apply (p,q)))
|
|
g _ = upperPrismPoly Medium Important 2 $ polyCirc 6 10
|
|
|
|
drawHoverCrit :: Creature -> Shape
|
|
drawHoverCrit cr = colorSH (_skinHead cskin)
|
|
(overPosSH (Q.apply tpq) $ upperBoxHalf Medium Typical 1 $ square 4)
|
|
<> colorSH (_skinUpper cskin)
|
|
(mconcat [overPosSH (Q.apply $ f a) $ upperBox Medium Typical 1 $ polyCirc 3 5 | a <- [0,pi/2,pi,1.5*pi]])
|
|
where
|
|
cskin = crShape $ _crType cr
|
|
f a = tpq `Q.comp` (1 & _xy .~ rotateV a 5, Q.qid)
|
|
tpq = (V3 0 0 0, Q.qid)
|
|
|
|
drawCrabCrit :: World -> Creature -> Shape
|
|
drawCrabCrit w cr = mconcat
|
|
[ crabUpperBody w cr
|
|
, colorSH (_skinLower cskin) $ crabFeet w cr
|
|
]
|
|
where
|
|
cskin = crShape $ _crType cr
|
|
|
|
drawChaseCrit :: World -> Creature -> Shape
|
|
drawChaseCrit w cr = mconcat
|
|
[ chaseUpperBody w cr
|
|
, rotmdir $ colorSH (_skinLower cskin) $ feet cr
|
|
]
|
|
where
|
|
cskin = crShape $ _crType cr
|
|
rotmdir = rotateSH (_crMvDir cr - _crDir cr)
|
|
|
|
crabUpperBody :: World -> Creature -> Shape
|
|
crabUpperBody _ cr = colorSH (_skinUpper cskin)
|
|
(
|
|
overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI 5 $ polyCirc 4 10
|
|
& each . _x *~ 0.6)
|
|
<> overPosSH (Q.apply lclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 20 0 (-2) 2)
|
|
<> overPosSH (Q.apply rclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 0 (-20) (-2) 2)
|
|
)
|
|
<> colorSH (_skinHead cskin)
|
|
(overPosSH (Q.apply headq) (upperPrismPolyHalfMI 1 $ square 2))
|
|
where
|
|
torsoq = (V3 0 0 10,Q.qid)
|
|
lclawq = torsoq `Q.comp` (V3 2 8 1, Q.slerp latck lrest lcool)
|
|
latck = Q.axisAngle (V3 0 0 1) (-0.5 * pi)
|
|
lrest = Q.axisAngle (V3 1 0 0) 1
|
|
cskin = crShape $ _crType cr
|
|
lcool = 1 - min 10 (fromIntegral . _meleeCooldownL $ _crType cr) / 10
|
|
rclawq = torsoq `Q.comp` (V3 2 (-8) 1, Q.slerp ratck rrest rcool)
|
|
ratck = Q.axisAngle (V3 0 0 1) (0.5 * pi)
|
|
rrest = Q.axisAngle (V3 1 0 0) (-1)
|
|
rcool = 1 - min 10 (fromIntegral . _meleeCooldownR $ _crType cr) / 10
|
|
headq = torsoq `Q.comp` (V3 3 0 4, Q.qid)
|
|
|
|
|
|
chaseUpperBody :: World -> Creature -> Shape
|
|
chaseUpperBody w 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
|
|
-- time = fromIntegral (mod (w ^. unpauseClock) 100) / 5
|
|
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.qz aimrot * 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) * Q.qz aimrot )
|
|
vocaltilt = case cr ^? crVocalization . vcTime of
|
|
Just x | x < 20 -> -pi * 0.05 * (10 - abs (fromIntegral x - 10))
|
|
_ -> 0
|
|
sLen = strideLength cr
|
|
tbob = 5 * (1 - oneSmooth (abs llegpos))
|
|
llegpos = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
|
|
(Just sa, Just LeftForward) -> f sa
|
|
(Just sa, Just RightForward) -> -f sa
|
|
_ -> 0
|
|
--tbob = 2 * oneSmooth ((sLen - 2*i) / sLen)
|
|
f i = (sLen - 2*i) / sLen
|
|
cxy = cr ^. crPos . _xy
|
|
aimrot = fromMaybe pi $ do
|
|
i <- cr ^. crIntention . targetCr
|
|
tcxy <- w ^? cWorld . lWorld . creatures . ix i . crPos . _xy
|
|
guard $ hasLOSIndirect cxy tcxy w
|
|
return . (0.5*) . nearZeroAngle $ argV (tcxy - cxy) - cr ^. crDir
|
|
|
|
oneSmooth :: Float -> Float
|
|
oneSmooth x = sin (pi * x * 0.5)
|
|
|
|
feet :: Creature -> Shape
|
|
{-# INLINE feet #-}
|
|
feet cr = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
|
|
(Just sa,Just LeftForward) -> sh (f sa)
|
|
(Just sa,Just 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 cr
|
|
-- f i = 8 * (sLen - 2*i) / sLen
|
|
f i = 8 * oneSmooth ((sLen - 2*i) / sLen)
|
|
|
|
crabFeet :: World -> Creature -> Shape
|
|
{-# INLINE crabFeet #-}
|
|
crabFeet _ cr =
|
|
uncurryV translateSHxy rpos (afoot & each . sfVs . each %~ Q.rotate r1)
|
|
<> (afoot
|
|
& each . sfVs . each %~ Q.rotate r2
|
|
& each . sfVs . each +~ V3 0 2 5)
|
|
<> uncurryV translateSHxy rpos' (afoot & each . sfVs . each %~ Q.rotate r1')
|
|
<> (afoot
|
|
& each . sfVs . each %~ Q.rotate r2'
|
|
& each . sfVs . each +~ V3 0 2 5)
|
|
<> uncurryV translateSHxy lpos (afoot & each . sfVs . each %~ Q.rotate l1)
|
|
<> (afoot
|
|
& each . sfVs . each %~ Q.rotate l2
|
|
& each . sfVs . each +~ V3 0 (-2) 5)
|
|
<> uncurryV translateSHxy lpos' (afoot & each . sfVs . each %~ Q.rotate l1')
|
|
<> (afoot
|
|
& each . sfVs . each %~ Q.rotate l2'
|
|
& each . sfVs . each +~ V3 0 (-2) 5)
|
|
where
|
|
rpos = rot (cr ^?! crType . rFootPos - cxy)
|
|
rot = rotateV cdir
|
|
lpos = rot ( cr ^?! crType . lFootPos - cxy)
|
|
f p q = q + 2 *^ (p - q)
|
|
cdir = -cr ^. crDir
|
|
cxy = cr ^. crPos . _xy
|
|
afoot = upperPrismPolyHalfST 10 $ polyCirc 3 2
|
|
(r1,r2) = spiderJoint (0 & _xy .~ rpos) (V3 0 2 5)
|
|
rpos' = f (V2 0 10) rpos
|
|
(r1',r2') = spiderJoint (0 & _xy .~ rpos') (V3 0 2 5)
|
|
(l1,l2) = spiderJoint (0 & _xy .~ lpos) (V3 0 (-2) 5)
|
|
lpos' = f (V2 0 (-10)) lpos
|
|
(l1',l2') = spiderJoint (0 & _xy .~ lpos') (V3 0 (-2) 5)
|
|
|
|
spiderJoint :: Point3 -> Point3 -> (Q.Quaternion Float, Q.Quaternion Float)
|
|
spiderJoint p q = (f $ Q.axisAngle (V3 0 (-1) 0) (pi - (a+b)), f . Q.axisAngle (V3 0 (-1) 0) $ a - b)
|
|
--spiderJoint p q = (Q.qz c, Q.axisAngle (V3 0 (-1) 0) $ a)
|
|
where
|
|
a = angleThreeSides 10 (distance p q) 10
|
|
b = angleVV3 (q-p) (V3 0 0 (-1))
|
|
c = argV $ (p-q) ^. _xy
|
|
f x = Q.qz c * x
|
|
|
|
--spiderJoint' :: Point3 -> Float -> Float -> Point3 -> (Q.Quaternion Float, Q.Quaternion Float)
|
|
--spiderJoint' p l1 l2 q = (f $ Q.axisAngle (V3 0 (-1) 0) (pi - (a+b)), f . Q.axisAngle (V3 0 (-1) 0) $ a - b)
|
|
----spiderJoint p q = (Q.qz c, Q.axisAngle (V3 0 (-1) 0) $ a)
|
|
-- where
|
|
-- a = angleThreeSides 10 (distance p q) 10
|
|
-- b = angleVV3 (q-p) (V3 0 0 (-1))
|
|
-- c = argV $ (p-q) ^. _xy
|
|
-- f x = Q.qz c * x
|
|
|
|
makeCorpse :: StdGen -> Creature -> SPic
|
|
makeCorpse g cr = case cr ^. crType of
|
|
HoverCrit{} -> noPic $ drawHoverCrit cr
|
|
ChaseCrit{} -> noPic $ chaseCorpse g cr
|
|
CrabCrit{} -> noPic $ crabCorpse g cr
|
|
_ ->
|
|
noPic
|
|
. scaleSH (V3 crsize crsize crsize)
|
|
$ mconcat
|
|
[ colorSH (_skinHead cskin) $ deadScalp cr
|
|
, colorSH (_skinUpper cskin) $ deadUpperBody cr
|
|
, rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
|
|
]
|
|
where
|
|
cskin = crShape $ _crType cr -- this should be fixed
|
|
crsize = 0.1 * crRad (cr ^. crType)
|
|
rotmdir = rotateSH (_crMvDir cr - _crDir cr)
|
|
|
|
chaseCorpse :: StdGen -> Creature -> Shape
|
|
chaseCorpse g cr = mconcat
|
|
[colorSH (_skinUpper cskin) . upperPrismPolyHalfMI 0 $ polyCirc 3 12
|
|
& each %~ vNormal
|
|
& each . _y *~ 0.6
|
|
, colorSH (_skinUpper cskin) . 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]))
|
|
, rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
|
|
]
|
|
where
|
|
neckq = (V3 6 0 0, Q.qz a)
|
|
(a,g') = randomR (-2,2) g
|
|
b = fst $ randomR (-2,2) g'
|
|
cskin = crShape $ _crType cr -- this should be fixed
|
|
rotmdir = rotateSH (_crMvDir cr - _crDir cr)
|
|
headq = neckq `Q.comp` (V3 16 0 0, Q.qz b )
|
|
|
|
crabCorpse :: StdGen -> Creature -> Shape
|
|
crabCorpse g cr = mconcat
|
|
[ colorSH (_skinUpper cskin) $ overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI 5 $ polyCirc 4 10
|
|
& each . _x *~ 0.6)
|
|
, colorSH (_skinUpper cskin) $ overPosSH (Q.apply lclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 20 0 (-2) 2)
|
|
<> overPosSH (Q.apply rclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 0 (-20) (-2) 2)
|
|
, colorSH (cskin ^?! skinLower) $
|
|
foldMap (mkfoot 5) (take 2 ps)
|
|
<> foldMap (mkfoot (-5)) (take 2 $ drop 2 ps)
|
|
, colorSH (_skinHead cskin)
|
|
(overPosSH (Q.apply headq) (upperPrismPolyHalfMI 1 $ square 2))
|
|
]
|
|
where
|
|
headq = torsoq `Q.comp` (V3 3 0 4, Q.qid)
|
|
torsoq = (V3 0 0 0,Q.qid)
|
|
lclawq = torsoq `Q.comp` (V3 2 8 1, Q.axisAngle (V3 1 0 0) (-0.1) * Q.qz la)
|
|
(la,g') = randomR (-2,2) g
|
|
ra = fst $ randomR (-2,2) g'
|
|
ps = evalState (replicateM 4 (randInCirc 9)) g
|
|
mkfoot y p =
|
|
let p' = 0 & _xy .~ p + V2 0 (3*y)
|
|
(q1,q2) = spiderJoint (V3 0 y 0) p'
|
|
in (afoot & each . sfVs . each %~ Q.apply (V3 0 y 0, q1))
|
|
<> (afoot & each . sfVs . each %~ Q.apply (p',q2))
|
|
afoot = upperPrismPolyST 10 $ polyCirc 3 2
|
|
rclawq = torsoq `Q.comp` (V3 2 (-8) 1, Q.axisAngle (V3 1 0 0) 0.1 * Q.qz ra)
|
|
cskin = crShape $ _crType cr -- this should be fixed
|
|
|
|
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)
|
|
|
|
barrelShape :: SPic
|
|
barrelShape = noPic $ cylinderPoly Medium Important (map (addZ 20) ps) (map (addZ 0) ps)
|
|
where
|
|
ps = polyCirc 3 10
|
|
|
|
lampCrSPic :: Float -> SPic
|
|
lampCrSPic h =
|
|
colorSH blue (upperBox Small Undesired h $ rectWH 5 5)
|
|
ST.:!: setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
|
|
|