loop/src/Dodge/Creature/Action.hs

--{-# LANGUAGE TupleSections #-}
{- | Actions performed by creatures within the world
 -}
module Dodge.Creature.Action 
    ( performActions
    , stripNoItems
    , setMinInvSize
    , dropUnselected
    , dropExcept
    , dropItem
--    , startReloadingWeapon
    , blinkAction
    , blinkActionFail
    , unsafeBlinkAction
    , sizeSelf
--    , crAutoReload
    , copyInvItemToFloor
    , youDropItem
    , pickUpItem
    , pickUpItemID
    )
    where
import Dodge.FloatFunction
import Dodge.Inventory.Add
import Dodge.CreatureEffect
--import Dodge.ShortShow
import Dodge.Path
import Dodge.Default
import Dodge.WallCreatureCollisions
import Dodge.Creature.Stance.Data
import Dodge.WorldEvent.Shockwave
import Dodge.Data
import Dodge.Base
--import Dodge.Zone
import Dodge.SoundLogic
--import Dodge.WorldEvent
import Dodge.Inventory
import Dodge.FloorItem
--import Dodge.LightSources
import Geometry
import Picture
import qualified IntMapHelp as IM
import LensHelp

--import Control.Monad
--import Control.Applicative
import Data.Maybe
import Data.Bifunctor
import Data.List (findIndex)
--import qualified Data.Map as M
performActions :: World -> Creature -> Creature
performActions w cr = cr
    & crActionPlan . apImpulse .~ concat iss
    & crActionPlan . apAction .~ catMaybes mayas
  where
    (iss, mayas) = unzip $ map (performAction cr w) $ cr ^. crActionPlan . apAction

type OutAction = ( [Impulse] , Maybe Action )

performAimAt :: Creature -> World -> Int -> Point2 -> OutAction
performAimAt cr w tcid p = ([TurnToward tpos aimSp], Just $ AimAt tcid tpos)
  where
    cdir = _crDir cr
    cpos = _crPos cr
    canSee' = canSee (_crID cr) tcid w
    aimSp = case cr ^? crMvType . mvAimSpeed of
        Just f -> doFloatFloat f $ safeAngleVV (unitVectorAtAngle cdir) (tpos - cpos)
        Nothing -> error "creature without aiming type"
    tpos | canSee'   = _crPos (_creatures w IM.! tcid)
         | otherwise = p

performPathTo :: Creature -> World -> Point2 -> OutAction
performPathTo cr w p
    | dist cpos p <= _crRad cr = ([], Nothing)
    | isWalkable cpos p w = ([MvTurnToward p,MvForward,RandomTurn jit] , Just (PathTo p))
    | otherwise = case pointTowardsImpulse p cpos w of
        Just q -> ([MvTurnToward q
                ,MvForward
                ,RandomTurn jit
--                ,ArbitraryImpulseEffect . const 
--                    $ debugPicture .~ drawPathList cpos p w
                ] 
            , Just (PathTo p))
        _ -> ([],Nothing)
  where
    cpos = _crPos cr
    jit = _mvTurnJit $ _crMvType cr

performTurnToA :: Creature -> Point2 -> OutAction
performTurnToA cr p
    | angleVV cdirv dirv < 0.1 = ([], Nothing)
    | otherwise = ([MvTurnToward p,RandomTurn jit] , Just (TurnToPoint p))
  where
    cpos = _crPos cr
    cdirv = unitVectorAtAngle (_crDir cr)
    dirv = p -.- cpos
    jit = _mvTurnJit $ _crMvType cr

{- | Performing an action means that a creature has some impulses for a frame, and
 updates or deletes the action itself.
-- doAction -}
performAction :: Creature -> World -> Action -> OutAction
performAction cr w ac = case ac of
    ActionNothing -> ([],Nothing)
    LabelAction str subAc -> second (fmap (LabelAction str)) $ performAction cr w subAc
    AimAt tcid p -> performAimAt cr w tcid p
    WaitThen 0 newAc -> ([] , Just newAc)
    WaitThen t newAc -> ([] , Just (WaitThen (t-1) newAc))
    ImpulsesList (xs:xss) -> (xs, Just $ ImpulsesList xss)
    ImpulsesList _  -> ([], Nothing)
    DoImpulses imps -> (imps, Nothing)
    DoActionThen fsta afta -> case performAction cr w fsta of
        (imps , Just nxta) -> (imps, Just (DoActionThen nxta afta))
        (imps , Nothing  ) -> (imps, Just afta)
    DoActionWhile f act -> performAction cr w $ DoActionWhilePartial act f act
    DoActionWhilePartial partAc f resetAc
        | doWdCrBl f w cr -> case performAction cr w partAc of
            (imps, Just nxta) -> (imps, Just $ DoActionWhilePartial nxta f resetAc)
            (imps, Nothing)   -> (imps, Just $ DoActionWhilePartial resetAc f resetAc)
        | otherwise -> performAction cr w partAc
    DoActionIf f ifa
        | doWdCrBl f w cr -> performAction cr w ifa
        | otherwise -> ([],Nothing)
    DoActionIfElse ifa f elsea
        | doWdCrBl f w cr -> performAction cr w ifa
        | otherwise -> performAction cr w elsea
    DoActionWhileInterrupt repa f afta
        | doWdCrBl f w cr -> (fst $ performAction cr w repa, Just $ DoActionWhileInterrupt repa f afta)
        | otherwise -> performAction cr w afta
    DoActions [] -> ([], Nothing)
    DoActions acs -> 
        let (imps, newAcs) = unzip $ map (performAction cr w) acs
        in (concat imps, Just . DoActions $ catMaybes newAcs)
    StartSentinelPost -> ([AddGoal $ SentinelAt (_crPos cr) (_crDir cr)], Nothing)
    PathTo p -> performPathTo cr w p
    TurnToPoint p -> performTurnToA cr p
    LeadTarget p -> case cr ^? crIntention . targetCr . _Just of
        Just tcr -> ([TurnTo (_crPos tcr +.+ rotateV (_crDir tcr) p)], Nothing)
        _        -> ([], Nothing)
    UseTarget f -> performAction cr w $ doMCrAc f $ cr ^? crIntention . targetCr . _Just
    UseSelf f   -> performAction cr w $ doCrAc f cr
    UseAheadPos f -> performAction cr w (doP2Ac f (_crPos cr +.+ 20 *.* unitVectorAtAngle (_crDir cr)))
    UseMvTargetPos f -> performAction cr w $ doMP2Ac f $ _mvToPoint $ _crIntention cr
    ArbitraryAction f -> performAction cr w (doCrWdAc f cr w)
    DoImpulsesAlongside sideImp mainAc -> case performAction cr w mainAc of
        (imp, Just nxtac) -> (sideImp ++ imp, Just $ DoImpulsesAlongside sideImp nxtac)
        (imp, _)          -> (sideImp ++ imp, Nothing)
    DoReplicate t nxtac -> performAction cr w $ DoReplicatePartial nxtac t nxtac
    DoReplicatePartial _   0 pac -> performAction cr w pac
    DoReplicatePartial startac t partac -> case performAction cr w partac of
        (imps , Just nextac) -> (imps, Just $ DoReplicatePartial startac t nextac)
        (imps , _)        -> (imps, Just $ DoReplicatePartial startac (t-1) startac)
    NoAction -> ([],Nothing)

{- | Like a blink action, but no ingoing distortion -}
blinkActionFail
    :: Creature
    -> World 
    -> World
blinkActionFail cr w = w
    & soundMultiFrom [TeleSound 0,TeleSound 1] p3 teleS Nothing
    & distortions .:~ distortionBulge
    & creatures . ix cid . crPos .~ p3
    & inverseShockwaveAt cpos 40 2 2
  where
    distR = 120
    distortionBulge = RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR) 1.9
    cid  = _crID cr
    p1 = mouseWorldPos w
    cpos = _crPos cr
    p2 = bouncePoint (const True) 1 cpos p1 w
    r  = 1.5 * _crRad cr
    p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2

