Start adding mouse control of inventory

data/dodge.config.json

@@ -2,7 +2,6 @@
   "_debug_booleans": [
     "Show_ms_frame",
     "Show_sound",
-    "Noclip",
     "Select_creature"
   ],
   "_debug_view_clip_bounds": "NoRoomClipBoundaries",

ghcidOutput

@@ -1,14 +1,5 @@
-/home/justin/Haskell/loop/src/Dodge/HeldUse.hs:70:31-47: error:
+/home/justin/Haskell/loop/src/Dodge/Render/ShapePicture.hs:61:19: warning: [-Wunused-matches]
-    • Data constructor not in scope:
+    Defined but not used: ‘cfig’
-        CrWeaponFailSound :: Int -> SoundOrigin
-    • Perhaps you meant ‘CrWeaponSound’ (imported from Dodge.Data.World)
    |
-70 |         Just 0 -> soundStart (CrWeaponFailSound (_crID cr)) (_crPos cr) click1S Nothing w
+61 | drawDIMouseOver w cfig = fromMaybe mempty $ do
-   |                               ^^^^^^^^^^^^^^^^^
+   |                   ^^^^
-/home/justin/Haskell/loop/src/Dodge/HeldUse.hs:71:29-45: error:
-    • Data constructor not in scope:
-        CrWeaponFailSound :: Int -> SoundOrigin
-    • Perhaps you meant ‘CrWeaponSound’ (imported from Dodge.Data.World)
-   |
-71 |         _ -> soundContinue (CrWeaponFailSound (_crID cr)) (_crPos cr) click1S Nothing w
-   |                             ^^^^^^^^^^^^^^^^^

src/Dodge/Creature/YourControl.hs

@@ -35,7 +35,7 @@ yourControl _ w
     intopinv = fromMaybe False $ do
         subinv <- w ^? hud . hudElement . subInventory
         Just $ case subinv of
-            NoSubInventory -> True
+            NoSubInventory{} -> True
             _ -> False
 
 handleHotkeys :: World -> World
@@ -169,7 +169,7 @@ pressedMBEffectsTopInventory pkeys w
   where
     youhammerdown = set (cWorld . lWorld . creatures . ix 0 . crHammerPosition) HammerDown
     inTopInv = case w ^. hud . hudElement of
-        DisplayInventory{_subInventory = NoSubInventory} -> True
+        DisplayInventory{_subInventory = NoSubInventory{}} -> True
         _ -> False
     isDown but = but `M.member` pkeys
     rotation =

src/Dodge/Data/HUD.hs

@@ -21,6 +21,9 @@ data HUDElement
 
 data SubInventory
     = NoSubInventory
+        { _nsSelected :: Maybe (Int,Int) 
+        , _nsMouseOver :: Maybe Int
+        }
     | ExamineInventory
     | CombineInventory { _ciSections :: SelectionSections CombinableItem }
     | LockedInventory

src/Dodge/Default/World.hs

@@ -161,7 +161,7 @@ defaultHUD =
 defaultDisplayInventory :: HUDElement
 defaultDisplayInventory =
     DisplayInventory
