Improve scroll selection/inventory modification

2026-03-24 19:21:04 +00:00
parent 5b297643db
commit 8ff2f37af5
16 changed files with 532 additions and 432 deletions
@@ -2,13 +2,15 @@ module Dodge.Base.Coordinate (
    worldPosToScreen,
    screenToWorldPos,
    mouseWorldPos,
+    mouseWorldPosW,
    worldPosToResOffset,
 ) where

+import Dodge.Data.World
 import Control.Lens
-import Dodge.Data.Camera
+--import Dodge.Data.Camera
 import Dodge.Data.Config
-import Dodge.Data.Input
+--import Dodge.Data.Input
 import Dodge.WindowSize
 import Geometry
 import Linear
@@ -37,6 +39,9 @@ worldPosToResOffset cfig cam p =
 mouseWorldPos :: Input -> Camera -> Point2
 mouseWorldPos inp cam = screenToWorldPos cam (inp ^. mousePos)

+mouseWorldPosW :: World -> Point2
+mouseWorldPosW w = mouseWorldPos (w ^. input) (w ^. wCam)
+
 screenToWorldPos :: Camera -> Point2 -> Point2
 screenToWorldPos cam p =
    (cam ^. camCenter) + (1 / (cam ^. camZoom)) *.* rotateV (cam ^. camRot) p
@@ -26,7 +26,7 @@ data MouseContext
    | OverCombEscape
    | OverTerminal {_mcoTermID :: Int, _mcoTermStatus :: TerminalStatus}
    | OutsideTerminal
-    | MouseGameRotate
+    | MouseGameRotate {_mcoRotateDist :: Float}  -- TODO warp mouse to this distance
    | OverDebug {_mcoDBBool :: DebugBool, _mcoDBInt :: Int}
    deriving (Show)

@@ -49,9 +49,7 @@ handleMouseMotionEvent mmev cfig = set mousePos themousepos . set mouseMoving Tr
  where
    P (V2 x y) = mouseMotionEventPos mmev
    themousepos =
-        V2
-            (fromIntegral x - 0.5 * windowXFloat cfig)
-            (0.5 * windowYFloat cfig - fromIntegral y)
+        V2 (fromIntegral x - 0.5 * windowXFloat cfig) (0.5 * windowYFloat cfig - fromIntegral y)

 handleMouseWheelEvent :: MouseWheelEventData -> Input -> Input
 handleMouseWheelEvent mwev = scrollAmount +~ fromIntegral y
