Allow for swapping inventory items

src/Dodge/Data/Creature.hs

@@ -97,9 +97,6 @@ data Intention = Intention
 
 --deriving (Eq, Show, Read) --Generic, Flat)
 
-crSel :: Creature -> ManipulatedObject
-crSel = _manObject . _crManipulation
-
 makeLenses ''Creature
 makeLenses ''CreatureTargeting
 makeLenses ''Intention

src/Dodge/DisplayInventory.hs

@@ -171,14 +171,6 @@ updateSectionsPositioning mselpos allavailablelines ((k, y) : xs) sss =
     linestaken ss' = max (length $ _ssShownItems ss') (_ssMinSize ss')
     previoussections = updateSectionsPositioning mselpos availablelines xs sss
 
---manObjIndex :: ManipulatedObject -> (Int,Int)
---manObjIndex mo = case mo of
---    InInventory SortInventory -> (-1, 0)
---    InInventory (SelItem i _) -> (0, i)
---    SelNothing -> (1,0)
---    InNearby SortNearby -> (2,0)
---    InNearby (SelCloseObject i) -> (3,i)
-
 updateSection ::
     IM.IntMap (SelectionItem a) ->
     Maybe Int ->
@@ -247,8 +239,6 @@ enterCombineInv cfig w =
             cm'
             sss
   where
-    --(updateCombineSelections w cfig sss)
-
     cm' = IM.fromAscList $ zip [0 ..] $ combineList' w
     cm
         | null cm' = IM.singleton 0 $ SelectionInfo ["No possible combinations"] 1 False white 0

src/Dodge/Inventory.hs

@@ -4,7 +4,6 @@ module Dodge.Inventory (
     selSecSelPos,
     checkInvSlotsYou,
     rmSelectedInvItem,
-    selNumPos,
     selNumTextEndPos,
     selSecSelCol,
     selNumEndMidHeight,
@@ -13,7 +12,7 @@ module Dodge.Inventory (
     updateRBList,
     updateTerminal,
     closeObjScrollDir,
-    changeSwapInvSel,
+    changeSwapSel,
     scrollAugInvSel,
     crNumFreeSlots,
     crInvSize,
@@ -55,7 +54,9 @@ rmInvItem ::
     World ->
     World
 rmInvItem cid invid w = case w ^? getcid . crInv . ix invid . itUse . useAmount of
-    Just x | x > 1 -> w & pointcid . crInv . ix invid . itUse . useAmount -~ 1
+    Just x
+        | x > 1 ->
+            w & pointcid . crInv . ix invid . itUse . useAmount -~ 1
                 & worldEventFlags . at InventoryChange ?~ ()
     _ ->
         w
@@ -112,15 +113,15 @@ rmSelectedInvItem cid w = case w ^? cWorld . lWorld . creatures . ix cid . crMan
     Just i -> rmInvItem cid i w
     Nothing -> w
 
-selNumPos :: ManipulatedObject -> World -> Maybe Int
+--selNumPos :: ManipulatedObject -> World -> Maybe Int
-selNumPos mo w =
+--selNumPos mo w =
-    w ^? hud . hudElement . diSections
+--    w ^? hud . hudElement . diSections
-        >>= case mo of
+--        >>= case mo of
-            InInventory SortInventory -> selSecSelPos (-1) 0
+--            InInventory SortInventory -> selSecSelPos (-1) 0
-            InInventory (SelItem i _) -> selSecSelPos 0 i
+--            InInventory (SelItem i _) -> selSecSelPos 0 i
-            SelNothing -> selSecSelPos 1 0
+--            SelNothing -> selSecSelPos 1 0
-            InNearby SortNearby -> selSecSelPos 2 0
+--            InNearby SortNearby -> selSecSelPos 2 0
-            InNearby (SelCloseObject i) -> selSecSelPos 3 i
+--            InNearby (SelCloseObject i) -> selSecSelPos 3 i
 
 -- there are still more ListDisplayParams to integrate here
 selNumTextEndPos :: Configuration -> ListDisplayParams -> SelectionSections a -> Int -> Int -> Maybe Point2
@@ -327,37 +328,89 @@ closeObjScrollDir x
     | x < 0 = over (hud . closeObjects) rotD
     | otherwise = id
 
-changeSwapInvSel :: Int -> World -> World
+changeSwapSel :: Int -> World -> World
-changeSwapInvSel k w = case you w ^? crManipulation . manObject of
+changeSwapSel yi w
-    Just (InInventory (SelItem i _)) ->
+    | yi == 0   = w
-        w & cWorld . lWorld . creatures . ix 0 %~ updatecreature i
+    | yi > 0    = foldr ($) w $ replicate yi (changeSwapWith $ f IM.cycleLT)
-            & worldEventFlags . at InventoryChange ?~ ()
+    | otherwise = foldr ($) w $ replicate (negate yi) (changeSwapWith $ f IM.cycleGT)
-    Just (InNearby (SelCloseObject i)) ->
-        w
-            & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject . inNearby . ispCloseObject
-                .~ ((i - k) `mod` numCO)
-            & hud . closeObjects %~ swapIndices i ((i - k) `mod` numCO)
-            & worldEventFlags . at InventoryChange ?~ ()
-    _ -> w
   where
-    updatecreature i =
+    f g i m = fst <$> g i m
-        (crInv %~ IM.safeSwapKeys (i `mod` n) (swapi i))
+
-            . (crLeftInvSel . lisMPos . _Just %~ updateLeftInvSel i)
+changeSwapClose :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int)
-            . (crManipulation . manObject . inInventory . ispItem %~ (`mod` n) . subtract k)
+    -> Int -> World -> World
-            . (crInvEquipped %~ IM.safeSwapKeys i (swapi i))
+changeSwapClose f i w = fromMaybe w $ do
-            . swapSite i (swapi i)
+    ss <- w ^? hud . hudElement . diSections . sssSections . ix 3 . ssItems
-            . swapSite (swapi i) i
+    k <- f i ss
+    return $ w
+            & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject . inNearby . ispCloseObject
+                .~ k
+            & hud . closeObjects %~ swapIndices i k
+            & hud . hudElement . diSections . sssExtra . sssSelPos . _Just . _2 .~ k
+            & worldEventFlags . at InventoryChange ?~ ()
+
+changeSwapInv :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int)
+    -> Int -> World -> World
+changeSwapInv f i w = fromMaybe w $ do
+    ss <- w ^? hud . hudElement . diSections . sssSections . ix 0 . ssItems
+    k <- f i ss
+    return $
+        w & cWorld . lWorld . creatures . ix 0 %~ updatecreature k
+            & hud . hudElement . diSections . sssExtra . sssSelPos . _Just . _2 .~ k
+            & worldEventFlags . at InventoryChange ?~ ()
+  where
+    updateLeftInvSel k li
+        | i == li = k
+        | k == li = i
+        | otherwise = li
+    updatecreature k =
+        (crInv %~ IM.safeSwapKeys i k)
+            . (crLeftInvSel . lisMPos . _Just %~ updateLeftInvSel k)
+            . (crManipulation . manObject . inInventory . ispItem .~ k)
+            . (crInvEquipped %~ IM.safeSwapKeys i k)
+            . swapSite i k
+            . swapSite k i
+    cr = you w
     swapSite a b = case cr ^? crInvEquipped . ix a of
         Just epos -> crEquipment . ix epos .~ b
         Nothing -> id
-    cr = you w
+
-    swapi i = (i - k) `mod` n
+changeSwapWith :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) -> World -> World
-    updateLeftInvSel i li
+changeSwapWith f w = case w ^? hud . hudElement . diSections . sssExtra . sssSelPos . _Just of
-        | i == li = swapi i
+    Just (0,i) -> w & changeSwapInv f i
-        | swapi i == li = i
+    Just (3,i) -> w & changeSwapClose f i
-        | otherwise = li
+    _ -> w
-    n = length $ _crInv cr
+
-    numCO = length $ w ^. hud . closeObjects
+--changeSwapInvSel' :: Int -> World -> World
+--changeSwapInvSel' k w = case you w ^? crManipulation . manObject of
+--    Just (InInventory (SelItem i _)) ->
+--        w & cWorld . lWorld . creatures . ix 0 %~ updatecreature i
+--            & worldEventFlags . at InventoryChange ?~ ()
+--    Just (InNearby (SelCloseObject i)) ->
+--        w
+--            & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject . inNearby . ispCloseObject
+--                .~ ((i - k) `mod` numCO)
+--            & hud . closeObjects %~ swapIndices i ((i - k) `mod` numCO)
+--            & worldEventFlags . at InventoryChange ?~ ()
+--    _ -> w
+--  where
+--    updatecreature i =
+--        (crInv %~ IM.safeSwapKeys (i `mod` n) (swapi i))
+--            . (crLeftInvSel . lisMPos . _Just %~ updateLeftInvSel i)
+--            . (crManipulation . manObject . inInventory . ispItem %~ (`mod` n) . subtract k)
+--            . (crInvEquipped %~ IM.safeSwapKeys i (swapi i))
+--            . swapSite i (swapi i)
+--            . swapSite (swapi i) i
+--    swapSite a b = case cr ^? crInvEquipped . ix a of
+--        Just epos -> crEquipment . ix epos .~ b
+--        Nothing -> id
+--    cr = you w
+--    swapi i = (i - k) `mod` n
+--    updateLeftInvSel i li
+--        | i == li = swapi i
+--        | swapi i == li = i
+--        | otherwise = li
+--    n = length $ _crInv cr
+--    numCO = length $ w ^. hud . closeObjects
 
 scrollAugInvSel :: Int -> World -> World
 scrollAugInvSel yi w

