272 lines
9.9 KiB
Haskell
272 lines
9.9 KiB
Haskell
module Dodge.Item.Grammar (
|
|
invLDT,
|
|
invAdj,
|
|
invRootMap,
|
|
invRootTrees,
|
|
baseCI,
|
|
allInvLocs,
|
|
) where
|
|
|
|
import Dodge.ItemUseCondition
|
|
import Dodge.Data.UseCondition
|
|
import Dodge.Item.MagAmmoType
|
|
import Dodge.Data.AmmoType
|
|
import Dodge.Item.AmmoSlots
|
|
import Dodge.Data.TriggerType
|
|
import Dodge.BaseTriggerType
|
|
import Dodge.Data.AimStance
|
|
import Dodge.Item.AimStance
|
|
import Control.Applicative
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Data.Maybe
|
|
import qualified Data.Set as S
|
|
import Dodge.Data.ComposedItem
|
|
import Dodge.Data.DoubleTree
|
|
import Dodge.Data.Item
|
|
import Dodge.DoubleTree
|
|
import LensHelp
|
|
import ListHelp
|
|
|
|
tryAttachItems :: LDTree ItemLink CItem -> LDTree ItemLink CItem ->
|
|
Maybe (LDTree ItemLink CItem)
|
|
tryAttachItems = leftRightCombine leftIsParentCombine rightIsParentCombine
|
|
|
|
itemToBreakLists ::
|
|
Item ->
|
|
ItemStructuralFunction ->
|
|
([(ItemStructuralFunction, ItemLink)], [(ItemStructuralFunction, ItemLink)])
|
|
itemToBreakLists itm itmf = case (itm ^. itType, itmf) of
|
|
(HELD TORCH, _) -> (getAmmoLinks itm, [])
|
|
(ATTACH UNDERBARRELSLOT, _) -> ([(UnderBarrelPlatformSF, UnderBarrelPlatformLink)], [])
|
|
(_, HeldPlatformSF) ->
|
|
( getAmmoLinks itm
|
|
<> extraWeaponLinksBelow itm
|
|
, [(WeaponTargetingSF, WeaponTargetingLink), (WeaponScopeSF, WeaponScopeLink)]
|
|
<> getAutoSpringLinks itm
|
|
<> extraWeaponLinks itm
|
|
)
|
|
(_, UnderBarrelPlatformSF) ->
|
|
( getAmmoLinks itm,[])
|
|
(DETECTOR {}, _) ->
|
|
( getAmmoLinks itm
|
|
, [(ARHUDSF,SFLink ARHUDSF),(TriggerSF, TriggerLink),(MapperSF,SFLink MapperSF)]
|
|
)
|
|
(MAPPER, _) ->
|
|
( []
|
|
, [(ARHUDSF,SFLink ARHUDSF)]
|
|
)
|
|
(_, GadgetPlatformSF) ->
|
|
( getAmmoLinks itm
|
|
, [(TriggerSF, TriggerLink), (WeaponTargetingSF, WeaponTargetingLink), (WeaponScopeSF, WeaponScopeLink)]
|
|
)
|
|
(_, AmmoMagSF{}) -> fromMaybe ([], []) $ do
|
|
atype <- magAmmoType itm
|
|
let screenanddet = case atype of
|
|
LauncherAmmo ->
|
|
[ (RemoteScreenSF, RemoteScreenLink)
|
|
, (RemoteDetonatorSF, RemoteDetonatorLink)
|
|
]
|
|
_ -> []
|
|
return
|
|
( [ (AmmoModifierSF atype, AmmoModLink)
|
|
, (AmmoTargetingSF atype, AmmoTargetingLink)
|
|
, (AmmoPayloadSF atype, AmmoPayloadLink)
|
|
, (AmmoEffectSF atype, AmmoEffectLink)
|
|
, (SmokeReducerSF, SmokeReducerLink)
|
|
]
|
|
<> screenanddet
|
|
, []
|
|
)
|
|
(_, RemoteScreenSF) ->
|
|
( [(JoystickSF, JoystickLink)]
|
|
, []
|
|
)
|
|
(_, WeaponTargetingSF) -> (getAmmoLinks itm ++ [(ARHUDSF, SFLink ARHUDSF)], [])
|
|
(ATTACH BULLETSYNTH, _) ->
|
|
([(AmmoMagSF ElectricalAmmo, AmmoInLink 0 ElectricalAmmo)], [])
|
|
_ -> ([], [])
|
|
|
|
getAutoSpringLinks :: Item -> [(ItemStructuralFunction, ItemLink)]
|
|
getAutoSpringLinks itm = case itemTriggerType itm of
|
|
HammerTrigger -> [(MakeAutoSF, MakeAutoLink)]
|
|
_ -> []
|
|
|
|
extraWeaponLinks :: Item -> [(ItemStructuralFunction, ItemLink)]
|
|
extraWeaponLinks itm = case itm ^. itType of
|
|
HELD GLAUNCHER -> launcherlinks <> [(GrenadeHitEffectSF,GrenadeHitEffectLink)]
|
|
HELD RLAUNCHER -> launcherlinks
|
|
HELD RLAUNCHERX{} -> launcherlinks
|
|
_ -> []
|
|
where
|
|
launcherlinks = [(ProjectileStabiliserSF,ProjectileStabiliserLink)]
|
|
|
|
extraWeaponLinksBelow :: Item -> [(ItemStructuralFunction, ItemLink)]
|
|
extraWeaponLinksBelow itm
|
|
-- | Just TwoHandUnder <- itm ^? itUse . heldAim . aimStance
|
|
| TwoHandUnder <- itemBaseStance itm
|
|
= [(UnderBarrelSlotSF,UnderBarrelSlotLink)]
|
|
| otherwise = []
|
|
|
|
getAmmoLinks :: Item -> [(ItemStructuralFunction, ItemLink)]
|
|
getAmmoLinks itm =
|
|
map
|
|
(\(i, a) -> (AmmoMagSF a, AmmoInLink i a))
|
|
(IM.toList $ itemAmmoSlots itm)
|
|
|
|
itemToFunction :: Item -> ItemStructuralFunction
|
|
itemToFunction itm = case itm ^. itType of
|
|
DETECTOR {} -> GadgetPlatformSF
|
|
MAPPER -> MapperSF
|
|
ITEMSCAN -> ToggleSF
|
|
INTROSCAN {} -> IntroScanSF
|
|
HELD LASER -> WeaponTargetingSF
|
|
HELD{} -> case itUseCondition itm of
|
|
UseableWhenAimed -> HeldPlatformSF
|
|
--Just MustBeHeld -> UnloadedWeaponSF
|
|
_ -> GadgetPlatformSF
|
|
_
|
|
| Just amtype <- magAmmoType itm-- ^? itConsumables . magType
|
|
, Just _ <- itm ^? itLocation . ilEquipSite . _Just ->
|
|
AmmoMagSF amtype
|
|
AMMOMAG{} -> maybe NoSF AmmoMagSF $ magAmmoType itm -- ^? itConsumables . magType
|
|
ATTACH REMOTESCREEN -> RemoteScreenSF
|
|
ATTACH JOYSTICK -> JoystickSF
|
|
ATTACH REMOTEDETONATOR -> RemoteDetonatorSF
|
|
ATTACH SMOKEREDUCER -> SmokeReducerSF
|
|
ATTACH BULLETSYNTH -> AmmoModifierSF BulletAmmo
|
|
ATTACH ZOOMSCOPE -> WeaponScopeSF
|
|
ATTACH HOMINGMODULE -> AmmoTargetingSF LauncherAmmo
|
|
ARHUD -> ARHUDSF
|
|
ATTACH UNDERBARRELSLOT -> UnderBarrelSlotSF
|
|
BULLETMOD BulletModPayload{} -> AmmoPayloadSF BulletAmmo
|
|
BULLETMOD BulletModEffect{} -> AmmoEffectSF BulletAmmo
|
|
TARGETING{} -> WeaponTargetingSF
|
|
EQUIP WRIST_ECG -> TriggerSF
|
|
EQUIP{} -> EquipmentPlatformSF
|
|
ATTACH SHELLPAYLOAD{} -> AmmoPayloadSF LauncherAmmo
|
|
DROPPER{} -> GadgetPlatformSF
|
|
CLICKER{} -> GadgetPlatformSF
|
|
_ -> NoSF
|
|
|
|
structureToPotentialFunction :: LDTree ItemLink CItem -> S.Set ItemStructuralFunction
|
|
structureToPotentialFunction ldt = case ldt ^. ldtValue . _1 . itType of
|
|
STICKYMOD -> S.singleton GrenadeHitEffectSF
|
|
ATTACH GIMBAL -> S.singleton ProjectileStabiliserSF
|
|
ATTACH GYROSCOPE -> S.singleton ProjectileStabiliserSF
|
|
HELD GLAUNCHER -> S.singleton UnderBarrelPlatformSF
|
|
_ -> S.singleton (ldt ^. ldtValue . _2)
|
|
|
|
baseCI :: Item -> CItem
|
|
baseCI itm = (itm, itemToFunction itm)
|
|
|
|
type LDTComb a b = LDTree b a -> LDTree b a -> Maybe (LDTree b a)
|
|
|
|
leftIsParentCombine :: LDTComb CItem ItemLink
|
|
leftIsParentCombine ltree rtree = do
|
|
let l = rightChildList ltree
|
|
xs = dropWhile ((\s -> not $ S.member s (structureToPotentialFunction rtree)) . fst) l
|
|
(sf,linktype) <- safeHead xs
|
|
return $
|
|
ltree & ldtRight .:~ (linktype, rtree & ldtValue . _2 .~ sf)
|
|
|
|
rightIsParentCombine :: LDTComb CItem ItemLink
|
|
rightIsParentCombine ltree rtree = do
|
|
let l = leftChildList rtree
|
|
xs = dropWhile ((\s -> not $ S.member s (structureToPotentialFunction ltree)) . fst) l
|
|
(sf,linktype) <- safeHead xs
|
|
return $
|
|
rtree & ldtLeft .:~ (linktype, ltree & ldtValue . _2 .~ sf)
|
|
|
|
leftChildList :: LDTree ItemLink CItem -> [(ItemStructuralFunction, ItemLink)]
|
|
leftChildList t = foldl' f l (reverse $ t ^.. ldtLeft . each . _1)
|
|
where
|
|
l = fst $ itemToBreakLists (t ^. ldtValue . _1) (t ^. ldtValue . _2)
|
|
f x y = tail $ dropWhile ((/=y) . snd) x
|
|
|
|
rightChildList :: LDTree ItemLink CItem -> [(ItemStructuralFunction, ItemLink)]
|
|
rightChildList t = foldl' f l (reverse $ t ^.. ldtRight . each . _1)
|
|
where
|
|
l = snd $ itemToBreakLists (t ^. ldtValue . _1) (t ^. ldtValue . _2)
|
|
f x y = tail $ dropWhile ((/=y) . snd) x
|
|
|
|
leftRightCombine ::
|
|
LDTComb a b ->
|
|
LDTComb a b ->
|
|
LDTree b a ->
|
|
LDTree b a ->
|
|
Maybe (LDTree 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)
|
|
|
|
-- this puts the first elements in the intmap at the end of the list
|
|
invLDT :: IM.IntMap Item -> [LDTree ItemLink CItem]
|
|
invLDT =
|
|
joinItemsInList tryAttachItems . IM.elems
|
|
. fmap (singleLDT . baseCI)
|
|
|
|
-- 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)
|
|
-- The first Int in the maybe is the root, the second the parent
|
|
invAdj :: IM.IntMap Item -> IM.IntMap (Maybe (Int, Int), [Int], [Int])
|
|
invAdj = IM.unions . map g . invLDT
|
|
where
|
|
g = dtToLRAdj getid . ldtToDT
|
|
getid (itm, _) =
|
|
fromMaybe
|
|
(error ("invAdj item " ++ show (_itID itm) ++ " location: " ++ show (itm ^? itLocation)))
|
|
$ itm ^? itLocation . ilInvID
|
|
|
|
-- returns an intmap with trees for (only!) root items, indexed by inventory position
|
|
invRootTrees :: IM.IntMap Item -> IM.IntMap (LDTree ItemLink CItem)
|
|
invRootTrees = IM.fromDistinctAscList . reverse . map getid . invLDT
|
|
where
|
|
getid :: LDTree ItemLink CItem -> (Int, LDTree ItemLink CItem)
|
|
getid t = (t ^?! ldtValue . _1 . itLocation . ilInvID, t)
|
|
|
|
-- returns an intmap with indents and locations for all items
|
|
allInvLocs :: IM.IntMap Item -> IM.IntMap (Int, LocationLDT ItemLink CItem)
|
|
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 ::
|
|
Int ->
|
|
LocationLDT ItemLink CItem ->
|
|
( IM.IntMap (Int, LocationLDT ItemLink CItem) ->
|
|
IM.IntMap (Int, LocationLDT ItemLink CItem)
|
|
) ->
|
|
IM.IntMap (Int, LocationLDT ItemLink CItem) ->
|
|
IM.IntMap (Int, LocationLDT ItemLink CItem)
|
|
g x ldt =
|
|
(.)
|
|
( IM.insert
|
|
(ldt ^?! locLDT . ldtValue . _1 . itLocation . ilInvID)
|
|
(x, ldt)
|
|
)
|