272 lines
9.7 KiB
Haskell
272 lines
9.7 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Item.Grammar (
|
|
invDT,
|
|
invDT',
|
|
invAdj,
|
|
invRootMap,
|
|
invIMDT,
|
|
baseCI,
|
|
invIndents,
|
|
) where
|
|
|
|
import NewInt
|
|
import Dodge.Item.Orientation
|
|
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 :: DTree CItem -> DTree CItem -> Maybe (DTree CItem)
|
|
tryAttachItems = leftRightCombine leftIsParentCombine rightIsParentCombine
|
|
|
|
itemAboveAttachables :: CItem -> [ItemSF]
|
|
itemAboveAttachables (itm,sf) = case (itm ^. itType, sf) of
|
|
(_, HeldPlatformSF) ->
|
|
[WeaponTargetingSF, WeaponScopeSF,TorchSF]
|
|
<> getAutoSpringLinks itm
|
|
<> extraWeaponLinks itm
|
|
(DETECTOR {}, _) -> [ARHUDSF,TriggerSF,MapperSF]
|
|
--(CRAFT TRANSFORMER, _) -> [LaserWeaponSF]
|
|
(LASER, _) -> [TransformerSF]
|
|
(MAPPER, _) -> [ARHUDSF]
|
|
(_, GadgetPlatformSF) -> [TriggerSF, WeaponTargetingSF, WeaponScopeSF]
|
|
_ -> []
|
|
|
|
itemBelowAttachables :: CItem -> [ItemSF]
|
|
itemBelowAttachables (itm,sf) = case (itm ^. itType, sf) of
|
|
(LASER, WeaponTargetingSF) -> getAmmoLinks itm
|
|
(LASER, LaserWeaponSF) -> [PulseBallSF] <> getAmmoLinks itm
|
|
(LASER, PulseBallSF) -> [PulseBallSF]
|
|
--(HELD LASER, _) -> [PulseBallSF]
|
|
(HELD LED, _) -> getAmmoLinks itm
|
|
(ATTACH CAPACITOR, _) -> [AmmoMagSF 0 ElectricalAmmo]
|
|
(ATTACH UNDERBARRELSLOT, _) -> [UnderBarrelPlatformSF]
|
|
(_, HeldPlatformSF) -> getAmmoLinks itm <> extraWeaponLinksBelow itm
|
|
(_, UnderBarrelPlatformSF) -> getAmmoLinks itm
|
|
(DETECTOR {}, _) -> getAmmoLinks itm
|
|
(_, GadgetPlatformSF) -> getAmmoLinks itm
|
|
(_, AmmoMagSF{}) -> fromMaybe [] $ do
|
|
atype <- magAmmoType itm
|
|
let screenanddet = case atype of
|
|
LauncherAmmo ->
|
|
[ RemoteScreenSF
|
|
, RemoteDetonatorSF
|
|
]
|
|
_ -> []
|
|
return $
|
|
[ AmmoModifierSF atype
|
|
, AmmoTargetingSF atype
|
|
, AmmoPayloadSF atype
|
|
, AmmoEffectSF atype
|
|
, SmokeReducerSF
|
|
]
|
|
<> screenanddet
|
|
|
|
(_, RemoteScreenSF) -> [JoystickSF]
|
|
(_, WeaponTargetingSF) -> getAmmoLinks itm ++ [ARHUDSF]
|
|
(ATTACH BULLETSYNTH, _) -> [AmmoMagSF 0 ElectricalAmmo]
|
|
_ -> []
|
|
|
|
getAutoSpringLinks :: Item -> [ItemSF]
|
|
getAutoSpringLinks itm = case baseItemTriggerType itm of
|
|
SemiAutoTrigger _ -> [MakeAutoSF]
|
|
_ -> []
|
|
|
|
extraWeaponLinks :: Item -> [ItemSF]
|
|
extraWeaponLinks itm = case itm ^. itType of
|
|
HELD GLAUNCHER -> launcherlinks <> [GrenadeHitEffectSF]
|
|
HELD RLAUNCHER -> launcherlinks
|
|
HELD RLAUNCHERX{} -> launcherlinks
|
|
_ -> []
|
|
where
|
|
launcherlinks = [ProjectileStabiliserSF]
|
|
|
|
extraWeaponLinksBelow :: Item -> [ItemSF]
|
|
extraWeaponLinksBelow itm
|
|
| TwoHandUnder <- itemBaseStance itm = [UnderBarrelSlotSF]
|
|
| otherwise = []
|
|
|
|
getAmmoLinks :: Item -> [ItemSF]
|
|
getAmmoLinks = map (uncurry AmmoMagSF) . IM.toList . itemAmmoSlots
|
|
|
|
itemToFunction :: Item -> ItemSF
|
|
itemToFunction itm = case itm ^. itType of
|
|
DETECTOR {} -> GadgetPlatformSF
|
|
MAPPER -> MapperSF
|
|
ITEMSCAN -> ToggleSF
|
|
INTROSCAN {} -> IntroScanSF
|
|
LASER -> WeaponTargetingSF
|
|
HELD LED -> TorchSF
|
|
HELD{} -> case itUseCondition itm of
|
|
UseableWhenAimed -> HeldPlatformSF
|
|
_ -> GadgetPlatformSF
|
|
_ | Just amtype <- magAmmoType itm-- ^? itConsumables . magType
|
|
, Just _ <- itm ^? itLocation . ilEquipSite . _Just ->
|
|
AmmoMagSF 0 amtype
|
|
AMMOMAG{} -> maybe NoSF (AmmoMagSF 0) $ 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
|
|
ATTACH CAPACITOR -> CapacitorSF
|
|
CRAFT TRANSFORMER -> TransformerSF
|
|
_ -> NoSF
|
|
|
|
treeToPotentialFunction :: DTree CItem -> S.Set ItemSF
|
|
treeToPotentialFunction ldt = case ldt ^. dtValue . _1 . itType of
|
|
STICKYMOD -> S.singleton GrenadeHitEffectSF
|
|
ATTACH GIMBAL -> S.singleton ProjectileStabiliserSF
|
|
ATTACH GYROSCOPE -> S.singleton ProjectileStabiliserSF
|
|
HELD GLAUNCHER -> S.singleton UnderBarrelPlatformSF
|
|
HELD BURSTRIFLE -> S.singleton UnderBarrelPlatformSF
|
|
LASER | sf == WeaponTargetingSF -> S.fromList [WeaponTargetingSF,LaserWeaponSF]
|
|
-- following limits items to ten ammo slots
|
|
_ | AmmoMagSF _ x <- ldt ^. dtValue . _2 -> S.fromList [AmmoMagSF i x | i <- [0..9]]
|
|
ATTACH CAPACITOR -> S.fromList [CapacitorSF,PulseBallSF]
|
|
_ -> S.singleton (ldt ^. dtValue . _2)
|
|
where
|
|
sf = ldt ^. dtValue . _2
|
|
|
|
baseCI :: Item -> CItem
|
|
baseCI itm = (itm, itemToFunction itm)
|
|
|
|
type DTComb a = DTree a -> DTree a -> Maybe (DTree a)
|
|
|
|
leftIsParentCombine :: DTComb CItem
|
|
leftIsParentCombine ltree rtree = do
|
|
sf <- find (`S.member` treeToPotentialFunction rtree) (rightChildList ltree)
|
|
let f (itm,psf) = (itm, updateLeftParentSF (itm ^. itType) psf sf)
|
|
return $ ltree & dtRight .:~ ( rtree & dtValue . _2 .~ sf)
|
|
& dtValue %~ f
|
|
|
|
updateLeftParentSF :: ItemType -> ItemSF -> ItemSF -> ItemSF
|
|
updateLeftParentSF LASER WeaponTargetingSF TransformerSF = LaserWeaponSF
|
|
updateLeftParentSF _ psf _ = psf
|
|
|
|
rightIsParentCombine :: DTComb CItem
|
|
rightIsParentCombine ltree rtree = do
|
|
sf <- find (`S.member` treeToPotentialFunction ltree) (leftChildList rtree)
|
|
let f (itm,psf) = (itm, updateRightParentSF (itm ^. itType) psf sf)
|
|
return $ rtree & dtLeft .:~ ( ltree & dtValue . _2 .~ sf)
|
|
& dtValue %~ f
|
|
|
|
updateRightParentSF :: ItemType -> ItemSF -> ItemSF -> ItemSF
|
|
updateRightParentSF LASER LaserWeaponSF CapacitorSF = PulseLaserSF
|
|
updateRightParentSF _ psf _ = psf
|
|
|
|
leftChildList :: DTree CItem -> [ItemSF]
|
|
leftChildList t = foldl' f l (reverse $ t ^.. dtLeft . each . dtValue . _2)
|
|
where
|
|
l = itemBelowAttachables (t ^. dtValue)
|
|
f x y = tail $ dropWhile (/=y) x
|
|
|
|
rightChildList :: DTree CItem -> [ItemSF]
|
|
rightChildList t = foldl' f l (reverse $ t ^.. dtRight . each . dtValue . _2)
|
|
where
|
|
l = itemAboveAttachables (t ^. dtValue)
|
|
f x y = tail $ dropWhile (/=y) x
|
|
|
|
leftRightCombine :: DTComb a -> DTComb a -> DTree a -> DTree a -> Maybe (DTree a)
|
|
leftRightCombine f f' t1 t2 = f t1 t2 <|> checkdepth t1 t2
|
|
where
|
|
--checkdepth t t'@(DT x ls rs) = fromMaybe (checktop t t') $ do
|
|
checkdepth t t'@(DT x ls rs) = fromMaybe (f' t t') $ do
|
|
t'' <- safeHead ls
|
|
tx <- checkdepth t t''
|
|
return $ Just $ DT x (tx : tail ls) rs
|
|
--checktop t t' = f' t t'
|
|
|
|
joinItemsInList :: (a -> a -> Maybe a) -> [a] -> [a]
|
|
joinItemsInList f = fst . h . ([],)
|
|
where
|
|
h (zs, []) = (zs, [])
|
|
h ([],y : ys) = h ([y],ys)
|
|
h ( z : zs, y : ys) = case f y z of
|
|
Nothing -> h ( y : z : zs,ys)
|
|
Just w -> h ( zs,w : ys)
|
|
|
|
-- this puts the first elements in the intmap at the end of the list
|
|
invDT :: NewIntMap InvInt Item -> [DTree CItem]
|
|
invDT =
|
|
joinItemsInList tryAttachItems . IM.elems . _unNIntMap
|
|
. fmap (singleDT . baseCI)
|
|
|
|
invDT' :: NewIntMap InvInt Item -> [DTree OItem]
|
|
invDT' = fmap propagateOrientation . invDT
|
|
|
|
-- this assumes the creature inventory is well formed, specifically the
|
|
-- location ids
|
|
invRootMap :: NewIntMap InvInt Item -> IM.IntMap (Maybe Int, DTree Item)
|
|
invRootMap =
|
|
foldMap
|
|
(dtToIntMapWithRoot (^?! itLocation . ilInvID . unNInt) . fmap (^. _1) )
|
|
. invDT
|
|
|
|
-- this assumes the creature inventory is well formed, specifically the
|
|
-- location ids
|
|
-- The first Int in the maybe is the root, the second the parent
|
|
invAdj :: NewIntMap InvInt Item -> IM.IntMap (Maybe (Int, Int), [Int], [Int])
|
|
invAdj = IM.unions . map g . invDT
|
|
where
|
|
g = dtToLRAdj getid
|
|
getid (itm, _) =
|
|
fromMaybe
|
|
(error ("invAdj item " ++ show (_itID itm) ++ " location: " ++ show (itm ^? itLocation)))
|
|
$ itm ^? itLocation . ilInvID . unNInt
|
|
|
|
---- returns an intmap with trees for (only!) root items, indexed by inventory position
|
|
invIMDT :: NewIntMap InvInt Item -> IM.IntMap (DTree OItem)
|
|
invIMDT = fmap propagateOrientation . IM.fromDistinctAscList . reverse . map getid . invDT
|
|
where
|
|
getid :: DTree CItem -> (Int, DTree CItem)
|
|
getid t = (t ^?! dtValue . _1 . itLocation . ilInvID . unNInt, t)
|
|
|
|
---- returns an intmap with indents and locations for all items
|
|
invIndents :: NewIntMap InvInt Item -> IM.IntMap (Int, LocationDT OItem)
|
|
invIndents inv = foldMap (f . LocDT TopDT) (IM.elems (invIMDT inv)) mempty
|
|
where
|
|
f t = cdtPropagateFold h h g 0 t id
|
|
h x _ _ = x + 1
|
|
g ::
|
|
Int ->
|
|
LocationDT OItem ->
|
|
( IM.IntMap (Int, LocationDT OItem) ->
|
|
IM.IntMap (Int, LocationDT OItem)
|
|
) ->
|
|
IM.IntMap (Int, LocationDT OItem) ->
|
|
IM.IntMap (Int, LocationDT OItem)
|
|
g x ldt =
|
|
(.)
|
|
( IM.insert
|
|
(ldt ^?! locDT . dtValue . _1 . itLocation . ilInvID . unNInt)
|
|
(x, ldt)
|
|
)
|