-        { _subInventory = NoSubInventory
+        { _subInventory = NoSubInventory {_nsSelected = Just (0,2), _nsMouseOver = Just 3}
         , _diSections = defaultInvSections
         }
 

src/Dodge/DisplayInventory.hs

@@ -30,7 +30,8 @@ import Regex
 
 toggleCombineInv :: Universe -> Universe
 toggleCombineInv uv = case uv ^? uvWorld . hud . hudElement . subInventory of
-    Just CombineInventory{} -> uv & uvWorld . hud . hudElement . subInventory .~ NoSubInventory
+    Just CombineInventory{} -> uv & uvWorld . hud . hudElement . subInventory 
+        .~ NoSubInventory Nothing Nothing
     _ -> uv & uvWorld %~ enterCombineInv (uv ^. uvConfig)
 
 updateCombinePositioning :: Universe -> Universe

src/Dodge/InputFocus.hs

@@ -30,7 +30,7 @@ regexScope ::
     Maybe
         ((SSSExtra -> f SSSExtra) -> HUDElement -> f HUDElement, Int)
 regexScope w = case w ^? hud . hudElement . subInventory of
-    Just NoSubInventory -> case he ^? diSections . sssExtra . sssSelPos . _Just of
+    Just NoSubInventory{} -> case he ^? diSections . sssExtra . sssSelPos . _Just of
         Just (-1, _) -> di (-1)
         Just (0, _) -> di (-1)
         Just (2, _) -> di 2
@@ -49,7 +49,7 @@ regexFocus ::
     Maybe
         ((SSSExtra -> f SSSExtra) -> HUDElement -> f HUDElement, Int)
 regexFocus w = case w ^? hud . hudElement . subInventory of
-    Just NoSubInventory -> case he ^? diSections . sssExtra . sssSelPos . _Just of
+    Just NoSubInventory{} -> case he ^? diSections . sssExtra . sssSelPos . _Just of
         Just (-1, _) -> di (-1)
         Just (2, _) -> di 2
         _ -> Nothing
@@ -71,7 +71,7 @@ inputFocus ::
     World ->
     Maybe ((String -> f String) -> World -> f World)
 inputFocus w = case w ^? hud . hudElement . subInventory of
-    Just NoSubInventory -> case he ^? diSections . sssExtra . sssSelPos . _Just of
+    Just NoSubInventory{} -> case he ^? diSections . sssExtra . sssSelPos . _Just of
         Just (-1, _) -> di (-1)
         Just (2, _) -> di 2
         _ -> Nothing

src/Dodge/Item/Grammar.hs

@@ -9,11 +9,11 @@ module Dodge.Item.Grammar (
     allInvLocs,
 ) where
 
-import Dodge.Data.ComposedItem
 import Control.Applicative
 import Data.Bifunctor
 import qualified Data.IntMap.Strict as IM
 import Data.Maybe
+import Dodge.Data.ComposedItem
 import Dodge.Data.DoubleTree
 import Dodge.Data.Item
 import Dodge.DoubleTree
@@ -21,15 +21,18 @@ import Dodge.Item.Orientation
 import LensHelp
 import ListHelp
 
-useBreakL :: [(ItemStructuralFunction, ComposeLinkType)] 
+useBreakL ::
-    -> [(ItemStructuralFunction, ComposeLinkType)] 
+    [(ItemStructuralFunction, ComposeLinkType)] ->
-    -> LinkTest
+    [(ItemStructuralFunction, ComposeLinkType)] ->
+    LinkTest
 useBreakL x y = useBreakListsLinkTest (map (uncurry noa) x) (map (uncurry noa) y)
   where
     noa a b = (a, ILink b orientAttachment)
 
-useBreakListsLinkTest :: [(ItemStructuralFunction, ItemLink)] 
+useBreakListsLinkTest ::
-    -> [(ItemStructuralFunction, ItemLink)] -> LinkTest
+    [(ItemStructuralFunction, ItemLink)] ->
+    [(ItemStructuralFunction, ItemLink)] ->
+    LinkTest
 useBreakListsLinkTest llist rlist = LTest ltest rtest
   where
     ltest (_, sf, _) = do
@@ -41,40 +44,42 @@ useBreakListsLinkTest llist rlist = LTest ltest rtest
         (_, linktype) <- safeHead xs
         return $ LUpdate linktype (set _3 (useBreakListsLinkTest llist (tail xs))) id
 
-itemToBreakLists
+itemToBreakLists ::
-    :: ComposedItem 
+    ComposedItem ->
-    -> ([(ItemStructuralFunction, ComposeLinkType)] , [(ItemStructuralFunction, ComposeLinkType)])
+    ([(ItemStructuralFunction, ComposeLinkType)], [(ItemStructuralFunction, ComposeLinkType)])
-itemToBreakLists ci = case (itm ^. itType,ci ^. cItemFunction) of
+itemToBreakLists ci = case (itm ^. itType, ci ^. cItemFunction) of
---    HELD TORCH -> (getAmmoLinks itm,[])
+    (HELD TORCH,_) -> (getAmmoLinks itm,[])
-    (_,WeaponPlatformSF) -> 
+    (_, WeaponPlatformSF) ->
-            ( getAmmoLinks itm
+        ( getAmmoLinks itm
-            , [(WeaponTargetingSF,WeaponTargetingLink), (WeaponScopeSF,WeaponScopeLink)]
+        , [(WeaponTargetingSF, WeaponTargetingLink), (WeaponScopeSF, WeaponScopeLink)]
-            )
+        )
---    AMMOMAG {} -> fromMaybe ([],[]) $ do
+    (_, AmmoMagSF{}) -> fromMaybe ([], []) $ do
-    (_,AmmoMagSF {}) -> fromMaybe ([],[]) $ do
         atype <- itm ^? itUse . amagType
         return
-            ([ (AmmoModifierSF atype, AmmoModLink)
+            (
-            , (AmmoTargetingSF atype, AmmoTargetingLink)
+                [ (AmmoModifierSF atype, AmmoModLink)
-            , (AmmoPayloadSF atype, AmmoPayloadLink)
+                , (AmmoTargetingSF atype, AmmoTargetingLink)
-            , (AmmoEffectSF atype, AmmoEffectLink)
+                , (AmmoPayloadSF atype, AmmoPayloadLink)
-            , (RemoteScreenSF, RemoteScreenLink)
+                , (AmmoEffectSF atype, AmmoEffectLink)
-            ],[])
+                , (RemoteScreenSF, RemoteScreenLink)
-    (_,WeaponTargetingSF) -> (getAmmoLinks itm ++ [(AugmentedHUDSF,AugmentedHUDLink)],[])
+                ]
-    _ -> ([],[])
+            , []
+            )
+    (_, WeaponTargetingSF) -> (getAmmoLinks itm ++ [(AugmentedHUDSF, AugmentedHUDLink)], [])
+    _ -> ([], [])
   where
     itm = ci ^. cItem
 
 getAmmoLinks :: Item -> [(ItemStructuralFunction, ComposeLinkType)]
-getAmmoLinks itm = map
+getAmmoLinks itm =
-                (\(i, a) -> (AmmoMagSF a,AmmoInLink i a))
+    map
-                (IM.toList $ itm ^. itAmmoSlots)
+        (\(i, a) -> (AmmoMagSF a, AmmoInLink i a))
+        (IM.toList $ itm ^. itAmmoSlots)
 
 itemToFunction :: Item -> ItemStructuralFunction
 itemToFunction itm = case itm ^. itType of
-    HELD TORCH -> WeaponScopeSF
+    HELD{} -> WeaponPlatformSF
-    HELD {} -> WeaponPlatformSF
+    AMMOMAG{} -> maybe UncomposableIsolateSF AmmoMagSF $ itm ^? itUse . amagType
-    AMMOMAG {} -> maybe UncomposableIsolateSF AmmoMagSF $ itm ^? itUse . amagType
     ATTACH REMOTESCREEN -> RemoteScreenSF
     ATTACH BULLETSYNTHESIZER -> AmmoModifierSF BulletAmmo
     ATTACH ZOOMSCOPE -> WeaponScopeSF
@@ -87,7 +92,7 @@ itemToFunction itm = case itm ^. itType of
     _ -> UncomposableIsolateSF
 
 pciToCI :: PartiallyComposedItem -> ComposedItem
-pciToCI (x,y,_) = CItem x y
+pciToCI (x, y, _) = CItem x y
 
 basePCI :: Item -> PartiallyComposedItem
 basePCI itm = case _itType itm of
@@ -106,9 +111,11 @@ llright itm pci = case pci ^. _1 . itType of
     _ -> _tryRightLink (uncurry useBreakL $ itemToBreakLists (CItem itm WeaponTargetingSF)) pci
 
 toLasgunUpdate :: Item -> LinkUpdate
-toLasgunUpdate itm = LUpdate (ILink FunctionChangeLink orientAttachment)
+toLasgunUpdate itm =
-    (\(par,_,_) -> (par,WeaponPlatformSF,uncurry useBreakL $ itemToBreakLists (CItem itm WeaponPlatformSF)))
+    LUpdate
-    (\(chi,_,up) -> (chi,FunctionChangeSF,up))
+        (ILink FunctionChangeLink orientAttachment)
+        (\(par, _, _) -> (par, WeaponPlatformSF, uncurry useBreakL $ itemToBreakLists (CItem itm WeaponPlatformSF)))
+        (\(chi, _, up) -> (chi, FunctionChangeSF, up))
 
 --itemLinkTestLeft :: Item -> PartiallyComposedItem -> Maybe LinkUpdate
 --itemLinkTestLeft itm = _tryLeftLink $
@@ -197,15 +204,15 @@ invTrees' = IM.unions . map (ldtToIM getindex . fmap (^. _1)) . map (fmap (\(x,
 
 -- returns an intmap with trees for root items, indexed by inventory position
 invRootTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ItemLink ComposedItem)