src/Dodge/Reloading.hs

@@ -16,9 +16,9 @@ crCancelReloading cr =
         & updateProgress
         & crManipulation . manObject . inInventory . iselAction .~ NoInvSelAction
   where
-    updateProgress = case crSel cr of
+    updateProgress = fromMaybe id $ do
-        InInventory (SelItem i _) -> crInv . ix i . itUse . heldConsumption . laProgress %~ const Nothing
+        InInventory (SelItem i _) <- cr ^? crManipulation . manObject
-        _ -> id
+        return $ crInv . ix i . itUse . heldConsumption . laProgress %~ const Nothing
 
 stepReloading :: Creature -> Creature
 stepReloading cr = case cr ^? crManipulation . manObject . inInventory of

src/Dodge/SelectionSections.hs

@@ -17,41 +17,37 @@ import Dodge.Data.SelectionList
 scrollSelectionSections :: Int -> SelectionSections a -> SelectionSections a
 scrollSelectionSections yi sss
     | yi == 0 = sss
-    | yi > 0 = foldr ($) sss $ replicate yi scrollUpSelectionSections
+    | yi > 0 = foldr ($) sss $ replicate yi (ssScrollUsing ssLookupUp)
-    | otherwise = foldr ($) sss $ replicate (negate yi) scrollDownSelectionSections
+    | otherwise = foldr ($) sss $ replicate (negate yi) (ssScrollUsing ssLookupDown)
 
 setFirstPosSelectionSections :: SelectionSections a -> SelectionSections a
 setFirstPosSelectionSections sss = fromMaybe sss $ do
     (i, j, _) <- ssLookupMin sss
     return $ sss & sssExtra . sssSelPos ?~ (i, j)
 
