loop/src/Dodge/Item/Grammar.hs

module Dodge.Item.Grammar (
    invLDT,
    invAdj,
    invRootMap,
    invRootTrees,
    basePCI,
    allInvLocs,
) where

import Control.Applicative
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

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 (_, 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 ->
    ([(ItemStructuralFunction, ComposeLinkType)], [(ItemStructuralFunction, ComposeLinkType)])
itemToBreakLists itm itmf = case (itm ^. itType, itmf) of
    (HELD TORCH, _) -> (getAmmoLinks itm, [])
    (_, HeldPlatformSF) ->
        ( getAmmoLinks itm
        , [(WeaponTargetingSF, WeaponTargetingLink), (WeaponScopeSF, WeaponScopeLink)]
        )
    (_, GadgetPlatformSF) ->
        ( getAmmoLinks itm
        , [(TriggerSF,TriggerLink),(WeaponTargetingSF, WeaponTargetingLink), (WeaponScopeSF, WeaponScopeLink)]
        )
    (_, AmmoMagSF{}) -> fromMaybe ([], []) $ do
        atype <- itm ^? itConsumables . magType
        return
            (
                [ (AmmoModifierSF atype, AmmoModLink)
                , (AmmoTargetingSF atype, AmmoTargetingLink)
                , (AmmoPayloadSF atype, AmmoPayloadLink)
                , (AmmoEffectSF atype, AmmoEffectLink)
                , (RemoteScreenSF, RemoteScreenLink)
                ]
            , []
            )
    (_, WeaponTargetingSF) -> (getAmmoLinks itm ++ [(AugmentedHUDSF, AugmentedHUDLink)], [])
    (ATTACH BULLETSYNTH, _) ->
        ([(AmmoMagSF ElectricalAmmo, AmmoInLink 0 ElectricalAmmo)], [])
    _ -> ([], [])

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 LASER -> WeaponTargetingSF
    HELD{} -> case itm ^? itUse . useCondition of
        Just MustBeHeld -> HeldPlatformSF
        _ -> GadgetPlatformSF
    AMMOMAG{} -> maybe UncomposableIsolateSF AmmoMagSF $ itm ^? itConsumables . magType
    ATTACH REMOTESCREEN -> RemoteScreenSF
    ATTACH BULLETSYNTH -> AmmoModifierSF BulletAmmo
    ATTACH ZOOMSCOPE -> WeaponScopeSF
    ATTACH HOMINGMODULE -> AmmoTargetingSF LauncherAmmo
    ATTACH AUGMENTEDHUD -> AugmentedHUDSF
    BULLETMOD BulletModTrajectory{} -> AmmoTargetingSF BulletAmmo
    BULLETMOD BulletModPayload{} -> AmmoPayloadSF BulletAmmo
    BULLETMOD BulletModEffect{} -> AmmoEffectSF BulletAmmo
    TARGETING{} -> WeaponTargetingSF
    EQUIP WRIST_ECG -> TriggerSF
    EQUIP{} -> EquipmentPlatformSF
    _ -> UncomposableIsolateSF

basePCI :: Item -> ComposedItem
basePCI itm = case _itType itm of
    _ -> (itm, itemToFunction itm, itemBaseConnections itm)

itemBaseConnections :: Item -> LinkTest
itemBaseConnections itm = case _itType itm of
    HELD LASER -> laserLinkTest itm
    _ -> uncurry useBreakL $ itemToBreakLists itm (itemToFunction itm)

laserLinkTest :: Item -> LinkTest
laserLinkTest itm = LTest (llleft itm) (llright itm)

llleft :: Item -> ComposedItem -> Maybe LinkUpdate
llleft itm =
    _tryLeftLink
        . uncurry useBreakL
        $ itemToBreakLists itm WeaponTargetingSF

llright :: Item -> ComposedItem -> Maybe LinkUpdate
llright itm pci = case pci ^. _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))

--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 ^. 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 ^. 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 . 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)
-- 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)
            )