{- | Teleport a creature to the mouse position -}
blinkAction :: Creature -> World -> World
blinkAction cr w = w
    & soundMultiFrom [TeleSound 0,TeleSound 1] p3 teleS Nothing
    & distortions .++~ distortionBulge 
    & creatures . ix cid . crPos .~ p3
    & blinkShockwave cid p3
    & inverseShockwaveAt cpos 40 2 2
  where
    distR = 120
    distortionBulge = 
        [RadialDistortion p3   (p3 +.+ V2 distR 0)   (p3 +.+ V2 0 distR)   0.1
        ,RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR) 1.9
        ]
    cid  = _crID cr
    p1 = mouseWorldPos w
    cpos = _crPos cr
    p2 = bouncePoint (const True) 1 cpos p1 w
    r  = 1.5 * _crRad cr
    p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2

{- | Teleport a creature to the mouse position.
Can go through walls, if ending up in wall does big damage. -}
unsafeBlinkAction 
    :: Creature
    -> World 
    -> World
unsafeBlinkAction cr w 
    | success = soundMultiFrom [TeleSound 0,TeleSound 1] mwp teleS Nothing
        . over distortions (distortionBulge ++)
        . set (creatures . ix cid . crPos) mwp
        . blinkShockwave cid mwp
        $ inverseShockwaveAt cpos 40 2 2 w
    | otherwise = w 
        & blinkActionFail cr
        & creatures . ix cid . crState . csDamage .:~
            Damage ENTERREMENT 10000 mwp mwp mwp NoDamageEffect
  where
    success = fromMaybe True $ do
        wl <- snd $ collidePointWallsFilterStream (const True) mwp cpos w
        return (isLHS mwp `uncurry` _wlLine wl)
    distR = 120
    distortionBulge = 
        [RadialDistortion mwp   (mwp +.+ V2 distR 0) (mwp +.+ V2 0 distR)  0.1
        ,RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR) 1.9
        ]
    cid  = _crID cr
    mwp = mouseWorldPos w
    cpos = _crPos cr