-invRootTrees = IM.fromDistinctAscList . reverse . map (getid . fmap (\(x, y, _) ->  CItem x y)) . invLDT
+invRootTrees = IM.fromDistinctAscList . reverse . map (getid . fmap (\(x, y, _) -> CItem x y)) . invLDT
   where
-    getid :: LabelDoubleTree ItemLink ComposedItem -> (Int,LabelDoubleTree ItemLink ComposedItem)
+    getid :: LabelDoubleTree ItemLink ComposedItem -> (Int, LabelDoubleTree ItemLink ComposedItem)
     getid t = (t ^?! ldtValue . cItem . itLocation . ilInvID, t)
 
 -- returns an intmap with indents and locations for all items
-allInvLocs :: IM.IntMap Item -> IM.IntMap (Int,LocationLDT ItemLink ComposedItem)
+allInvLocs :: IM.IntMap Item -> IM.IntMap (Int, LocationLDT ItemLink ComposedItem)
 allInvLocs inv = foldMap (f . LocLDT TopLDT) (IM.elems (invRootTrees inv)) mempty
   where
     f t = cldtPropagateFold h h g 0 t id
     h x _ _ _ = x + 1
-    g x ldt = (.) (IM.insert (ldt ^?! locLDT . ldtValue . cItem . itLocation . ilInvID) (x,ldt))
+    g x ldt = (.) (IM.insert (ldt ^?! locLDT . ldtValue . cItem . itLocation . ilInvID) (x, ldt))

