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
@@ -17,6 +17,8 @@ module Dodge.Item.Weapon.BatteryGuns
    , splitBeamCombine
    ) where
 import Dodge.Data
+import Dodge.Tesla
+import Dodge.Beam
 import Dodge.Item.Weapon.LaserPath
 import Dodge.Item.Location
 import Dodge.Creature.HandPos
@@ -52,28 +54,25 @@ import Control.Monad.State

 defaultBatteryGun :: Item
 defaultBatteryGun = defaultGun
-    & itModules .~ batteryModules
+    & itType . iyModules .~ batteryModules

-batteryModules :: M.Map ModuleSlot ItemModule
+batteryModules :: M.Map ModuleSlot ItemModuleType
 batteryModules = M.fromList 
-    [(ModBattery, DefaultModule)
-    ,(ModTeleport, DefaultModule)
+    [(ModBattery,  EMPTYMODULE)
+    ,(ModTeleport, EMPTYMODULE)
    ]

 defaultAutoBatteryGun :: Item
 defaultAutoBatteryGun = defaultAutoGun
-    & itModules .~ batteryModules
+    & itType . iyModules .~ batteryModules

 sparkGun :: Item
 sparkGun = teslaGun
-    & itName .~ "SPARKGUN"
-    & itType .~ SPARKGUN
+    & itType . iyBase .~ SPARKGUN
    & itParams . arcSize .~ 10
 teslaGun :: Item
 teslaGun = defaultBatteryGun 
-    { _itName = "TESLA"
-    , _itType = TESLAGUN
-    , _itConsumption = defaultAmmo
+    { _itConsumption = defaultAmmo
        { _laMax = 200
        , _laLoaded = 200
        , _laReloadTime = 80
@@ -97,14 +96,7 @@ teslaGun = defaultBatteryGun
        }
    , _itParams = teslaParams
    }
-teslaParams :: ItemParams
-teslaParams = Arcing 
-    { _currentArc = Nothing
-    , _arcSize = 20
-    , _arcNumber = 10
-    , _newArcStep = defaultArcStep
-    , _previousArcEffect = NoPreviousArcEffect
-    }
+    & itType . iyBase .~ TESLAGUN
 teslaGunPic :: Item -> SPic
 teslaGunPic _ = noPic $ colorSH blue $
           upperPrismPoly 5 (rectNESW xb    8 xa    0)
@@ -114,8 +106,7 @@ teslaGunPic _ = noPic $ colorSH blue $
    xb = 9
 lasGunPulse :: Item
 lasGunPulse = lasGun
-    & itName .~ "PULSELAS"
-    & itType .~ LASPULSE
+    & itType . iyBase .~ LASPULSE
    & itUse . useMods .~
        [ ammoCheckI
        , withItem $ \it -> withTempLight 1 (100 * frac it) (xyzV4 (_lasColor $ _itParams it))
@@ -134,8 +125,7 @@ lasGunPulse = lasGun

 lasGunWide :: Int -> Item
 lasGunWide n = lasGun
-    & itName .~ "PARALELLAS"++show n
-    & itType .~ LASGUNWIDE n
+    & itType . iyBase .~ LASGUNWIDE n
    & itParams . lasColor .~ orange
    & itParams . lasDamage .~ 2
    & itUse .~ ( ruseInstant shootLaser NoHammer
@@ -155,8 +145,7 @@ lasGunWide n = lasGun
    xs = [ 0.25 * (fromIntegral x - fromIntegral (n'-1) /2)  | x <- [0..n'-1] ]
 lasGunWidePulse :: Item
 lasGunWidePulse = lasGun
-    & itName .~ "LASWIDEPULSE"
-    & itType .~ LASGUNWIDEPULSE
+    & itType . iyBase .~ LASGUNWIDEPULSE
    & itParams . lasColor .~ orange
    & itParams . lasDamage .~ 2
    & itUse .~ ( ruseInstant shootLaser NoHammer
@@ -183,8 +172,7 @@ lasGunWidePulse = lasGun
        n' = (ceiling $ (150 :: Float) * frac it) :: Int
 lasGunSway :: Item
 lasGunSway = lasGun
-    & itName .~ "SWAYLAS"
-    & itType .~ LASGUNSWAY
+    & itType . iyBase .~ LASGUNSWAY
    & itParams . lasColor .~ orange
    & itParams . lasDamage .~ 11
    & itUse .~ ( ruseInstant shootLaser NoHammer
@@ -206,8 +194,7 @@ lasGunSway = lasGun
        x' = _lasCycle $ _itParams it
 lasGunFocus :: Int -> Item
 lasGunFocus n = lasGunWide n
-    & itName .~ "FOCALAS"++show n
-    & itType .~ LASGUNFOCUS n
+    & itType . iyBase .~ LASGUNFOCUS n
    & itParams . lasColor .~ red
    & itUse . useMods .~
        [ ammoCheckI
@@ -223,8 +210,7 @@ lasGunFocus n = lasGunWide n

 lasGunDual :: Item
 lasGunDual = lasGun
-    & itName .~ "DUALAS"
-    & itType .~ LASGUNDUAL
+    & itType . iyBase .~ LASGUNDUAL
    & itParams .~ DualBeam
        { _phaseV = 1
        , _lasColor = orange
@@ -246,11 +232,10 @@ lasGunDual = lasGun
        & useAim . aimRange .~ 1
        & useAim . aimStance .~ TwoHandTwist
        )
-    & itModules . at ModDualBeam ?~ DefaultModule
+    & itType . iyModules . at ModDualBeam ?~ EMPTYMODULE
 lasGunSwing :: Item
 lasGunSwing = lasGun
-    & itName .~ "SWINGLAS"
-    & itType .~ LASGUNSWING
+    & itType . iyBase .~ LASGUNSWING
    & itParams . lasColor .~ orange
    & itUse . useMods .~
        [ ammoCheckI
@@ -268,9 +253,7 @@ lasGunSwing = lasGun
        x' = _lasCycle $ _itParams it
 lasGun :: Item
 lasGun = defaultAutoBatteryGun 
-    { _itName = "LASGUN"
-    , _itType = LASGUN
-    , _itConsumption = defaultAmmo
+    { _itConsumption = defaultAmmo
        { _laMax = 200
        , _laLoaded = 200
        , _laReloadTime = 80
@@ -303,6 +286,8 @@ lasGun = defaultAutoBatteryGun
        , _dimSPic = lasGunPic
        }
    }
+    & itType . iyBase .~ LASGUN
+
 lasGunPic :: Item -> SPic
 lasGunPic it = 
    ( colorSH blue $ 
@@ -335,9 +320,7 @@ lasGunTweak = TweakParam

 tractorGun :: Item
 tractorGun = lasGun 
-    { _itName = "TRACTORGUN"
-    , _itType = TRACTORGUN
-    , _itConsumption = defaultAmmo
+    { _itConsumption = defaultAmmo
        { _laMax = 10000
        , _laLoaded = 10000
        , _laReloadTime = 40
@@ -360,6 +343,8 @@ tractorGun = lasGun
        , _tweakSel = 0
        }
    }
+    & itType . iyBase .~ TRACTORGUN
+
 tractorGunTweak :: TweakParam
 tractorGunTweak = TweakParam
    { _doTweak = thetweak
@@ -400,84 +385,6 @@ shootTeslaArc it cr w = w'
    pos = _crPos cr +.+ aimingMuzzlePos cr it *.* unitVectorAtAngle dir
    dir = _crDir cr

-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)

 shootLaser :: Item -> Creature -> World -> World
 shootLaser it cr = instantParticles .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir
@@ -537,64 +444,6 @@ dualRayAt :: BeamType -> Int -> World -> Color -> Int -> Float -> Point2 -> Floa
 dualRayAt bt itid w col dam phasev pos dir = basicBeamAt itid w col dam phasev pos dir
    & bmType .~ bt

-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)
-        ]
 aTractorBeam :: Item -> Creature -> World -> World
 aTractorBeam _ cr w = w & props . at i ?~ tractorBeamAt i spos outpos dir power
  where