Improve scroll selection/inventory modification

src/Dodge/Base/Coordinate.hs

@@ -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

src/Dodge/Data/Input.hs

@@ -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)
 

src/Dodge/Event/Input.hs

@@ -49,9 +49,7 @@ handleMouseMotionEvent mmev cfig = set mousePos themousepos . set mouseMoving Tr
   where
     P (V2 x y) = mouseMotionEventPos mmev
     themousepos =
-        V2
+        V2 (fromIntegral x - 0.5 * windowXFloat cfig) (0.5 * windowYFloat cfig - fromIntegral y)
-            (fromIntegral x - 0.5 * windowXFloat cfig)
-            (0.5 * windowYFloat cfig - fromIntegral y)
 
 handleMouseWheelEvent :: MouseWheelEventData -> Input -> Input
 handleMouseWheelEvent mwev = scrollAmount +~ fromIntegral y

src/Dodge/Inventory.hs

@@ -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 Control.Monad
-import Linear
 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 ^?
+        epos <-
-                     itLocation
+            itm
-                    . ilEquipSite
+                ^? itLocation
-                    . _Just
+                . 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) 
+    citems =
-        $ IM.filter (isclose . _flItPos) (lw^.floorItems)
+        map NInt $
-    cbts = lw^..buttons . each . filtered canpress . filtered (isclose . _btPos) . to _btID
+            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 
+changeSwapWith f w
-    | Just (Sel j i _) <- w ^. hud . diSelection = swapItemWith f (j,i) 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

src/Dodge/Placement/Instance/Button.hs

@@ -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 :: Color -> Color -> PlacementSpot -> Placement
-triggerSwitchSPic c1 c2 ps = psPtCont ps (PutTrigger False) $
+--triggerSwitchSPic c1 c2 ps = psPtCont ps (PutTrigger False) $
-    \tp ->
+--    \tp ->
-        Just $
+--        Just $
-            pContID
+--            pContID
-                ps
+--                ps
-                ( PutButton
+--                ( PutButton
-                    ( makeSwitch
+--                    ( makeSwitch
-                        c1
+--                        c1
-                        c2
+--                        c2
-                        (SetTrigger True $ trigid tp)
+--                        (SetTrigger True $ trigid tp)
-                        (SetTrigger False $ trigid tp)
+--                        (SetTrigger False $ trigid tp)
-                    )
+--                    )
-                )
+--                )
-                (const Nothing)
+--                (const Nothing)
-  where
+--  where
-    trigid tp = fromJust $ _plMID tp
+--    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
+--triggerSwitch :: Color -> PlacementSpot -> Placement
-triggerSwitchSPicLight c1 c2 ps = psPtCont ps (PutTrigger False) $
+--triggerSwitch col ps = psPtCont ps (PutTrigger False) $
-    \tp -> Just $
+--    \tp ->
-        pContID atFstLnkOut (PutLS thels) $
+--        Just $
-            \lsid ->
+--            pContID
-                Just $
+--                ps
-                    pContID
+--                (PutButton (makeSwitch col col (SetTrigger True $ trigid tp) (SetTrigger False $ trigid tp)))
-                        ps
+--                (const Nothing)
-                        (PutButton (makeSwitch c1 c2 (oneff lsid $ trigid tp) (offeff lsid $ trigid tp)))
+--  where
-                        (const Nothing)
+--    trigid tp = fromJust $ _plMID tp
-  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
 
 putLitButOnPos :: Color -> PlacementSpot -> (Placement -> Maybe Placement) -> Placement
 putLitButOnPos col theps subpl =

src/Dodge/Placement/Instance/LightSource.hs

@@ -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) =
+vShape p (V3 x y z) = abar n <> abar (-n)
-    thinHighBar z wallposUp lxy
-        <> thinHighBar z wallposDown lxy
   where
+    abar a = thinHighBar z (p + a) lxy
     lxy = V2 x y
-    n = vNormal (wallpos -.- lxy)
+    n = vNormal (p - lxy)
-    wallposUp = wallpos +.+ n
-    wallposDown = wallpos -.- n
 
 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))

src/Dodge/Placement/PlaceSpot.hs

@@ -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 :: Int -> [[Point2]] -> [[Point2]] -> [(Point2, Point2)] -> GenWorld -> GenWorld
-placeChasm gw rid ps shiftps cfs =
+placeChasm rid ps shiftps cfs =
-    gw
+    (gwWorld . cWorld . chasms <>~ shiftps)
-        & gwWorld . cWorld . chasms <>~ shiftps
+        . (gwWorld . cWorld . cliffs <>~ cfs)
-        & gwWorld . cWorld . cliffs <>~ cfs
+        . (genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps))
-        & genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps)
+        . (gwWorld %~ f)
-        & 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
+        & tolw
-        & gwWorld %~ placeMachineWalls (_mcMaterial mc) wallpoly mcid wlid
+        . machines
-        & tolw %~ maybe id placeturretitm mitm
+        . 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 
+    baseWall =
-        & wlStructure . wsMachine .~ mcid
+        defaultMachineWall
-        & wlMaterial .~ mat
+            & wlStructure
+            . wsMachine
+            .~ mcid
+            & wlMaterial
+            .~ mat
 
 mvLS :: Point2 -> Float -> LightSource -> LightSource
 mvLS x rot = lsParam . lsPos . _xy %~ ((+ x) . rotateV rot)

src/Dodge/Render/Picture.hs

@@ -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

src/Dodge/Room/Tutorial.hs

@@ -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 120 0) (V2 120 300)]
-         , [spanLightI (V2 0 128) (V2 300 128)]
+--         , [spanLightI (V2 0 128) (V2 300 128)]
-         , [spanLightI (V2 300 0) (V2 0 300), sps0 $ putShape $ thinHighBar 95 0 300]
+--         , [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]

src/Dodge/TestString.hs

@@ -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)

src/Dodge/Update.hs

@@ -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
+--    isrotatedrag = do
-        t1 <- w ^. input . mouseButtons . at ButtonLeft
+--        t1 <- w ^. input . mouseButtons . at ButtonLeft
-        t2 <- w ^. input . mouseButtons . at ButtonRight
+--        t2 <- w ^. input . mouseButtons . at ButtonRight
-        guard $ t1 > t2
+--        guard $ t1 > t2
-        return MouseGameRotate
+--        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

src/Dodge/Update/Camera.hs

@@ -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) =

src/Dodge/Update/Input/InGame.hs

@@ -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 =

src/Dodge/Update/Scroll.hs

@@ -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)

src/Dodge/WallCreatureCollisions.hs

@@ -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