src/Dodge/ListDisplayParams.hs

@@ -61,7 +61,7 @@ determineInvSelCursorWidth w = case _rbOptions w of
         | otherwise -> topInvW
   where
     hasnosubinv = case w ^? hud . hudElement . subInventory of
-        Just NoSubInventory -> True
+        Just NoSubInventory{} -> True
         _ -> False
 
 optionListDisplayParams :: ListDisplayParams

src/Dodge/Render/HUD.hs

@@ -2,6 +2,7 @@
 
 module Dodge.Render.HUD (
     drawHUD,
+    selNumPos, -- this shoud probably be pushed back here
 ) where
 
 import Control.Lens
@@ -70,7 +71,7 @@ drawInventory sss w cfig =
 drawSubInventory :: SubInventory -> Configuration -> World -> Picture
 drawSubInventory subinv cfig w = case subinv of
     LockedInventory -> mempty -- topInvCursor col cursPos cfig w
-    NoSubInventory -> drawRBOptions cfig w
+    NoSubInventory{} -> drawRBOptions cfig w
     ExamineInventory -> drawExamineInventory cfig w
     DisplayTerminal tid -> displayTerminal tid cfig (w ^. cWorld . lWorld)
     CombineInventory{_ciSections = sss} -> drawCombineInventory cfig sss w

