Implement zipper for attachment trees

ghcidOutput

@@ -1 +1,5 @@
-All good (598 modules, at 01:27:16)
+/home/justin/Haskell/loop/src/Dodge/Render/ShapePicture.hs:78:1-12: warning: [-Wunused-top-binds]
+    Defined but not used: ‘anyTargeting’
+   |
+78 | anyTargeting w = fromMaybe mempty $ do
+   | ^^^^^^^^^^^^

src/Dodge/Creature.hs

@@ -244,7 +244,8 @@ inventoryX c = case c of
     'V' -> 
         [targetingScope tt | tt <- [minBound .. maxBound]]
         <>
-        [ augmentedHUD
+        [ battery
+        , augmentedHUD
         , autoRifle
         , megaTinMag 10200
         ] <>

src/Dodge/Creature/State.hs

@@ -3,6 +3,8 @@ module Dodge.Creature.State (
     doDamage,
 ) where
 
+import Dodge.Targeting.Draw
+import Dodge.Data.DoubleTree
 import qualified Data.Map.Strict as M
 import Data.Maybe
 import Data.Monoid
@@ -15,7 +17,6 @@ import Dodge.Creature.State.WalkCycle
 import Dodge.Creature.Test
 import Dodge.Damage
 import Dodge.Data.ComposedItem
-import Dodge.Data.DoubleTree
 import Dodge.Data.World
 import Dodge.DoubleTree
 import Dodge.Euse
@@ -158,26 +159,26 @@ equipmentEffects cr = alaf Endo foldMap (useEquipment cr) (IM.keys $ _crInvEquip
 
 -- a loop going over all inventory items
 invSideEff :: Creature -> World -> World
-invSideEff cr = alaf Endo foldMap f (_crInv cr) . updateRootItem cr
+invSideEff cr = alaf Endo foldMap f (_crInv cr) . updateHeldRootItem cr
   where
     f it =
         itemInvSideEffect cr it
             . maybe id (\g -> doInvEffect g it cr) (it ^? itEffect . ieInv)
 
-updateRootItem :: Creature -> World -> World
+updateHeldRootItem :: Creature -> World -> World
-updateRootItem cr = fromMaybe id $ do
+updateHeldRootItem cr = fromMaybe id $ do
     invid <- cr ^? crManipulation . manObject . imRootItem
     itmtree <- invTrees' (_crInv cr) ^? ix invid
-    return $ updateRootItem' itmtree cr
+    return $ updateAttachedItems itmtree cr
 
-updateRootItem' :: LabelDoubleTree ItemLink Item -> Creature -> World -> World
+updateAttachedItems :: LabelDoubleTree ItemLink Item -> Creature -> World -> World
-updateRootItem' itmtree cr =
+updateAttachedItems itmtree cr =
-    ldtPropagateFoldTree
+    cldtPropagateFold
         chainLinkOrientation
         chainLinkOrientation
         (updateItemWithOrientation cr)
         (heldItemRelativeOrient (_ldtValue itmtree) cr (0, Q.qID))
-        itmtree
+        (LocLDT TopLDT itmtree)
 
 -- need to check rotation
 chainLinkOrientation ::
@@ -194,15 +195,51 @@ chainLinkOrientation mo par (ILink lt f) child = (p + Q.rotate q p1, q * q1)
 updateItemWithOrientation ::
     Creature ->
     (Point3, Q.Quaternion Float) ->
-    LabelDoubleTree ItemLink Item ->
+    LocationLDT ItemLink Item ->
     World ->
     World
-updateItemWithOrientation cr m itmtree = case _itType itm of
+updateItemWithOrientation cr m loc@(LocLDT _ itmtree) = case _itType itm of
     HELD TORCH -> shineTorch cr itmtree m
+    TARGETING TARGETLASER -> makeTargetLaser cr itmtree m
+    ATTACH AUGMENTEDHUD -> drawAugmentedHUD loc
     _ -> id
   where
     itm = itmtree ^. ldtValue
 
+drawAugmentedHUD :: LocationLDT ItemLink Item -> World -> World
+drawAugmentedHUD (LocLDT con _) w = fromMaybe w $ do
+    itm <- con ^? cldtParent
+    return $ w & cWorld . lWorld . flares <>~ drawTargeting itm w
+
+makeTargetLaser :: Creature -> LabelDoubleTree ItemLink Item -> (Point3, Q.Quaternion Float)
+    -> World -> World
+makeTargetLaser cr itmtree (p,q) w = fromMaybe (w & pointItUse . tgPos .~ Nothing) $ do
+    guard (crIsAiming cr)
+    (_, mag) <- find (isammolink . _iatType . fst) (itmtree ^. ldtLeft)
+    i <- mag ^? ldtValue . itUse . amagLoadStatus . iaLoaded
+    guard $ i >= x
+    maginvid <- mag ^? ldtValue . itLocation . ilInvID
+    return $ w
+        & cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix maginvid . itUse . amagLoadStatus . iaLoaded -~ x
+       & cWorld . lWorld . lasers .:~ LaserStart
+                        { _lpPhaseV = 1
+                        , _lpDir = _crDir cr + argV (Q.qToV2 q)
+                        , _lpPos = pos
+                        , _lpColor = col
+                        , _lpType = TargetingLaser (_itID itm)
+                        }
+  where
+    x = 1
+    isammolink AmmoInLink{} = True
+    isammolink _ = False
+    pos = _crPos cr + xyV3 (rotate3 cdir (p + V3 5 0 0))
+    cdir = _crDir cr
+    itm = itmtree ^. ldtValue
+    pointItUse = cWorld . lWorld . creatures . ix cid . crInv . ix invid . itUse
+    cid = _crID cr
+    invid = _ilInvID $ _itLocation itm
+    col = blue -- mixColors reloadFrac (1-reloadFrac) blue red
+
 shineTorch :: Creature -> LabelDoubleTree ItemLink Item -> (Point3, Q.Quaternion Float) -> World -> World
 shineTorch cr itmtree (p, q) = fromMaybe id $ do
     (_, mag) <- find (isammolink . _iatType . fst) (itmtree ^. ldtLeft)
@@ -227,21 +264,13 @@ itemInvSideEffect cr itm = case _itType itm of
     _ -> id
 
 -- this probably needs to be set to null when dropped as well?
+-- does this need to be updated if it is not attached to the used root item?
 updateItemTargeting :: TargetingType -> Creature -> Item -> World -> World
 updateItemTargeting tt cr itm w = case tt of
     _ | not isattached -> w 
             & pointItUse . tgPos .~ Nothing
             & pointItUse . tgActive .~ False
-    TARGETLASER | crIsAiming cr -> w
+    TARGETLASER -> w
-                & cWorld . lWorld . lasers
-                    .:~ LaserStart
-                        { _lpPhaseV = 1
-                        , _lpDir = _crDir cr
-                        , _lpPos = sp
-                        , _lpColor = col
-                        , _lpType = TargetingLaser (_itID itm)
-                        }
-    TARGETLASER -> w & pointItUse . tgPos .~ Nothing
     TargetRBPress | rbpressed -> w
                 & pointItUse . tgPos %~ maybe (Just $ mouseWorldPos (w ^. input) (w ^. wCam)) Just
                 & pointItUse . tgActive .~ True
@@ -260,8 +289,6 @@ updateItemTargeting tt cr itm w = case tt of
     invid = _ilInvID $ _itLocation itm
     isattached = itm ^?! itLocation . ilIsAttached
     rbpressed = SDL.ButtonRight `M.member` _mouseButtons (_input w)
-    sp = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr)
-    col = blue -- mixColors reloadFrac (1-reloadFrac) blue red
 
 setRBCreatureTargeting :: Creature -> World -> ItemUse -> ItemUse
 setRBCreatureTargeting cr w ituse

src/Dodge/Data/DoubleTree.hs

@@ -42,30 +42,26 @@ data LabelDoubleTree b a = LDT {_ldtValue :: a, _ldtLeft :: [(b,LabelDoubleTree
 
 -- I am not sure about the double use of records here
 data ContextLDT b a = TopLDT
-        { _cldtValue :: a}
     | LeftwardLDT
         { _cldtUp :: ContextLDT b a  
-        , _cldtCloseLeft :: [LabelDoubleTree b a] 
+        , _cldtCloseLeft :: [(b,LabelDoubleTree b a)] 
+        , _cldtParent :: a
         , _cldtLink :: b
-        , _cldtValue :: a
+        , _cldtCloseRight :: [(b,LabelDoubleTree b a)]
-        , _cldtCloseRight :: [LabelDoubleTree b a]
+        , _cldtFarRight :: [(b,LabelDoubleTree b a)]
-        , _cldtFarRight :: [LabelDoubleTree b a]
         }
     | RightwardLDT 
         { _cldtUp :: ContextLDT b a  
-        , _cldtFarLeft :: [LabelDoubleTree b a]
+        , _cldtFarLeft :: [(b,LabelDoubleTree b a)]
-        , _cldtCloseLeft :: [LabelDoubleTree b a] 
+        , _cldtCloseLeft :: [(b,LabelDoubleTree b a)] 
+        , _cldtParent :: a
         , _cldtLink :: b
-        , _cldtValue :: a
+        , _cldtCloseRight :: [(b,LabelDoubleTree b a)]
-        , _cldtCloseRight :: [LabelDoubleTree b a]
         }
 
--- this is not quite right, it duplicates the value when the context is at the
--- top
 data LocationLDT b a = LocLDT
     { _locLdtContext :: ContextLDT b a
-    , _locLdtLeft :: [LabelDoubleTree b a]
+    , _locLDT :: LabelDoubleTree b a
-    , _locLdtRight :: [LabelDoubleTree b a]
     }
 
 instance Functor DoubleTree where
@@ -84,5 +80,7 @@ instance Bifunctor LabelDoubleTree where
 
 makeLenses ''DoubleTree
 makeLenses ''LabelDoubleTree
+makeLenses ''LocationLDT
+makeLenses ''ContextLDT
 deriveJSON defaultOptions ''DoubleTree
 deriveJSON defaultOptions ''LabelDoubleTree

src/Dodge/Data/Item.hs

@@ -13,6 +13,7 @@ module Dodge.Data.Item (
     module Dodge.Data.Item.Location,
 ) where
 
+import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -34,6 +35,7 @@ data Item = Item
     , _itID :: NewInt ItmInt
     , _itLocation :: ItemLocation
     , _itEffect :: ItEffect
+    , _itAmmoSlots :: IM.IntMap AmmoType
     , _itInvSize :: Int
     , _itDimension :: ItemDimension
     , _itCurseStatus :: CurseStatus

src/Dodge/Data/Item/Use.hs

@@ -22,7 +22,6 @@ import Dodge.Data.Item.Scope
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
-import qualified Data.IntMap.Strict as IM
 import Dodge.Data.GenFloat
 import Dodge.Data.Hammer
 import Dodge.Data.Item.HeldDelay
@@ -38,7 +37,7 @@ data ItemUse
         { _heldDelay :: UseDelay
         , _heldHammer :: HammerPosition
         , _heldAim :: AimParams
-        , _heldAmmoTypes :: IM.IntMap AmmoType
+--        , _heldAmmoTypes :: IM.IntMap AmmoType
         , _heldParams :: HeldParams
         , _heldTriggerType :: TriggerType
         }

src/Dodge/Default/Item.hs

@@ -26,7 +26,8 @@ defaultHeldItem = Item
         { _itCurseStatus = Uncursed
         , _itType = HELD PISTOL
         , _itEffect = defaultItEffect
-        , _itID = 0
+        , _itID = 0 -- should this return an error ? const $ error "itID not correctly initialised" ?
+        , _itAmmoSlots = mempty
         , _itInvSize = 1
         , _itLocation = InVoid
         , _itDimension = defaultItemDimension
@@ -45,7 +46,7 @@ singleAmmo x = IM.insert 0 x mempty
 
 defaultBulletWeapon :: Item
 defaultBulletWeapon = defaultHeldItem
-        & itUse . heldAmmoTypes .~ singleAmmo BulletAmmo
+        & itAmmoSlots .~ singleAmmo BulletAmmo
         & itUse . heldAim . aimMuzzles .~ [Muzzle (V2 15 0) 0 0.01 0 PistolFlare MuzzleShootBullet]
 
 defaultConsumable :: Item

src/Dodge/Default/Item/Use.hs

@@ -30,7 +30,6 @@ defaultHeldUse = UseHeld
     { _heldDelay = FixedRate{_rateMax = 8, _rateTime = 0}
     , _heldHammer = HammerUp
     , _heldAim = defaultAimParams
-    , _heldAmmoTypes = mempty
     , _heldParams = BulletShooterParams
         { _muzVel = ConstFloat 0.8
         , _rifling = ConstFloat 0.8

src/Dodge/DoubleTree.hs

@@ -15,7 +15,7 @@ singleLDT x = LDT x [] []
 ldtToDT :: LabelDoubleTree b a -> DoubleTree a
 ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r)
 
--- propogate two functions down the links of an LDT tree
+-- propagate two functions down the links of an LDT tree
 -- which function is chosen depends on whether it is a left or right branch
 ldtPropagate :: (c -> b -> c) -> (c -> b -> c) 
     -> c 
@@ -110,7 +110,7 @@ dtToLRAdj f (DT x l r) = IM.insert i (Nothing,map g l , map g r)
 
 -- returns an adjacency map with oldest ancestor and direct parent if they exist
 -- and any left and right children
--- allows to propogate failure in the index discovery
+-- allows to propagate failure in the index discovery
 dtToLRAdjEither :: (a -> Either String Int) -> DoubleTree a 
     -> Either String (IM.IntMap (Maybe (Int,Int),[Int],[Int]))
 dtToLRAdjEither f (DT x l r) = do
@@ -184,4 +184,61 @@ prettyLDT :: (a -> String) -> LabelDoubleTree b a -> [String]
 prettyLDT f (LDT x l r) = concatMap (map ('/':) . prettyLDT f . snd) r 
     ++ (f x : concatMap (map ('\\':) . prettyLDT f . snd) l)
 
+ldtToLoc :: LabelDoubleTree b a -> LocationLDT b a
+ldtToLoc = LocLDT TopLDT
 
+-- should probably do tests for these
+locUp :: LocationLDT b a -> Maybe (LocationLDT b a)
+locUp (LocLDT TopLDT _) = Nothing
+locUp (LocLDT c@LeftwardLDT{} t) = Just $ LocLDT (_cldtUp c) 
+    (LDT (_cldtParent c) (_cldtCloseLeft c ++ ((_cldtLink c,t):_cldtCloseRight c)) (_cldtFarRight c))
+locUp (LocLDT c@RightwardLDT{} t) = Just $ LocLDT (_cldtUp c) 
+    (LDT (_cldtParent c) (_cldtFarLeft c) (_cldtCloseLeft c ++ ((_cldtLink c,t):_cldtCloseRight c)))
+
+-- should probably do tests for these
+locGoLeft :: LocationLDT b a -> [LocationLDT b a]
+locGoLeft (LocLDT c (LDT v l r)) = 
+    [ LocLDT (LeftwardLDT c closel v link closer r) t | (closel,(link,t),closer) <- locGoHelp id l]
+
+-- should probably do tests for these
+locGoRight :: LocationLDT b a -> [LocationLDT b a]
+locGoRight (LocLDT c (LDT v l r)) = 
+    [ LocLDT (RightwardLDT c l closel v link closer) t | (closel,(link,t),closer) <- locGoHelp id r]
+
+-- this seems like it might be very inefficient for large lists
+-- difference lists?
+locGoHelp :: (a -> b) -> [a] -> [([a],b,[a])]
+locGoHelp f = go []
+  where
+    go cleft (y:ys) = (cleft,f y, ys) : go (cleft <> [y]) ys
+    go _ [] = []
+
+-- Propgates a value (of type c) down the branches of the ContextLDT.
+-- The value is updated according a "left" or "right" function (lf or rf),
+-- that acts on the parent value, the link, and the child value.
+-- For each context node, the updated value is used to update a final value (of type d).
+cldtPropagateFold :: (c -> a -> b -> a -> c) 
+    -> (c -> a -> b -> a -> c) 
+    -> (c -> LocationLDT b a -> d -> d)
+    -> c 
+    -> LocationLDT b a 
+    -> d 
+    -> d
+cldtPropagateFold lf rf up x loc = 
+    alaf Endo foldMap 
+        (\(LocLDT con' t') -> cldtPropagateFold 
+            lf 
+            rf 
+            up 
+            (lf x (_cldtParent con') (_cldtLink con') (_ldtValue t')) 
+            (LocLDT con' t'))
+        (locGoLeft loc)
+    .    alaf Endo foldMap 
+        (\(LocLDT con' t') -> cldtPropagateFold 
+            lf 
+            rf 
+            up 
+            (rf x (_cldtParent con') (_cldtLink con') (_ldtValue t')) 
+            (LocLDT con' t'))
+        (locGoRight loc)
+    . up x loc

src/Dodge/Item/Grammar.hs

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

src/Dodge/Item/Held/BatteryGuns.hs

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

src/Dodge/Item/Held/Cane.hs

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

src/Dodge/Item/Held/Launcher.hs

@@ -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 ..]

src/Dodge/Item/Held/SprayGuns.hs

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

src/Dodge/Item/Held/Utility.hs

@@ -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.

src/Dodge/Item/Held/Weapons.hs

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

src/Dodge/Item/Orientation.hs

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

src/Dodge/Item/Scope.hs

@@ -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
+targetingScope tt= case tt of
-    & itType .~ TARGETING tt
+    TARGETLASER -> defaultHeldItem
-    & itUse .~ UseTargeting 
+        & itType .~ TARGETING tt
-        { _tgPos = Nothing 
+        & itAmmoSlots .~ singleAmmo ElectricalAmmo
-        , _tgID = Nothing 
+        & itUse .~ UseTargeting 
-        , _tgActive = False
+            { _tgPos = Nothing 
-        }
+            , _tgID = Nothing 
+            , _tgActive = False
+            }
+    _ -> defaultHeldItem
+        & itType .~ TARGETING tt
+        & itUse .~ UseTargeting 
+            { _tgPos = Nothing 
+            , _tgID = Nothing 
+            , _tgActive = False
+            }
 
 homingModule :: Item
 homingModule = makeAttach HOMINGMODULE

src/Dodge/Item/Weapon/Drone.hs

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

src/Dodge/Render/ShapePicture.hs

@@ -39,7 +39,7 @@ worldSPic cfig u =
         <> foldup btSPic (filtOn _btPos _buttons)
         <> foldup mcSPic (filtOn _mcPos _machines)
         <> aimDelaySweep w
-        <> anyTargeting w
+--        <> anyTargeting w
   where
     w = _uvWorld u
     foldup = foldMap'

src/Dodge/TestString.hs

@@ -20,7 +20,7 @@ import Dodge.Data.Universe
 import qualified IntMapHelp as IM
 
 testStringInit :: Universe -> [String]
-testStringInit _ = [fromMaybe mempty (Just "A" <> Just "B")]
+testStringInit _ = []
 --testStringInit u = [maybe mempty show $ u ^? uvWorld . cWorld . lWorld . projectiles . ix 0 . prjUpdates . ix 3 . pjuControllerID]
 --testStringInit u = (topTestPart u
 --    <>) $ map showh $