justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Work on mouse selection in options menu

Browse Source
This commit is contained in:
justin
2023-05-10 10:02:37 +01:00
parent ab714d63db
commit cc42a5e124
10 changed files with 130 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Coordinate.hs
+2
View File
@@ -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
+32 -25
View File
@@ -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
src/Dodge/ListDisplayParams.hs
+7 -5
View File
@@ -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
src/Dodge/Menu/Option.hs
+9 -8
View File
@@ -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 =
src/Dodge/Render/HUD.hs
+4 -1
View File
@@ -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
+5 -9
View File
@@ -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(?!)
src/Dodge/ScreenPos.hs
+4 -1
View File
@@ -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
+21 -13
View File
@@ -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
src/Dodge/SelectionSections/Draw.hs
+11 -11
View File
@@ -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
src/Dodge/Update/Input/ScreenLayer.hs
+35 -15
View File
@@ -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