Implement zipper for attachment trees

2024-10-05 14:39:34 +01:00
parent 71d4802a4a
commit 164beeea6d
23 changed files with 391 additions and 277 deletions
@@ -5,6 +5,7 @@ module Dodge.Item.Grammar (
    invIndentIM,
    invAdj,
    invRootMap,
+    invRootTrees,
 ) where

 import Control.Applicative
@@ -54,13 +55,14 @@ itemToBreakLists itm = case itm ^. itType of
            , (AmmoEffectSF atype, AmmoEffectLink)
            , (RemoteScreenSF, RemoteScreenLink)
            ],[])
+    TARGETING TARGETLASER -> (getAmmoLinks itm ++ [(AugmentedHUDSF,AugmentedHUDLink)],[])
    TARGETING{} -> ([(AugmentedHUDSF,AugmentedHUDLink)],[])
    _ -> ([],[])

 getAmmoLinks :: Item -> [(ItemStructuralFunction, ComposeLinkType)]
 getAmmoLinks itm = map
                (\(i, a) -> (AmmoMagSF a,AmmoInLink i a))
-                (IM.toList $ itm ^. itUse . heldAmmoTypes)
+                (IM.toList $ itm ^. itAmmoSlots)

 itemToFunction :: Item -> ItemStructuralFunction
 itemToFunction itm = case itm ^. itType of
@@ -160,14 +162,21 @@ invIndentIM =
        . map (bimap _iatType (\(x, y, _) -> (x, y)))
        . invLDT

-- returns an intmap with trees for all root items
+-- returns an intmap with trees for all items
 invTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ComposeLinkType Item)
 invTrees = fmap (first _iatType) . invTrees'

-- returns an intmap with trees for all root items
+-- returns an intmap with trees for all items
 invTrees' :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ItemLink Item)
 invTrees' = IM.unions . map (ldtToIM getindex . fmap (^. _1)) . map (fmap (\(x, y, _) -> (x, y))) . invLDT
  where
    getindex i =
        fromMaybe (error "in invTrees try to get non-inventory item tree") $
            i ^? itLocation . ilInvID
+
+-- returns an intmap with trees for root items, indexed by inventory position
+invRootTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ItemLink ComposedItem)
+invRootTrees = IM.fromAscList . reverse . map (getid . fmap (\(x, y, _) ->  (x, y))) . invLDT
+  where
+    getid :: LabelDoubleTree ItemLink ComposedItem -> (Int,LabelDoubleTree ItemLink ComposedItem)
+    getid t = (t ^?! ldtValue . _1 . itLocation . ilInvID, t)
@@ -33,7 +33,7 @@ teslaGun =
        & itUse . heldAim . aimMuzzles . ix 0 . mzFlareType .~ TeslaGunFlare
        & itUse . heldAim . aimMuzzles . ix 0 . mzEffect .~ MuzzleTesla
        & itType .~ HELD TESLAGUN
-        & itUse . heldAmmoTypes .~ singleAmmo ElectricalAmmo
+        & itAmmoSlots .~ singleAmmo ElectricalAmmo
        & itUse . heldTriggerType .~ AutoTrigger

 -- previous phaseV parameters: 0.2, 1, 5
@@ -41,7 +41,7 @@ lasGun :: Item
 lasGun =
    defaultHeldItem
        & itUse . heldParams .~ BeamShooterParams (Just (tone440sawtoothquietS,2))
-        & itUse . heldAmmoTypes .~ singleAmmo ElectricalAmmo
+        & itAmmoSlots .~ singleAmmo ElectricalAmmo
        & itUse . heldDelay .~ NoDelay
        & itUse . heldTriggerType .~ AutoTrigger
        & itUse . heldAim . aimMuzzles . ix 0 . mzPos .~ V2 30 0
@@ -46,7 +46,7 @@ volleyGun i =
        & itUse . heldParams . torqueAfter .~ 0.15 + 0.05 * fromIntegral i
        & itUse . heldParams . recoil .~ 20 + 10 * fromIntegral i
        & itType .~ HELD (VOLLEYGUN i)
-        & itUse . heldAmmoTypes .~ IM.fromList (zip [0..i-1] $ repeat BulletAmmo)
+        & itAmmoSlots .~ IM.fromList (zip [0..i-1] $ repeat BulletAmmo)

 rifle :: Item
 rifle =
@@ -87,7 +87,7 @@ miniGunX i =
        & itUse . heldAim . aimWeight .~ 6
        & itUse . heldAim . aimRange .~ 1
        & itUse . heldAim . aimZoom .~ defaultItZoom{_izFac = 1.5}
-        & itUse . heldAmmoTypes .~ singleAmmo BeltBulletAmmo
+        & itAmmoSlots .~ singleAmmo BeltBulletAmmo
        & itUse . heldParams . bulGunSound ?~ (mini1S,2)
        & itUse . heldAim . aimTurnSpeed .~ 0.5
        & itUse . heldAim . aimMuzzles 
@@ -21,7 +21,7 @@ launcher =
        & itUse . heldAim . aimStance .~ TwoHandOver
        & itUse . heldAim . aimMuzzles . ix 0 . mzInaccuracy .~ 0
        & itUse . heldAim . aimMuzzles . ix 0 . mzEffect .~ MuzzleLauncher
