loop/src/Dodge/Beam.hs

module Dodge.Beam where
import Dodge.Data
import Dodge.Particle.Flame
import Dodge.Particle.TeslaArc
import Dodge.Item.Location
import Dodge.WorldEvent.Damage
--import Dodge.WorldEvent.ThingsHit
import Dodge.WorldEvent.HelperParticle
import Dodge.Item.Weapon.LaserPath
import Geometry
import LensHelp
import Picture
import RandomHelp
--import Dodge.Zone
import Dodge.Base.Collide
import Shape

import Data.List (sortOn)
import MonadHelp
import Data.Maybe
import qualified Data.IntMap.Strict as IM

flameBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam))
    -> World -> World
flameBeamCombine (p,(a,b,_),(x,y,_))
    = makeFlame p (2 *.* normalizeV (normalizeV (b-.-a)+.+normalizeV (y-.-x)))
lasBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam))
    -> World -> World
lasBeamCombine (p,(a,b,_),(x,y,_)) 
    = instantParticles .:~ lasRayAt yellow 11 1 p (argV (normalizeV (b-.-a)+.+normalizeV (y-.-x)))

splitBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam))
    -> World -> World
splitBeamCombine (p,(a,b,_),(x,y,_)) 
    = (instantParticles .:~ lasRayAt yellow 11 1 p (dir+0.5*pi))
    . (instantParticles .:~ lasRayAt yellow 11 1 p (dir-0.5*pi))
  where
    dir = argV (normalizeV (b-.-a)+.+normalizeV (y-.-x))

teslaBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam))
    -> World -> World
teslaBeamCombine (p,(a,b,bm),(x,y,_)) w
    = w' & pointToItem (_itemPositions w IM.! itid) . itParams . subParams ?~ ip
  where
    itid = fromJust $ _bmOrigin bm
    dir = argV (normalizeV (b-.-a)+.+normalizeV (y-.-x))
    (w',ip) = shootTeslaArc' (fromJust . _subParams $ _itParams it) p dir w
    it = case getItem itid w of
        Nothing -> error "tried to get item use teslaBeamCombine that doesn't exist"
        Just itm -> itm

lasRayAt :: Color -> Int -> Float -> Point2 -> Float -> Particle
lasRayAt col dam phasev pos dir = LaserParticle
    { _ptUpdate = mvLaser phasev pos dir
    , _ptRange = 800
    , _ptDamage = dam
    , _ptPhaseV = phasev
    , _ptColor = col
    , _ptPoints = []
    }
mvLaser :: Float    -- ^ Phase velocity, controls deflection through windows
    -> Point2 
    -> Float 
    -> World 
    -> Particle 
    -> (World, Maybe Particle)
mvLaser phasev sp dir w pt =
    ( damThingHitWith (\p1 p2 p3 -> Damage LASERING dam p1 p2 p3 NoDamageEffect) sp xp thHit w
    , Just pt {_ptPoints = sp:ps ,_ptUpdate = ptSimpleTime 0 }
    )
  where
    dam = _ptDamage pt
    xp = sp +.+ 800 *.* unitVectorAtAngle dir
    (thHit, ps) = reflectLaserAlong phasev sp xp w

drawLaser :: Particle -> Picture
drawLaser pt =
    setLayer BloomNoZWrite $ pictures
    [ setDepth 19.5 . color (brightX 10 1 col)  $ thickLine 3  ps
    ]
  where
    col = _ptColor pt
    ps = _ptPoints pt

shootTeslaArc' :: ItemParams -> Point2 -> Float -> World -> (World,ItemParams)
shootTeslaArc' ip pos dir w = 
    (w & randGen .~ g
       & instantParticles .:~ aTeslaArcAt col newarc
    , ip & currentArc ?~ newarc
    )
  where
    (col,g) = takeOne [white,azure,blue,cyan] & runState $ _randGen w
    newarc = createArc ip w pos dir & evalState $ _randGen w

createArc :: ItemParams
    -> World
    -> Point2
    -> Float
    -> State StdGen [ArcStep]
createArc arcparams@Arcing{_currentArc = Nothing} w p dir = createNewArc arcparams w p dir
createArc arcparams w p dir = updateArc arcparams w p dir

createNewArc :: ItemParams -> World -> Point2 -> Float
    -> State StdGen [ArcStep]
createNewArc arcparams w p dir = take (_arcNumber arcparams)
    <$> unfoldrMID (_newArcStep arcparams arcparams w) (ArcStep p dir Nothing)

defaultArcStep :: RandomGen g => ItemParams -> World -> ArcStep
    -> State g (Maybe ArcStep)
defaultArcStep _     _ (ArcStep _ _ (Just _)) = return Nothing
defaultArcStep itparams w (ArcStep p dir _) = do
    let csize = _arcSize itparams
    --rot <- takeOne [pi/4,negate pi/4]
    rot <- takeOne [0]
    let center = csize *.* rotateV rot (unitVectorAtAngle dir) +.+ p
    newp <- (center +.+) <$> randInCirc csize
    let mcr = listToMaybe 
            . sortOn (dist center . _crPos) 
            . filter (\cr -> dist center (_crPos cr) < csize)
            . IM.elems
            $ _creatures w
        mwl = listToMaybe
            . sortOn (dist p . fst)
            . mapMaybe (\ q -> sequence $ collidePointWallsFilterStream (const True) p (center +.+ q) w)
                -- collidePointWallsWall and wlsnearpoint
            $ polyCirc 6 csize
        f (q,wl) = ArcStep q dir (Just $ Right wl)
        g cr   = ArcStep (_crPos cr +.+ csize *.* unitVectorAtAngle dir) dir (Just $ Left cr)
    return . listToMaybe . sortOn (dist p . (^. asPos))
        $ ArcStep newp dir Nothing : catMaybes [fmap f mwl,fmap g mcr]

updateArc :: ItemParams
    -> World
    -> Point2
    -> Float
    -> State StdGen [ArcStep]
updateArc ip w p dir = take (_arcNumber ip) <$> zipArcs ip w (ArcStep p dir Nothing) carc
  where
    carc = tail $ fromJust $ _currentArc ip

zipArcs :: ItemParams
    -> World
    -> ArcStep
    -> [ArcStep]
    -> State StdGen [ArcStep]
zipArcs ip w x (y:ys) = (x :) <$> do  
    defaultnext <- _newArcStep ip ip w x
    case defaultnext of
        Nothing -> return []
        Just z@(ArcStep _ _ (Just _)) -> return [z]
        Just z -> do
            p <- randInCirc 5
            let csize = _arcSize ip
                center = _asPos x +.+ csize *.* unitVectorAtAngle (_asDir x)
                newp = _asPos y +.+ p
                --newdir = argV $ newp -.- _asPos x
                newdir = _asDir x
            if dist newp center < csize
                then zipArcs ip w (y & asPos .~ newp & asDir .~ newdir) ys
                else zipArcs ip w z ys
zipArcs ip w y _ = createNewArc ip w (_asPos y) (_asDir y)