Cleanup
This commit is contained in:
+23
-99
@@ -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 =
|
||||
|
||||
Reference in New Issue
Block a user