151 lines
5.9 KiB
Haskell
151 lines
5.9 KiB
Haskell
module Dodge.Item.Grammar (
|
|
invTrees,
|
|
invIndentIM,
|
|
invAdj,
|
|
invRootMap,
|
|
) where
|
|
|
|
import Control.Applicative
|
|
--import TreeHelp
|
|
|
|
import LensHelp
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Data.Maybe
|
|
import Dodge.Data.ComposedItem
|
|
import Dodge.Data.DoubleTree
|
|
import Dodge.Data.Item
|
|
import Dodge.DoubleTree
|
|
import ListHelp
|
|
|
|
useBreakListsLinkTest :: [(ItemStructuralFunction,ComposeLinkType)]
|
|
-> [(ItemStructuralFunction,ComposeLinkType)]
|
|
-> LinkTest
|
|
useBreakListsLinkTest llist rlist = LinkTest ltest rtest
|
|
where
|
|
ltest (_,sf,_) = do
|
|
let xs = dropWhile ((/= sf) . fst) llist
|
|
(_,linktype) <- safeHead xs
|
|
return $ LinkUpdate linktype (set _3 (useBreakListsLinkTest (tail xs) rlist)) id
|
|
rtest (_,sf,_) = do
|
|
let xs = dropWhile ((/= sf) . fst) rlist
|
|
(_,linktype) <- safeHead xs
|
|
return $ LinkUpdate linktype (set _3 (useBreakListsLinkTest llist (tail xs))) id
|
|
|
|
basePartiallyComposedItem :: Item -> PartiallyComposedItem
|
|
basePartiallyComposedItem itm = case itm ^. itType . iyBase of
|
|
HELD _ -> (itm, WeaponPlatformSF, useBreakListsLinkTest
|
|
(map (\(i,a) -> (AmmoMagSF a,AmmoInLink i a)) (IM.toList $ itm ^. itUse . heldAmmoTypes))
|
|
[(WeaponTargetingSF,WeaponTargetingLink), (WeaponScopeSF,WeaponScopeLink)]
|
|
)
|
|
AMMOMAG _ -> ammoComposedItem itm
|
|
ATTACH TARGETATTACH{} -> (itm,WeaponTargetingSF, LinkTest (const Nothing) (const Nothing))
|
|
ATTACH ZOOMSCOPE -> (itm,WeaponScopeSF, LinkTest (const Nothing) (const Nothing))
|
|
ATTACH HOMINGMODULE -> (itm,AmmoTargetingSF ProjectileAmmo, LinkTest (const Nothing) (const Nothing))
|
|
ATTACH REMOTESCREEN -> (itm,RemoteScreenSF, LinkTest (const Nothing) (const Nothing))
|
|
_ -> (itm,UncomposableIsolateSF, LinkTest (const Nothing) (const Nothing))
|
|
|
|
ammoComposedItem :: Item -> PartiallyComposedItem
|
|
ammoComposedItem itm = fromMaybe (error "in ammoComposedItem, wrong item") $ do
|
|
atype <- itm ^? itUse . amagType
|
|
return (itm
|
|
, AmmoMagSF atype
|
|
, useBreakListsLinkTest
|
|
[(AmmoModifierSF atype, AmmoModLink)
|
|
,(AmmoTargetingSF atype, AmmoTargetingLink)
|
|
,(RemoteScreenSF, RemoteScreenLink)
|
|
]
|
|
[]
|
|
)
|
|
|
|
type LDTComb a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe (LabelDoubleTree b a)
|
|
|
|
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
|
|
lu <- (rtree ^. ldtValue . _3 . tryLeftLink) (ltree ^. ldtValue)
|
|
return $ rtree & ldtValue %~ (lu ^. luParentUpdate)
|
|
& ldtLeft .:~ (lu ^. luLinkType, ltree & ldtValue %~ (lu ^. luChildUpdate))
|
|
|
|
leftRightCombine ::
|
|
LDTComb a b ->
|
|
LDTComb a b ->
|
|
LabelDoubleTree b a ->
|
|
LabelDoubleTree b a ->
|
|
Maybe (LabelDoubleTree b a)
|
|
leftRightCombine f f' t1 t2 =
|
|
f t1 t2
|
|
<|> checkdepth t1 t2
|
|
where
|
|
checkdepth t t'@(LDT x ls rs) = fromMaybe (checktop t t') $ do
|
|
(lab, t'') <- safeHead ls
|
|
tx <- checkdepth t t''
|
|
return $ Just $ LDT x ((lab, tx) : tail ls) rs
|
|
checktop t t' = f' t t'
|
|
|
|
joinItemsInList :: (a -> a -> Maybe a) -> [a] -> [a]
|
|
joinItemsInList f xs = snd $ h (xs, [])
|
|
where
|
|
h ([], zs) = ([], zs)
|
|
h (y : ys, []) = h (ys, [y])
|
|
h (y : ys, z : zs) = case f y z of
|
|
Nothing -> h (ys, y : z : zs)
|
|
Just w -> h (w : ys, zs)
|
|
|
|
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
|
|
-- debugged with suitable info
|
|
--invAdj :: IM.IntMap Item -> IM.IntMap (Maybe (Int,Int),[Int],[Int])
|
|
--invAdj = IM.unions . fmap (dtToLRAdj getid . ldtToDT) . invLDT
|
|
-- where
|
|
-- getid (itm, _,_,_) = fromMaybe
|
|
-- (error ("invAdj item " ++ show (_itID itm) ++ " location:" ++ show (itm ^? itLocation . ilInvID)) )
|
|
-- $ itm ^? itLocation . ilInvID
|
|
|
|
-- this assumes the creature inventory is well formed, specifically the
|
|
-- 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 Item)
|
|
invRootMap = foldMap (dtToIntMapWithRoot (^?! itLocation . ilInvID) . fmap (^. _1) . ldtToDT) . invLDT
|
|
|
|
--invRootMap = foldMap (dtToRootIntMap g . ldtToDT) . invLDT
|
|
-- where
|
|
-- g = _
|
|
|
|
-- this assumes the creature inventory is well formed, specifically the
|
|
-- location ids
|
|
-- consider explicitly reseting the inventory ids (but this probably really
|
|
-- should be done upstream anyway in the actually creature inventory)
|
|
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, _, _) =
|
|
maybe
|
|
(Left ("invAdj item " ++ show (_itID itm) ++ " location: " ++ show (itm ^? itLocation)))
|
|
Right
|
|
$ itm ^? itLocation . ilInvID
|
|
|
|
invIndentIM :: IM.IntMap Item -> IM.IntMap (Item, Int, LabelDoubleTreeNodeType ComposeLinkType)
|
|
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 . fmap (^. _1)) . invLDT
|
|
where
|
|
getindex :: Item -> Int
|
|
getindex i =
|
|
fromMaybe (error "in invTrees try to get non-inventory item tree") $
|
|
i ^? itLocation . ilInvID
|