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 ::
    LabelDoubleTree ItemLink CItem ->
    LabelDoubleTree ItemLink CItem ->
    Maybe (LabelDoubleTree ItemLink CItem)
tryAttachItems = leftRightCombine leftIsParentCombine rightIsParentCombine

useBreakL ::
    [(ItemStructuralFunction, ItemLink)] ->
    [(ItemStructuralFunction, ItemLink)] ->
    LinkTest
useBreakL 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 (useBreakL (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 (useBreakL llist (tail xs))) 
            (_2 .~ sf)

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 ::
    LabelDoubleTree 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, 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 CItem -> Maybe LinkUpdate
llleft itm =
    _tryLeftLink
        . uncurry useBreakL
        $ itemToBreakLists itm WeaponTargetingSF

llright :: Item -> LabelDoubleTree ItemLink CItem -> 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
        FunctionChangeLink
        (\(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
                    (FunctionChangeLink)
                    (\(par, _, up) -> (par, MakeAutoSF, up))
                    (\(chi, _, up) -> (chi, FunctionChangeSF, up))
                )
        _ -> Nothing

--itemLinkTestLeft :: Item -> PartiallyCItem -> 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 CItem ItemLink
leftIsParentCombine' ltree rtree = Nothing

leftIsParentCombine :: LDTComb CItem 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 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 :: LabelDoubleTree 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

rightIsParentCombine' :: LDTComb CItem 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 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 (LabelDoubleTree ItemLink CItem)
invRootTrees = IM.fromDistinctAscList . reverse . map getid . invLDT
  where
    getid ::
        LabelDoubleTree ItemLink CItem ->
        (Int, LabelDoubleTree 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)
            )