loop/src/Dodge/Creature/Picture.hs

{- |
Drawing of creatures.
Takes into account damage etc.
-}
module Dodge.Creature.Picture (
    basicCrPict,
    deadScalp,
    deadUpperBody,
    deadFeet,
) where

import Shape
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 Geometry
import Picture
import qualified Quaternion as Q
--import Shape
import ShapePicture

basicCrPict :: Creature -> SPic
basicCrPict cr = uncurryV translateSPxy (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr) 
    <> (basicCrShape cr, mempty)

--testShape :: Shape
--testShape = translateSHz 10 . rotateSHx 1 . upperCylinder 20 $ polyCirc 2 10

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) ->
        mconcat
            [ translateSHxy (f sa) off aFoot
            , translateSHxy (- f sa) (- off) aFoot
            ]
    Just (Walking sa RightForward) ->
        mconcat
            [ translateSHxy (- f sa) off aFoot
            , translateSHxy (f sa) (- off) aFoot
            ]
    _ ->
        mconcat
            [ translateSHxy 0 off aFoot
            , translateSHxy 0 (- off) aFoot
            ]
  where
    aFoot :: Shape
    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 
--cr = case cr ^? crStance . carriage of
--    Just (Walking sa LeftForward) ->
--        mconcat
--            [ translateSHxy (f sa) off aFoot
--            , translateSHxy (- f sa) (- off) aFoot
--            ]
--    Just (Walking sa RightForward) ->
--        mconcat
--            [ translateSHxy (- f sa) off aFoot
--            , translateSHxy (f sa) (- off) aFoot
--            ]
--    _ ->
--        mconcat
--            [ translateSHxy 0 off aFoot
--            , translateSHxy 0 (- off) aFoot
--            ]
--  where
--    aFoot :: Shape
--    aFoot = upperPrismPolyT 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
  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 =
    mconcat
        [ arms cr
        , shoulderSH $ torso cr
        ]

shoulderSH :: Shape -> Shape
shoulderSH = translateSHz 20

drawEquipment :: Creature -> SPic
{-# INLINE drawEquipment #-}
drawEquipment cr = foldMap (itemEquipPict cr) (_crInv cr)