Move background item effects out of records

2025-06-05 22:08:39 +01:00
parent 10ca82c4d5
commit 9a699e70ed
11 changed files with 272 additions and 143 deletions
@@ -0,0 +1,103 @@
+module Dodge.Item.BackgroundEffect (
+    itBackgroundEffect,
+    itEffectOnPickup,
+    itEffectOnDrop,
+) where
+
+import Dodge.Inventory.SelectionList
+--import Dodge.Inventory.Path
+import Data.Maybe
+import Color
+import Dodge.Default.Wall
+import Dodge.Wall.Delete
+import Dodge.Item.HeldOffset
+import Dodge.Creature.Test
+import Geometry.Vector
+import Dodge.Wall.Move
+import Dodge.Wall.Create
+import Dodge.Item.Location
+import Dodge.Data.World
+import Control.Lens
+
+itBackgroundEffect :: Item -> Creature -> World -> World
+itBackgroundEffect itm cr w = case itm ^. itType of
+    COPIER _ -> copierItemUpdate' itm cr w
+    ITEMSCAN -> cancelExamineInventory' w
+    HELD FLATSHIELD -> rootNotrootEff' createShieldWall' removeShieldWall' itm cr w
+    HELD MINIGUNX{} ->
+        w & pointerToItem itm . itParams . wTime
+            %~ (max 0 . subtract 1)
+    _ -> w
+
+copierItemUpdate' :: Item -> Creature -> World -> World
+copierItemUpdate' itm cr w = fromMaybe w $ do
+    x <- itm ^? itScroll . itsInt
+    invid <- itm ^? itLocation . ilInvID
+    ip <- itm ^? itType . ibtPathing
+    i <- getInventoryPath x ip invid cr
+    itm' <- cr ^? crInv . ix i
+    v <- getItemValue itm' w cr
+    return $ w & pointerToItem itm . itUse . uValue .~ v
+
+cancelExamineInventory' :: World -> World
+cancelExamineInventory' = hud . hudElement . subInventory %~ f
+  where
+    f ExamineInventory = NoSubInventory
+    f x = x
+
+rootNotrootEff' ::
+    (Item -> Creature -> World -> World) ->
+    (Item -> Creature -> World -> World) ->
+    Item ->
+    Creature ->
+    World ->
+    World
+rootNotrootEff' f g it
+    | it ^? itLocation . ilIsRoot == Just True = f it
+    | otherwise = g it
+
+createShieldWall' :: Item -> Creature -> World -> World
+createShieldWall' it cr w = case it ^? itParams . flatShieldWlMIX . _Just of
+    Nothing ->
+        let (wlid, w') = createWall ((shieldWall' crid){_wlLine = wlline, _wlID = wlid}) w
+         in w' & pointerToItem it . itParams .~ FlatShieldParams (Just wlid)
+    Just wid -> moveWallID wid wlline w
+  where
+    crid = _crID cr
+    wlline = (a, b)
+    crdirv = unitVectorAtAngle $ _crDir cr
+    crpos = _crPos cr
+    rad = _crRad cr + 2
+    a = crpos +.+ rad *.* crdirv -.- 10 *.* therot crdirv
+    b = crpos +.+ rad *.* crdirv +.+ 10 *.* therot crdirv
+    therot
+        | crIsAiming cr = vNormal
+        | otherwise = rotateV (twoFlatHRot cr) . vNormal
+
+removeShieldWall' :: Item -> Creature -> World -> World
+removeShieldWall' it _ w = case it ^? itParams . flatShieldWlMIX . _Just of
+    Nothing -> w
+    Just wid ->
+        w & deleteWallID wid
+            & pointerToItem it . itParams . flatShieldWlMIX .~ Nothing
+
+itEffectOnPickup :: Item -> Creature -> World -> World
+itEffectOnPickup _ _ = id
+
+itEffectOnDrop :: Item -> Creature -> World -> World
+itEffectOnDrop itm _ w = case itm ^. itType of
+    HELD MINIGUNX{} -> w & pointerToItemID (_itID itm) . itParams . wTime .~ 0
+    _ -> w
+
+shieldWall' :: Int -> Wall
+shieldWall' crid =
+    defaultWall
+        { _wlColor = yellow
+        , _wlOpacity = SeeAbove
+        , _wlPathable = True
+        , _wlWalkable = True
+        , _wlFireThrough = True
+        , _wlReflect = True
+        , _wlRotateTo = False
+        , _wlStructure = CreaturePart crid -- shieldWallDamage
+        }