215 lines
7.4 KiB
Haskell
215 lines
7.4 KiB
Haskell
--{-# LANGUAGE BangPatterns #-}
|
|
{- |
|
|
Extra weapon effects, supplementing explicit use effects.
|
|
-}
|
|
module Dodge.Item.Weapon.ExtraEffect
|
|
(-- itemLaserScopeEffect
|
|
autoSonarEffect
|
|
, autoEffect
|
|
, autoRadarEffect
|
|
, targetRBPress
|
|
, targetRBCreature
|
|
, targetCursor
|
|
, targetLaser
|
|
, targetDistanceDraw
|
|
-- , rbSetTarget
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Dodge.Zone
|
|
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 Sound.Data
|
|
import ShortShow
|
|
|
|
import qualified Data.Map.Strict as M
|
|
--import Data.Bifunctor
|
|
import Data.Maybe
|
|
--import qualified Control.Foldl as L
|
|
import qualified Streaming.Prelude 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 (_eqEq $ _itUse itm)) < 1 = eff itm cr w
|
|
& creatures . ix (_crID cr) . crInv . ix (_ipInvID $ _itPos itm)
|
|
. itUse . eqEq . eqParams . eparamInt .~ t
|
|
& soundStart OnceSound (_crPos cr) sid Nothing
|
|
| otherwise = w
|
|
& creatures . ix (_crID cr) . crInv . ix (_ipInvID $ _itPos itm)
|
|
. itUse . eqEq . 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) -> 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 :: Item -> Creature -> Configuration -> World -> Picture
|
|
targetSimpleDraw = targetDraw $ const activeTargetCursorPic
|
|
|
|
targetDistanceDraw :: Item -> Creature -> Configuration -> World -> Picture
|
|
targetDistanceDraw itm _ cfig w = fromMaybe mempty $ do
|
|
p <- itm ^? itTargeting . tgPos . _Just
|
|
let p1 = worldPosToScreen w p
|
|
mwp = mouseWorldPos w
|
|
p2 = worldPosToScreen w mwp
|
|
thecol = if dist p mwp > 100 then red else white
|
|
return $ winScale cfig
|
|
$ setLayer FixedCoordLayer
|
|
$ color thecol
|
|
$ line [p1, p2]
|
|
<> transMidLine p1 p2 (scale 0.1 0.1 . text . shortShow $ dist p mwp)
|
|
|
|
transMidLine :: Point2 -> Point2 -> Picture -> Picture
|
|
transMidLine p1 p2 = translate 20 (f p1 p2) . uncurryV translate (0.5 *.* (p1 +.+ p2))
|
|
where
|
|
f (V2 x y) (V2 x' y')
|
|
| y > y' && x > x' = max (-10) (x'-x)
|
|
| y > y' && x < x' = min 10 (x'-x)
|
|
| x > x' = min 10 (x-x')
|
|
| otherwise = max (-10) (x-x')
|
|
|
|
|
|
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 `M.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 = minStreamOn (dist mwp . _crPos)
|
|
. S.filter (canseepos . _crPos)
|
|
$ crsInsideCirc mwp 40 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 :: 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 `M.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 `M.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 _ 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
|
|
-- | _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
|