diff --git a/ghcidOutput b/ghcidOutput index 2846911b9..973b6a3a4 100644 --- a/ghcidOutput +++ b/ghcidOutput @@ -1 +1 @@ -All good (619 modules, at 13:12:05) +All good (619 modules, at 14:32:19) diff --git a/src/Dodge/DoubleTree.hs b/src/Dodge/DoubleTree.hs index 6de5fed3f..f9962399e 100644 --- a/src/Dodge/DoubleTree.hs +++ b/src/Dodge/DoubleTree.hs @@ -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 diff --git a/src/Dodge/Inventory/Add.hs b/src/Dodge/Inventory/Add.hs index 33fd2957d..80854a5dc 100644 --- a/src/Dodge/Inventory/Add.hs +++ b/src/Dodge/Inventory/Add.hs @@ -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 diff --git a/src/Dodge/Inventory/Location.hs b/src/Dodge/Inventory/Location.hs index 73b45e2f8..043126243 100644 --- a/src/Dodge/Inventory/Location.hs +++ b/src/Dodge/Inventory/Location.hs @@ -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 diff --git a/src/Dodge/Item/Grammar.hs b/src/Dodge/Item/Grammar.hs index 703d98917..c00693863 100644 --- a/src/Dodge/Item/Grammar.hs +++ b/src/Dodge/Item/Grammar.hs @@ -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 diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index ad41bc083..bd2b960ce 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -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 diff --git a/src/Dodge/TestString.hs b/src/Dodge/TestString.hs index 1e4bf18a6..82db9b65a 100644 --- a/src/Dodge/TestString.hs +++ b/src/Dodge/TestString.hs @@ -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" diff --git a/tags b/tags index 2cf9ec3b7..d4ba35320 100644 --- a/tags +++ b/tags @@ -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