From cc42a5e1245ca9f8ca2e658eb1656271bb7248e6 Mon Sep 17 00:00:00 2001 From: justin Date: Wed, 10 May 2023 10:02:37 +0100 Subject: [PATCH] Work on mouse selection in options menu --- src/Dodge/Base/Coordinate.hs | 2 + src/Dodge/Data/SelectionList.hs | 57 +++++++++++++++------------ src/Dodge/ListDisplayParams.hs | 12 +++--- src/Dodge/Menu/Option.hs | 17 ++++---- src/Dodge/Render/HUD.hs | 5 ++- src/Dodge/Render/List.hs | 14 +++---- src/Dodge/ScreenPos.hs | 5 ++- src/Dodge/SelectionList.hs | 34 ++++++++++------ src/Dodge/SelectionSections/Draw.hs | 22 +++++------ src/Dodge/Update/Input/ScreenLayer.hs | 50 ++++++++++++++++------- 10 files changed, 130 insertions(+), 88 deletions(-) diff --git a/src/Dodge/Base/Coordinate.hs b/src/Dodge/Base/Coordinate.hs index 4099f2da5..03cebebbc 100644 --- a/src/Dodge/Base/Coordinate.hs +++ b/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 = diff --git a/src/Dodge/Data/SelectionList.hs b/src/Dodge/Data/SelectionList.hs index 1a9b474de..0d3e49584 100644 --- a/src/Dodge/Data/SelectionList.hs +++ b/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 - , _ldpPosY :: Float + { _ldpPos :: ScreenPos , _ldpScale :: Float , _ldpVerticalGap :: Float , _ldpCursorSides :: [CardinalPoint] @@ -23,12 +26,12 @@ data ListDisplayParams = ListDisplayParams data SelectionList a = SelectionList { _slItems :: [SelectionItem a] , _slSelPos :: Maybe Int - , _slRegex :: String + , _slRegex :: String , _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) } @@ -58,29 +61,32 @@ data SelectionSection a = SelectionSection , _ssIndent :: Int , _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 - { _siPictures :: [String] - , _siHeight :: Int - , _siIsSelectable :: Bool - , _siColor :: Color - , _siOffX :: Int - , _siPayload :: a - } +data SelectionItem a + = SelectionItem + { _siPictures :: [String] + , _siHeight :: Int + , _siIsSelectable :: Bool + , _siColor :: Color + , _siOffX :: Int + , _siPayload :: a + } | SelectionInfo - { _siPictures :: [String] - , _siHeight :: Int - , _siIsSelectable :: Bool - , _siColor :: Color - , _siOffX :: Int - } + { _siPictures :: [String] + , _siHeight :: Int + , _siIsSelectable :: Bool + , _siColor :: Color + , _siOffX :: Int + } makeLenses ''ListDisplayParams makeLenses ''SelectionList @@ -89,5 +95,6 @@ makeLenses ''SelectionSection makeLenses ''SelectionSections makeLenses ''SSSExtra makeLenses ''SectionCursor + --deriveJSON defaultOptions ''SelectionItem --deriveJSON defaultOptions ''SelectionList diff --git a/src/Dodge/ListDisplayParams.hs b/src/Dodge/ListDisplayParams.hs index b53a8f5e5..355d9851b 100644 --- a/src/Dodge/ListDisplayParams.hs +++ b/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 - , _ldpPosY = 0 + , _ldpPos = ScreenPos {_spScreenOff = V2 (-0.5) 0.5 -- top left + , _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 - & ldpPosY .~ 60 + & ldpPos . spPixelOff .~ V2 subInvX (-61) & ldpCursorSides .~ [North, South, West] subInvX :: Float diff --git a/src/Dodge/Menu/Option.hs b/src/Dodge/Menu/Option.hs index 585b4f17a..cad8a0cbd 100644 --- a/src/Dodge/Menu/Option.hs +++ b/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 - { _ldpPosX = 50 - , _ldpPosY = 50 - , _ldpScale = 2 - , _ldpVerticalGap = 0 - , _ldpWidth = FixedSelectionWidth 25 - , _ldpCursorSides = [North, South, West] - } + defaultListDisplayParams + & ldpPos . spPixelOff .~ V2 50 (-50) + & ldpScale .~ 2 + & ldpVerticalGap .~ 0 + & ldpWidth .~ FixedSelectionWidth 25 + & ldpCursorSides .~ [North, South, West] initializeOptionMenu :: String -> [MenuOption] -> PositionedMenuOption -> Universe -> ScreenLayer initializeOptionMenu title ops pmo u = diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 5dce9e6a6..5f287371e 100644 --- a/src/Dodge/Render/HUD.hs +++ b/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 diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 15ed2d3e1..d56639982 100644 --- a/src/Dodge/Render/List.hs +++ b/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 = - mconcat - . zipWith (drawListElement ygap s) [i ..] +listPicturesYgapScaleYoff 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(?!) diff --git a/src/Dodge/ScreenPos.hs b/src/Dodge/ScreenPos.hs index c3dfac3d4..b118f6dad 100644 --- a/src/Dodge/ScreenPos.hs +++ b/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 diff --git a/src/Dodge/SelectionList.hs b/src/Dodge/SelectionList.hs index 06899f1a1..f7736df28 100644 --- a/src/Dodge/SelectionList.hs +++ b/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 Data.IntMap.Strict (IntMap) +import Linear +import Regex getAvailableListLines :: ListDisplayParams -> Configuration -> Int getAvailableListLines ldps cfig = floor ((dToBot - vgap) / itmHeight) where vgap = ldps ^. ldpVerticalGap - itmHeight = 10 * ldps ^. ldpScale + vgap - dToBot = fromIntegral (cfig ^. windowY) - (ldps ^. ldpPosY + dFromScreenBot) - dFromScreenBot = 5 -- fromMaybe 0 $ sl ^? slSizeRestriction . ssrType . ssrFromScreenBottom + itmHeight = 20 * ldps ^. ldpScale + vgap + winy = fromIntegral $ cfig ^. windowY + dToBot = + winy / 2 + winy * (ldps ^. ldpPos . spScreenOff . _y) + + (ldps ^. ldpPos . spPixelOff . _y) getShownItems :: SelectionList a -> [SelectionItem a] getShownItems sl = case sl ^. slRegexList of @@ -22,15 +25,19 @@ getShownItems sl = case sl ^. slRegexList of makeRegexList :: SelectionList a -> [(SelectionItem a, Maybe Int)] makeRegexList sl = case sl ^. slRegex of - "" | not (sl ^. slRegexInput) -> [] - str -> (SelectionInfo - { _siPictures = ["FILTER: "++str] + "" | not (sl ^. slRegexInput) -> [] + str -> + ( SelectionInfo + { _siPictures = ["FILTER: " ++ str] , _siHeight = 1 , _siIsSelectable = False - --, _siWidth = length $ "FILTER: "++str - , _siColor = white + , --, _siWidth = length $ "FILTER: "++str + _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 diff --git a/src/Dodge/SelectionSections/Draw.hs b/src/Dodge/SelectionSections/Draw.hs index b34422b14..82ad498d8 100644 --- a/src/Dodge/SelectionSections/Draw.hs +++ b/src/Dodge/SelectionSections/Draw.hs @@ -1,23 +1,23 @@ module Dodge.SelectionSections.Draw where -import Picture.Base -import Dodge.Data.CardinalPoint +import Dodge.ScreenPos 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 - (_ldpVerticalGap ldps) - (_ldpScale ldps) - 0 - pics - ) - <> thecursor' - ) + translateScreenPos cfig (ldps ^. ldpPos) $ + listPicturesYgapScaleYoff + (_ldpVerticalGap ldps) + (_ldpScale ldps) + 0 + pics + <> thecursor' where thecursor' = fromMaybe mempty $ do (i, j) <- sss ^? sssExtra . sssSelPos . _Just diff --git a/src/Dodge/Update/Input/ScreenLayer.hs b/src/Dodge/Update/Input/ScreenLayer.hs index e0a562b57..63cd64294 100644 --- a/src/Dodge/Update/Input/ScreenLayer.hs +++ b/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 - | x > xl && x < xr - && ylower == yupper - && (mmoving || (_scDisplayTime screen <= 1)) -- slight hack - && ylower >= 0 - && ylower < ymax - && isselectable = - u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper - | otherwise = u +mouseOverSelectionList ldps screen u = fromMaybe u $ do + yi <- ldpVerticalSelection (u ^. uvConfig) ldps (u ^. uvWorld . input . mousePos) + guard $ (mmoving || (_scDisplayTime screen <= 1)) + && isselectable yi + && yi >= 0 + && yi < ymax +-- && x > xl && x < xr + return $ u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yi +-- | 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 - yupper = floor $ (hh - (15 + y + _ldpPosY ldps)) / 50 - xl = _ldpPosX ldps - hw - xr = xl + _ldpScale ldps * 26 * 9 +-- ylower = ceiling $ (hh - (75 + y + _ldpPosY ldps)) / 50 +-- yupper = floor $ (hh - (15 + y + _ldpPosY ldps)) / 50 +-- xl = _ldpPosX ldps - hw +-- 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