-scrollUpSelectionSections :: SelectionSections a -> SelectionSections a
+ssScrollUsing ::
-scrollUpSelectionSections sss = sss & sssExtra . sssSelPos .~
+    (Int -> Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)) ->
-    fmap f (ssScrollUp (sss & sssSections %~ fmap (ssItems %~ IM.filter _siIsSelectable)))
+    SelectionSections a ->
+    SelectionSections a
+ssScrollUsing g sss =
+    sss & sssExtra . sssSelPos
+        .~ fmap f (ssScrollUsing' g (sss & sssSections %~ fmap (ssItems %~ IM.filter _siIsSelectable)))
   where
     f (i, j, _) = (i, j)
 
-ssScrollUp :: SelectionSections a -> Maybe (Int,Int,SelectionItem a)
+ssScrollUsing' ::
-ssScrollUp sss = l <|> ssLookupMin sss
+    ( Int ->
+      Int ->
+      SelectionSections a ->
+      Maybe (Int, Int, SelectionItem a)
+    ) ->
+    SelectionSections a ->
+    Maybe (Int, Int, SelectionItem a)
+ssScrollUsing' f sss = l <|> ssLookupMin sss
   where
     l = do
         (i, j) <- sss ^? sssExtra . sssSelPos . _Just
-        ssLookupUp i j sss
+        f i j sss
-
-ssScrollDown :: SelectionSections a -> Maybe (Int,Int,SelectionItem a)
-ssScrollDown sss = l <|> ssLookupMin sss
-  where
-    l = do
-        (i,j) <- sss ^? sssExtra . sssSelPos . _Just
-        ssLookupDown i j sss
-
-scrollDownSelectionSections :: SelectionSections a -> SelectionSections a
-scrollDownSelectionSections sss = sss & sssExtra . sssSelPos .~
-    fmap f (ssScrollDown (sss & sssSections %~ fmap (ssItems %~ IM.filter _siIsSelectable)))
-  where
-    f (i,j,_) = (i,j)
-
---        & sssSections . ix i' . ssCursor ?~ SectionCursor j' j' (_siHeight si) (_siColor si)
 
 ssSetCursor ::
     (SelectionSections a -> Maybe (Int, Int, SelectionItem a)) ->
@@ -135,7 +131,8 @@ selSecSelPos i j sss = do
         . subtract (ss ^. ssOffset)
         . sum
         . fmap (length . _siPictures)
-        . fst $ IM.split j (ss ^. ssItems)
+        . fst
+        $ IM.split j (ss ^. ssItems)
   where
     secpos = sum . fmap (length . _ssShownItems) . fst $ IM.split i $ sss ^. sssSections
 

src/Dodge/TestString.hs

@@ -3,14 +3,14 @@ module Dodge.TestString where
 import Data.Aeson (ToJSON)
 import Data.ByteString.Lazy.Char8 (unpack)
 import qualified Data.Aeson.Encode.Pretty as AEP
---import Control.Lens
+import Control.Lens
 import Dodge.Data.Universe
 --import Data.Maybe
 --import ShortShow
 --import qualified Data.Map.Strict as M
 --import qualified IntMapHelp as IM
 testStringInit :: Universe -> [String]
-testStringInit _ = []
+testStringInit u = [show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos . _Just]
 --    [show $ fmap IM.keys $ u ^? uvWorld . hud . hudElement . subInventory . ciSections . sssSections]
 
 getPretty :: ToJSON a => a -> [String]

src/Dodge/Update/Input/InGame.hs

@@ -1,5 +1,5 @@
-module Dodge.Update.Input.InGame 
+module Dodge.Update.Input.InGame (
-    ( updateUseInputInGame
+    updateUseInputInGame,
 ) where
 
 import qualified Data.IntMap.Strict as IM
@@ -39,9 +39,12 @@ updateUseInputInGame h u = case h of
             | lbinitialpress ->
                 u & uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus %~ const True
         CombineInventory{_ciSections = sss}
-            | inSubInvRegex (u ^. uvWorld) -> u & uvWorld . hud . hudElement . subInventory . ciSections %~ doRegexInput u (-1)
+            | inSubInvRegex (u ^. uvWorld) ->
+                u & uvWorld . hud . hudElement . subInventory . ciSections %~ doRegexInput u (-1)
                     & uvWorld . worldEventFlags . at CombineInventoryChange ?~ ()
-            | lbinitialpress -> (uvWorld . worldEventFlags . at InventoryChange ?~ ()) . maybeExitCombine $ over uvWorld (tryCombine sss) u
+            | lbinitialpress ->
+                (uvWorld . worldEventFlags . at InventoryChange ?~ ()) . maybeExitCombine $
+                    over uvWorld (tryCombine sss) u
                         & uvWorld . worldEventFlags . at CombineInventoryChange ?~ ()
         --        _ -> case regexFocus w of
         --            Nothing -> M.foldlWithKey' updateKeyInGame u pkeys
@@ -154,11 +157,16 @@ doRegexInput u i sss
 
 updateBackspaceRegex :: World -> World
 updateBackspaceRegex w = case di ^? subInventory of
-    Just NoSubInventory | secfocus (-1) 0 -> w & hud . hudElement . diSections %~ trybackspace (-1)
+    Just NoSubInventory
+        | secfocus (-1) 0 ->
+            w & hud . hudElement . diSections %~ trybackspace (-1)
                 & worldEventFlags . at InventoryChange ?~ ()
-    Just NoSubInventory | secfocus 2 3 -> w & hud . hudElement . diSections %~ trybackspace 2
+    Just NoSubInventory
+        | secfocus 2 3 ->
+            w & hud . hudElement . diSections %~ trybackspace 2
                 & worldEventFlags . at InventoryChange ?~ ()
-    Just CombineInventory{} -> w & hud . hudElement . subInventory . ciSections %~ trybackspace (-1)
+    Just CombineInventory{} ->
+        w & hud . hudElement . subInventory . ciSections %~ trybackspace (-1)
             & worldEventFlags . at InventoryChange ?~ ()
     _ -> w
   where
@@ -208,9 +216,11 @@ spaceAction :: World -> World
 spaceAction w = case w ^. hud . hudElement of
     DisplayCarte -> w & hud . carteCenter .~ theLoc
     DisplayInventory{_subInventory = NoSubInventory} -> case selectedCloseObject w of
-        Just (Left flit) -> pickUpItem 0 flit w
+        Just (Left flit) ->
+            pickUpItem 0 flit w
                 & worldEventFlags . at InventoryChange ?~ ()
-        Just (Right but) -> doButtonEvent (_btEvent but) but w
+        Just (Right but) ->
+            doButtonEvent (_btEvent but) but w
                 & worldEventFlags . at InventoryChange ?~ ()
         _ -> w
     DisplayInventory{_subInventory = DisplayTerminal{}} ->

src/Dodge/Update/Scroll.hs

@@ -31,7 +31,7 @@ updateWheelEvent yi w = case w ^. hud . hudElement of
             (Nothing, _) -> closeObjScrollDir y w
             (Just f, _) -> doHeldScroll f y (you w) w
         | lbDown -> w & cWorld . camPos . camZoom +~ y
-        | invKeyDown -> changeSwapInvSel yi w
+        | invKeyDown -> changeSwapSel yi w
         | otherwise -> stopSoundFrom (CrReloadSound 0) $ scrollAugInvSel yi w
     DisplayInventory {_subInventory = ExamineInventory mi}
         | invKeyDown && rbDown -> w & moveTweakSel yi

src/IntMapHelp.hs

@@ -15,8 +15,12 @@ module IntMapHelp
     unsafeSwapKeys,
     safeSwapKeys,
     findIndex,
+
+    cycleGT,
+    cycleLT,
 ) where
 
+import Control.Applicative
 import Data.Aeson
 import Data.IntMap.Strict
 import GHC.Generics
@@ -84,3 +88,9 @@ findIndex t = foldrWithKey f Nothing
     f k x _
         | t x = Just k
         | otherwise = Nothing
+
+cycleGT :: Int -> IntMap a -> Maybe (Int, a)
+cycleGT i m = lookupGT i m <|> lookupMin m
+
+cycleLT :: Int -> IntMap a -> Maybe (Int, a)
+cycleLT i m = lookupLT i m <|> lookupMax m