blinkShockwave 
    :: Int      -- ^ Blinking creature ID.
    -> Point2 
    -> World 
    -> World
blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan 

setMinInvSize :: Int -> Creature -> World -> World
setMinInvSize n cr = creatures . ix (_crID cr) . crInvCapacity .~ n

-- maybe this should be removed...
stripNoItems :: Creature -> World -> World
stripNoItems cr = organiseInvKeys (_crID cr) .
    ( creatures . ix (_crID cr) . crInv %~ IM.mapMaybe Just )

organiseInvKeys :: Int -> World -> World
organiseInvKeys cid w = w & creatures . ix cid %~
    ( ( crInvSel . iselPos .~ newSelKey ) 
    . ( crInv .~ newInv ) 
    . ( crInvSel . iselAction .~ NoInvSelAction) )
  where
    cr  = _creatures w IM.! cid
    pairs = IM.toList (_crInv cr)
    newSelKey = fromMaybe 0 $ findIndex ( (== crSel cr) . fst) pairs
    newInv = IM.fromAscList $ zip [0..] $ map snd pairs

dropUnselected :: Creature -> World -> World
dropUnselected cr w = foldr (dropItem cr) w . IM.keys 
    $ crSel cr `IM.delete` _crInv cr 

dropExcept :: Creature -> Int -> World -> World
dropExcept cr invid w = foldr (dropItem cr) w . IM.keys 
    $ invid `IM.delete` _crInv cr 

dropItem :: Creature -> Int -> World -> World
dropItem cr invid = rmInvItem cid invid . copyInvItemToFloor cr invid -- . mayberemoveequip
  where
    cid = _crID cr
-- the following should be done in rmInvItem
--    mayberemoveequip = case _crLeftInvSel cr of
--        Just i | i == invid -> creatures . ix cid . crLeftInvSel .~ Nothing
--        _ -> id

youDropItem :: World -> World
youDropItem w 
    | _crInvLock (you w) = w
    | otherwise = youDropItem' w

{- | Get your creature to drop the item under the cursor.  -}
youDropItem' :: World -> World
youDropItem' w = case yourItem w ^? _Just . itCurseStatus of
    Just Uncursed -> w
        & dropItem cr (crSel cr) 
        & soundStart (CrSound (_crID cr)) (_crPos cr) whiteNoiseFadeOutS Nothing
    _ -> w
  where
    cr = you w

{- | Copy an inventory item to the floor.  -}
copyInvItemToFloor :: Creature -> Int -> World -> World
copyInvItemToFloor cr i = copyItemToFloor (_crPos cr) 
    $ _crInv cr IM.! i 
        & itIsHeld .~ False

sizeSelf :: Float -> Creature -> World -> Maybe World
sizeSelf x cr w 
    -- | _crPos cr1 == _crPos cr2 = Just $ w
    | not (crOnWall cr1 w) = Just $ w
        & soundMultiFrom [TeleSound 0,TeleSound 1] cpos teleS Nothing
        & over distortions (distortionBulge :)
        & creatures . ix cid %~ 
            ( (crRad .~ 10 * x) 
            . (crMvType . mvSpeed .~ yourDefaultSpeed * x)
            . (crStance . strideLength .~ ceiling (fromIntegral yourDefaultStrideLength * x))
            )
    | otherwise = Nothing
  where
    cr1 = colCrWall w (cr {_crRad = 10* x})
    distR = 120
    distortionBulge 
        | _crRad cr < 10*x  = raddist 1.9
        | otherwise         = raddist 0.1
    raddist = RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR)
    cid  = _crID cr
    cpos = _crPos cr

pickUpItemID :: Int -> Int -> World -> World
pickUpItemID cid flid w = pickUpItem cid (_floorItems w IM.! flid) w

{- | Pick up a specific item. -}
pickUpItem :: Int -> FloorItem -> World -> World
pickUpItem cid flit w = maybe w (soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing . snd)
    $ tryPutItemInInv cid flit w