Work on mouse selection in options menu

src/Dodge/Base/Coordinate.hs

@@ -22,6 +22,8 @@ import Geometry
 {- | Transform world coordinates to scaled screen coordinates.
  - These have to be scaled according to the size of the window to get actual screen positions.
  - This allows for line thicknesses etc to correspond to pixel sizes.
+ - I believe the resulting point is the number of pixels from the center of
+ - the screen, I am not sure how rounding affects this though.
 -}
 worldPosToScreen :: Camera -> Point2 -> Point2
 worldPosToScreen cam =

src/Dodge/Data/SelectionList.hs

@@ -1,19 +1,22 @@
+{-# LANGUAGE StrictData #-}
 --{-# LANGUAGE DeriveGeneric #-}
 --{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE StrictData #-}
+
 module Dodge.Data.SelectionList where
-import Picture.Data
+
 import Color
 import Control.Lens
-import Dodge.Data.CardinalPoint
 import Data.IntMap.Strict (IntMap)
+import Dodge.Data.CardinalPoint
+import Dodge.Data.ScreenPos
+import Picture.Data
+
 --import Data.Aeson
 --import Data.Aeson.TH
 
 data ListDisplayParams = ListDisplayParams
-    { _ldpPosX :: Float
+    { _ldpPos :: ScreenPos
-    , _ldpPosY :: Float
     , _ldpScale :: Float
     , _ldpVerticalGap :: Float
     , _ldpCursorSides :: [CardinalPoint]
@@ -27,8 +30,8 @@ data SelectionList a = SelectionList
     , _slRegexInput :: Bool
     , _slRegexList :: [(SelectionItem a, Maybe Int)]
     }
-    --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
+--deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data SelectionSections a = SelectionSections
     { _sssSections :: IntMap (SelectionSection a)
@@ -39,7 +42,7 @@ data SelectionSections a = SelectionSections
 -- a pair of ints (i,i+1) such that the lower is the regex section, the higher
 -- is the items section.
 data SSSExtra = SSSExtra
-    { _sssSelPos :: Maybe (Int,Int)
+    { _sssSelPos :: Maybe (Int, Int)
     , _sssFilters :: IntMap (Maybe String)
     }
 
@@ -59,14 +62,17 @@ data SelectionSection a = SelectionSection
     , _ssDescriptor :: String
     }
 
-data SelectionWidth = FixedSelectionWidth Int
+data SelectionWidth
+    = FixedSelectionWidth Int
     | VariableSelectionWidth (Int -> Int)
     | UseMaxSelectionItemWidth
 
-data CursorType = NoCursor
+data CursorType
+    = NoCursor
     | BorderCursor [CardinalPoint]
 
-data SelectionItem a = SelectionItem
+data SelectionItem a
+    = SelectionItem
         { _siPictures :: [String]
         , _siHeight :: Int
         , _siIsSelectable :: Bool
@@ -89,5 +95,6 @@ makeLenses ''SelectionSection
 makeLenses ''SelectionSections
 makeLenses ''SSSExtra
 makeLenses ''SectionCursor
+
 --deriveJSON defaultOptions ''SelectionItem
 --deriveJSON defaultOptions ''SelectionList

src/Dodge/ListDisplayParams.hs

@@ -2,23 +2,25 @@ module Dodge.ListDisplayParams
     ( invDisplayParams
     , secondColumnParams
     , subInvX
+    , defaultListDisplayParams
     ) where
 
+import Dodge.Data.ScreenPos
 import Dodge.Data.CardinalPoint
 import SDL (MouseButton (..))
 import Dodge.Data.SelectionList
 import Dodge.Data.World
 import qualified Data.Map.Strict as M
 import Control.Lens
-
+import Linear
 
 defaultListDisplayParams :: ListDisplayParams
 defaultListDisplayParams =
     ListDisplayParams
         { _ldpVerticalGap = 0
         , _ldpScale = 1
-        , _ldpPosX = 0
+        , _ldpPos = ScreenPos {_spScreenOff = V2 (-0.5) 0.5 -- top left
-        , _ldpPosY = 0
+            , _spPixelOff = 0}
         , _ldpCursorSides = mempty
         , _ldpWidth = FixedSelectionWidth 15
         }
@@ -28,6 +30,7 @@ invDisplayParams w =
     defaultListDisplayParams
         & ldpCursorSides .~ selcursortype
         & ldpWidth .~ FixedSelectionWidth (determineInvSelCursorWidth w)
+        & ldpPos . spPixelOff .~ V2 6 (-1)
   where
     selcursortype
         | isexaminesub || ButtonRight `M.member` _mouseButtons (_input w) = [North, South, East, West]
@@ -39,8 +42,7 @@ invDisplayParams w =
 secondColumnParams :: ListDisplayParams
 secondColumnParams =
     defaultListDisplayParams
-        & ldpPosX .~ subInvX
+        & ldpPos . spPixelOff .~ V2 subInvX (-61)
-        & ldpPosY .~ 60
         & ldpCursorSides .~ [North, South, West]
 
 subInvX :: Float

src/Dodge/Menu/Option.hs

@@ -1,5 +1,7 @@
 module Dodge.Menu.Option where
 
+import Dodge.ListDisplayParams
+import Dodge.Data.ScreenPos
 import Control.Applicative
 import Data.Maybe
 import Dodge.Data.CardinalPoint
@@ -10,17 +12,16 @@ import Dodge.SelectionList
 import LensHelp
 import Padding
 import Picture.Base
+import Linear
 
 optionListDisplayParams :: ListDisplayParams
 optionListDisplayParams =
-    ListDisplayParams
+    defaultListDisplayParams
-        { _ldpPosX = 50
+        & ldpPos . spPixelOff .~ V2 50 (-50)
-        , _ldpPosY = 50
+        & ldpScale .~ 2
-        , _ldpScale = 2
+        & ldpVerticalGap .~ 0
-        , _ldpVerticalGap = 0
+        & ldpWidth .~ FixedSelectionWidth 25
-        , _ldpWidth = FixedSelectionWidth 25
+        & ldpCursorSides .~ [North, South, West]
-        , _ldpCursorSides = [North, South, West]
-        }
 
 initializeOptionMenu :: String -> [MenuOption] -> PositionedMenuOption -> Universe -> ScreenLayer
 initializeOptionMenu title ops pmo u =

src/Dodge/Render/HUD.hs

@@ -3,6 +3,7 @@ module Dodge.Render.HUD (
     drawHUD,
 ) where
 
+import Dodge.ScreenPos
 import Control.Lens
 import Control.Monad
 import qualified Data.Map.Strict as M
@@ -170,7 +171,9 @@ combineInventoryExtra sss cfig w = fromMaybe mempty $ do
   where
     invcursor i = fromMaybe mempty $ do
         sss' <- w ^? hud . hudElement . diSections
-        return $ toTopLeft cfig $ selSecDrawCursor 17 [North, South, East] (invDisplayParams w) sss' 0 i
+        let idp = invDisplayParams w
+        return $ translateScreenPos cfig (idp ^. ldpPos) 
+            $ selSecDrawCursor 17 [North, South, East] idp sss' 0 i
 
 displayTerminal :: Int -> Configuration -> LWorld -> Picture
 displayTerminal tid cfig w = fromMaybe mempty $ do

src/Dodge/Render/List.hs

@@ -12,6 +12,7 @@ module Dodge.Render.List (
     toTopLeft,
 ) where
 
+import Dodge.ScreenPos
 import Data.Maybe
 import Dodge.Base.Window
 import Dodge.Data.CardinalPoint
@@ -26,16 +27,15 @@ import Picture
 
 drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
 drawSelectionList ldps cfig sl =
-    toTopLeft
+    translateScreenPos
         cfig
-        ( translate (ldps ^. ldpPosX) (negate $ ldps ^. ldpPosY) $
+        (ldps ^. ldpPos) $
             listPicturesYgapScaleYoff
                 (_ldpVerticalGap ldps)
                 (_ldpScale ldps)
                 0
                 (makeSelectionListPictures sl)
                 <> drawSelectionCursor sl ldps
-        )
 
 makeSelectionListPictures :: SelectionList a -> [Picture]
 makeSelectionListPictures = concatMap f . getShownItems
@@ -76,9 +76,7 @@ drawListYoff :: Int -> [Picture] -> Picture
 drawListYoff = listPicturesYgapScaleYoff 0 1
 
 listPicturesYgapScaleYoff :: Float -> Float -> Int -> [Picture] -> Picture
-listPicturesYgapScaleYoff ygap s i =
+listPicturesYgapScaleYoff ygap s i = mconcat . zipWith (drawListElement ygap s) [i ..]
-    mconcat
-        . zipWith (drawListElement ygap s) [i ..]
 
 stackPicturesAt :: [Picture] -> Picture
 stackPicturesAt = stackPicturesAtOff 0
@@ -103,12 +101,10 @@ listCursorDisplayParams ::
     Int ->
     Picture
 listCursorDisplayParams ldp borders a b c d =
-    translate xoff (- yoff) . listCursorChooseBorderScale ygap s borders a b c d
+    listCursorChooseBorderScale ygap s borders a b c d
   where
     ygap = _ldpVerticalGap ldp
     s = _ldpScale ldp
-    xoff = _ldpPosX ldp
-    yoff = _ldpPosY ldp
 
 -- displays a cursor that should match up to list text pictures
 -- the width of a character appears to be 9(?!)

src/Dodge/ScreenPos.hs

@@ -1,11 +1,11 @@
 module Dodge.ScreenPos where
 
+import Control.Lens
 import Dodge.Base.Window
 import Dodge.Data.Config
 import Dodge.Data.ScreenPos
 import Geometry.Data
 import Picture.Base
-import Control.Lens
 
 fromTopLeft :: Point2 -> ScreenPos
 fromTopLeft (V2 x y) = ScreenPos (V2 (-0.5) 0.5) (V2 x (- y))
@@ -16,3 +16,6 @@ translateScreenPos cfig sp = translate x y
     V2 x y = sp ^. spScreenOff * V2 hw hh + sp ^. spPixelOff
     hw = halfWidth cfig
     hh = halfHeight cfig
+
+screenPosAbs :: Configuration -> ScreenPos -> Point2
+screenPosAbs = undefined

src/Dodge/SelectionList.hs

@@ -1,19 +1,22 @@
 module Dodge.SelectionList where
 
 import Color
-import Regex
+import Data.Maybe
+import Dodge.Data.ScreenPos
 import Dodge.Data.Universe
 import LensHelp
-import Data.Maybe
+import Linear
---import Data.IntMap.Strict (IntMap)
+import Regex
 
 getAvailableListLines :: ListDisplayParams -> Configuration -> Int
 getAvailableListLines ldps cfig = floor ((dToBot - vgap) / itmHeight)
   where
     vgap = ldps ^. ldpVerticalGap
-    itmHeight = 10 * ldps ^. ldpScale + vgap
+    itmHeight = 20 * ldps ^. ldpScale + vgap
-    dToBot = fromIntegral (cfig ^. windowY) - (ldps ^. ldpPosY + dFromScreenBot)
+    winy = fromIntegral $ cfig ^. windowY
-    dFromScreenBot = 5 -- fromMaybe 0 $ sl ^? slSizeRestriction . ssrType . ssrFromScreenBottom
+    dToBot =
+        winy / 2 + winy * (ldps ^. ldpPos . spScreenOff . _y)
+            + (ldps ^. ldpPos . spPixelOff . _y)
 
 getShownItems :: SelectionList a -> [SelectionItem a]
 getShownItems sl = case sl ^. slRegexList of
@@ -23,14 +26,18 @@ getShownItems sl = case sl ^. slRegexList of
 makeRegexList :: SelectionList a -> [(SelectionItem a, Maybe Int)]
 makeRegexList sl = case sl ^. slRegex of
     "" | not (sl ^. slRegexInput) -> []
-        str ->  (SelectionInfo 
+    str ->
-            { _siPictures = ["FILTER: "++str] 
+        ( SelectionInfo
+            { _siPictures = ["FILTER: " ++ str]
             , _siHeight = 1
             , _siIsSelectable = False
-            --, _siWidth = length $ "FILTER: "++str
+            , --, _siWidth = length $ "FILTER: "++str
-            , _siColor = white
+              _siColor = white
             , _siOffX = 0
-            }, Nothing) : filter (doregex str) (zip (_slItems sl) $ fmap Just [0..])
+            }
+        , Nothing
+        ) :
+        filter (doregex str) (zip (_slItems sl) $ fmap Just [0 ..])
   where
     doregex str = regexList str . _siPictures . fst
 
@@ -40,7 +47,8 @@ setShownItems sl = sl & slRegexList .~ makeRegexList sl
 moveSelectionListSelection :: Int -> SelectionList a -> SelectionList a
 moveSelectionListSelection yi sl = sl & slSelPos %~ f
   where
-    f x | maxsel == 0 = Nothing
+    f x
+        | maxsel == 0 = Nothing
         | isNothing x = Just 0
         | otherwise = fmap ((`mod` maxsel) . subtract yi) x
     maxsel = case _slRegex sl of

src/Dodge/SelectionSections/Draw.hs

@@ -1,23 +1,23 @@
 module Dodge.SelectionSections.Draw where
 
-import Picture.Base
+import Dodge.ScreenPos
-import Dodge.Data.CardinalPoint
 import Control.Lens
 import Data.Maybe
+import Dodge.Data.CardinalPoint
 import Dodge.Data.Config
-import Dodge.Render.List
 import Dodge.Data.SelectionList
+import Dodge.Render.List
+import Picture.Base
 
 drawSelectionSections :: SelectionSections a -> ListDisplayParams -> Configuration -> Picture
 drawSelectionSections sss ldps cfig =
-    toTopLeft cfig ((translate (ldps ^. ldpPosX) (negate $ ldps ^. ldpPosY) $ listPicturesYgapScaleYoff
+    translateScreenPos cfig (ldps ^. ldpPos) $
+        listPicturesYgapScaleYoff
             (_ldpVerticalGap ldps)
             (_ldpScale ldps)
             0
             pics
-        )
             <> thecursor'
-        )
   where
     thecursor' = fromMaybe mempty $ do
         (i, j) <- sss ^? sssExtra . sssSelPos . _Just

src/Dodge/Update/Input/ScreenLayer.hs

@@ -2,6 +2,9 @@ module Dodge.Update.Input.ScreenLayer (
     updateUseInputOnScreen,
 ) where
 
+import Linear
+import Dodge.Data.ScreenPos
+import Control.Monad
 import qualified Data.Map.Strict as M
 import Data.Maybe
 import Dodge.Base.Window
@@ -76,31 +79,48 @@ mouseOverSelectionList ::
     ScreenLayer ->
     Universe ->
     Universe
-mouseOverSelectionList ldps screen u
+mouseOverSelectionList ldps screen u = fromMaybe u $ do
-    | x > xl && x < xr
+    yi <- ldpVerticalSelection (u ^. uvConfig) ldps (u ^. uvWorld . input . mousePos)
-        && ylower == yupper
+    guard $ (mmoving || (_scDisplayTime screen <= 1))
-        && (mmoving || (_scDisplayTime screen <= 1)) -- slight hack
+        && isselectable yi
-        && ylower >= 0
+        && yi >= 0
-        && ylower < ymax
+        && yi < ymax
-        && isselectable =
+--      && x > xl && x < xr
-        u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper
+    return $ u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yi
-    | otherwise = u
+--    | x > xl && x < xr
+--        && ylower == yupper
+--        && (mmoving || (_scDisplayTime screen <= 1)) -- slight hack
+--        && isselectable =
+--        u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper
+--    | otherwise = u
   where
     sl = _scSelectionList screen
-    isselectable =
+    isselectable yi =
         fromMaybe False $
-            u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yupper . siIsSelectable
+            u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yi . siIsSelectable
     ymax = maybe 0 length $ sl ^? slItems
     mmoving = u ^. uvWorld . input . mouseMoving
-    ylower = ceiling $ (hh - (75 + y + _ldpPosY ldps)) / 50
+--    ylower = ceiling $ (hh - (75 + y + _ldpPosY ldps)) / 50
-    yupper = floor $ (hh - (15 + y + _ldpPosY ldps)) / 50
+--    yupper = floor $ (hh - (15 + y + _ldpPosY ldps)) / 50
-    xl = _ldpPosX ldps - hw
+--    xl = _ldpPosX ldps - hw
-    xr = xl + _ldpScale ldps * 26 * 9
+--    xr = xl + _ldpScale ldps * 26 * 9
     V2 x y = u ^. uvWorld . input . mousePos
     cfig = u ^. uvConfig
     hh = halfHeight cfig
     hw = halfWidth cfig
 
+ldpVerticalSelection :: Configuration -> ListDisplayParams -> Point2 -> Maybe Int
+ldpVerticalSelection cfig ldp (V2 _ y) | yupper == ylower = Just yupper
+    | otherwise = Nothing
+  where
+    winy = cfig ^. windowY
+    ygap = ldp ^. ldpVerticalGap
+    yoff = ygap + 20 * ldp ^. ldpScale
+    top :: Float
+    top = fromIntegral winy * (ldp ^. ldpPos . spScreenOff . _y) + ldp ^. ldpPos . spPixelOff . _y
+    yupper = floor $ (top - (y + ygap)) / yoff
+    ylower = ceiling ((top - y) / yoff) - 1
+
 menuWheelEvents :: Universe -> Universe
 menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y)))
   where