src/Dodge/Render/List.hs

@@ -10,6 +10,7 @@ module Dodge.Render.List (
     stackPicturesAt,
     toTopLeft,
     listCursorChooseBorderScale,
+    selSecDrawCursorAt,
 ) where
 
 import Dodge.SelectionSections
@@ -84,9 +85,8 @@ stackPicturesAt = stackPicturesAtOff 0
 stackPicturesAtOff :: Int -> [Picture] -> Picture
 stackPicturesAtOff i = mconcat . zipWith (drawListElement 10 1 0) [i, i -1 ..]
 
-selSecDrawCursor :: Int -> ListDisplayParams -> SelectionSections a -> Picture
+selSecDrawCursorAt :: (Int,Int) -> Int -> ListDisplayParams -> SelectionSections a -> Picture
-selSecDrawCursor xsize ldp sss = fromMaybe mempty $ do
+selSecDrawCursorAt (i,j) xsize ldp sss = fromMaybe mempty $ do
-    (i, j) <- sss ^? sssExtra . sssSelPos . _Just
     yint <- selSecYint i j sss
     xint <- sss ^? sssSections . ix i . ssIndent
     si <- sss ^? sssSections . ix i . ssItems . ix j
@@ -101,6 +101,11 @@ selSecDrawCursor xsize ldp sss = fromMaybe mempty $ do
             xsize
             (_siHeight si)
 
+selSecDrawCursor :: Int -> ListDisplayParams -> SelectionSections a -> Picture
+selSecDrawCursor xsize ldp sss = maybe mempty 
+    (\x -> selSecDrawCursorAt x xsize ldp sss)
+    (sss ^? sssExtra . sssSelPos . _Just) 
+
 -- displays a cursor that should match up to list text pictures
 listCursorChooseBorderScale ::
     Float ->

src/Dodge/Render/ShapePicture.hs

@@ -2,23 +2,27 @@ module Dodge.Render.ShapePicture (
     worldSPic,
 ) where
 
-import Data.Strict.Tuple
+import Dodge.Render.HUD
-import NewInt
+import Dodge.ListDisplayParams
-import Dodge.Render.List
+import qualified Data.Map.Strict as M
 import Control.Lens
 import Control.Monad (guard)
 import Data.Foldable
 import Data.Maybe
+import Data.Strict.Tuple
 import Dodge.Base
 import Dodge.Creature.Picture
 import Dodge.Data.Universe
 import Dodge.Debug.Picture
 import Dodge.Draw
 import Dodge.RadarBlip
+import Dodge.Render.List
 import Dodge.Render.Picture
 import Geometry
 import qualified IntMapHelp as IM
+import NewInt
 import Picture
+import qualified SDL
 import Shape
 import ShapePicture
 
@@ -35,12 +39,40 @@ worldSPic cfig u =
         <> foldup btSPic (filtOn _btPos _buttons)
         <> foldup mcSPic (filtOn _mcPos _machines)
         <> aimDelaySweep w
+        <> drawMouseSelection w
+        <> drawDISelections w cfig
+        <> drawDIMouseOver w cfig
   where
     w = _uvWorld u
     foldup = foldMap'
     filtOn f g = IM.filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
     pointIsClose = cullPoint cfig w
 
