From 36238669f5e6d385acf18e15a72dcd9953de785c Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 1 Oct 2024 13:28:25 +0100 Subject: [PATCH] Cleanup invLDT --- ghcidOutput | 2 +- src/Dodge/Creature/Picture.hs | 2 +- src/Dodge/Item/Draw.hs | 3 +- src/Dodge/Item/Grammar.hs | 111 +++++++++++++++++----------------- 4 files changed, 58 insertions(+), 60 deletions(-) diff --git a/ghcidOutput b/ghcidOutput index 28749886d..3e12d3194 100644 --- a/ghcidOutput +++ b/ghcidOutput @@ -1 +1 @@ -All good (604 modules, at 13:20:50) +All good (604 modules, at 13:28:17) diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index 8841a6697..3e52b28dd 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -173,4 +173,4 @@ shoulderSH = translateSHz 20 drawEquipment :: Creature -> SPic {-# INLINE drawEquipment #-} -drawEquipment cr = foldMap (itemEquipPict cr . fmap (\(a,b,_) -> (a,b))) (invLDT'' $ _crInv cr) +drawEquipment cr = foldMap (itemEquipPict cr . fmap (\(a,b,_) -> (a,b))) (invLDT $ _crInv cr) diff --git a/src/Dodge/Item/Draw.hs b/src/Dodge/Item/Draw.hs index aed6aba07..44f234253 100644 --- a/src/Dodge/Item/Draw.hs +++ b/src/Dodge/Item/Draw.hs @@ -16,8 +16,7 @@ import Dodge.Item.Draw.SPic import Dodge.Item.HeldOffset import ShapePicture -itemEquipPict :: Creature -> LabelDoubleTree ItemLink ComposedItem - -> SPic +itemEquipPict :: Creature -> LabelDoubleTree ItemLink ComposedItem -> SPic itemEquipPict cr itmtree = case itm ^. itUse of UseHeld{} | itm ^? itLocation . ilIsRoot == Just True -> overPosSP (heldItemOffset itm cr) (itemTreeSPic itmtree) diff --git a/src/Dodge/Item/Grammar.hs b/src/Dodge/Item/Grammar.hs index cd6fdf936..cb03a6a16 100644 --- a/src/Dodge/Item/Grammar.hs +++ b/src/Dodge/Item/Grammar.hs @@ -1,80 +1,81 @@ module Dodge.Item.Grammar ( - invLDT', - invLDT'', + invLDT, invTrees, invIndentIM, invAdj, invRootMap, ) where -import Dodge.Item.Orientation ---import qualified Linear.Quaternion as Q ---import Geometry.Data import Control.Applicative import Data.Bifunctor - -import LensHelp 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 - -useBreakListsLinkTest :: [(ItemStructuralFunction,a)] -> [(ItemStructuralFunction,a)] -> LinkTest a +useBreakListsLinkTest :: [(ItemStructuralFunction, a)] -> [(ItemStructuralFunction, a)] -> LinkTest a useBreakListsLinkTest llist rlist = LTest ltest rtest where - ltest (_,sf,_) = do + ltest (_, sf, _) = do let xs = dropWhile ((/= sf) . fst) llist - (_,linktype) <- safeHead xs + (_, linktype) <- safeHead xs return $ LUpdate linktype (set _3 (useBreakListsLinkTest (tail xs) rlist)) id - rtest (_,sf,_) = do + rtest (_, sf, _) = do let xs = dropWhile ((/= sf) . fst) rlist - (_,linktype) <- safeHead xs + (_, linktype) <- safeHead xs return $ LUpdate linktype (set _3 (useBreakListsLinkTest llist (tail xs))) id - basePartiallyComposedItem' :: Item -> PartiallyComposedItem ItemLink basePartiallyComposedItem' itm = case itm ^. itType of - HELD _ -> (itm, WeaponPlatformSF, useBreakListsLinkTest - (map (\(i,a) -> noa (AmmoMagSF a) (AmmoInLink i a)) - (IM.toList $ itm ^. itUse . heldAmmoTypes)) - [noa WeaponTargetingSF WeaponTargetingLink, noa WeaponScopeSF WeaponScopeLink] + HELD _ -> + ( itm + , WeaponPlatformSF + , useBreakListsLinkTest + ( map + (\(i, a) -> noa (AmmoMagSF a) (AmmoInLink i a)) + (IM.toList $ itm ^. itUse . heldAmmoTypes) + ) + [noa WeaponTargetingSF WeaponTargetingLink, noa WeaponScopeSF WeaponScopeLink] ) AMMOMAG _ -> ammoComposedItem' itm - TARGETING {} -> (itm,WeaponTargetingSF, useBreakListsLinkTest [noa AugmentedHUDSF AugmentedHUDLink] []) + TARGETING{} -> (itm, WeaponTargetingSF, useBreakListsLinkTest [noa AugmentedHUDSF AugmentedHUDLink] []) ATTACH ZOOMSCOPE -> nolinks WeaponScopeSF ATTACH HOMINGMODULE -> nolinks $ AmmoTargetingSF ProjectileAmmo ATTACH AUGMENTEDHUD -> nolinks AugmentedHUDSF - BULLETMOD BulletModTrajectory {} -> nolinks $ AmmoTargetingSF BulletAmmo - BULLETMOD BulletModPayload {} -> nolinks $ AmmoPayloadSF BulletAmmo - BULLETMOD BulletModEffect {} -> nolinks $ AmmoEffectSF BulletAmmo + BULLETMOD BulletModTrajectory{} -> nolinks $ AmmoTargetingSF BulletAmmo + BULLETMOD BulletModPayload{} -> nolinks $ AmmoPayloadSF BulletAmmo + BULLETMOD BulletModEffect{} -> nolinks $ AmmoEffectSF BulletAmmo ATTACH REMOTESCREEN -> nolinks RemoteScreenSF - ATTACH BULLETSYNTHESIZER -> (itm,AmmoModifierSF BulletAmmo, LTest (const Nothing) (const Nothing)) - LEFT {} -> isolate - EQUIP {} -> isolate - CONSUMABLE {} -> isolate - CRAFT {} -> isolate --- _ -> + ATTACH BULLETSYNTHESIZER -> (itm, AmmoModifierSF BulletAmmo, LTest (const Nothing) (const Nothing)) + LEFT{} -> isolate + EQUIP{} -> isolate + CONSUMABLE{} -> isolate + CRAFT{} -> isolate where + -- _ -> + noa x y = (x, ILink y orientAttachment) - nolinks x = (itm,x, LTest (const Nothing) (const Nothing)) - isolate = (itm,UncomposableIsolateSF, LTest (const Nothing) (const Nothing)) + nolinks x = (itm, x, LTest (const Nothing) (const Nothing)) + isolate = (itm, UncomposableIsolateSF, LTest (const Nothing) (const Nothing)) ammoComposedItem' :: Item -> PartiallyComposedItem ItemLink ammoComposedItem' itm = fromMaybe (error "in ammoComposedItem, wrong item") $ do atype <- itm ^? itUse . amagType - return (itm + return + ( itm , AmmoMagSF atype - , useBreakListsLinkTest - [noa (AmmoModifierSF atype) AmmoModLink - ,noa (AmmoTargetingSF atype) AmmoTargetingLink - ,noa (AmmoPayloadSF atype) AmmoPayloadLink - ,noa (AmmoEffectSF atype) AmmoEffectLink - ,noa RemoteScreenSF RemoteScreenLink - ] + , useBreakListsLinkTest + [ noa (AmmoModifierSF atype) AmmoModLink + , noa (AmmoTargetingSF atype) AmmoTargetingLink + , noa (AmmoPayloadSF atype) AmmoPayloadLink + , noa (AmmoEffectSF atype) AmmoEffectLink + , noa RemoteScreenSF RemoteScreenLink + ] [] ) where @@ -85,14 +86,16 @@ type LDTComb a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe (LabelDou leftIsParentCombine :: LDTComb (PartiallyComposedItem a) a leftIsParentCombine ltree rtree = do lu <- (ltree ^. ldtValue . _3 . tryRightLink) (rtree ^. ldtValue) - return $ ltree & ldtValue %~ (lu ^. luParentUpdate) - & ldtRight %~ (++ [(lu ^. luLinkType, rtree & ldtValue %~ (lu ^. luChildUpdate))]) + return $ + ltree & ldtValue %~ (lu ^. luParentUpdate) + & ldtRight %~ (++ [(lu ^. luLinkType, rtree & ldtValue %~ (lu ^. luChildUpdate))]) rightIsParentCombine :: LDTComb (PartiallyComposedItem a) a rightIsParentCombine ltree rtree = do lu <- (rtree ^. ldtValue . _3 . tryLeftLink) (ltree ^. ldtValue) - return $ rtree & ldtValue %~ (lu ^. luParentUpdate) - & ldtLeft .:~ (lu ^. luLinkType, ltree & ldtValue %~ (lu ^. luChildUpdate)) + return $ + rtree & ldtValue %~ (lu ^. luParentUpdate) + & ldtLeft .:~ (lu ^. luLinkType, ltree & ldtValue %~ (lu ^. luChildUpdate)) leftRightCombine :: LDTComb a b -> @@ -119,24 +122,17 @@ joinItemsInList f xs = snd $ h (xs, []) Nothing -> h (ys, y : z : zs) Just w -> h (w : ys, zs) -invLDT'' :: IM.IntMap Item -> [LabelDoubleTree ItemLink (PartiallyComposedItem ItemLink)] -invLDT'' = +invLDT :: IM.IntMap Item -> [LabelDoubleTree ItemLink (PartiallyComposedItem ItemLink)] +invLDT = joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems . fmap (singleLDT . basePartiallyComposedItem') -invLDT' :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType ComposedItem] -invLDT' = map (bimap _iatType (\(x,y,_) -> (x,y))) . 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) invRootMap :: IM.IntMap Item -> IM.IntMap (Maybe Int, DoubleTree Item) -invRootMap = foldMap (dtToIntMapWithRoot (^?! itLocation . ilInvID) . fmap (^. _1) . ldtToDT) . invLDT'' - ---invRootMap = foldMap (dtToRootIntMap g . ldtToDT) . invLDT --- where --- g = _ +invRootMap = foldMap (dtToIntMapWithRoot (^?! itLocation . ilInvID) . fmap (^. _1) . ldtToDT) . invLDT -- this assumes the creature inventory is well formed, specifically the -- location ids @@ -144,7 +140,7 @@ invRootMap = foldMap (dtToIntMapWithRoot (^?! itLocation . ilInvID) . fmap (^. _ -- should be done upstream anyway in the actually creature inventory) invAdj :: IM.IntMap Item -> Either String (IM.IntMap (Maybe (Int, Int), [Int], [Int])) invAdj im = do - l <- mapM g $ invLDT'' im + l <- mapM g $ invLDT im return $ IM.unions l where g = dtToLRAdjEither getid . ldtToDT @@ -155,12 +151,15 @@ invAdj im = do $ itm ^? itLocation . ilInvID invIndentIM :: IM.IntMap Item -> IM.IntMap (Item, Int, LabelDoubleTreeNodeType ComposeLinkType) -invIndentIM = IM.fromAscList . zip [0 ..] . reverse . map (over _1 (^. _1)) - . concatMap ldtToIndentList . invLDT' +invIndentIM = + IM.fromAscList . zip [0 ..] . reverse . map (over _1 (^. _1)) + . concatMap ldtToIndentList + . map (bimap _iatType (\(x, y, _) -> (x, y))) + . invLDT -- returns an intmap with trees for all root items invTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ComposeLinkType Item) -invTrees = IM.unions . map (ldtToIM getindex . fmap (^. _1)) . invLDT' +invTrees = IM.unions . map (ldtToIM getindex . fmap (^. _1)) . map (bimap _iatType (\(x, y, _) -> (x, y))) . invLDT where getindex :: Item -> Int getindex i =