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

Tweak mouse over display

Browse Source
This commit is contained in:
justin
2024-11-19 12:51:50 +00:00
parent e31f6dfd4b
commit 13339c9a12
8 changed files with 289 additions and 245 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Debug/Picture.hs
+5 -5
View File
@@ -101,7 +101,7 @@ intersectLinefromScreen cfig w a b =
$ screenPolygon cfig (w ^. wCam)
drawCollisionTest :: World -> Picture
drawCollisionTest w = fromMaybe mempty $ do
drawCollisionTest w = concat $ do
a <- w ^. input . heldWorldPos . at ButtonLeft
b <- w ^. input . heldWorldPos . at ButtonRight
return $
@@ -166,7 +166,7 @@ drawCreatureDisplayTexts :: World -> Picture
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (w ^. cWorld . lWorld . creatures)
drawPathBetween :: World -> Picture
drawPathBetween w = fromMaybe mempty $ do
drawPathBetween w = concat $ do
sp <- w ^. input . clickPos . at ButtonLeft
ep <- w ^. input . clickPos . at ButtonRight
let nodepos = (`getNodePos` w)
@@ -178,7 +178,7 @@ drawPathBetween w = fromMaybe mempty $ do
<> foldMap (color orange . arrow sp) (pointTowardsImpulse sp ep w)
drawWallsNearYou :: World -> Picture
drawWallsNearYou w = fromMaybe mempty $ do
drawWallsNearYou w = concat $ do
p <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
return $ setLayer DebugLayer $ foldMap f $ wlsNearPoint p w
where
@@ -195,7 +195,7 @@ drawWallsNearCursor w =
(a, b) = _wlLine wl
drawInspectWalls :: World -> Picture
drawInspectWalls w = fromMaybe mempty $ do
drawInspectWalls w = concat $ do
a <- w ^. input . clickPos . at ButtonLeft
b <- w ^. input . heldPos . at ButtonLeft
return $
@@ -215,7 +215,7 @@ drawInspectWall w wl =
(a, b) = _wlLine wl
drawDoorPaths :: World -> Int -> Picture
drawDoorPaths w drid = fromMaybe mempty $ do
drawDoorPaths w drid = concat $ do
paths <- w ^? cWorld . lWorld . doors . ix drid . drObstructs
return $ foldMap' (drawPathEdge . (^. penPathEdge)) paths
src/Dodge/DisplayInventory.hs
+1 -1
View File
@@ -62,7 +62,7 @@ updateCombineSections w cfig =
(IM.fromDistinctAscList . zip [0 ..] $ combineList w)
"COMBINATIONS"
$ w ^? hud . hudElement . subInventory . ciFilter . _Just
invitms = fromMaybe mempty $ w ^? hud . hudElement . diSections . ix 0 . ssItems
invitms = fold $ w ^? hud . hudElement . diSections . ix 0 . ssItems
regexCombs :: IM.IntMap (SelectionItem ()) -> SelectionItem CombinableItem -> String -> Bool
regexCombs inv ci str = case str of
src/Dodge/Render/HUD.hs
+28 -8
View File
@@ -66,10 +66,10 @@ drawInventory sss w cfig =
<> drawRootCursor w sss (w ^? hud . hudElement . diSelection . _Just) ldp cfig
<> iextra
<> drawMouseOver cfig w
<> translateScreenPos
cfig
(ldp ^. ldpPos)
(drawDISelections w)
-- <> translateScreenPos
-- cfig
-- (ldp ^. ldpPos)
-- (drawDISelections w)
where
ldp = invDisplayParams w
curs = invCursorParams w
@@ -111,7 +111,9 @@ getRootItemBounds i inv = do
return (x, y)
drawMouseOver :: Configuration -> World -> Picture
drawMouseOver cfig w = fromMaybe mempty $ invsel <|> combinvsel
drawMouseOver cfig w = concat (invsel <|> combinvsel
<|> drawDragSelect cfig w)
<> concat (drawDragSelected cfig w)
where
invsel = do
(j, i) <- w ^? input . mouseContext . mcoInvSelect <|>
@@ -140,15 +142,33 @@ drawMouseOver cfig w = fromMaybe mempty $ invsel <|> combinvsel
-- return ((i, j), (i, j + x))
-- _ -> Nothing
drawDISelections :: World -> Picture
drawDISelections w = fromMaybe mempty $ do
--drawDISelections :: World -> Picture
--drawDISelections w = fromMaybe mempty $
-- drawDragSelect w <|>
-- drawDragSelected w
drawDragSelected :: Configuration -> World -> Maybe Picture
drawDragSelected cfig w = do
y <- w ^? hud . hudElement . diSelectionExtra
guard $ y > 0
(i,j) <- w ^? hud . hudElement . diSelection . _Just
guard $ i == 0
sss <- w ^? hud . hudElement . diSections
let idp = invDisplayParams w
let f x = selSecDrawCursorAt 15 idp BackdropCursor sss (0, x)
return . translateScreenPos cfig (invDisplayParams w ^. ldpPos)
. color (withAlpha 0.2 white) . foldMap f $ [j .. j + y]
drawDragSelect :: Configuration -> World -> Maybe Picture
drawDragSelect cfig w = do
OverInvDragSelect (i,j) mselend <- w ^? input . mouseContext
(a,b) <- mselend
guard $ i == a
sss <- w ^? hud . hudElement . diSections
let idp = invDisplayParams w
let f x = selSecDrawCursorAt 15 idp BackdropCursor sss (i, x)
return . color (withAlpha 0.2 white) . foldMap f $ [min j b .. max j b]
return . translateScreenPos cfig (invDisplayParams w ^. ldpPos)
. color (withAlpha 0.2 white) . foldMap f $ [min j b .. max j b]
-- fromMaybe mempty $ do
-- ((i, j), (a, b)) <- getMouseInvSel w
-- guard $ i == a
src/Dodge/TestString.hs
+2 -1
View File
@@ -21,7 +21,8 @@ import Dodge.Data.Universe
import qualified IntMapHelp as IM
testStringInit :: Universe -> [String]
testStringInit _ = []
testStringInit u = [show $
u ^? uvWorld . hud . hudElement . diSelectionExtra]
-- fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . ix 0 . crInv . each . itLocation . ilIsRoot
-- , show . fmap (fmap _siPictures) $ u ^? uvWorld . hud . hudElement . diSections . ix (-1) . ssItems
-- <> [[toEnum (i+j * 32) | i <- [0..31]] | j <- [0..7]]
src/Dodge/Update.hs
+43 -72
View File
@@ -287,7 +287,7 @@ functionalUpdate u =
. over uvWorld updateRBList
. over uvWorld updateCloseObjects
. over uvWorld updateWheelEvents
. over uvWorld (updateMouseInventorySelection (u ^. uvConfig))
-- . over uvWorld (updateMouseInventorySelection (u ^. uvConfig))
. over uvWorld zoneClouds
. over uvWorld zoneCreatures
-- . over uvWorld updateInventorySelectionList
@@ -308,83 +308,54 @@ checkTermDist w = fromMaybe w $ do
--updateMouseInventoryEffects :: Configuration -> World -> World
--updateMouseInventoryEffects cfig w = w
updateMouseInventorySelection :: Configuration -> World -> World
updateMouseInventorySelection cfig w = fromMaybe w $ do
sss <- w ^? hud . hudElement . diSections
return $ updateMouseInventorySelection' sss cfig w
--updateMouseInventorySelection :: Configuration -> World -> World
--updateMouseInventorySelection cfig w = fromMaybe w $ do
-- sss <- w ^? hud . hudElement . diSections
-- return $ updateMouseInventorySelection' sss cfig w
updateMouseInventorySelection' ::
IM.IntMap (SelectionSection a) ->
Configuration ->
World ->
World
updateMouseInventorySelection' sss cfig w
| leftclickstart = w
-- case msel of
-- Nothing -> fromMaybe w $ do
-- ysel <- inverseSelSecYint (posSelSecYint cfig ldp (mpos ^. _y)) sss
-- return $
-- w & input . mouseContext
-- .~ OverInvDragSelect ysel Nothing
-- Just p -> w --startDrag p w
| leftclickheld = case w ^? input . mouseContext of
Just OverInvDragSelect{} ->
w & input . mouseContext . mcoSelEnd .~ msel
Just OverInvDrag -> fromMaybe w $ do
sel <- w ^? hud . hudElement . diSelection . _Just
x <- w ^? hud . hudElement . diSelectionExtra
return $ w & shiftInvItems sel x cfig mpos ldp sss
_ -> w
| otherwise = case w ^? input . mouseContext of
Just (OverInvDragSelect ssel (Just esel)) ->
w & input . mouseContext .~ MouseInGame
& hud . hudElement . diSelectionExtra
.~ (max (snd ssel) (snd esel) - min (snd ssel) (snd esel))
& augInvDirectSelect (min ssel esel)
_ -> w-- & hud . hudElement . subInventory . nsSelected .~ MouseInvNothing
where
leftclickstart = w ^? input . mouseButtons . ix ButtonLeft == Just 0 && nobuttonright
leftclickheld = ButtonLeft `M.member` (w ^. input . mouseButtons) && nobuttonright
nobuttonright = not $ ButtonRight `M.member` (w ^. input . mouseButtons)
mpos = w ^. input . mousePos
ldp = invDisplayParams w
msel = inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
--updateMouseInventorySelection' ::
-- IM.IntMap (SelectionSection a) ->
-- Configuration ->
-- World ->
-- World
--updateMouseInventorySelection' sss cfig w
-- | leftclickstart = w
---- case msel of
---- Nothing -> fromMaybe w $ do
---- ysel <- inverseSelSecYint (posSelSecYint cfig ldp (mpos ^. _y)) sss
---- return $
---- w & input . mouseContext
---- .~ OverInvDragSelect ysel Nothing
---- Just p -> w --startDrag p w
-- | leftclickheld = case w ^? input . mouseContext of
---- Just OverInvDragSelect{} ->
---- w & input . mouseContext . mcoSelEnd .~ msel
---- Just OverInvDrag -> fromMaybe w $ do
---- sel <- w ^? hud . hudElement . diSelection . _Just
---- x <- w ^? hud . hudElement . diSelectionExtra
---- return $ w & shiftInvItems sel x cfig mpos ldp sss
-- _ -> w
-- | otherwise = w
---- | otherwise = case w ^? input . mouseContext of
---- Just (OverInvDragSelect ssel (Just esel)) ->
---- w & input . mouseContext .~ MouseInGame
---- & hud . hudElement . diSelectionExtra
---- .~ (max (snd ssel) (snd esel) - min (snd ssel) (snd esel))
---- & augInvDirectSelect (min ssel esel)
---- _ -> w-- & hud . hudElement . subInventory . nsSelected .~ MouseInvNothing
-- where
-- leftclickstart = w ^? input . mouseButtons . ix ButtonLeft == Just 0 && nobuttonright
-- leftclickheld = ButtonLeft `M.member` (w ^. input . mouseButtons) && nobuttonright
-- nobuttonright = not $ ButtonRight `M.member` (w ^. input . mouseButtons)
-- mpos = w ^. input . mousePos
-- ldp = invDisplayParams w
-- msel = inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
shiftInvItems ::
(Int, Int) ->
Int ->
Configuration ->
Point2 ->
ListDisplayParams ->
IM.IntMap (SelectionSection a) ->
World ->
World
shiftInvItems topsel x cfig mpos ldp sss w = case inverseSelBoundaryUp cfig ldp sss mpos of
Just p | p < topsel -> shiftInvItemsUp topsel x w
_ -> case inverseSelBoundaryDown cfig ldp sss mpos of
Just p | p > (topsel & _2 +~ x) -> shiftInvItemsDown topsel x w
_ -> w
shiftInvItemsUp :: (Int, Int) -> Int -> World -> World
shiftInvItemsUp (_, i) x w = foldl' f w [i .. i + x]
where
f w' i' = swapInvItems g i' w'
g i' m = fst <$> IM.lookupLT i' m
shiftInvItemsDown :: (Int, Int) -> Int -> World -> World
shiftInvItemsDown (_, i) x w = fromMaybe w $ do
guard . isJust $
w ^? hud . hudElement . diSections . ix 0 . ssItems . ix (i + x + 1)
return $ foldl' f w $ reverse [i .. i + x]
where
f w' i' = swapInvItems g i' w'
g i' m = fst <$> IM.lookupGT i' m
updateMouseContext :: Configuration -> Universe -> Universe
updateMouseContext cfig u = case u ^. uvWorld . input . mouseContext of
OverInvDrag | lbheld -> u
OverInvDragSelect{} | lbheld -> u
OverInvDragSelect{} -> u
_ -> u & uvWorld . input . mouseContext
.~ fromMaybe
aimcontext
src/Dodge/Update/Input/InGame.hs
+60 -4
View File
@@ -3,6 +3,7 @@ module Dodge.Update.Input.InGame (
updateMouseInGame,
) where
import Data.Foldable
import Dodge.ListDisplayParams
import Control.Applicative
import Control.Monad
@@ -91,11 +92,35 @@ updateUseInputInGame u = updateFunctionKeys $ case u ^. uvWorld . hud . hudEleme
updateMouseInGame :: Configuration -> World -> World
updateMouseInGame cfig w = case w ^? input . mouseButtons . ix ButtonLeft of
Just 0 -> updateMouseClickInGame cfig w
Just _ -> updateMouseHeldInGame w
Nothing -> w
Just _ -> updateMouseHeldInGame cfig w
Nothing -> case w ^? input . mouseButtonsReleased . ix ButtonLeft of
Just 0 -> updateMouseReleaseInGame w
_ -> w
updateMouseHeldInGame :: World -> World
updateMouseHeldInGame w = w
updateMouseHeldInGame :: Configuration -> World -> World
updateMouseHeldInGame cfig w = case w ^. input . mouseContext of
OverInvDragSelect{} -> fromMaybe w $ do
sss <- w ^? hud . hudElement . diSections
let msel = inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
return $ w & input . mouseContext . mcoSelEnd .~ msel
OverInvDrag -> fromMaybe w $ do
sss <- w ^? hud . hudElement . diSections
let mpos = w ^. input . mousePos
sel <- w ^? hud . hudElement . diSelection . _Just
x <- w ^? hud . hudElement . diSelectionExtra
return $ w & shiftInvItems sel x cfig mpos ldp sss
_ -> w
where
ldp = invDisplayParams w
updateMouseReleaseInGame :: World -> World
updateMouseReleaseInGame w = case w ^. input . mouseContext of
OverInvDragSelect ssel (Just esel) ->
w & input . mouseContext .~ MouseInGame
& hud . hudElement . diSelectionExtra
.~ (max (snd ssel) (snd esel) - min (snd ssel) (snd esel))
& augInvDirectSelect (min ssel esel)
_ -> w
updateMouseClickInGame :: Configuration -> World -> World
updateMouseClickInGame cfig w = case w ^. input . mouseContext of
@@ -152,6 +177,37 @@ startDrag (a, b) w = fromMaybe (augInvDirectSelect (a, b) $ setmichosen 0 w) $ d
(input . mouseContext .~ OverInvDrag)
. (hud . hudElement . diSelectionExtra .~ x)
shiftInvItems ::
(Int, Int) ->
Int ->
Configuration ->
Point2 ->
ListDisplayParams ->
IM.IntMap (SelectionSection a) ->
World ->
World
shiftInvItems topsel x cfig mpos ldp sss w = case inverseSelBoundaryUp cfig ldp sss mpos of
Just p | p < topsel -> shiftInvItemsUp topsel x w
_ -> case inverseSelBoundaryDown cfig ldp sss mpos of
Just p | p > (topsel & _2 +~ x) -> shiftInvItemsDown topsel x w
_ -> w
shiftInvItemsUp :: (Int, Int) -> Int -> World -> World
shiftInvItemsUp (_, i) x w = foldl' f w [i .. i + x]
where
f w' i' = swapInvItems g i' w'
g i' m = fst <$> IM.lookupLT i' m
shiftInvItemsDown :: (Int, Int) -> Int -> World -> World
shiftInvItemsDown (_, i) x w = fromMaybe w $ do
guard . isJust $
w ^? hud . hudElement . diSections . ix 0 . ssItems . ix (i + x + 1)
return $ foldl' f w $ reverse [i .. i + x]
where
f w' i' = swapInvItems g i' w'
g i' m = fst <$> IM.lookupGT i' m
updateFunctionKeys :: Universe -> Universe
updateFunctionKeys u =
M.foldlWithKey'