{- |
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)