Implement zipper for attachment trees

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
-updateRootItem cr = fromMaybe id $ do
+updateHeldRootItem :: Creature -> World -> World
+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
-updateRootItem' itmtree cr =
-    ldtPropagateFoldTree
+updateAttachedItems :: LabelDoubleTree ItemLink Item -> Creature -> World -> World
+updateAttachedItems itmtree cr =
+    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
-                & cWorld . lWorld . lasers
-                    .:~ LaserStart
-                        { _lpPhaseV = 1
-                        , _lpDir = _crDir cr
-                        , _lpPos = sp
-                        , _lpColor = col
-                        , _lpType = TargetingLaser (_itID itm)
-                        }
-    TARGETLASER -> w & pointItUse . tgPos .~ Nothing
+    TARGETLASER -> w
     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