justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Cleanup invLDT

Browse Source
This commit is contained in:
justin
2024-10-01 13:28:25 +01:00
parent ea353f8bcc
commit 36238669f5
4 changed files with 58 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files
ghcidOutput
+1 -1
View File
@@ -1 +1 @@
All good (604 modules, at 13:20:50)
All good (604 modules, at 13:28:17)
src/Dodge/Creature/Picture.hs
+1 -1
View File
@@ -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)
src/Dodge/Item/Draw.hs
+1 -2
View File
@@ -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)
src/Dodge/Item/Grammar.hs
+55 -56
View File
@@ -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 =