@@ -1,4 +1,4 @@
--{-# LANGUAGE TupleSections #-}
+-- {-# LANGUAGE TupleSections #-}
 module Dodge.Inventory (
    rmInvItem,
    destroyInvItem,
@@ -14,15 +14,22 @@ module Dodge.Inventory (
    swapItemWith,
    destroyItem,
    destroyAllInvItems,
+    multiSelScroll,
+    changeSwapSelSet,
+    concurrentIS,
+    collectInvItems,
+    shiftInvItemsUp,
+    shiftInvItemsDown,
 ) where

-import Dodge.Euse
-import Linear
+import Control.Monad
 import Data.Function
+import qualified Data.IntSet as IS
 import Data.Maybe
 import Dodge.Base
 import Dodge.Data.SelectionList
 import Dodge.Data.World
+import Dodge.Euse
 import Dodge.Inventory.Location
 import Dodge.Inventory.RBList
 import Dodge.Inventory.Swap
@@ -30,6 +37,7 @@ import Dodge.SelectionSections
 import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
+import Linear
 import ListHelp
 import NewInt

@@ -65,7 +73,8 @@ destroyItem itid w = case w ^? cWorld . lWorld . items . ix itid . itLocation of
    Just InInv{_ilCrID = cid, _ilInvID = invid} -> destroyInvItem cid invid w
    Just OnTurret{} -> error "need to write code for destroying items on turrets"
    Just OnFloor ->
-        w & cWorld . lWorld . items . at itid .~ Nothing
+        w
+            & cWorld . lWorld . items . at itid .~ Nothing
            & cWorld . lWorld . floorItems . at itid .~ Nothing
    Just InVoid -> w & cWorld . lWorld . items . at itid .~ Nothing

@@ -74,7 +83,7 @@ destroyItem itid w = case w ^? cWorld . lWorld . items . ix itid . itLocation of
 rmInvItem :: Int -> NewInt InvInt -> World -> World
 rmInvItem cid invid w =
    w
-        & dounequipfunction --the ordering of these is
+        & dounequipfunction -- the ordering of these is
        & pointcid . crInv %~ f -- important
        & removeAnySlotEquipment
        & cWorld . lWorld . items . ix itid . itLocation . ilEquipSite .~ Nothing
@@ -97,12 +106,13 @@ rmInvItem cid invid w =
    itm = w ^?! cWorld . lWorld . items . ix itid
    dounequipfunction = effectOnRemove itm cr
    removeAnySlotEquipment = fromMaybe id $ do
-        epos <- itm ^?
-                     itLocation
-                    . ilEquipSite
-                    . _Just
+        epos <-
+            itm
+                ^? itLocation
+                . ilEquipSite
+                . _Just
        return $ pointcid . crEquipment . at epos .~ Nothing
--        return $ pointcid . crEquipment .~ mempty
+    --        return $ pointcid . crEquipment .~ mempty
    maxk = fmap fst $ IM.lookupMax $ _unNIntMap $ cr ^. crInv
    f inv =
        let (xs, ys) = IM.split (_unNInt invid) $ _unNIntMap inv
@@ -114,14 +124,18 @@ rmInvItem cid invid w =

 updateCloseObjects :: World -> World
 updateCloseObjects w =
-    w & hud . closeItems %~ h citems
+    w
+        & hud . closeItems %~ h citems
        & hud . closeButtons %~ h cbts
  where
    h a b = intersect b a `union` a
    lw = w ^. cWorld . lWorld
-    citems = map NInt $ IM.keys $ IM.intersection (lw ^. items) 
-        $ IM.filter (isclose . _flItPos) (lw^.floorItems)
-    cbts = lw^..buttons . each . filtered canpress . filtered (isclose . _btPos) . to _btID
+    citems =
+        map NInt $
+            IM.keys $
+                IM.intersection (lw ^. items) $
+                    IM.filter (isclose . _flItPos) (lw ^. floorItems)
+    cbts = lw ^.. buttons . each . filtered canpress . filtered (isclose . _btPos) . to _btID
    canpress bt = case bt ^. btEvent of
        ButtonPress{_btOn = t} -> not t
        ButtonAccessTerminal tid -> fromMaybe False $ do
@@ -131,6 +145,66 @@ updateCloseObjects w =
    isclose x = dist y x < 40 && hasButtonLOS y x w
    y = you w ^. crPos . _xy

+changeSwapSelSet :: Int -> World -> World
+changeSwapSelSet yi w
+    | yi >= 0 = foldl' (&) w $ replicate yi (swapSelSet shiftSetUp)
+    | otherwise = foldl' (&) w $ replicate (negate yi) (swapSelSet shiftSetDown)
+
+swapSelSet :: (Int -> IS.IntSet -> World -> World) -> World -> World
+swapSelSet f w = fromMaybe w $ do
+    Sel j _ is <- w ^. hud . diSelection
+    return $
+        if concurrentIS is
+            then f j is w
+            else collectInvItems j is w
+
+shiftSetUp :: Int -> IS.IntSet -> World -> World
+shiftSetUp j is w = fromMaybe w $ do
+    (mini, _) <- IS.minView is
+    guard (mini > 0)
+    return $ shiftInvItemsUp j is w
+
+shiftSetDown :: Int -> IS.IntSet -> World -> World
+shiftSetDown j is w = fromMaybe w $ do
+    (maxi, _) <- IS.maxView is
+    (maxinv, _) <- IM.lookupMax =<< (w ^? hud . diSections . ix j . ssItems)
+    guard (maxi < maxinv)
+    return $ shiftInvItemsDown j is w
+
+shiftInvItemsDown :: Int -> IS.IntSet -> World -> World
+shiftInvItemsDown j is w = fromMaybe w $ do
+    let i = IS.findMax is
+    guard . isJust $ w ^? hud . diSections . ix j . ssItems . ix i
+    return $ IS.foldr f w is
+  where
+    f i' = swapItemWith g (j, i')
+    g i' m = fst <$> IM.lookupGT i' m
+
+
+shiftInvItemsUp :: Int -> IS.IntSet -> World -> World
+shiftInvItemsUp j is w = IS.foldl' f w is
+  where
+    f w' i' = swapItemWith g (j, i') w'
+    g i' m = fst <$> IM.lookupLT i' m
+
+concurrentIS :: IS.IntSet -> Bool
+concurrentIS = go . IS.minView
+  where
+    go x = fromMaybe True $ do
+        (i, is) <- x
+        (j, js) <- IS.minView is
+        return $ i + 1 == j && go (Just (j, js))
+
+collectInvItems :: Int -> IS.IntSet -> World -> World
+collectInvItems secid is w = fromMaybe w $ do
+    guard $ secid == 0
+    (j, js) <- IS.minView is
+    return $ h j js w
+  where
+    h j js w' = fromMaybe w' $ do
+        (k, ks) <- IS.minView js
+        return . h (j + 1) ks $ swapInvItems (\_ _ -> Just (j + 1)) k w'
+
 changeSwapSel :: Int -> World -> World
 changeSwapSel yi w
    | yi >= 0 = foldl' (&) w $ replicate yi (changeSwapWith $ f IM.cycleLT)
@@ -138,6 +212,24 @@ changeSwapSel yi w
  where
    f g i m = fst <$> g i m

+multiSelScroll :: Int -> World -> World
+multiSelScroll yi w
+    | yi >= 0 = foldl' (&) w $ replicate yi (multiSelScroll' $ f IM.lookupLT)
+    | otherwise = foldl' (&) w $ replicate (negate yi) (multiSelScroll' $ f IM.lookupGT)
+  where
+    f g i m = fst <$> g i m
+
+multiSelScroll' :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) -> World -> World
+multiSelScroll' f w = fromMaybe w $ do
+    Sel j i is <- w ^. hud . diSelection
+    ss <- w ^? hud . diSections . ix j . ssItems
+    k <- f i ss
+    let insertordelete = if k `IS.member` is then IS.delete i else IS.insert i . IS.insert k
+    return $
+        w
+            & hud . diSelection . _Just . slSet %~ insertordelete
+            & hud . diSelection . _Just . slInt .~ k
+
 changeSwapOther ::
    ((Int -> Identity Int) -> ManipulatedObject -> Identity ManipulatedObject) ->
    Int ->
@@ -155,7 +247,13 @@ changeSwapOther manlens n f i w = fromMaybe w $ do
    return $
        w
            & swapAnyExtraSelection i k
-            & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject . manlens
+            & cWorld
+                . lWorld
+                . creatures
+                . ix 0
+                . crManipulation
+                . manObject
+                . manlens
                %~ doswap
            & hud . closeItems %~ swapIndices i k
            & hud . diSelection . _Just . slInt %~ doswap
@@ -173,8 +271,8 @@ swapItemWith f (j, i) = case j of
    _ -> id

 changeSwapWith :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) -> World -> World
