Cleanup

src/Dodge/Creature/Impulse/UseItem.hs

@@ -27,7 +27,7 @@ useRootItem :: Int -> World -> World
 useRootItem crid w = fromMaybe w $ do
         cr <- w ^? cWorld . lWorld . creatures . ix crid
         itRef <- cr ^? crManipulation . manObject . imRootItem
-        it <- invTrees' (_crInv cr) ^? ix itRef
+        it <- invTrees (_crInv cr) ^? ix itRef
         return $
             itemEffect cr it w
                 & worldEventFlags . at InventoryChange ?~ ()
@@ -115,7 +115,7 @@ useItemLeftClick' :: Creature -> World -> World
 useItemLeftClick' cr' w = fromMaybe w $ do
     cr <- w ^? cWorld . lWorld . creatures . ix (_crID cr')
     itRef <- cr ^? crManipulation . manObject . imSelectedItem
-    it <- invTrees' (_crInv cr) ^? ix itRef
+    it <- invTrees (_crInv cr) ^? ix itRef
     return $
         itemEffect cr it w
             & worldEventFlags . at InventoryChange ?~ ()

src/Dodge/Data/ComposedItem.hs

@@ -24,7 +24,7 @@ data ItemStructuralFunction
     = WeaponPlatformSF
     | WeaponScopeSF
     | WeaponTargetingSF
-    | AmmoMagSF
+    | AmmoMagSF AmmoType
     | RemoteScreenSF
     | UncomposableIsolateSF
     | AmmoModifierSF AmmoType

src/Dodge/DisplayInventory.hs

@@ -116,7 +116,7 @@ updateDisplaySections w cfig sss =
     --invitems' = MIM.merge MIM.dropMissing MIM.dropMissing (MIM.zipWithMatched $ const addindent) indents $ IM.mapWithKey (invSelectionItem cr) inv
     invitems' = IM.mapWithKey (invSelectionItem cr) inv
     cr = you w
-    inv = invIndentIM'  $ _crInv (you w)
+    inv = invIndentIM  $ _crInv (you w)
     --indents = indentInv inv
     --inv = indentInv $ _crInv (you w)
     nfreeslots = crNumFreeSlots cr

src/Dodge/Inventory/Location.hs

@@ -20,7 +20,7 @@ import Control.Applicative
 -- assumes all item locations inside the items are correct
 tryGetRootAttachedFromInvID :: Int -> IM.IntMap Item -> Maybe (Int, IS.IntSet)
 tryGetRootAttachedFromInvID invid im = do
-    let imroots = invRootMap' im
+    let imroots = invRootMap im
         theroot = fromMaybe invid $ imroots ^? ix invid . _1 . _Just
     t <- imroots ^? ix theroot . _2
     --return (theroot, foldMap (IS.singleton . (^?! _1 . itLocation . ilInvID)) t)
@@ -31,7 +31,7 @@ tryGetRootAttachedFromInvID invid im = do
  -- location ids
 tryGetRootItemInvID :: Int -> Creature -> Maybe Int
 tryGetRootItemInvID i cr = do
-    let adj = case invAdj' (_crInv cr) of
+    let adj = case invAdj (_crInv cr) of
             Left str -> error $ "tryToGetRootItemInvID: "++ str
             Right x -> x
     theroot <- adj ^? ix i

src/Dodge/Item/Grammar.hs

@@ -1,8 +1,8 @@
 module Dodge.Item.Grammar (
-    invTrees',
-    invIndentIM',
-    invAdj',
-    invRootMap',
+    invTrees,
+    invIndentIM,
+    invAdj,
+    invRootMap,
 ) where
 
 import Control.Applicative
@@ -17,10 +17,6 @@ import Dodge.Data.Item
 import Dodge.DoubleTree
 import ListHelp
 
-type ComposedItemStructure =
-    (Item, ComposedItem, [(ComposeLinkType, ComposedItem)], [(ComposeLinkType, ComposedItem)])
-type CIL = (ComposedItem, [(ComposeLinkType, ComposedItem)], [(ComposeLinkType, ComposedItem)])
-
 useBreakListsLinkTest :: [(ItemStructuralFunction,ComposeLinkType)]
     -> [(ItemStructuralFunction,ComposeLinkType)]
     -> LinkTest
@@ -35,80 +31,39 @@ useBreakListsLinkTest llist rlist = LinkTest ltest rtest
         (_,linktype) <- safeHead xs
         return $ LinkUpdate linktype (set _3 (useBreakListsLinkTest llist (tail xs))) id
 
-cisToItem :: ComposedItemStructure -> Item
-cisToItem (x, _, _, _) = x
-
 basePartiallyComposedItem :: Item -> PartiallyComposedItem
 basePartiallyComposedItem itm = case itm ^. itType . iyBase of
-    HELD hit -> (itm, WeaponPlatformSF, useBreakListsLinkTest 
-        []
+    HELD _ -> (itm, WeaponPlatformSF, useBreakListsLinkTest 
+        (map (\(i,a) -> (AmmoMagSF a,AmmoInLink i a)) (IM.toList $ itm ^. itUse . heldAmmoTypes))
         [(WeaponTargetingSF,WeaponTargetingLink), (WeaponScopeSF,WeaponScopeLink)]
         )
-    ATTACH (TARGETATTACH{}) -> (itm,WeaponTargetingSF, LinkTest (const Nothing) (const Nothing))
+    AMMOMAG _ -> ammoComposedItem itm
+    ATTACH TARGETATTACH{} -> (itm,WeaponTargetingSF, LinkTest (const Nothing) (const Nothing))
+    ATTACH ZOOMSCOPE -> (itm,WeaponScopeSF, LinkTest (const Nothing) (const Nothing))
+    ATTACH ROCKETHOMER -> (itm,AmmoModifierSF ProjectileAmmo, LinkTest (const Nothing) (const Nothing))
+    ATTACH REMOTESCREEN -> (itm,AmmoModifierSF ProjectileAmmo, LinkTest (const Nothing) (const Nothing))
     _ -> (itm,UncomposableIsolateSF, LinkTest (const Nothing) (const Nothing))
     --AMMOMAG _ -> ammoComposedItem' itm
 
-baseComposedItem :: ItemBaseType -> Item -> CIL
-baseComposedItem ibt itm = case ibt of
-    HELD hit -> heldComposedItem itm hit
-    AMMOMAG _ -> ammoComposedItem itm
-    ATTACH BULLETSYNTHESIZER -> (AmmoModifierCI BulletAmmo, [], [])
-    ATTACH (TARGETATTACH{}) -> (WeaponTargetingCI, [], [])
-    ATTACH ZOOMSCOPE -> (WeaponScopeCI, [], [])
-    ATTACH ROCKETHOMER -> (AmmoModifierCI ProjectileAmmo, [], [])
-    ATTACH REMOTESCREEN -> (AmmoModifierCI ProjectileAmmo, [], [])
-    _ -> (UncomposableCI, [], [])
-
-heldComposedItem :: Item -> HeldItemType -> CIL
-heldComposedItem itm hit = case hit of
-    _ ->
-        ( WeaponCI
-        , map f ats
-        , [(WeaponTargetingLink, WeaponTargetingCI), (WeaponScopeLink, WeaponScopeCI)]
-        )
-  where
-    ats = maybe [] IM.toList $ itm ^? itUse . heldAmmoTypes
-    f (i, atype) = (AmmoInLink i atype, AmmoCI atype)
-
-ammoComposedItem :: Item -> CIL
+ammoComposedItem :: Item -> PartiallyComposedItem
 ammoComposedItem itm = fromMaybe (error "in ammoComposedItem, wrong item") $ do
     atype <- itm ^? itUse . amagType
-    return (AmmoCI atype, [(AmmoModLink, AmmoModifierCI atype)], [])
-
-baseCIS :: Item -> ComposedItemStructure
-baseCIS itm =
-    let (a, b, c) = baseComposedItem (itm ^. itType . iyBase) itm
-     in (itm, a, b, c)
+    return (itm, AmmoMagSF atype, useBreakListsLinkTest [(AmmoModifierSF atype, AmmoModLink)] [])
 
 type LDTComb a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe (LabelDoubleTree b a)
 
-leftIsParentCombine' :: LDTComb PartiallyComposedItem ComposeLinkType
-leftIsParentCombine' ltree rtree = do
+leftIsParentCombine :: LDTComb PartiallyComposedItem ComposeLinkType
+leftIsParentCombine ltree rtree = do
     lu <- (ltree ^. ldtValue . _3 . tryRightLink) (rtree ^. ldtValue)
     return $ ltree & ldtValue %~ (lu ^. luParentUpdate)
         & ldtRight %~ (++ [(lu ^. luLinkType, rtree & ldtValue %~ (lu ^. luChildUpdate))])
 
-rightIsParentCombine' :: LDTComb PartiallyComposedItem ComposeLinkType
-rightIsParentCombine' ltree rtree = do
+rightIsParentCombine :: LDTComb PartiallyComposedItem ComposeLinkType
+rightIsParentCombine ltree rtree = do
     lu <- (rtree ^. ldtValue . _3 . tryLeftLink) (ltree ^. ldtValue)
     return $ rtree & ldtValue %~ (lu ^. luParentUpdate)
         & ldtLeft .:~ (lu ^. luLinkType, ltree & ldtValue %~ (lu ^. luChildUpdate))
 
--- the following imposes a strict ordering on the possible attachments
-leftIsParentCombine :: LDTComb ComposedItemStructure ComposeLinkType
-leftIsParentCombine (LDT (itm, p, lc, rc) lt rt) t'@(LDT (_, p', _, _) _ _) = do
-    let f (_, x) = p' == x
-        (_, ys) = break f rc
-    (linktype, _) <- safeHead ys
-    return $ LDT (itm, p, lc, tail ys) lt (rt ++ [(linktype, t')])
-
-rightIsParentCombine :: LDTComb ComposedItemStructure ComposeLinkType
-rightIsParentCombine t'@(LDT (_, p', _, _) _ _) (LDT (itm, p, lc, rc) lt rt) = do
-    let f (_, x) = p' == x
-        (_, ys) = break f lc
-    (linktype, _) <- safeHead ys
-    return $ LDT (itm, p, tail ys, rc) ((linktype, t') : lt) rt
-
 leftRightCombine ::
     LDTComb a b ->
     LDTComb a b ->
@@ -134,14 +89,9 @@ joinItemsInList f xs = snd $ h (xs, [])
         Nothing -> h (ys, (y : z : zs))
         Just w -> h ((w : ys), zs)
 
-invLDT :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType ComposedItemStructure]
+invLDT :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType PartiallyComposedItem]
 invLDT =
     joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems
-        . fmap (singleLDT . baseCIS)
-
-invLDT' :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType PartiallyComposedItem]
-invLDT' =
-    joinItemsInList (leftRightCombine leftIsParentCombine' rightIsParentCombine') . IM.elems
         . fmap (singleLDT . basePartiallyComposedItem)
 
 -- this has provoked an error: hopefully it will crop up at some point and get
@@ -157,11 +107,8 @@ invLDT' =
 -- location ids
 -- consider explicitly reseting the inventory ids (but this probably really
 -- should be done upstream anyway in the actually creature inventory)
-invRootMap :: IM.IntMap Item -> IM.IntMap (Maybe Int, DoubleTree ComposedItemStructure)
-invRootMap = foldMap (dtToIntMapWithRoot (^?! _1 . itLocation . ilInvID) . ldtToDT) . invLDT
-
-invRootMap' :: IM.IntMap Item -> IM.IntMap (Maybe Int, DoubleTree Item)
-invRootMap' = foldMap (dtToIntMapWithRoot (^?! itLocation . ilInvID) . fmap (^. _1) . ldtToDT) . invLDT'
+invRootMap :: IM.IntMap Item -> IM.IntMap (Maybe Int, DoubleTree Item)
+invRootMap = foldMap (dtToIntMapWithRoot (^?! itLocation . ilInvID) . fmap (^. _1) . ldtToDT) . invLDT
 
 --invRootMap = foldMap (dtToRootIntMap g . ldtToDT) . invLDT
 --  where
@@ -175,18 +122,6 @@ invAdj :: IM.IntMap Item -> Either String (IM.IntMap (Maybe (Int, Int), [Int], [
 invAdj im = do
     l <- mapM g $ invLDT im
     return $ IM.unions l
-  where
-    g = dtToLRAdjEither getid . ldtToDT
-    getid (itm, _, _, _) =
-        maybe
-            (Left ("invAdj item " ++ show (_itID itm) ++ " location: " ++ show (itm ^? itLocation)))
-            Right
-            $ itm ^? itLocation . ilInvID
-
-invAdj' :: IM.IntMap Item -> Either String (IM.IntMap (Maybe (Int, Int), [Int], [Int]))
-invAdj' im = do
-    l <- mapM g $ invLDT' im
-    return $ IM.unions l
   where
     g = dtToLRAdjEither getid . ldtToDT
     getid (itm, _, _) =
@@ -196,22 +131,11 @@ invAdj' im = do
             $ itm ^? itLocation . ilInvID
 
 invIndentIM :: IM.IntMap Item -> IM.IntMap (Item, Int, LabelDoubleTreeNodeType ComposeLinkType)
-invIndentIM = IM.fromAscList . zip [0 ..] . reverse . map (over _1 cisToItem) . concatMap ldtToIndentList . invLDT
-
-invIndentIM' :: IM.IntMap Item -> IM.IntMap (Item, Int, LabelDoubleTreeNodeType ComposeLinkType)
-invIndentIM' = IM.fromAscList . zip [0 ..] . reverse . map (over _1 (^. _1)) 
-    . concatMap ldtToIndentList . invLDT'
+invIndentIM = IM.fromAscList . zip [0 ..] . reverse . map (over _1 (^. _1)) 
+    . concatMap ldtToIndentList . invLDT
 
 invTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ComposeLinkType Item)
-invTrees = IM.unions . map (ldtToIM getindex) . map (fmap cisToItem) . invLDT
-  where
-    getindex :: Item -> Int
-    getindex i =
-        fromMaybe (error "in invTrees try to get non-inventory item tree") $
-            i ^? itLocation . ilInvID
-
-invTrees' :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ComposeLinkType Item)
-invTrees' = IM.unions . map (ldtToIM getindex) . map (fmap (^. _1)) . invLDT'
+invTrees = IM.unions . map (ldtToIM getindex) . map (fmap (^. _1)) . invLDT
   where
     getindex :: Item -> Int
     getindex i =

src/Dodge/Render/HUD.hs

@@ -62,7 +62,7 @@ drawInventory sss w cfig = drawSelectionSections sss (invDisplayParams w) cfig
   where
     iextra = fromMaybe mempty $ do
         inv <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
-        let x = case invAdj' inv of
+        let x = case invAdj inv of
                 Left str -> error $ "drawInventory: " ++ str
                 Right y -> y
         return $ inventoryExtra sss cfig w x

src/Dodge/WorldEffect.hs

@@ -40,7 +40,7 @@ doWdWd we = case we of
         cr <- w ^? cWorld . lWorld . creatures . ix crid
         --it <- getItem itid w
         itRef <- cr ^? crManipulation . manObject . imSelectedItem
-        it <- invTrees' (_crInv cr) ^? ix itRef
+        it <- invTrees (_crInv cr) ^? ix itRef
         return $ doItCrWdWd f it cr w
     WdWdFromItCrixWdWd it crid f -> \w -> fromMaybe w $ do
         cr <- w ^? cWorld . lWorld . creatures . ix crid