+drawMouseSelection :: World -> SPic
+drawMouseSelection w = fromMaybe mempty $ do
+    guard (SDL.ButtonLeft `M.member` (w ^. input . mouseButtons)
+        && not (SDL.ButtonRight `M.member` (w ^. input . mouseButtons))
+        )
+    p <- w ^? input . clickPos . ix SDL.ButtonLeft
+    return $ noShape $ color (withAlpha 0.5 white) 
+        $ setLayer FixedCoordLayer $ polygon $ reverse $ rectVV p (w ^. input . mousePos)
+
+drawDIMouseOver :: World -> Configuration -> SPic
+drawDIMouseOver w cfig = fromMaybe mempty $ do
+    i <- w ^? hud . hudElement . subInventory . nsMouseOver . _Just
+    sss <- w ^? hud . hudElement . diSections
+    let idp = invDisplayParams w
+    return . noShape . setLayer FixedCoordLayer . color white $ selSecDrawCursorAt (0,i) 10 idp sss
+
+drawDISelections :: World -> Configuration -> SPic
+drawDISelections w cfig = fromMaybe mempty $ do
+    (i,j) <- w ^? hud . hudElement . subInventory . nsSelected . _Just
+    sss <- w ^? hud . hudElement . diSections
+    let idp = invDisplayParams w
+    tp <- selNumPos cfig idp sss 0 i
+    bp <- selNumPos cfig idp sss 0 j
+    return . noShape . setLayer FixedCoordLayer . color red $ line [tp,bp]
+
 aimDelaySweep :: World -> SPic
 aimDelaySweep w = fromMaybe mempty $ do
     cr <- w ^? cWorld . lWorld . creatures . ix 0
@@ -85,8 +117,8 @@ drawCreature cr = case _crType cr of
 
 lampCrSPic :: Float -> SPic
 lampCrSPic h =