-changeSwapWith f w 
-    | Just (Sel j i _) <- w ^. hud . diSelection = swapItemWith f (j,i) w
+changeSwapWith f w
+    | Just (Sel j i _) <- w ^. hud . diSelection = swapItemWith f (j, i) w
    | otherwise = w

 invSetSelection :: Selection -> World -> World
@@ -192,7 +290,8 @@ scrollAugInvSel :: Int -> World -> World
 scrollAugInvSel yi w
    | yi == 0 = w
    | otherwise =
-        w & hud %~ doscroll
+        w
+            & hud %~ doscroll
            & worldEventFlags . at InventoryChange ?~ ()
            & setInvPosFromSS
            & cWorld . lWorld %~ crUpdateItemLocations 0
@@ -203,7 +302,8 @@ scrollAugInvSel yi w

 scrollAugNextInSection :: World -> World
 scrollAugNextInSection w =
-    w & hud %~ doscroll
+    w
+        & hud %~ doscroll
        & worldEventFlags . at InventoryChange ?~ ()
        & setInvPosFromSS
        & cWorld . lWorld %~ crUpdateItemLocations 0
@@ -1,4 +1,8 @@
-module Dodge.Placement.Instance.Button where
+module Dodge.Placement.Instance.Button (
+    putLitButOnPos,
+    extTrigLitPos,
+    putLitButOnPosExtTrig,
+) where

 import Color
 import Control.Lens
