180 lines
6.9 KiB
Haskell
180 lines
6.9 KiB
Haskell
module Dodge.Item.Grammar (
|
|
invLDT,
|
|
invTrees',
|
|
invTrees,
|
|
invIndentIM,
|
|
invAdj,
|
|
invRootMap,
|
|
) where
|
|
|
|
import Control.Applicative
|
|
import Data.Bifunctor
|
|
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 Dodge.Item.Orientation
|
|
import LensHelp
|
|
import ListHelp
|
|
|
|
useBreakL' :: [(ItemStructuralFunction, ComposeLinkType)] -> [(ItemStructuralFunction, ComposeLinkType)]
|
|
-> LinkTest ItemLink
|
|
useBreakL' x y = useBreakListsLinkTest (map (uncurry noa) x) (map (uncurry noa) y)
|
|
where
|
|
noa a b = (a, ILink b orientAttachment)
|
|
|
|
useBreakListsLinkTest :: [(ItemStructuralFunction, a)] -> [(ItemStructuralFunction, a)] -> LinkTest a
|
|
useBreakListsLinkTest llist rlist = LTest ltest rtest
|
|
where
|
|
ltest (_, sf, _) = do
|
|
let xs = dropWhile ((/= sf) . fst) llist
|
|
(_, linktype) <- safeHead xs
|
|
return $ LUpdate linktype (set _3 (useBreakListsLinkTest (tail xs) rlist)) id
|
|
rtest (_, sf, _) = do
|
|
let xs = dropWhile ((/= sf) . fst) rlist
|
|
(_, linktype) <- safeHead xs
|
|
return $ LUpdate linktype (set _3 (useBreakListsLinkTest llist (tail xs))) id
|
|
|
|
itemToBreakLists :: Item
|
|
-> ([(ItemStructuralFunction, ComposeLinkType)] , [(ItemStructuralFunction, ComposeLinkType)])
|
|
itemToBreakLists itm = case itm ^. itType of
|
|
HELD TORCH -> (getAmmoLinks itm,[])
|
|
HELD {} ->
|
|
( getAmmoLinks itm
|
|
, [(WeaponTargetingSF,WeaponTargetingLink), (WeaponScopeSF,WeaponScopeLink)]
|
|
)
|
|
AMMOMAG {} -> fromMaybe ([],[]) $ do
|
|
atype <- itm ^? itUse . amagType
|
|
return
|
|
([ (AmmoModifierSF atype, AmmoModLink)
|
|
, (AmmoTargetingSF atype, AmmoTargetingLink)
|
|
, (AmmoPayloadSF atype, AmmoPayloadLink)
|
|
, (AmmoEffectSF atype, AmmoEffectLink)
|
|
, (RemoteScreenSF, RemoteScreenLink)
|
|
],[])
|
|
TARGETING{} -> ([(AugmentedHUDSF,AugmentedHUDLink)],[])
|
|
_ -> ([],[])
|
|
|
|
getAmmoLinks :: Item -> [(ItemStructuralFunction, ComposeLinkType)]
|
|
getAmmoLinks itm = map
|
|
(\(i, a) -> (AmmoMagSF a,AmmoInLink i a))
|
|
(IM.toList $ itm ^. itUse . heldAmmoTypes)
|
|
|
|
itemToFunction :: Item -> ItemStructuralFunction
|
|
itemToFunction itm = case itm ^. itType of
|
|
HELD TORCH -> WeaponScopeSF
|
|
HELD {} -> WeaponPlatformSF
|
|
AMMOMAG {} -> maybe UncomposableIsolateSF AmmoMagSF $ itm ^? itUse . amagType
|
|
ATTACH REMOTESCREEN -> RemoteScreenSF
|
|
ATTACH BULLETSYNTHESIZER -> AmmoModifierSF BulletAmmo
|
|
ATTACH ZOOMSCOPE -> WeaponScopeSF
|
|
ATTACH HOMINGMODULE -> AmmoTargetingSF ProjectileAmmo
|
|
ATTACH AUGMENTEDHUD -> AugmentedHUDSF
|
|
BULLETMOD BulletModTrajectory{} -> AmmoTargetingSF BulletAmmo
|
|
BULLETMOD BulletModPayload{} -> AmmoPayloadSF BulletAmmo
|
|
BULLETMOD BulletModEffect{} -> AmmoEffectSF BulletAmmo
|
|
TARGETING{} -> WeaponTargetingSF
|
|
_ -> UncomposableIsolateSF
|
|
|
|
simplePCI :: Item -> PartiallyComposedItem ItemLink
|
|
simplePCI itm = (itm, itemToFunction itm, uncurry useBreakL' $ itemToBreakLists itm)
|
|
|
|
basePartiallyComposedItem' :: Item -> PartiallyComposedItem ItemLink
|
|
basePartiallyComposedItem' itm = simplePCI itm
|
|
|
|
type LDTComb a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe (LabelDoubleTree b a)
|
|
|
|
leftIsParentCombine :: LDTComb (PartiallyComposedItem a) a
|
|
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 a) a
|
|
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 ItemLink (PartiallyComposedItem ItemLink)]
|
|
invLDT =
|
|
joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems
|
|
. fmap (singleLDT . basePartiallyComposedItem')
|
|
|
|
-- 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
|
|
|
|
-- 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
|
|
. map (bimap _iatType (\(x, y, _) -> (x, y)))
|
|
. invLDT
|
|
|
|
-- returns an intmap with trees for all root items
|
|
invTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ComposeLinkType Item)
|
|
invTrees = IM.unions . map (ldtToIM getindex . fmap (^. _1)) . map (bimap _iatType (\(x, y, _) -> (x, y))) . invLDT
|
|
where
|
|
getindex :: Item -> Int
|
|
getindex i =
|
|
fromMaybe (error "in invTrees try to get non-inventory item tree") $
|
|
i ^? itLocation . ilInvID
|
|
|
|
-- returns an intmap with trees for all root items
|
|
invTrees' :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ItemLink Item)
|
|
invTrees' = IM.unions . map (ldtToIM getindex . fmap (^. _1)) . map (bimap id (\(x, y, _) -> (x, y))) . invLDT
|
|
where
|
|
getindex :: Item -> Int
|
|
getindex i =
|
|
fromMaybe (error "in invTrees try to get non-inventory item tree") $
|
|
i ^? itLocation . ilInvID
|