loop/src/Dodge/Item/Weapon/ExtraEffect.hs

--{-# LANGUAGE BangPatterns #-}
{- |
Extra weapon effects, supplementing explicit use effects.
 -}
module Dodge.Item.Weapon.ExtraEffect
    (-- itemLaserScopeEffect
     autoSonarEffect
    , autoEffect
    , autoRadarEffect
    , targetRBPress
    , targetRBCreature
    , targetCursor
    , targetLaser
--    , rbSetTarget
    ) where
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
--import Dodge.Item.Weapon.Decoration
import Dodge.Item.Weapon.UseEffect
import Dodge.Item.Weapon.LaserPath
--import Dodge.Item.Attachment.Data
import Dodge.Creature.Test
import Dodge.WorldEvent.HelperParticle
import Picture
import Geometry.Vector
import Geometry.Data
import LensHelp
import qualified FoldlHelp as L
import Sound.Data

--import Data.Bifunctor
import Data.Maybe
--import qualified Control.Foldl as L
import qualified Data.Set as S
import qualified SDL
autoEffect :: (Item -> Creature -> World -> World) -> Int -> SoundID -> Item -> Creature -> World -> World
autoEffect eff t sid itm cr w
    | _eparamInt (_eqParams (_itUse itm)) < 1 = eff itm cr w 
        & creatures . ix (_crID cr) . crInv . ix (fromJust $ _itInvPos itm)
                                     . itUse . eqParams . eparamInt .~ t
       & soundStart OnceSound (_crPos cr) sid Nothing
    | otherwise = w 
        & creatures . ix (_crID cr) . crInv . ix (fromJust $ _itInvPos itm)
                                     . itUse . eqParams . eparamInt -~ 1

{- | Automatically send out radar pulses that detect walls.  -}
autoRadarEffect :: Item -> Creature -> World -> World
autoRadarEffect = autoEffect (const aWallPulse) 100 click1S
{- | Automatically send out sonar pulses that detect creatures.  -}
autoSonarEffect :: Item -> Creature -> World -> World
autoSonarEffect = autoEffect (const aSonarPulse) 50 click1S
defaultTargeting :: Targeting
defaultTargeting = Targeting
    { _tgPos = Nothing
    , _tgUpdate = \_ _ w t -> (w,t)
    , _tgDraw = \_ _ _ _ -> mempty
    , _tgID = Nothing
    , _tgActive = False
    }
targetLaser :: Targeting
targetLaser = defaultTargeting
    & tgUpdate  .~ targetLaserUpdate
targetRBPress :: Targeting
targetRBPress = defaultTargeting
    & tgUpdate  .~ targetUpdateWith targetRBPressUpdate
    & tgDraw    .~ targetSimpleDraw
targetRBCreature :: Targeting
targetRBCreature = defaultTargeting
    & tgUpdate  .~ targetRBCreatureUp 
    & tgDraw    .~ targetRBCreatureDraw

targetCursor :: Targeting
targetCursor = defaultTargeting
    & tgUpdate  .~ targetUpdateWith targetCursorUpdate
    & tgDraw    .~ targetSimpleDraw

targetDraw :: (Item -> Picture) -> Int -> Item -> Creature -> Configuration -> World -> Picture
targetDraw f _ it _ cfig w = fromMaybe mempty $ do
    p <- it ^? itTargeting . tgPos . _Just
    return $ winScale cfig 
        $ setLayer FixedCoordLayer 
        $ color white 
        $ uncurryV translate (worldPosToScreen w p)
        $ f it
targetSimpleDraw :: Int -> Item -> Creature -> Configuration -> World -> Picture
targetSimpleDraw = targetDraw $ const activeTargetCursorPic
targetRBCreatureUp :: Item -> Creature -> World -> Targeting -> (World, Targeting)
targetRBCreatureUp it cr w t
    | not $ _itIsHeld it = (w, t   
        & tgID .~ Nothing
        & tgPos .~ Nothing
        & tgActive .~ False
        )
    | SDL.ButtonRight `S.member` _mouseButtons w && isJust (t ^? tgID . _Just)
        && canSeeTarget = (w, t & updatePos
        & tgActive .~ True
        )
    | otherwise = (w, t & tgID .~ fmap _crID newtarg
        & updatePos
        & tgActive .~ False 
        )
  where
    newtarg = L.fold 
        (L.prefilter (canseepos . _crPos) $ L.minimumOn (dist mwp . _crPos)) 
        $ creaturesNearPointI 3 mwp w
    canseepos p = hasLOS (_crPos cr) p w
    mwp = mouseWorldPos w
    updatePos t' = t' & tgPos .~ posFromMaybeID (_tgID t')
    posFromMaybeID Nothing = Nothing
    posFromMaybeID (Just i) = w ^? creatures . ix i . crPos
    canSeeTarget = fromMaybe False $ do
        cid <- t ^? tgID . _Just
        cpos <- w ^? creatures . ix cid . crPos
        Just $ hasLOS cpos (_crPos cr) w

targetRBCreatureDraw :: Int -> Item -> Creature -> Configuration -> World -> Picture
targetRBCreatureDraw = targetDraw thepic
  where
    thepic it | _tgActive $ _itTargeting it = activeTargetCursorPic
        | otherwise = targetCursorPic

activeTargetCursorPic :: Picture
activeTargetCursorPic = pictures
    [rotate a $ line [V2 15 0,V2 10 0] <> targCorner | a <- [0,0.5*pi,pi,1.5*pi]]

targetCursorPic :: Picture
targetCursorPic = pictures
    [rotate a targCorner | a <- [0,0.5*pi,pi,1.5*pi]]
targCorner :: Picture
targCorner = pictures
    [line [V2   x  x, V2 x (x-y)]
    ,line [V2   x  x, V2 (x-y) x]
    ]
  where
    x = 10
    y = 5

targetUpdateWith :: (World -> Targeting -> Targeting)
    -> Item -> Creature -> World -> Targeting -> (World,Targeting)
targetUpdateWith f it _ w t 
    | _itIsHeld it = (w, f w t)
    | otherwise    = (w,t)

targetCursorUpdate :: World -> Targeting -> Targeting
targetCursorUpdate w t
    | SDL.ButtonRight `S.member` _mouseButtons w = t
        & tgPos . _Just .~ mouseWorldPos w
        & tgActive .~ True
    | otherwise = t & tgPos %~ const Nothing
        & tgActive .~ False

targetRBPressUpdate :: World -> Targeting -> Targeting
targetRBPressUpdate w t
    | SDL.ButtonRight `S.member` _mouseButtons w = t
        & tgPos %~ maybe (Just $ mouseWorldPos w) Just
        & tgActive .~ True
    | otherwise = t & tgPos %~ const Nothing
        & tgActive .~ False

targetLaserUpdate :: Item -> Creature -> World -> Targeting -> (World,Targeting)
targetLaserUpdate it cr w t
    | crIsAiming cr = (addLaserPic w,t
        & tgPos    .~ fmap fst mp
        & tgActive .~ True
        )
    | otherwise = (w,t & tgPos %~ const Nothing
        & tgActive .~ False
        )
  where
    (mp, ps) = reflectLaserAlong 0.2 [] sp ep w
    sp = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr)
    ep = sp +.+ 5000 *.* normalizeV (mouseWorldPos w -.- sp)
    addLaserPic = instantParticles .:~ Particle
        { _ptDraw = const $ setLayer BloomNoZWrite $ pictures
            [ setDepth 19   . color (brightX 0 0.5 col) $ thickLine 5 (sp:ps)
            , setDepth 19.5 . color (brightX 5 1 col)  $ thickLine 1  (sp:ps)
            ]
        , _ptUpdate = ptSimpleTime 1
        }
    wpammo = _itConsumption it
    reloadFrac 
        | _ammoLoaded wpammo == 0 = 1
        | otherwise = case _reloadState wpammo of
            Just' rs -> fromIntegral rs / fromIntegral (_reloadTime wpammo)
            Nothing' -> 1
    col = mixColors reloadFrac (1-reloadFrac) blue red