@@ -8,54 +12,54 @@ import Dodge.LevelGen.PlacementHelper
 import Dodge.LevelGen.Switch
 import Dodge.LightSource
 import Dodge.Placement.Instance.LightSource
-import Dodge.PlacementSpot
+--import Dodge.PlacementSpot
 import Geometry
 import Shape

-triggerSwitchSPic :: Color -> Color -> PlacementSpot -> Placement
-triggerSwitchSPic c1 c2 ps = psPtCont ps (PutTrigger False) $
-    \tp ->
-        Just $
-            pContID
-                ps
-                ( PutButton
-                    ( makeSwitch
-                        c1
-                        c2
-                        (SetTrigger True $ trigid tp)
-                        (SetTrigger False $ trigid tp)
-                    )
-                )
-                (const Nothing)
-  where
-    trigid tp = fromJust $ _plMID tp
+--triggerSwitchSPic :: Color -> Color -> PlacementSpot -> Placement
+--triggerSwitchSPic c1 c2 ps = psPtCont ps (PutTrigger False) $
+--    \tp ->
+--        Just $
+--            pContID
+--                ps
+--                ( PutButton
+--                    ( makeSwitch
+--                        c1
+--                        c2
+--                        (SetTrigger True $ trigid tp)
+--                        (SetTrigger False $ trigid tp)
+--                    )
+--                )
+--                (const Nothing)
+--  where
+--    trigid tp = fromJust $ _plMID tp
+--
+--triggerSwitchSPicLight :: Color -> Color -> PlacementSpot -> Placement
+--triggerSwitchSPicLight c1 c2 ps = psPtCont ps (PutTrigger False) $
+--    \tp -> Just $
+--        pContID atFstLnkOut (PutLS thels) $
+--            \lsid ->
+--                Just $
+--                    pContID
+--                        ps
+--                        (PutButton (makeSwitch c1 c2 (oneff lsid $ trigid tp) (offeff lsid $ trigid tp)))
+--                        (const Nothing)
+--  where
+--    thels = lsColPosRad (V3 0.5 0 0) (V3 0 0 78) 75
+--    trigid tp = fromJust $ _plMID tp
+--    oneff lsid tid = WorldEffects [SetLSCol (V3 0 0.5 0) lsid, SetTrigger True tid]
+--    offeff lsid tid = WorldEffects [SetLSCol (V3 0.5 0 0) lsid, SetTrigger False tid]

-triggerSwitchSPicLight :: Color -> Color -> PlacementSpot -> Placement
-triggerSwitchSPicLight c1 c2 ps = psPtCont ps (PutTrigger False) $
-    \tp -> Just $
-        pContID atFstLnkOut (PutLS thels) $
-            \lsid ->
-                Just $
-                    pContID
-                        ps
-                        (PutButton (makeSwitch c1 c2 (oneff lsid $ trigid tp) (offeff lsid $ trigid tp)))
-                        (const Nothing)
-  where
-    thels = lsColPosRad (V3 0.5 0 0) (V3 0 0 78) 75
-    trigid tp = fromJust $ _plMID tp
-    oneff lsid tid = WorldEffects [SetLSCol (V3 0 0.5 0) lsid, SetTrigger True tid]
-    offeff lsid tid = WorldEffects [SetLSCol (V3 0.5 0 0) lsid, SetTrigger False tid]
-
-triggerSwitch :: Color -> PlacementSpot -> Placement
-triggerSwitch col ps = psPtCont ps (PutTrigger False) $
-    \tp ->
-        Just $
-            pContID
-                ps
-                (PutButton (makeSwitch col col (SetTrigger True $ trigid tp) (SetTrigger False $ trigid tp)))
-                (const Nothing)
-  where
-    trigid tp = fromJust $ _plMID tp
+--triggerSwitch :: Color -> PlacementSpot -> Placement
+--triggerSwitch col ps = psPtCont ps (PutTrigger False) $
+--    \tp ->
+--        Just $
+--            pContID
+--                ps
+--                (PutButton (makeSwitch col col (SetTrigger True $ trigid tp) (SetTrigger False $ trigid tp)))
+--                (const Nothing)
+--  where
+--    trigid tp = fromJust $ _plMID tp

 putLitButOnPos :: Color -> PlacementSpot -> (Placement -> Maybe Placement) -> Placement
 putLitButOnPos col theps subpl =