-        & itUse . heldAmmoTypes .~ singleAmmo ProjectileAmmo
+        & itAmmoSlots .~ singleAmmo ProjectileAmmo
        & itType .~ HELD LAUNCHER
        & itUse . heldParams . muzVel .~ ConstFloat 0
        & itUse . heldParams . rifling .~ ConstFloat 0
@@ -39,6 +39,6 @@ launcherX i =
            <*> pure DefaultFlareType
            <*> pure MuzzleLauncher
            )
-        & itUse . heldAmmoTypes .~ IM.fromList [(j,ProjectileAmmo) | j <- [0..i-1]]
+        & itAmmoSlots .~ IM.fromList [(j,ProjectileAmmo) | j <- [0..i-1]]
  where
    angles = take i [0,2*pi/ fromIntegral i ..]
@@ -18,7 +18,7 @@ poisonSprayer :: Item
 poisonSprayer =
    flameThrower
        & itType .~ HELD POISONSPRAYER
-        & itUse . heldAmmoTypes .~ singleAmmo GasAmmo
+        & itAmmoSlots .~ singleAmmo GasAmmo
        & itUse . heldParams . gasCreation .~ CreatePoisonGas --aGasCloud
        & itUse . heldParams . recoil .~ 0
        & itUse . heldParams . torqueAfter .~ 0
@@ -90,7 +90,7 @@ flameThrower =
                        , _nzCurrentWalkAngle = 0
                        }
            ]
-        & itUse . heldAmmoTypes .~ singleAmmo GasAmmo
+        & itAmmoSlots .~ singleAmmo GasAmmo
        & itType .~ HELD FLAMETHROWER
        & itUse . heldParams .~ GasSprayParams
            {_gasCreation = CreateFlame
@@ -28,7 +28,7 @@ torch =
    defaultHeldItem
        & itType .~ HELD TORCH
        & itUse . heldAim . aimMuzzles . ix 0 . mzPos . _x .~ 10
-        & itUse . heldAmmoTypes .~ singleAmmo ElectricalAmmo
+        & itAmmoSlots .~ singleAmmo ElectricalAmmo

 {- |
 Sends out pulses that display walls.
@@ -10,7 +10,7 @@ shatterGun =
    defaultHeldItem
        & itType .~ HELD SHATTERGUN
        & itUse . heldDelay . rateMax .~ 10
-        & itUse . heldAmmoTypes .~ singleAmmo ElectricalAmmo
+        & itAmmoSlots .~ singleAmmo ElectricalAmmo
        & itUse . heldAim . aimMuzzles . ix 0 . mzPos .~ V2 30 0
        & itUse . heldAim . aimMuzzles . ix 0 . mzInaccuracy .~ 0
        & itUse . heldAim . aimMuzzles . ix 0 . mzEffect .~ MuzzleShatter
@@ -10,6 +10,7 @@ import qualified Quaternion as Q
 orientChild :: Item -> (Point3, Q.Quaternion Float)
 orientChild itm = case _itType itm of
    HELD TORCH -> (V3 0 5 0, Q.qID)
+    TARGETING TARGETLASER -> (V3 15 (-5) 0, Q.qID)
    _ -> (0, Q.qID)

 orientByLink :: Item -> ComposeLinkType -> (Point3, Q.Quaternion Float)
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 module Dodge.Item.Scope (
    zoomScope,
    targetingScope,
@@ -20,13 +21,22 @@ zoomScope = defaultHeldItem
    & itUse .~ UseScope OpticScope{_opticPos = 0, _opticZoom = 1, _opticDefaultZoom = 0.5}

 targetingScope :: TargetingType -> Item
-targetingScope tt = defaultHeldItem
-    & itType .~ TARGETING tt
-    & itUse .~ UseTargeting 
-        { _tgPos = Nothing 
-        , _tgID = Nothing 
-        , _tgActive = False
-        }
+targetingScope tt= case tt of
+    TARGETLASER -> defaultHeldItem
+        & itType .~ TARGETING tt
+        & itAmmoSlots .~ singleAmmo ElectricalAmmo
+        & itUse .~ UseTargeting 
+            { _tgPos = Nothing 
+            , _tgID = Nothing 
+            , _tgActive = False
+            }
+    _ -> defaultHeldItem
+        & itType .~ TARGETING tt
+        & itUse .~ UseTargeting 
+            { _tgPos = Nothing 
+            , _tgID = Nothing 
+            , _tgActive = False
+            }

 homingModule :: Item
 homingModule = makeAttach HOMINGMODULE
@@ -16,7 +16,7 @@ droneLauncher =
        & itUse . heldAim . aimWeight .~ 8
        & itUse . heldAim . aimRange .~ 0.5
        & itUse . heldAim . aimStance .~ TwoHandOver
-        & itUse . heldAmmoTypes .~ singleAmmo DroneAmmo
+        & itAmmoSlots .~ singleAmmo DroneAmmo
        & itType .~ HELD DRONELAUNCHER

 lasDronesPic :: Item -> SPic