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

Improve item location code, including some error detection

Browse Source
This commit is contained in:
justin
2024-09-23 14:33:14 +01:00
parent 3a08cf93f5
commit 43b365185d
8 changed files with 93 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files
ghcidOutput
+1 -1
View File
@@ -1 +1 @@
All good (619 modules, at 13:12:05)
All good (619 modules, at 14:32:19)
src/Dodge/DoubleTree.hs
+26
View File
@@ -47,12 +47,38 @@ dtToLRAdj f (DT x l r) = IM.insert i (Nothing,map g l , map g r)
i = f x
g = f . _dtValue
-- returns an adjacency map with oldest ancestor and direct parent if they exist
-- and any left and right children
-- allows to propogate failure in the index discovery
dtToLRAdjEither :: (a -> Either String Int) -> DoubleTree a
-> Either String (IM.IntMap (Maybe (Int,Int),[Int],[Int]))
dtToLRAdjEither f (DT x l r) = do
i <- f x
l' <- mapM g l
r' <- mapM g r
childrenasnodes <- mapM (dtToAdjRootParentEither i i f) $ l <> r
return $ IM.insert i (Nothing,l' , r')
$ IM.unions childrenasnodes
where
g = f . _dtValue
dtToAdjRootParent :: Int -> Int -> (a -> Int) -> DoubleTree a -> IM.IntMap (Maybe (Int,Int),[Int],[Int])
dtToAdjRootParent root par f (DT x l r) = IM.insert (f x) (Just (root,par),map g l , map g r)
. IM.unions $ map (dtToAdjRootParent root (f x) f) $ l <> r
where
g = f . _dtValue
dtToAdjRootParentEither :: Int -> Int
-> (a -> Either String Int) -> DoubleTree a -> Either String (IM.IntMap (Maybe (Int,Int),[Int],[Int]))
dtToAdjRootParentEither root par f (DT x l r) = do
i <- f x
l' <- mapM g l
r' <- mapM g r
childrenasnodes <- mapM (dtToAdjRootParentEither root i f) $ l <> r
return $ IM.insert i (Just (root,par),l' , r') $ IM.unions childrenasnodes
where
g = f . _dtValue
ldtToIM :: (a -> Int) -> LabelDoubleTree b a -> IM.IntMap (LabelDoubleTree b a)
ldtToIM f t@(LDT x l r) = IM.insert (f x) t $ IM.unions $ map (ldtToIM f . snd) $ l <> r
src/Dodge/Inventory/Add.hs
-10
View File
@@ -18,16 +18,6 @@ import Dodge.FloorItem
import Dodge.Inventory.CheckSlots
import qualified IntMapHelp as IM
--putItemInInvID :: Int -> Int -> World -> (Maybe Int, World)
--putItemInInvID cid flid w = fromMaybe (Nothing, w) $ do
-- flit <- w ^? cWorld . lWorld . floorItems . ix flid
-- (i, w') <- tryPutItemInInv cid flit w
-- return (Just i, w')
--putItemInInvSlot :: Int -> Item -> IM.IntMap Item -> IM.IntMap Item
--putItemInInvSlot = IM.insert
----putItemInInvSlot = IM.insertWith (const $ itUse . useAmount +~ 1)
tryPutItemIDInInv :: Int -> Int -> World -> Maybe (Int, World)
tryPutItemIDInInv cid flitid w = do
flit <- w ^? cWorld . lWorld . floorItems . ix flitid
src/Dodge/Inventory/Location.hs
+8 -1
View File
@@ -1,4 +1,9 @@
module Dodge.Inventory.Location
(updateRootItemID
, crUpdateItemLocations
, setInvPosFromSS
, tryGetRootItemInvID
)
where
import Dodge.Base.You
import Dodge.Data.SelectionList
@@ -12,7 +17,9 @@ import Control.Applicative
tryGetRootItemInvID :: Int -> Creature -> Maybe Int
tryGetRootItemInvID i cr = do
let adj = invAdj (_crInv cr)
let adj = case invAdj' (_crInv cr) of
Left str -> error $ "tryToGetRootItemInvID: "++ str
Right x -> x
thetree <- adj ^? ix i -- to check that the index does point to SOME item in the inventory
thetree ^? _1 . _Just . _1 <|> Just i
src/Dodge/Item/Grammar.hs
+18 -5
View File
@@ -1,7 +1,7 @@
module Dodge.Item.Grammar
(invTrees
, invIndentIM
, invAdj
, invAdj'
)
where
import Control.Applicative
@@ -92,11 +92,24 @@ invLDT :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType ComposedItemStructu
invLDT = joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems .
fmap (singleLDT . baseCIS)
invAdj :: IM.IntMap Item -> IM.IntMap (Maybe (Int,Int),[Int],[Int])
invAdj = IM.unions . fmap (dtToLRAdj getid . ldtToDT) . invLDT
-- this has provoked an error: hopefully it will crop up at some point and get
-- debugged with suitable info
--invAdj :: IM.IntMap Item -> IM.IntMap (Maybe (Int,Int),[Int],[Int])
--invAdj = IM.unions . fmap (dtToLRAdj getid . ldtToDT) . invLDT
-- where
-- getid (itm, _,_,_) = fromMaybe
-- (error ("invAdj item " ++ show (_itID itm) ++ " location:" ++ show (itm ^? itLocation . ilInvID)) )
-- $ itm ^? itLocation . ilInvID
invAdj' :: IM.IntMap Item -> Either String (IM.IntMap (Maybe (Int,Int),[Int],[Int]))
invAdj' im = do
l <- mapM g $ invLDT im
return $ IM.unions l
where
getid (itm, _,_,_) = fromMaybe (error "invAdj attempt to find item not in inventory") $
itm ^? itLocation . ilInvID
g = dtToLRAdjEither getid . ldtToDT
getid (itm, _,_,_) = maybe
(Left ("invAdj' item " ++ show ( _itID itm) ++ " location:" ++ show (itm ^? itLocation . ilInvID)) )
Right $ itm ^? itLocation . ilInvID
invIndentIM :: IM.IntMap Item -> IM.IntMap (Item,Int, LabelDoubleTreeNodeType ComposeLinkType )
invIndentIM = IM.fromAscList . zip [0..] . reverse . map (over _1 cisToItem) . concatMap ldtToIndentList . invLDT
src/Dodge/Render/HUD.hs
+4 -1
View File
@@ -62,7 +62,10 @@ drawInventory sss w cfig = drawSelectionSections sss (invDisplayParams w) cfig
where
iextra = fromMaybe mempty $ do
inv <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
return $ inventoryExtra sss cfig w (invAdj inv)
let x = case invAdj' inv of
Left str -> error $ "drawInventory: " ++ str
Right y -> y
return $ inventoryExtra sss cfig w x
drawSubInventory :: SubInventory -> Configuration -> World -> Picture
drawSubInventory subinv cfig w = case subinv of
src/Dodge/TestString.hs
+13 -12
View File
@@ -20,18 +20,19 @@ import Dodge.Data.Universe
import qualified IntMapHelp as IM
testStringInit :: Universe -> [String]
testStringInit u = (topTestPart u
<>) $ map showh $
(IM.toList . IM.filter (\itloc -> itloc ^? ilCrID == Just 0) $ (u ^. uvWorld . cWorld . lWorld . itemLocations)) <> ( IM.elems $ fmap h (u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crInv))
where
h itm = (_itID itm, _itLocation itm)
showh (x,(InInv a b c d)) = show x ++ "," ++ show a ++ "," ++ show b ++"," ++ show c ++"," ++ show d
showh _ = ""
topTestPart :: Universe -> [String]
topTestPart u = [show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos
, maybe "" showManObj $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
]
testStringInit _ = []
--testStringInit u = (topTestPart u
-- <>) $ map showh $
-- (IM.toList . IM.filter (\itloc -> itloc ^? ilCrID == Just 0) $ (u ^. uvWorld . cWorld . lWorld . itemLocations)) <> ( IM.elems $ fmap h (u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crInv))
-- where
-- h itm = (_itID itm, _itLocation itm)
-- showh (x,(InInv a b c d)) = show x ++ "," ++ show a ++ "," ++ show b ++"," ++ show c ++"," ++ show d
-- showh _ = ""
--
--topTestPart :: Universe -> [String]
--topTestPart u = [show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos
-- , maybe "" showManObj $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
-- ]
showManObj :: ManipulatedObject -> String
showManObj (InInventory SortInventory) = "SortInventory"
tags
+23 -17
View File
@@ -4868,12 +4868,14 @@ crSpring src/Dodge/Update.hs 643;" f
crStratConMatches src/Dodge/Creature/Test.hs 72;" f
crToBox' src/Dodge/Creature/ShadowBox.hs 10;" f
crUpdateInvidLocations src/Dodge/Inventory/FindRoot.hs 29;" f
crUpdateInvidLocations src/Dodge/Inventory/Location.hs 37;" f
crUpdateItemLocations src/Dodge/Inventory/FindRoot.hs 23;" f
crUpdateItemLocations src/Dodge/Inventory/Location.hs 31;" f
crZoneOfPoint src/Dodge/Base/Zone.hs 54;" f
crZoneSize src/Dodge/Zoning/Creature.hs 39;" f
craftInfo src/Dodge/Item/Info.hs 154;" f
crankSlowS src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs 420;" f
createAndSelectItem src/Dodge/Inventory/Add.hs 57;" f
createAndSelectItem src/Dodge/Inventory/Add.hs 47;" f
createArc src/Dodge/Tesla/Arc.hs 67;" f
createBarrelSpark src/Dodge/Particle/Spark.hs 21;" f
createBarrelSpark src/Dodge/Spark.hs 44;" f
@@ -4886,7 +4888,7 @@ createLightMap src/Render.hs 26;" f
createNewArc src/Dodge/Tesla/Arc.hs 76;" f
createPathGrid src/Dodge/Room/Path.hs 21;" f
createProjectile src/Dodge/Projectile/Create.hs 14;" f
createPutItem src/Dodge/Inventory/Add.hs 67;" f
createPutItem src/Dodge/Inventory/Add.hs 57;" f
createShieldWall src/Dodge/Euse.hs 134;" f
createTorchLightOffset src/Dodge/LightSource/Torch.hs 9;" f
createUnusedLinkPos src/Dodge/Tree/Shift.hs 117;" f
@@ -5385,9 +5387,10 @@ dropItem src/Dodge/Creature/Action.hs 183;" f
dropItemKey src/Dodge/Config/KeyConfig.hs 24;" f
drumMag src/Dodge/Item/Ammo.hs 36;" f
dtIL src/Dodge/DoubleTree.hs 22;" f
dtToAdjRootParent src/Dodge/DoubleTree.hs 50;" f
dtToAdjRootParent src/Dodge/DoubleTree.hs 64;" f
dtToAdjacency src/Dodge/DoubleTree.hs 29;" f
dtToLRAdj src/Dodge/DoubleTree.hs 43;" f
dtToLRAdjEither src/Dodge/DoubleTree.hs 53;" f
dtToUpDownAdj src/Dodge/DoubleTree.hs 35;" f
dummyMenuOption src/Dodge/Menu/Option.hs 81;" f
duplicateItem src/Dodge/Item/Weapon/TriggerType.hs 742;" f
@@ -5700,7 +5703,7 @@ hatCombinations src/Dodge/Combine/Combinations.hs 33;" f
head src/DoubleStack.hs 14;" f
headLamp src/Dodge/Item/Equipment.hs 118;" f
headLampShape src/Dodge/Item/Draw/SPic.hs 494;" f
headMap src/Dodge/DoubleTree.hs 83;" f
headMap src/Dodge/DoubleTree.hs 97;" f
heal src/Dodge/Item/Consumable.hs 17;" f
heal25 src/Dodge/Item/Consumable.hs 14;" f
healS src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs 354;" f
@@ -5824,19 +5827,20 @@ intersectSegsSeg src/Geometry/Intersect.hs 232;" f
intervalList src/Geometry.hs 315;" f
interweave src/Justify.hs 17;" f
intsToPos src/Dodge/Room/Modify/Girder.hs 160;" f
invAdj src/Dodge/Item/Grammar.hs 95;" f
invAdj src/Dodge/Item/Grammar.hs 98;" f
invAdj' src/Dodge/Item/Grammar.hs 109;" f
invDimColor src/Dodge/DisplayInventory.hs 140;" f
invDimColor src/Dodge/Inventory/Color.hs 4;" f
invDisplayParams src/Dodge/ListDisplayParams.hs 29;" f
invHead src/Dodge/Render/HUD.hs 293;" f
invIndentIM src/Dodge/Item/Grammar.hs 101;" f
invIndentIM src/Dodge/Item/Grammar.hs 121;" f
invLDT src/Dodge/Item/Grammar.hs 91;" f
invSelectionItem src/Dodge/Inventory/SelectionList.hs 35;" f
invSelectionItem' src/Dodge/Inventory/SelectionList.hs 17;" f
invShiftPointBy src/Dodge/ShiftPoint.hs 8;" f
invSideEff src/Dodge/Creature/State.hs 236;" f
invSize src/Dodge/Inventory/CheckSlots.hs 40;" f
invTrees src/Dodge/Item/Grammar.hs 104;" f
invTrees src/Dodge/Item/Grammar.hs 124;" f
inventoryExtra src/Dodge/Render/HUD.hs 186;" f
inventoryExtraH src/Dodge/Render/HUD.hs 190;" f
inventoryX src/Dodge/Creature.hs 115;" f
@@ -5966,7 +5970,7 @@ lasTunnel src/Dodge/Room/LasTurret.hs 124;" f
lasTunnelRunPast src/Dodge/Room/LasTurret.hs 165;" f
lasTurret src/Dodge/Placement/Instance/Turret.hs 23;" f
lasTurret src/Dodge/Placements/Turret.hs 29;" f
lastMap src/Dodge/DoubleTree.hs 87;" f
lastMap src/Dodge/DoubleTree.hs 101;" f
latchkey src/Dodge/Item/Held/Utility.hs 23;" f
latchkey src/Dodge/Item/PassKey.hs 14;" f
launcher src/Dodge/Item/Held/Launcher.hs 12;" f
@@ -5977,10 +5981,10 @@ launcherX src/Dodge/Item/Held/Launcher.hs 48;" f
layerNum src/Picture/Data.hs 31;" f
layoutLevelFromSeed src/Dodge/LevelGen.hs 47;" f
ldpVerticalSelection src/Dodge/Update/Input/ScreenLayer.hs 90;" f
ldtIL src/Dodge/DoubleTree.hs 62;" f
ldtIL src/Dodge/DoubleTree.hs 76;" f
ldtToDT src/Dodge/DoubleTree.hs 13;" f
ldtToIM src/Dodge/DoubleTree.hs 56;" f
ldtToIndentList src/Dodge/DoubleTree.hs 59;" f
ldtToIM src/Dodge/DoubleTree.hs 70;" f
ldtToIndentList src/Dodge/DoubleTree.hs 73;" f
left src/DoubleStack.hs 16;" f
leftInfo src/Dodge/Item/Info.hs 109;" f
leftIsParentCombine src/Dodge/Item/Grammar.hs 57;" f
@@ -6479,7 +6483,7 @@ pesNearSeg src/Dodge/Zoning/Pathing.hs 37;" f
picAtCrPos1 src/Dodge/Render/ShapePicture.hs 99;" f
picFormat src/Polyhedra.hs 22;" f
picMap src/Picture/Base.hs 67;" f
pickUpItem src/Dodge/Inventory/Add.hs 77;" f
pickUpItem src/Dodge/Inventory/Add.hs 67;" f
pickUpS src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs 444;" f
pickUpSound src/Dodge/SoundLogic/Synonyms.hs 4;" f
picsToSelectable src/Dodge/Render/HUD.hs 346;" f
@@ -6637,8 +6641,8 @@ prependTwo src/Geometry.hs 165;" f
pressedMBEffects src/Dodge/Update/UsingInput.hs 27;" f
pressedMBEffectsNoInventory src/Dodge/Update/UsingInput.hs 40;" f
pressedMBEffectsTopInventory src/Dodge/Creature/YourControl.hs 206;" f
prettyDT src/Dodge/DoubleTree.hs 92;" f
prettyLDT src/Dodge/DoubleTree.hs 96;" f
prettyDT src/Dodge/DoubleTree.hs 106;" f
prettyLDT src/Dodge/DoubleTree.hs 110;" f
primeS src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs 422;" f
printColumnTitles src/Dodge/Tree/Shift.hs 142;" f
printColumns src/Dodge/Tree/Shift.hs 132;" f
@@ -7047,7 +7051,7 @@ setHotkey src/Dodge/Hotkey.hs 38;" f
setInLinks src/Dodge/RoomLink.hs 51;" f
setInLinksByType src/Dodge/RoomLink.hs 54;" f
setInLinksPD src/Dodge/RoomLink.hs 74;" f
setInvPosFromSS src/Dodge/Inventory/Location.hs 6;" f
setInvPosFromSS src/Dodge/Inventory/Location.hs 48;" f
setItemCharge src/Dodge/ItEffect.hs 36;" f
setLayer src/Picture/Base.hs 139;" f
setLinkType src/Dodge/RoomLink.hs 60;" f
@@ -7600,11 +7604,12 @@ tryChargeBattery src/Dodge/Euse.hs 43;" f
tryCombine src/Dodge/Update/Input/InGame.hs 252;" f
tryGetChannel src/Sound.hs 96;" f
tryGetRootItemInvID src/Dodge/Inventory/FindRoot.hs 10;" f
tryGetRootItemInvID src/Dodge/Inventory/Location.hs 18;" f
tryMeleeAttack src/Dodge/Creature/ReaderUpdate.hs 36;" f
tryNextLoadAction src/Dodge/Reloading.hs 36;" f
tryPlay src/Sound.hs 83;" f
tryPutItemIDInInv src/Dodge/Inventory/Add.hs 31;" f
tryPutItemInInv src/Dodge/Inventory/Add.hs 37;" f
tryPutItemIDInInv src/Dodge/Inventory/Add.hs 21;" f
tryPutItemInInv src/Dodge/Inventory/Add.hs 27;" f
trySeedFromClipboard src/Dodge/Menu.hs 88;" f
trySiphonFuel src/Dodge/Euse.hs 46;" f
trySpinByCID src/Dodge/Projectile/Update.hs 123;" f
@@ -7731,6 +7736,7 @@ updateRadarSweeps src/Dodge/Update.hs 445;" f
updateRandNode src/TreeHelp.hs 108;" f
updateRenderSplit appDodge/Main.hs 105;" f
updateRootItemID src/Dodge/Inventory/FindRoot.hs 16;" f
updateRootItemID src/Dodge/Inventory/Location.hs 24;" f
updateScopeZoom src/Dodge/Update/Camera.hs 129;" f
updateScopeZoom' src/Dodge/Update/Camera.hs 134;" f
updateScrollTestValue src/Dodge/ScrollValue.hs 6;" f