@@ -45,7 +45,7 @@ mntLSOn shapeF ls wallp lsp@(V3 lx ly _) =
    ps0jPushPS (PutLabel "light") .
    ps0jPushPS (putShape $ shapeF wallp lsp)
    --ps0j (PutLabel "light") .
-    --ps0j (putShape . setCol $ shapeF wallp lsp)
+    --ps0j (putShape $ shapeF wallp lsp)
        . pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
  where
    lsp' = lsp -.-.- V3 x y 1
@@ -96,38 +96,17 @@ aShape wallpos (V3 x y z) = girder (z + 2) 20 10 pout wallpos
    pout = V2 x y -.- 2 *.* squashNormalizeV (V2 x y -.- wallpos)

 vShape :: Point2 -> Point3 -> Shape
-vShape wallpos (V3 x y z) =
-    thinHighBar z wallposUp lxy
-        <> thinHighBar z wallposDown lxy
+vShape p (V3 x y z) = abar n <> abar (-n)
  where
+    abar a = thinHighBar z (p + a) lxy
    lxy = V2 x y
-    n = vNormal (wallpos -.- lxy)
-    wallposUp = wallpos +.+ n
-    wallposDown = wallpos -.- n
+    n = vNormal (p - lxy)

 mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement
 mntLS shp wallp lampp = mntLSOn shp defaultLS wallp lampp (const Nothing)
  where
    defaultLS = LS 0 $ LSParam 0 300 0.6

--mntLSCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
--mntLSCol shp col wallp lampp = mntLSOn shp (Just col) defaultLS wallp lampp (const Nothing)
--  where
--    defaultLS = LS 0 $ LSParam 0 200 0.6
-
--mntLSLampCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
--mntLSLampCol shp (V4 x y z _) wallp lampp =
--    mntLSOn
--        shp
--        Nothing
--        (defaultLS & lsParam . lsCol .~ col)
--        wallp
--        lampp
--        (const Nothing)
--  where
--    col = V3 x y z
--    defaultLS = LS 0 $ LSParam 0 200 0.6
-
 mntLSCond ::
    (Point2 -> Point3 -> Shape) ->
    --    -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
@@ -92,7 +92,6 @@ placeSpotRoomRand ::
 placeSpotRoomRand rid i f plmnt w =
    let (ps, g) =
            runState
-                -- (_rmRandPSs (w ^?! genRooms . ix rid) !! i)
                (w ^?! genRooms . ix rid . rmRandPSs . ix i)
                $ w ^. gwWorld . randGen
     in placeSpot rid (w & gwWorld . randGen .~ g) (plmnt & plSpot .~ f ps)
@@ -143,11 +142,11 @@ placeSpotID rid ps pt w = case pt of
    PutChasm ps' qs ->
        ( 0
        , placeChasm
-            w
            rid
            ps'
            (map (map doShift) ps')
            (foldMap (loopPairs . map doShift) qs)
+            w
        )
    PutLabel{} -> (0, w)
  where
@@ -156,13 +155,12 @@ placeSpotID rid ps pt w = case pt of
    doShift = shiftPointBy (p, rot)
    pashift = compP2A (p, rot)

-placeChasm :: GenWorld -> Int -> [[Point2]] -> [[Point2]] -> [(Point2, Point2)] -> GenWorld
-placeChasm gw rid ps shiftps cfs =
-    gw
-        & gwWorld . cWorld . chasms <>~ shiftps
-        & gwWorld . cWorld . cliffs <>~ cfs
-        & genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps)
-        & gwWorld %~ f
+placeChasm :: Int -> [[Point2]] -> [[Point2]] -> [(Point2, Point2)] -> GenWorld -> GenWorld
+placeChasm rid ps shiftps cfs =
+    (gwWorld . cWorld . chasms <>~ shiftps)
+        . (gwWorld . cWorld . cliffs <>~ cfs)
+        . (genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps))
+        . (gwWorld %~ f)
  where
    -- f w = foldl' g w (loopPairs shiftps)
    f w = foldl' g w cfs
