120 lines
4.3 KiB
Haskell
120 lines
4.3 KiB
Haskell
module Dodge.Targeting (
|
|
updateTargeting,
|
|
) where
|
|
|
|
import Color
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Dodge.Base.Collide
|
|
import Dodge.Base.Coordinate
|
|
import Dodge.Creature.Test
|
|
import Dodge.Data.World
|
|
import Dodge.Item.Weapon.LaserPath
|
|
import Dodge.Zoning.Creature
|
|
import FoldableHelp
|
|
import Geometry.Vector
|
|
import LensHelp
|
|
import qualified SDL
|
|
|
|
updateTargeting :: Maybe TargetType -> Creature -> World -> World
|
|
updateTargeting tu = case tu of
|
|
Nothing -> clearTargeting
|
|
Just TargetLaser -> targetLaserUpdate'
|
|
Just TargetRBPress -> upCT (flip targetRBPressUpdate . _crTargeting)
|
|
Just TargetRBLine -> upCT (flip targetRBPressUpdate . _crTargeting)
|
|
Just TargetRBCreature -> upCT targetRBCreatureUp
|
|
Just TargetCursor -> upCT (flip targetCursorUpdate . _crTargeting)
|
|
|
|
clearTargeting :: Creature -> World -> World
|
|
clearTargeting cr = cWorld . lWorld . creatures . ix (_crID cr) . crTargeting .~ defaultTargeting
|
|
|
|
defaultTargeting :: CreatureTargeting
|
|
defaultTargeting = CreatureTargeting Nothing Nothing Nothing False
|
|
|
|
upCT :: (Creature -> World -> CreatureTargeting) -> Creature -> World -> World
|
|
upCT f cr w = w & cWorld . lWorld . creatures . ix (_crID cr) . crTargeting .~ f cr w
|
|
|
|
targetRBCreatureUp :: Creature -> World -> CreatureTargeting
|
|
targetRBCreatureUp cr w
|
|
| SDL.ButtonRight `M.member` _mouseButtons (_input w) && isJust (t ^? ctID . _Just)
|
|
&& canSeeTarget =
|
|
t & updatePos & ctActive .~ True
|
|
& ctType ?~ TargetRBCreature
|
|
| otherwise = t & ctID .~ fmap _crID newtarg & updatePos & ctActive .~ False
|
|
& ctType ?~ TargetRBCreature
|
|
where
|
|
t = _crTargeting cr
|
|
newtarg =
|
|
safeMinimumOn (dist mwp . _crPos)
|
|
. filter (canseepos . _crPos)
|
|
$ crsNearCirc mwp 40 w
|
|
canseepos p = hasLOS (_crPos cr) p w
|
|
mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos)
|
|
updatePos t' = t' & ctPos .~ posFromMaybeID (_ctID t')
|
|
posFromMaybeID Nothing = Nothing
|
|
posFromMaybeID (Just i) = w ^? cWorld . lWorld . creatures . ix i . crPos
|
|
canSeeTarget = fromMaybe False $ do
|
|
cid <- t ^? ctID . _Just
|
|
cpos <- w ^? cWorld . lWorld . creatures . ix cid . crPos
|
|
Just $ hasLOS cpos (_crPos cr) w
|
|
|
|
targetCursorUpdate :: World -> CreatureTargeting -> CreatureTargeting
|
|
targetCursorUpdate w ct =
|
|
ct
|
|
& ctPos . _Just .~ mouseWorldPos (w ^. input) (w ^. cWorld . camPos)
|
|
& ctActive .~ True
|
|
& ctType ?~ TargetCursor
|
|
|
|
targetRBPressUpdate :: World -> CreatureTargeting -> CreatureTargeting
|
|
targetRBPressUpdate w t
|
|
| SDL.ButtonRight `M.member` _mouseButtons (_input w) =
|
|
t
|
|
& ctPos %~ maybe (Just $ mouseWorldPos (w ^. input) (w ^. cWorld . camPos)) Just
|
|
& ctActive .~ True
|
|
& ctType ?~ TargetRBPress
|
|
| otherwise =
|
|
t
|
|
& ctPos %~ const Nothing
|
|
& ctActive .~ False
|
|
& ctType ?~ TargetRBPress
|
|
|
|
targetLaserUpdate' :: Creature -> World -> World
|
|
targetLaserUpdate' cr w =
|
|
let (w', ct') = targetLaserUpdate cr w (_crTargeting cr)
|
|
in w' & cWorld . lWorld . creatures . ix (_crID cr) . crTargeting .~ ct'
|
|
|
|
targetLaserUpdate :: Creature -> World -> CreatureTargeting -> (World, CreatureTargeting)
|
|
targetLaserUpdate cr w t
|
|
| crIsAiming cr =
|
|
( addLaserPic w
|
|
, t
|
|
& ctPos .~ fmap fst mp
|
|
& ctActive .~ True
|
|
& ctType ?~ TargetLaser
|
|
)
|
|
| otherwise =
|
|
( w
|
|
, t & ctPos %~ const Nothing
|
|
& ctActive .~ False
|
|
)
|
|
where
|
|
(mp, _) = reflectLaserAlong 0.2 sp ep w
|
|
sp = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr)
|
|
ep = sp +.+ 5000 *.* normalizeV (mouseWorldPos (w ^. input) (w ^. cWorld . camPos) -.- sp)
|
|
addLaserPic =
|
|
cWorld . lWorld . lasers
|
|
.:~ LaserStart
|
|
{ _lpPhaseV = 1
|
|
, _lpDir = _crDir cr
|
|
, _lpPos = sp
|
|
, _lpColor = col
|
|
, _lpType = TargetingLaser
|
|
}
|
|
--wpammo = _itConsumption it
|
|
-- reloadFrac
|
|
-- | _laLoaded wpammo == 0 = 1
|
|
-- | otherwise = case _laTransfer wpammo of
|
|
-- Transfer _ rs -> fromIntegral rs / fromIntegral (_laReloadTime wpammo)
|
|
-- NoTransfer -> 1
|
|
col = blue -- mixColors reloadFrac (1-reloadFrac) blue red
|