212 lines
8.3 KiB
Haskell
212 lines
8.3 KiB
Haskell
module Dodge.Item.Grammar (
|
|
invLDT,
|
|
invTrees,
|
|
invAdj,
|
|
invRootMap,
|
|
invRootTrees,
|
|
pciToCI,
|
|
basePCI,
|
|
allInvLocs,
|
|
) where
|
|
|
|
import Dodge.Data.ComposedItem
|
|
import Control.Applicative
|
|
import Data.Bifunctor
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Data.Maybe
|
|
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
|
|
useBreakL x y = useBreakListsLinkTest (map (uncurry noa) x) (map (uncurry noa) y)
|
|
where
|
|
noa a b = (a, ILink b orientAttachment)
|
|
|
|
useBreakListsLinkTest :: [(ItemStructuralFunction, ItemLink)]
|
|
-> [(ItemStructuralFunction, ItemLink)] -> LinkTest
|
|
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
|
|
:: ComposedItem
|
|
-> ([(ItemStructuralFunction, ComposeLinkType)] , [(ItemStructuralFunction, ComposeLinkType)])
|
|
itemToBreakLists ci = case (itm ^. itType,ci ^. cItemFunction) of
|
|
-- HELD TORCH -> (getAmmoLinks itm,[])
|
|
(_,WeaponPlatformSF) ->
|
|
( getAmmoLinks itm
|
|
, [(WeaponTargetingSF,WeaponTargetingLink), (WeaponScopeSF,WeaponScopeLink)]
|
|
)
|
|
-- AMMOMAG {} -> fromMaybe ([],[]) $ do
|
|
(_,AmmoMagSF {}) -> fromMaybe ([],[]) $ do
|
|
atype <- itm ^? itUse . amagType
|
|
return
|
|
([ (AmmoModifierSF atype, AmmoModLink)
|
|
, (AmmoTargetingSF atype, AmmoTargetingLink)
|
|
, (AmmoPayloadSF atype, AmmoPayloadLink)
|
|
, (AmmoEffectSF atype, AmmoEffectLink)
|
|
, (RemoteScreenSF, RemoteScreenLink)
|
|
],[])
|
|
(_,WeaponTargetingSF) -> (getAmmoLinks itm ++ [(AugmentedHUDSF,AugmentedHUDLink)],[])
|
|
_ -> ([],[])
|
|
where
|
|
itm = ci ^. cItem
|
|
|
|
getAmmoLinks :: Item -> [(ItemStructuralFunction, ComposeLinkType)]
|
|
getAmmoLinks itm = map
|
|
(\(i, a) -> (AmmoMagSF a,AmmoInLink i a))
|
|
(IM.toList $ itm ^. itAmmoSlots)
|
|
|
|
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
|
|
|
|
pciToCI :: PartiallyComposedItem -> ComposedItem
|
|
pciToCI (x,y,_) = CItem x y
|
|
|
|
basePCI :: Item -> PartiallyComposedItem
|
|
basePCI itm = case _itType itm of
|
|
HELD LASER -> (itm, WeaponTargetingSF, laserLinkTest itm)
|
|
_ -> (itm, itemToFunction itm, uncurry useBreakL $ itemToBreakLists (CItem itm (itemToFunction itm)))
|
|
|
|
laserLinkTest :: Item -> LinkTest
|
|
laserLinkTest itm = LTest (llleft itm) (llright itm)
|
|
|
|
llleft :: Item -> PartiallyComposedItem -> Maybe LinkUpdate
|
|
llleft itm pci = _tryLeftLink (uncurry useBreakL $ itemToBreakLists (CItem itm WeaponTargetingSF)) pci
|
|
|
|
llright :: Item -> PartiallyComposedItem -> Maybe LinkUpdate
|
|
llright itm pci = case pci ^. _1 . itType of
|
|
CRAFT TRANSFORMER -> Just (toLasgunUpdate itm)
|
|
_ -> _tryRightLink (uncurry useBreakL $ itemToBreakLists (CItem itm WeaponTargetingSF)) pci
|
|
|
|
toLasgunUpdate :: Item -> LinkUpdate
|
|
toLasgunUpdate itm = LUpdate (ILink FunctionChangeLink orientAttachment)
|
|
(\(par,_,_) -> (par,WeaponPlatformSF,uncurry useBreakL $ itemToBreakLists (CItem itm WeaponPlatformSF)))
|
|
(\(chi,_,up) -> (chi,FunctionChangeSF,up))
|
|
|
|
--itemLinkTestLeft :: Item -> PartiallyComposedItem -> Maybe LinkUpdate
|
|
--itemLinkTestLeft itm = _tryLeftLink $
|
|
-- uncurry useBreakL $ itemToBreakLists itm
|
|
|
|
type LDTComb a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe (LabelDoubleTree b a)
|
|
|
|
leftIsParentCombine :: LDTComb PartiallyComposedItem ItemLink
|
|
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 ItemLink
|
|
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]
|
|
invLDT =
|
|
joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems
|
|
. fmap (singleLDT . basePCI)
|
|
|
|
-- 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
|
|
|
|
-- returns an intmap with trees for all items
|
|
invTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ComposeLinkType Item)
|
|
invTrees = fmap (first _iatType) . invTrees'
|
|
|
|
-- returns an intmap with trees for all items
|
|
invTrees' :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ItemLink Item)
|
|
invTrees' = IM.unions . map (ldtToIM getindex . fmap (^. _1)) . map (fmap (\(x, y, _) -> (x, y))) . invLDT
|
|
where
|
|
getindex i =
|
|
fromMaybe (error "in invTrees try to get non-inventory item tree") $
|
|
i ^? itLocation . ilInvID
|
|
|
|
-- returns an intmap with trees for root items, indexed by inventory position
|
|
invRootTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ItemLink ComposedItem)
|
|
invRootTrees = IM.fromDistinctAscList . reverse . map (getid . fmap (\(x, y, _) -> CItem x y)) . invLDT
|
|
where
|
|
getid :: LabelDoubleTree ItemLink ComposedItem -> (Int,LabelDoubleTree ItemLink ComposedItem)
|
|
getid t = (t ^?! ldtValue . cItem . itLocation . ilInvID, t)
|
|
|
|
-- returns an intmap with indents and locations for all items
|
|
allInvLocs :: IM.IntMap Item -> IM.IntMap (Int,LocationLDT ItemLink ComposedItem)
|
|
allInvLocs inv = foldMap (f . LocLDT TopLDT) (IM.elems (invRootTrees inv)) mempty
|
|
where
|
|
f t = cldtPropagateFold h h g 0 t id
|
|
h x _ _ _ = x + 1
|
|
g x ldt = (.) (IM.insert (ldt ^?! locLDT . ldtValue . cItem . itLocation . ilInvID) (x,ldt))
|