332 lines
12 KiB
Haskell
332 lines
12 KiB
Haskell
module Dodge.Item.Grammar (
|
|
invLDT,
|
|
invAdj,
|
|
invRootMap,
|
|
invRootTrees,
|
|
baseCI,
|
|
allInvLocs,
|
|
) where
|
|
|
|
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 Dodge.Item.Orientation
|
|
import LensHelp
|
|
import ListHelp
|
|
|
|
tryAttachItems ::
|
|
LabelDoubleTree ItemLink ComposedItem ->
|
|
LabelDoubleTree ItemLink ComposedItem ->
|
|
Maybe (LabelDoubleTree ItemLink ComposedItem)
|
|
tryAttachItems = leftRightCombine leftIsParentCombine rightIsParentCombine
|
|
|
|
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 ldt = do
|
|
let xs =
|
|
dropWhile
|
|
((\s -> not $ S.member s (structureToPotentialFunction ldt)) . fst)
|
|
llist
|
|
(sf, linktype) <- safeHead xs
|
|
return $ LUpdate linktype (set _3 (useBreakListsLinkTest (tail xs) rlist))
|
|
(_2 .~ sf)
|
|
rtest ldt = do
|
|
let xs =
|
|
dropWhile
|
|
((\s -> not $ S.member s (structureToPotentialFunction ldt)) . fst)
|
|
rlist
|
|
(sf, linktype) <- safeHead xs
|
|
return $ LUpdate linktype (set _3 (useBreakListsLinkTest llist (tail xs)))
|
|
(_2 .~ sf)
|
|
|
|
itemToBreakLists ::
|
|
Item ->
|
|
ItemStructuralFunction ->
|
|
([(ItemStructuralFunction, ComposeLinkType)], [(ItemStructuralFunction, ComposeLinkType)])
|
|
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
|
|
)
|
|
(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 <- itm ^? itConsumables . magType
|
|
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, ComposeLinkType)]
|
|
getAutoSpringLinks itm = case baseTriggerType itm of
|
|
HammerTrigger -> [(MakeAutoSF, MakeAutoLink)]
|
|
_ -> []
|
|
|
|
extraWeaponLinks :: Item -> [(ItemStructuralFunction, ComposeLinkType)]
|
|
extraWeaponLinks itm = case itm ^. itType of
|
|
HELD GLAUNCHER -> launcherlinks <> [(GrenadeHitEffectSF,GrenadeHitEffectLink)]
|
|
HELD RLAUNCHER -> launcherlinks
|
|
HELD RLAUNCHERX{} -> launcherlinks
|
|
_ -> []
|
|
where
|
|
launcherlinks = [(ProjectileStabiliserSF,ProjectileStabiliserLink)]
|
|
|
|
extraWeaponLinksBelow :: Item -> [(ItemStructuralFunction, ComposeLinkType)]
|
|
extraWeaponLinksBelow itm
|
|
-- | Just TwoHandUnder <- itm ^? itUse . heldAim . aimStance
|
|
| TwoHandUnder <- aStance itm
|
|
= [(UnderBarrelSlotSF,UnderBarrelSlotLink)]
|
|
| otherwise = []
|
|
|
|
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
|
|
DETECTOR {} -> GadgetPlatformSF
|
|
MAPPER -> MapperSF
|
|
ITEMSCAN -> ToggleSF
|
|
INTROSCAN {} -> IntroScanSF
|
|
HELD LASER -> WeaponTargetingSF
|
|
HELD{} -> case itm ^? itUseCondition of
|
|
Just UseableWhenAimed -> HeldPlatformSF
|
|
--Just MustBeHeld -> UnloadedWeaponSF
|
|
_ -> GadgetPlatformSF
|
|
_
|
|
| Just amtype <- itm ^? itConsumables . magType
|
|
, Just _ <- itm ^? itLocation . ilEquipSite . _Just ->
|
|
AmmoMagSF amtype
|
|
AMMOMAG{} -> maybe NoSF AmmoMagSF $ 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 ::
|
|
LabelDoubleTree ItemLink ComposedItem ->
|
|
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 -> ComposedItem
|
|
baseCI itm = (itm, itemToFunction itm, itemBaseConnections itm)
|
|
|
|
itemBaseConnections :: Item -> LinkTest
|
|
itemBaseConnections itm = case _itType itm of
|
|
HELD LASER -> laserLinkTest itm
|
|
CRAFT SPRING -> springLinkTest
|
|
_ -> uncurry useBreakL $ itemToBreakLists itm (itemToFunction itm)
|
|
|
|
laserLinkTest :: Item -> LinkTest
|
|
laserLinkTest itm = LTest (llleft itm) (llright itm)
|
|
|
|
llleft :: Item -> LabelDoubleTree ItemLink ComposedItem -> Maybe LinkUpdate
|
|
llleft itm =
|
|
_tryLeftLink
|
|
. uncurry useBreakL
|
|
$ itemToBreakLists itm WeaponTargetingSF
|
|
|
|
llright :: Item -> LabelDoubleTree ItemLink ComposedItem -> Maybe LinkUpdate
|
|
llright itm pci = case pci ^. ldtValue . _1 . itType of
|
|
CRAFT TRANSFORMER -> Just (toLasgunUpdate itm)
|
|
_ -> _tryRightLink (uncurry useBreakL $ itemToBreakLists itm WeaponTargetingSF) pci
|
|
|
|
toLasgunUpdate :: Item -> LinkUpdate
|
|
toLasgunUpdate itm =
|
|
LUpdate
|
|
(ILink FunctionChangeLink orientAttachment)
|
|
(\(par, _, _) -> (par, HeldPlatformSF, uncurry useBreakL $ itemToBreakLists itm HeldPlatformSF))
|
|
(\(chi, _, up) -> (chi, FunctionChangeSF, up))
|
|
|
|
springLinkTest :: LinkTest
|
|
springLinkTest = LTest (const Nothing) $
|
|
\ci -> case ci ^. ldtValue . _1 . itType of
|
|
CRAFT HARDWARE ->
|
|
Just
|
|
( LUpdate
|
|
(ILink FunctionChangeLink orientAttachment)
|
|
(\(par, _, up) -> (par, MakeAutoSF, up))
|
|
(\(chi, _, up) -> (chi, FunctionChangeSF, up))
|
|
)
|
|
_ -> Nothing
|
|
|
|
--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 ComposedItem ItemLink
|
|
leftIsParentCombine ltree rtree = do
|
|
lu <- (ltree ^. ldtValue . _3 . tryRightLink) rtree --(rtree ^. ldtValue)
|
|
return $
|
|
ltree & ldtValue %~ (lu ^. luParentUpdate)
|
|
& ldtRight %~ (++ [(lu ^. luLinkType, rtree & ldtValue %~ (lu ^. luChildUpdate))])
|
|
|
|
rightIsParentCombine :: LDTComb ComposedItem ItemLink
|
|
rightIsParentCombine ltree rtree = do
|
|
lu <- (rtree ^. ldtValue . _3 . tryLeftLink) ltree -- (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)
|
|
|
|
-- this puts the first elements in the intmap at the end of the list
|
|
invLDT :: IM.IntMap Item -> [LabelDoubleTree ItemLink ComposedItem]
|
|
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 (LabelDoubleTree ItemLink ComposedItem)
|
|
invRootTrees = IM.fromDistinctAscList . reverse . map getid . invLDT
|
|
where
|
|
getid ::
|
|
LabelDoubleTree ItemLink ComposedItem ->
|
|
(Int, LabelDoubleTree ItemLink ComposedItem)
|
|
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 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 ::
|
|
Int ->
|
|
LocationLDT ItemLink ComposedItem ->
|
|
( IM.IntMap (Int, LocationLDT ItemLink ComposedItem) ->
|
|
IM.IntMap (Int, LocationLDT ItemLink ComposedItem)
|
|
) ->
|
|
IM.IntMap (Int, LocationLDT ItemLink ComposedItem) ->
|
|
IM.IntMap (Int, LocationLDT ItemLink ComposedItem)
|
|
g x ldt =
|
|
(.)
|
|
( IM.insert
|
|
(ldt ^?! locLDT . ldtValue . _1 . itLocation . ilInvID)
|
|
(x, ldt)
|
|
)
|