Start adding mouse control of inventory

src/Dodge/Render/ShapePicture.hs

@@ -2,23 +2,27 @@ module Dodge.Render.ShapePicture (
     worldSPic,
 ) where
 
-import Data.Strict.Tuple
-import NewInt
-import Dodge.Render.List
+import Dodge.Render.HUD
+import Dodge.ListDisplayParams
+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)
-    :!: setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
+    colorSH blue (upperBox Small Typical h $ rectWH 5 5)
+        :!: 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)) (_electronBeams $ _beams lw)
+        --        <> foldMap (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _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
-            (toTopLeft cfig . translate (1.3* halfWidth cfig) 0 
-                . drawList 
-                . take 50 . drop (u ^. uvDebugMessageOffset)
-                . map text $ foldMap (`_debugMessage` u) (_uvDebug u))
+        <> setLayer
+            FixedCoordLayer
+            ( toTopLeft cfig . translate (1.3 * halfWidth cfig) 0
+                . drawList
+                . take 50
+                . 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)
-