{- |
Drawing of creatures.
Takes into account damage etc.
-}
module Dodge.Creature.Picture (
    makeCorpse,
    drawCreature,
) where

import Control.Lens
import Control.Monad
import Data.Foldable
import qualified Data.IntMap.Strict as IM
import Data.Maybe
import qualified Data.Strict.Tuple as ST
import Dodge.Base.Collide
import Dodge.Creature.HandPos
import Dodge.Creature.Radius
import Dodge.Creature.Shape
import Dodge.Creature.Slime
import Dodge.Damage
import Dodge.Data.Equipment.Misc
import Dodge.Data.World
import Dodge.Item.Draw
import Dodge.Item.Grammar
import Geometry
import Geometry.Zone
import Linear
import Picture
import qualified Quaternion as Q
import RandomHelp
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 w m cr
        SwarmCrit -> basicCrPict w m cr
        AutoCrit -> basicCrPict w m cr
        CrabCrit{} -> noPic $ drawCrabCrit w cr
        HoverCrit{} -> noPic $ drawHoverCrit cr
        SlinkCrit{} -> noPic $ drawSlinkCrit cr
        SlimeCrit{} -> noPic $ drawSlimeCrit cr
        BeeCrit{} -> noPic $ drawBeeCrit cr
        HiveCrit{} -> drawHive
  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 Typical (cr ^?! crType . slimeEngulfProgress + min 15 r) ps
  where
    r = slimeToRad $ cr ^?! crType . slimeSlime - cr ^?! crType . slimeSlimeChange
    so = slimeOutline cr
    ps = fromMaybe so $ do
        SlimeDistortion x' qs _ <- cr ^? crType . slimeDistortion
        let x = fromIntegral x'
        guard $ length qs == 12
        return $ zipWith (+) (fmap (0.1 * (10 - x) *^) so) (fmap (0.1 * x *^) qs)

basicCrPict :: World -> IM.IntMap Item -> Creature -> SPic
basicCrPict w m cr = drawEquipment w m cr <> noPic (basicCrShape w cr)

basicCrShape :: World -> Creature -> Shape
basicCrShape w cr =
    scaleSH (V3 crsize crsize crsize) $
        mconcat
            [ colorSH (_skinHead cskin) . overPosSH (translateToES w cr OnHead) $ scalp
            , colorSH (_skinUpper cskin) $ upperBody w 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)
        <> shead
        & each . sfColor .~ cskin ^?! skinUpper
  where
    shead =
        polyCirc 6 15
            & upperPrismPoly Medium Important 10
            & each . sfVs . each %~ Q.apply (cr ^?! crType . slinkHeadPos)
    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 15

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)

drawHive :: SPic
drawHive = noPic $ upperPrismPolyHalfMI 25 $ polyCirc 6 20

drawBeeCrit :: Creature -> Shape
drawBeeCrit cr =
    colorSH
        col
        (f . upperPrismPolyHalfMI 3 $ polyCirc 6 r)
        <> colorSH (dark col) (overPosSH (Q.apply beakpos) $ upperPrismPolyHalfST 1 [V2 0 (-2), V2 4 0, V2 0 2])
  where
    r = cr ^. crType . to crRad
    beakpos = (V3 (r - 1) 0 0, Q.qid)
    col | cr ^?! crType . beeAggro > 0 = red
        | otherwise = yellow
    f   | Mounted{} <- cr ^. crStance . carriage =
            each.sfVs.each._y *~ g (modTo 1 $ cr ^?! crType . beeSlime . to ((/ 100) . fromIntegral))
        | otherwise = id
    g x | x > 0.5 = 2 - x
        | otherwise = 1 + x

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) lneckshape
        <> overPosSH (Q.apply neckq2) uneckshape
        )
        <> colorSH
--            (_skinHead cskin)
            yellow headshape
  where
    --    time = fromIntegral (mod (w ^. unpauseClock) 100) / 5
    tz = 4
    cskin = crShape $ _crType cr
    torsoq = (V3 0 0 (10 + tz + tbob), Q.qy (-cr ^?! crType . chaseqy0))
    mcool = 1 - min 10 (fromIntegral . _meleeCooldown $ _crType cr) / 10