@@ -201,9 +199,14 @@ plMachine ::
 plMachine wallpoly mc mitm p rot gw =
    ( mcid
    , gw
-        & tolw . machines . at mcid ?~ themc
-        & gwWorld %~ placeMachineWalls (_mcMaterial mc) wallpoly mcid wlid
-        & tolw %~ maybe id placeturretitm mitm
+        & tolw
+        . machines
+        . at mcid
+        ?~ themc
+        & gwWorld
+        %~ placeMachineWalls (_mcMaterial mc) wallpoly mcid wlid
+        & tolw
+        %~ maybe id placeturretitm mitm
    )
  where
    tolw = gwWorld . cWorld . lWorld
@@ -221,9 +224,13 @@ plMachine wallpoly mc mitm p rot gw =
 placeMachineWalls :: Material -> [Point2] -> Int -> Int -> World -> World
 placeMachineWalls mat poly mcid = insertStructureWalls MachinePart baseWall poly mcid
  where
-    baseWall = defaultMachineWall 
-        & wlStructure . wsMachine .~ mcid
-        & wlMaterial .~ mat
+    baseWall =
+        defaultMachineWall
+            & wlStructure
+            . wsMachine
+            .~ mcid
+            & wlMaterial
+            .~ mat

 mvLS :: Point2 -> Float -> LightSource -> LightSource
 mvLS x rot = lsParam . lsPos . _xy %~ ((+ x) . rotateV rot)
@@ -115,7 +115,7 @@ mouseCursorType u = case u ^. uvWorld . input . mouseContext of
    OverCombEscape -> rotate (pi / 4) $ drawPlus 5
    OverTerminal _ ts -> drawCursorByTerminalStatus ts
    OutsideTerminal -> rotate (pi / 4) $ drawPlus 5
-    MouseGameRotate -> rotate a (drawVerticalDoubleArrow 5)
+    MouseGameRotate {} -> rotate a (drawVerticalDoubleArrow 5)
    OverDebug {} -> drawPlus 5 <> rotate (pi/4) (drawPlus 5)
    --OverDebug db i -> scale 0.1 0.1 $ text (show db ++ show i)
  where
@@ -303,9 +303,9 @@ chasmSpitTerminal = do
        l3 = mntLightLnkShape shp $ resetPLUse $ rprBool $ \rp _ -> f rp East North 
        l4 = mntLightLnkShape shp $ resetPLUse $ rprBool $ \rp _ -> f rp East South
    ls <- takeOne [[l1,l2],[l3,l4]
-          ,[spanLightI (V2 120 0) (V2 120 300)]
-         , [spanLightI (V2 0 128) (V2 300 128)]
-         , [spanLightI (V2 300 0) (V2 0 300), sps0 $ putShape $ thinHighBar 95 0 300]
+--          ,[spanLightI (V2 120 0) (V2 120 300)]
+--         , [spanLightI (V2 0 128) (V2 300 128)]
+--         , [spanLightI (V2 300 0) (V2 0 300), sps0 $ putShape $ thinHighBar 95 0 300]
        ]
    gh <- takeOne [55,75,97]
    gird <- takeOne [girderZ gh 30 10,girder gh 30 10,girderV gh 30 10]
@@ -33,7 +33,7 @@ import Data.Monoid
 import RandomHelp

 testStringInit :: Universe -> [String]