-     colorSH blue (upperBox Small Typical h $ rectWH 5 5)
+    colorSH blue (upperBox Small Typical h $ rectWH 5 5)
-    :!: setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
+        :!: setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
 
 picAtCrPos1 :: Picture -> Creature -> SPic
 --{-# INLINE picAtCrPos #-}
@@ -125,19 +157,23 @@ extraPics cfig u =
         <> foldMap drawBul (_bullets lw)
         <> foldMap drawBlip (_radarBlips lw)
         <> _flares lw
---        <> foldMap (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams lw)
+        --        <> foldMap (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams lw)
---        <> foldMap (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams lw)
+        --        <> foldMap (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams lw)
         <> foldMap (dbArg (drawLightSource . _lsPict)) (_lightSources lw)
         <> testPic cfig w
         <> foldMap ppDraw (_pressPlates lw)
         <> viewClipBounds cfig w
         <> debugDraw cfig w
         <> foldMap (`_debugPic` u) (_uvDebug u)
-        <> setLayer FixedCoordLayer
+        <> setLayer
-            (toTopLeft cfig . translate (1.3* halfWidth cfig) 0 
+            FixedCoordLayer
+            ( toTopLeft cfig . translate (1.3 * halfWidth cfig) 0
                 . drawList
-                . take 50 . drop (u ^. uvDebugMessageOffset)
+                . take 50
-                . map text $ foldMap (`_debugMessage` u) (_uvDebug u))
+                . drop (u ^. uvDebugMessageOffset)
+                . map text
+                $ foldMap (`_debugMessage` u) (_uvDebug u)
+            )
   where
     w = u ^. uvWorld
     lw = w ^. cWorld . lWorld
@@ -151,7 +187,8 @@ ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
 floorItemSPic :: FloorItem -> SPic
 floorItemSPic flit =
     uncurryV translateSPxy (_flItPos flit) $
-        rotateSP (_flItRot flit) 
+        rotateSP
+            (_flItRot flit)
             (itemSPic $ _flIt flit)
 
 btSPic :: Button -> SPic
@@ -163,4 +200,3 @@ mcSPic :: Machine -> SPic
 mcSPic mc =
     uncurryV translateSPxy (_mcPos mc) $
         rotateSP (_mcDir mc) (drawMachine mc)
-

src/Dodge/Terminal.hs

@@ -222,7 +222,7 @@ disconnectTerminal tm =
 
 exitTerminalSubInv :: World -> World
 exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of
-    Just _ -> w & hud . hudElement . subInventory .~ NoSubInventory
+    Just _ -> w & hud . hudElement . subInventory .~ NoSubInventory Nothing Nothing
     _ -> w
 
 damageCodeCommand :: TerminalCommand

src/Dodge/Update.hs

@@ -288,7 +288,7 @@ checkTermDist w = fromMaybe w $ do
     btid <- w ^? cWorld . lWorld . terminals . ix tmid . tmButtonID
     btpos <- w ^? cWorld . lWorld . buttons . ix btid . btPos
     guard $ dist btpos (_crPos $ you w) > 40
-    return (w & hud . hudElement . subInventory .~ NoSubInventory)
+    return (w & hud . hudElement . subInventory .~ NoSubInventory Nothing Nothing)
 
 
 updateWheelEvents :: World -> World

src/Dodge/Update/Input/InGame.hs

@@ -40,7 +40,8 @@ updateUseInputInGame u = case u ^. uvWorld . hud . hudElement of
                 u & uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus %~ const True
         CombineInventory{_ciSections = sss}
             | inSubInvRegex (u ^. uvWorld) ->
-                u & uvWorld . hud . hudElement . subInventory . ciSections 
+                u
+                    & uvWorld . hud . hudElement . subInventory . ciSections
                         %~ doRegexInput (u ^. uvWorld . input) (-1)
                     & uvWorld . worldEventFlags . at CombineInventoryChange ?~ ()
             | lbinitialpress ->
@@ -116,7 +117,7 @@ updateInitialPressInGame uv sc = case sc of
     ScancodeP -> pauseGame uv
     ScancodeF -> over uvWorld youDropItem uv
     ScancodeM -> toggleMap uv
---    ScancodeR -> over (uvWorld . cWorld . lWorld . creatures . ix 0) crReloadToggle uv
+    --    ScancodeR -> over (uvWorld . cWorld . lWorld . creatures . ix 0) crReloadToggle uv
     ScancodeT -> over uvWorld testEvent uv
     ScancodeX -> uv & uvWorld %~ toggleTweakInv
     ScancodeC -> toggleCombineInv uv
@@ -158,11 +159,11 @@ doRegexInput inp i sss
 
 updateBackspaceRegex :: World -> World
 updateBackspaceRegex w = case di ^? subInventory of
-    Just NoSubInventory
+    Just NoSubInventory{}
         | secfocus (-1) 0 ->
             w & hud . hudElement . diSections %~ trybackspace (-1)
                 & worldEventFlags . at InventoryChange ?~ ()
-    Just NoSubInventory
+    Just NoSubInventory{}
         | secfocus 2 3 ->
             w & hud . hudElement . diSections %~ trybackspace 2
                 & worldEventFlags . at InventoryChange ?~ ()
@@ -187,11 +188,11 @@ updateBackspaceRegex w = case di ^? subInventory of
 
 updateEnterRegex :: World -> World
 updateEnterRegex w = case w ^? hud . hudElement . subInventory of
-    Just NoSubInventory
+    Just NoSubInventory{}
         | secfocus (-1) 0 ->
             w & hud . hudElement . diSections . sssExtra . sssSelPos ?~ (-1, 0)
                 & hud . hudElement . diSections %~ enterregex (-1)
-    Just NoSubInventory
+    Just NoSubInventory{}
         | secfocus 2 3 ->
             w & hud . hudElement . diSections . sssExtra . sssSelPos ?~ (2, 0)
                 & hud . hudElement . diSections %~ enterregex 2
@@ -216,7 +217,7 @@ pauseGame u = u & uvScreenLayers .~ [pauseMenu u]
 spaceAction :: World -> World
 spaceAction w = case w ^. hud . hudElement of
     DisplayCarte -> w & hud . carteCenter .~ theLoc
-    DisplayInventory{_subInventory = NoSubInventory} -> case selectedCloseObject w of
+    DisplayInventory{_subInventory = NoSubInventory{}} -> case selectedCloseObject w of
         Just (Left flit) ->
             pickUpItem 0 flit w
                 & worldEventFlags . at InventoryChange ?~ ()
@@ -225,9 +226,9 @@ spaceAction w = case w ^. hud . hudElement of
                 & worldEventFlags . at InventoryChange ?~ ()
         _ -> w
     DisplayInventory{_subInventory = DisplayTerminal{}} ->
-        w & hud . hudElement . subInventory .~ NoSubInventory
+        w & hud . hudElement . subInventory .~ NoSubInventory Nothing Nothing
             & worldEventFlags . at InventoryChange ?~ ()
-    _ -> w & hud . hudElement . subInventory .~ NoSubInventory
+    _ -> w & hud . hudElement . subInventory .~ NoSubInventory Nothing Nothing
   where
     theLoc =
         doWorldPos
@@ -238,25 +239,30 @@ toggleMap :: Universe -> Universe
 toggleMap u = case u ^. uvWorld . hud . hudElement of
     DisplayCarte ->
         u & uvWorld . hud . hudElement
-            .~ DisplayInventory{_subInventory = NoSubInventory, _diSections = defaultInvSections}
+            .~ DisplayInventory
+                { _subInventory = NoSubInventory Nothing Nothing
+                , _diSections = defaultInvSections
+                }
     _ -> u & uvWorld . hud . hudElement .~ DisplayCarte
 
 toggleTweakInv :: World -> World
 toggleTweakInv w = case w ^? hud . hudElement . subInventory of
-    Just ExamineInventory{} -> w & thepointer .~ NoSubInventory
+    Just ExamineInventory{} -> w & thepointer .~ NoSubInventory Nothing Nothing
     _ -> w & thepointer .~ ExamineInventory -- mi
   where
     thepointer = hud . hudElement . subInventory
+
 --    mi = 0 <$ (yourSelectedItem w >>= (^? itTweaks . tweakParams . ix 0))
 
 tryCombine :: SelectionSections CombinableItem -> World -> World
 tryCombine sss w = fromMaybe w $ do
     (i, j) <- sss ^? sssExtra . sssSelPos . _Just
     CombinableItem is it _ <- sss ^? sssSections . ix i . ssItems . ix j . siPayload
-    return $ snd (createItemYou it (foldr (destroyInvItem 0) w (sort is)))
+    return $
-        & cWorld . lWorld . creatures . ix 0 . crHammerPosition .~ HammerDown
+        snd (createItemYou it (foldr (destroyInvItem 0) w (sort is)))
+            & cWorld . lWorld . creatures . ix 0 . crHammerPosition .~ HammerDown
 
 maybeExitCombine :: Universe -> Universe
 maybeExitCombine u
     | ButtonRight `M.member` (u ^. uvWorld . input . mouseButtons) = u
-    | otherwise = u & uvWorld . hud . hudElement . subInventory .~ NoSubInventory
+    | otherwise = u & uvWorld . hud . hudElement . subInventory .~ NoSubInventory Nothing Nothing

src/Dodge/Update/Scroll.hs

@@ -22,7 +22,7 @@ updateWheelEvent yi w = case w ^. hud . hudElement of
     DisplayCarte
         | bdown ButtonRight -> w & hud . carteZoom %~ min 0.75 . max 0.05 . ((1 + y * 0.1) *)
         | otherwise -> w & cWorld . lWorld . selLocation %~ (`mod` numLocs) . (+ yi)
-    DisplayInventory{_subInventory = NoSubInventory}
+    DisplayInventory{_subInventory = NoSubInventory{}}
         -- functions that modify the inventory should be centralised so that
         -- this lock can be sensibly applied, perhaps
         | w ^?! cWorld . lWorld . creatures . ix 0 . crInvLock -> w

src/Geometry/Polygon.hs

@@ -35,6 +35,14 @@ rectXH x h = rectNSWE h (- h) 0 x
 rectXY :: Float -> Float -> [Point2]
 rectXY x y = rectNSWE y 0 0 x
 
+rectVV :: Point2 -> Point2 -> [Point2]
+rectVV (V2 x y) (V2 a b) = rectNSWE n s w e
+  where
+    (e,w) | x > a = (x,a)
+        | otherwise = (a,x)
+    (n,s) | y > b = (y,b)
+        | otherwise = (b,y)
+
 square :: Float -> [Point2]
 square n = rectWH n n