Defunction-ify item modules, requires more cleanup

2022-06-08 12:28:11 +01:00
parent d91a53f76c
commit bcbfd7d2fa
48 changed files with 762 additions and 740 deletions
@@ -0,0 +1,158 @@
+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.HelperParticle
+import Dodge.Item.Weapon.LaserPath
+import Geometry
+import LensHelp
+import Picture
+import Dodge.RandomHelp
+import Dodge.Zone
+import Dodge.Base.Collide
+import Shape
+
+import Data.List (sortOn)
+import System.Random
+import MonadHelp
+import Control.Monad.State
+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
+    { _ptDraw = const blank
+    , _ptUpdate = mvLaser phasev pos dir
+    , _ptRange = 800
+    , _ptDamage = dam
+    , _ptPhaseV = phasev
+    , _ptColor = col
+    }
+mvLaser :: Float    -- ^ Phase velocity, controls deflection through windows
+    -> Point2 
+    -> Float 
+    -> World 
+    -> Particle 
+    -> (World, Maybe Particle)
+mvLaser phasev pos dir w pt
+    = ( damThingHitWith (\p1 p2 p3 -> Damage LASERING dam p1 p2 p3 NoDamageEffect) pos xp thHit w
+      , Just pt {_ptDraw = const pic ,_ptUpdate = ptSimpleTime 0 }
+      )
+  where
+    dam = _ptDamage pt
+    xp = pos +.+ 800 *.* unitVectorAtAngle dir
+    (thHit, ps) = reflectLaserAlong phasev [] pos xp w
+    col = _ptColor pt
+    pic = setLayer BloomNoZWrite $ pictures
+        [ setDepth 19   . color (brightX 0 0.5 col) $ thickLine 20 (pos:ps)
+        , setDepth 19.5 . color (brightX 10 1 col)  $ thickLine 3  (pos:ps)
+        ]
+
+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
+        wlsnearpoint = wallsNearPoint p w
+        mwl = listToMaybe
+            . sortOn (dist p . fst)
+            . mapMaybe (\ q -> collidePointWallsWall p (center +.+ q) 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)