-testStringInit u = fmap show $ u ^.. uvWorld . cWorld . lWorld . doors . each . drUpdate . drLerpTimer
+testStringInit u = [show $ u ^? uvWorld . input . mouseContext . mcoRotateDist]
 --    (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcType . _McDamSensor . sensAmount)
 --    <> (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcMaterial)
 --testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir)
@@ -155,10 +155,32 @@ updateUniverseLast u =
            %~ M.union (fmap (const mp) (u ^. uvWorld . input . mouseButtons))
        & uvWorld . input . heldWorldPos
            %~ M.union (fmap (const mwp) (u ^. uvWorld . input . mouseButtons))
+        & uvIOEffects %~ doMouseWarping u
  where
    mp = u ^. uvWorld . input . mousePos
    mwp = screenToWorldPos (u ^. uvWorld . wCam) mp

+doMouseWarping :: p -> a -> a
+doMouseWarping _ = id
+
+--doMouseWarping :: Universe -> (Universe -> IO Universe) -> (Universe -> IO Universe)
+--doMouseWarping u f u'
+--    | Just x <- u ^? uvWorld . input . mouseContext . mcoRotateDist
+--        = SDL.warpMouse WarpCurrentFocus (P p) >> f (u' & uvWorld . input . mousePos .~ nmp)
+--    | otherwise = f u'
+--  where
+--    cfig = u' ^. uvConfig
+--    nmp = V2
+--            (fromIntegral x - 0.5 * windowXFloat cfig)
+--            (0.5 * windowYFloat cfig - fromIntegral y)
+--    p@(V2 x y) = (cwin + (msp & each %~ round)) & each %~ fromIntegral
+--    cwin :: V2 Int
+--    cwin = ((getWindowSize _gr_world_res (u' ^. uvConfig))) 
+--    mwp = mouseWorldPosW (u' ^. uvWorld)
+--    msp = u' ^. uvWorld . input . mousePos & _y %~ negate
+--    cc = u' ^. uvWorld . wCam . camCenter
+--    d = dist mwp cc
+
 {- For most menus the only way to change the world is using event handling.  -}
 updateUniverseMid :: Universe -> Universe
 updateUniverseMid u = case _uvScreenLayers u of
@@ -380,14 +402,17 @@ updateMouseContextGame :: Config -> Universe -> MouseContext -> MouseContext
 updateMouseContextGame cfig u = \case
    OverInvDrag i _ -> OverInvDrag i (inverseSelNumPos cfig invDP mpos disss)
    x@OverInvDragSelect{} -> x
-    _ -> fromMaybe aimcontext (isrotatedrag <|> overterm <|> overinv <|> overcomb)
+    MouseGameRotate x
+        | ButtonRight `M.member` (w ^. input . mouseButtons) -> MouseGameRotate x
+    --_ -> fromMaybe aimcontext (isrotatedrag <|> overterm <|> overinv <|> overcomb)
+    _ -> fromMaybe aimcontext (overterm <|> overinv <|> overcomb)
  where
    w = u ^. uvWorld
-    isrotatedrag = do
-        t1 <- w ^. input . mouseButtons . at ButtonLeft
-        t2 <- w ^. input . mouseButtons . at ButtonRight
-        guard $ t1 > t2
-        return MouseGameRotate
+--    isrotatedrag = do
+--        t1 <- w ^. input . mouseButtons . at ButtonLeft
+--        t2 <- w ^. input . mouseButtons . at ButtonRight
+--        guard $ t1 > t2
+--        return $ MouseGameRotate (dist (mouseWorldPosW w) (w ^. wCam . camCenter))
    aimcontext
        | ButtonRight `M.member` (w ^. input . mouseButtons) = MouseAiming
        | Display_debug `S.member` (cfig ^. debug_booleans) = getDebugMouseOver u
@@ -203,7 +203,7 @@ viewDistanceFromItems _ = 1

 rotateCamera :: Config -> World -> World
 rotateCamera cfig w
-    | MouseGameRotate <- w ^. input . mouseContext
+    | MouseGameRotate {} <- w ^. input . mouseContext
      , Just rotation <-
            angleBetween (w ^. input . mousePos)
                <$> (w ^. input . heldPos . at SDL.ButtonRight) =
@@ -5,6 +5,7 @@ module Dodge.Update.Input.InGame (
    updateMouseInGame,
 ) where

+import Dodge.Base.Coordinate
 import Dodge.Button.Event
 import Control.Applicative
 import Control.Monad
@@ -98,7 +99,7 @@ updateMouseHeldInGame :: Config -> World -> World
 updateMouseHeldInGame cfig w = case w ^. input . mouseContext of
    OverInvDragSelect{}
        | ButtonRight `M.member` (w ^. input . mouseButtons) ->
-            w & input . mouseContext .~ MouseGameRotate
+            w & input . mouseContext .~ MouseGameRotate (dist (mouseWorldPosW w) (w ^. wCam . camCenter))
    OverInvDragSelect (Just sstart) _ ->
        let sss = w ^. hud . diSections
            msel = inverseSelNumPos cfig invDP (w ^. input . mousePos) sss
@@ -289,23 +290,6 @@ startDrag (a, b) w = setcontext $ case w ^? hud . diSelection . _Just of
  where
    setcontext = input . mouseContext .~ OverInvDrag a (Just (a, b))

-concurrentIS :: IS.IntSet -> Bool
-concurrentIS = go . IS.minView
-  where
-    go x = fromMaybe True $ do
-        (i, is) <- x
-        (j, js) <- IS.minView is
-        return $ i + 1 == j && go (Just (j, js))
-
-collectInvItems :: Int -> IS.IntSet -> World -> World
-collectInvItems secid is w = fromMaybe w $ do
-    guard $ secid == 0
-    (j, js) <- IS.minView is
-    return $ h j js w
-  where
-    h j js w' = fromMaybe w' $ do
-        (k, ks) <- IS.minView js
-        return . h (j + 1) ks $ swapInvItems (\_ _ -> Just (j + 1)) k w'

 shiftInvItems ::
    Config ->
@@ -346,20 +330,6 @@ setSelWhileDragging w = fromMaybe w $ do
    guard $ i == k && j `IS.member` xs
    return $ w & hud . diSelection . _Just . slInt .~ j

-shiftInvItemsUp :: Int -> IS.IntSet -> World -> World
-shiftInvItemsUp j is w = IS.foldl' f w is
-  where
-    f w' i' = swapItemWith g (j, i') w'
-    g i' m = fst <$> IM.lookupLT i' m
-
-shiftInvItemsDown :: Int -> IS.IntSet -> World -> World
-shiftInvItemsDown j is w = fromMaybe w $ do
-    let i = IS.findMax is
-    guard . isJust $ w ^? hud . diSections . ix j . ssItems . ix i
-    return $ IS.foldr f w is
-  where
-    f i' = swapItemWith g (j, i')
-    g i' m = fst <$> IM.lookupGT i' m

 updateFunctionKeys :: Universe -> Universe
 updateFunctionKeys u =
@@ -35,7 +35,10 @@ updateBaseWheelEvent yi w
        EquipOptions{} -> w & rbState . opSel %~ scrollRBOption yi rbscrollmax
        NoRightButtonState -> fromMaybe w (selectedItemScroll yi w)
    | bdown ButtonLeft = w & wCam . camZoom +~ fromIntegral yi
+    | ScancodeCapsLock `M.member` _pressedKeys (_input w) 
+        , ScancodeLShift `M.member` (w ^. input . pressedKeys) = changeSwapSelSet yi w
    | ScancodeCapsLock `M.member` _pressedKeys (_input w) = changeSwapSel yi w
+    | ScancodeLShift `M.member` (w ^. input . pressedKeys) = multiSelScroll yi w
    | otherwise = scrollAugInvSel yi w
  where
    bdown b = w & has (input . mouseButtons . ix b)
@@ -17,7 +17,6 @@ import Dodge.Zoning.Wall
 import Geometry

 colCrsWalls :: Universe -> Universe
--colCrsWalls uv = uv
 colCrsWalls uv = uv & uvWorld . cWorld . lWorld . creatures %~ fmap (noclipCheck (_uvConfig uv) (_uvWorld uv))

 noclipCheck :: Config -> World -> Creature -> Creature