--    (qy1,qy2,qy3)  
----        | CloseToMelee i <- cr ^?!crActionPlan.apStrategy
----            = (0,0,0)
--        | otherwise = (pi/3,-2*pi/3,pi/3)
--        | otherwise = (pi * w^.cWorld.cClock.to ((*0.01).fromIntegral),0,0)
--        | otherwise = (-1.8 * mcool , 0, 2 * mcool + vocaltilt)
    qy1 = cr ^?! crType . chaseqy1
    qy2 = cr ^?! crType . chaseqy2
    qy3 = cr ^?! crType . chaseqy3
    lneckshape = colorSH red $ upperPrismPolyHalfMI 4 (vNormal <$> trapTBH 2 5 (nlen/4))
        & each . sfVs . each +~ V3 (nlen/4) 0 (-2)
    uneckshape = colorSH green $ upperPrismPolyHalfMI 3 (vNormal <$> trapTBH 3 2 (nlen/4))
        & each . sfVs . each +~ V3 (nlen/4) 0 (-1.5)
    headshape = overPosSH (Q.apply headq) (upperBox Medium Important 2 [V2 0 (-4), V2 9 0, V2 0 4])
    neckq = torsoq `Q.comp` (V3 8 0 4, Q.qz aimrot * Q.qy (pi + qy1))
    neckq2 = neckq `Q.comp` (V3 (nlen/2) 0 0, Q.qy qy2)
    headq = neckq2 `Q.comp` (V3 (nlen/2) 0 0, Q.qy (pi + qy3) * Q.qz aimrot)
    nlen = 16
    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

{- NECK ARTICULATION   
Viewed from side, all hinges, torso/lower neck also hinges in Q.qz (not shown)
    na1 na2 na3    <- angles, in diagram all == 0, in Q.qy
     |   |   |
  ---.---.---.---       z
   |   |   |   |        ^>x                           
 torso | u.neck|                                   
     l.neck   head                  
Rough examples
Flat aim:           Resting:
                        .\\
                        \  \\
      .                  .
     / \                /
 ---.   .---        ---.
a1 = 60             a1 = 60
a2 = -120           a2 = 60
a3 = 60             a3 = -160
-}

--ikTwoArms :: Point3 -> Point3 -> Point3 -> Point3 -> (QFloat,QFloat)
--ikTwoArms 

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)
  where
    -- spiderJoint p q = (Q.qz c, Q.axisAngle (V3 0 (-1) 0) $ a)

    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 :: World -> StdGen -> Creature -> SPic
makeCorpse w g cr = case cr ^. crType of
    HoverCrit{} -> noPic $ drawHoverCrit cr
    ChaseCrit{} -> noPic $ chaseCorpse g cr
    CrabCrit{} -> noPic $ crabCorpse g cr
    BeeCrit{} -> noPic $ drawBeeCrit cr
    _ ->
        noPic
            . scaleSH (V3 crsize crsize crsize)
            $ mconcat
                [ colorSH (_skinHead cskin) $ deadScalp cr
                , colorSH (_skinUpper cskin) $ deadUpperBody w 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 :: World -> Creature -> Shape
{-# INLINE arms #-}
arms w cr =
    (^. _1) $
        translateToRightHand w cr aHand
            <> translateToLeftHand w 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 :: World -> Creature -> Shape
{-# INLINE torso #-}
torso w cr = overPosSH (translateToES w 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 :: World -> Creature -> Shape
deadUpperBody w cr = deadRot cr . translateSHz (negate 10) . upperBody w $ 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 :: World -> Creature -> Shape
{-# INLINE upperBody #-}
upperBody w cr = arms w cr <> torso w cr

drawEquipment :: World -> IM.IntMap Item -> Creature -> SPic
{-# INLINE drawEquipment #-}
drawEquipment w m cr = foldMap (itemEquipPict w 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)