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

Fix scroll selection of floor items and buttons

Browse Source
This commit is contained in:
justin
2022-12-25 23:37:42 +00:00
parent 2ae7f2bbc1
commit d2141d90ae
13 changed files with 75 additions and 126 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Combine.hs
+2 -2
View File
@@ -87,11 +87,11 @@ fullModuleName = fromMaybe "EMPTYMODULE" . moduleName
toggleCombineInv :: World -> World
toggleCombineInv w = case w ^. cWorld . lWorld . hud . hudElement of
DisplayInventory CombineInventory{} -> w & cWorld . lWorld . hud . hudElement .~ DisplayInventory NoSubInventory
DisplayInventory CombineInventory{} -> w & cWorld . lWorld . hud . hudElement . subInventory .~ NoSubInventory
_ -> w & enterCombineInv
enterCombineInv :: World -> World
enterCombineInv w = w & cWorld . lWorld . hud . hudElement .~ DisplayInventory (CombineInventory mi)
enterCombineInv w = w & cWorld . lWorld . hud . hudElement . subInventory .~ CombineInventory mi
where
mi = 0 <$ listToMaybe (combineItemListYou w)
src/Dodge/Data/HUD.hs
+2 -1
View File
@@ -13,7 +13,8 @@ import Geometry.Data
data HUDElement
= DisplayInventory
{ _subInventory :: SubInventory}
{ _subInventory :: SubInventory
}
| DisplayCarte
deriving (Eq, Ord, Show, Read) --Generic, Flat)
src/Dodge/Data/SelectionList.hs
+8 -5
View File
@@ -1,5 +1,5 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
--{-# LANGUAGE DeriveGeneric #-}
--{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data.SelectionList where
@@ -8,8 +8,8 @@ import Picture.Data
import Control.Lens
import Data.Set (Set)
import Dodge.Data.CardinalPoint
import Data.Aeson
import Data.Aeson.TH
--import Data.Aeson
--import Data.Aeson.TH
data ListDisplayParams = ListDisplayParams
{ _ldpPosX :: Float
@@ -26,6 +26,7 @@ data SelectionList a = SelectionList
, _slSelPos :: Maybe Int
, _slLength :: Int
}
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
data SelectionWidth = FixedSelectionWidth Int
| VariableSelectionWidth (Int -> Int)
@@ -43,8 +44,10 @@ data SelectionItem a = SelectionItem
, _siOffX :: Int
, _siPayload :: a
}
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
makeLenses ''ListDisplayParams
makeLenses ''SelectionList
makeLenses ''SelectionItem
deriveJSON defaultOptions ''SelectionItem
--deriveJSON defaultOptions ''SelectionItem
--deriveJSON defaultOptions ''SelectionList
src/Dodge/Default/World.hs
+1
View File
@@ -1,5 +1,6 @@
module Dodge.Default.World where
--import Dodge.Data.SelectionList
import Data.Graph.Inductive.Graph hiding ((&))
import qualified Data.Map as M
import qualified Data.Set as S
src/Dodge/Inventory.hs
+3 -7
View File
@@ -121,11 +121,7 @@ closeObjectCol e = case e of
Right _ -> yellow
selNumPos :: Int -> World -> Int
selNumPos i w = splitgap + (foldl' (+) 0 . fst $ IM.split i (augmentedInvSizes w))
where
splitgap = 0
-- | i < length (yourInv w) = 0
-- | otherwise = 1
selNumPos i w = sum . fst $ IM.split i (augmentedInvSizes w)
selNumTextPos :: Configuration -> World -> Int -> Point2
selNumTextPos cfig w i = V2 (150 - hw) (hh - (20 * fromIntegral ipos + 20))
@@ -162,7 +158,7 @@ updateTerminal = checkTermDist
checkTermDist :: World -> World
checkTermDist w = case w ^? cWorld . lWorld . hud . hudElement . subInventory . termID of
Just tmid -> fromMaybe (w & cWorld . lWorld . hud . hudElement .~ DisplayInventory NoSubInventory) $ do
Just tmid -> fromMaybe (w & cWorld . lWorld . hud . hudElement . subInventory .~ NoSubInventory) $ do
btid <- w ^? cWorld . lWorld . terminals . ix tmid . tmButtonID
btpos <- w ^? cWorld . lWorld . buttons . ix btid . btPos
if dist btpos (_crPos $ you w) < 40 then Just w else Nothing
@@ -395,4 +391,4 @@ selectedCloseObject w
inv = _crInv cr
selectNthCloseObject :: World -> Int -> Maybe (Int, Either FloorItem Button)
selectNthCloseObject w n = (length (yourInv w) + n,) <$> (_closeObjects (_lWorld (_cWorld w)) !? n)
selectNthCloseObject w n = (length (yourInv w) + n + 1,) <$> (_closeObjects (_lWorld (_cWorld w)) !? n)
src/Dodge/Render/HUD.hs
+20 -92
View File
@@ -3,6 +3,7 @@ module Dodge.Render.HUD (
drawHUD,
) where
import Dodge.Inventory.SelectionList
import Dodge.Data.CardinalPoint
import Dodge.Data.SelectionList
import Control.Lens
@@ -33,17 +34,18 @@ drawHUD :: Universe -> Picture
drawHUD uv = case w ^. cWorld . lWorld . hud . hudElement of
DisplayCarte -> drawCarte cfig w
DisplayInventory subinv ->
drawInGameHUD subinv uv
drawInGameHUD sl uv
<> drawSubInventory subinv cfig w
where
sl = makeInventorySelectionList w
w = _uvWorld uv
cfig = _uvConfig uv
drawInGameHUD :: SubInventory -> Universe -> Picture
drawInGameHUD subinv uv =
drawInGameHUD :: SelectionList () -> Universe -> Picture
drawInGameHUD sl uv =
pictures
[ winScale cfig . dShadCol white $ displayHP 0 cfig w
, inventoryDisplay subinv cfig w
, inventoryDisplay sl cfig w
]
where
w = _uvWorld uv
@@ -59,13 +61,6 @@ defaultListDisplayParams = ListDisplayParams
, _ldpWidth = FixedSelectionWidth 15
}
defaultSelectionList :: SelectionList a
defaultSelectionList = SelectionList
{_slItems = []
, _slSelPos = Nothing
, _slLength = 0
}
subInvListDisplayParams :: ListDisplayParams
subInvListDisplayParams = ListDisplayParams
{ _ldpVerticalGap = 10
@@ -83,25 +78,6 @@ subInvSelectionList = SelectionList
, _slLength = 0
}
inventorySelectionList :: World -> [SelectionItem ()]
inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv)
++ [SelectionItem displayFreeSlots 1 True (length thetext) invDimColor 2 ()]
++ map (closeObjectToSelectionItem nfreeslots) (w ^. cWorld . lWorld . closeObjects)
where
cr = you w
inv = _crInv cr
nfreeslots = crNumFreeSlots cr
thetext = case nfreeslots of
0 -> " INVENTORY FULL"
1 -> " +1 FREE SLOT"
x -> " +" ++ show x ++ " FREE SLOTS"
displayFreeSlots = [color invDimColor $ text thetext]
inventoryCursorPos :: SubInventory -> World -> Maybe Int
inventoryCursorPos subinv w = case subinv of
CombineInventory {} -> Nothing
_ -> Just $ yourInvSel w
invDisplayParams :: World -> ListDisplayParams
invDisplayParams w = defaultListDisplayParams
& ldpWidth .~ FixedSelectionWidth topInvW
@@ -112,10 +88,8 @@ invDisplayParams w = defaultListDisplayParams
| ButtonRight `M.member` _mouseButtons (_input w) = [North,South,East,West]
| otherwise = [North,South,West]
inventoryDisplay :: SubInventory -> Configuration -> World -> Picture
inventoryDisplay subinv cfig w = drawSelectionList (invDisplayParams w) cfig $
defaultSelectionList & slItems .~ inventorySelectionList w
& slSelPos .~ inventoryCursorPos subinv w
inventoryDisplay :: SelectionList () -> Configuration -> World -> Picture
inventoryDisplay sl cfig w = drawSelectionList (invDisplayParams w) cfig sl
drawSubInventory :: SubInventory -> Configuration -> World -> Picture
drawSubInventory subinv cfig w = case subinv of
@@ -171,15 +145,16 @@ drawSubInventory subinv cfig w = case subinv of
extrapics
closeobjectcursor = case selectedCloseObject w of
Nothing -> mempty
Just (i, co) ->
listCursorNS
clObjFloatIn
0
cfig
(selNumPos i w)
(closeObjectCol co)
topInvW
(invSelSize i w)
Just (i,co) -> drawCursorAt (invDisplayParams w & ldpCursorType .~ BorderCursor (Set.fromList [North,South])) cfig (Just i) (inventorySelectionList w)
-- Just (i, co) ->
-- listCursorNS
-- clObjFloatIn
-- 0
-- cfig
-- (selNumPos i w)
-- (closeObjectCol co)
-- topInvW
-- (invSelSize i w)
itcol = fromMaybe (greyN 0.5) (it ^? _Just . itInvColor)
cr = you w
it = yourItem w
@@ -356,38 +331,8 @@ invHead cfig s =
$ text s
closeObjectToSelectionItem :: Int -> Either FloorItem Button -> SelectionItem ()
closeObjectToSelectionItem n e = SelectionItem
{ _siPictures = pics
, _siHeight = length pics
, _siIsSelectable = True
, _siWidth = 15
, _siColor = col
, _siOffX = 2
, _siPayload = ()
}
where
(pics,col) = closeObjectToTextPictures' n e
closeObjectToTextPictures' :: Int -> Either FloorItem Button -> ([Picture],Color)
closeObjectToTextPictures' nfreeslots e = case e of
Left flit -> let it = _flIt flit
in (map (applycolor it . textindent) $ itemDisplay it, thecol it)
Right bt -> ([color yellow $ textindent $ _btText bt], yellow)
where
textindent = text . (replicate clObjIntIn ' ' ++)
applycolor it
| nfreeslots >= itSlotsTaken it = color $ _itInvColor it
| otherwise = color invDimColor
thecol it
| nfreeslots >= itSlotsTaken it = _itInvColor it
| otherwise = invDimColor
clObjIntIn :: Int
clObjIntIn = 2
clObjFloatIn :: Float
clObjFloatIn = fromIntegral clObjIntIn * 9
--clObjFloatIn :: Float
--clObjFloatIn = fromIntegral clObjIntIn * 9
drawCarte :: Configuration -> World -> Picture
drawCarte cfig w =
@@ -475,23 +420,6 @@ picsToSelectable wdth pics = SelectionItem
textSelItems :: [String] -> [SelectionItem ()]
textSelItems = map (picsToSelectable 15 . (:[]) . text)
invSelectionItem :: Creature -> (Int,Item) -> SelectionItem ()
invSelectionItem cr (i,it) = SelectionItem
{ _siPictures = pics
, _siHeight = length pics
, _siIsSelectable = True
, _siWidth = 15
, _siColor = col
, _siOffX = 0
, _siPayload = ()
}
where
col = _itInvColor it
pics = take (itSlotsTaken it) . (++ replicate 10 (color col $ text "*")) $ case _itCurseStatus it of
UndroppableIdentified -> map (color yellow . text) (itemDisplay it)
_ | crSel cr == i -> map (color col . text) (selectedItemDisplay cr it)
_ -> map (color col . text) (itemDisplay it)
itemText :: Item -> [Picture]
{-# INLINE itemText #-}
itemText it = f $ case _itCurseStatus it of
src/Dodge/Render/List.hs
+8 -5
View File
@@ -12,7 +12,7 @@ import Dodge.Data.SelectionList
import Geometry
import ListHelp
import Picture
--import LensHelp
import LensHelp
drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
drawSelectionList ldps cfig sl =
@@ -32,9 +32,10 @@ makeSelectionListPictures sl = concatMap _siPictures $ _slItems sl
-- SelectionSizeRestriction {} -> concatMap (_siPictures . fst) $ _slShownItems sl
-- _ -> concatMap _siPictures $ _slItems sl
drawSelectionCursor :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
drawSelectionCursor ldps cfig sl = fromMaybe mempty $ do
i <- _slSelPos sl
drawCursorAt :: ListDisplayParams -> Configuration -> Maybe Int -> [SelectionItem a] -> Picture
drawCursorAt ldps cfig mi lis = fromMaybe mempty $ do
i <- mi
selit <- lis !? i
f <- case _ldpCursorType ldps of
BorderCursor cps -> Just $ listCursorChooseBorderScale (_ldpVerticalGap ldps) (_ldpScale ldps) cps
@@ -43,11 +44,13 @@ drawSelectionCursor ldps cfig sl = fromMaybe mempty $ do
col = _siColor selit
return $ f (_ldpPosX ldps + (9 * fromIntegral (_siOffX selit))) (_ldpPosY ldps) cfig j col wdth (_siHeight selit)
where
lis = _slItems sl
wdth = case _ldpWidth ldps of
FixedSelectionWidth x -> x
_ -> 1
drawSelectionCursor :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
drawSelectionCursor ldps cfig sl = drawCursorAt ldps cfig (sl ^. slSelPos) (sl ^. slItems)
-- given a list of pictures that are each the size of a "text" call, displays them as
-- a list on the screen
listPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture
src/Dodge/SelectionList.hs
+7
View File
@@ -15,3 +15,10 @@ getAvailableListLines ldps cfig = nlines
dToBot = cfig ^. windowY - (ldps ^. ldpPosY + dFromScreenBot)
dFromScreenBot = 5 -- fromMaybe 0 $ sl ^? slSizeRestriction . ssrType . ssrFromScreenBottom
defaultSelectionList :: SelectionList a
defaultSelectionList = SelectionList
{_slItems = []
, _slSelPos = Nothing
, _slLength = 0
}
src/Dodge/TestString.hs
+9 -7
View File
@@ -3,13 +3,15 @@ module Dodge.TestString where
import Control.Lens
import Dodge.Data.Universe
--import Data.Maybe
import ShortShow
import qualified Data.Map.Strict as M
--import ShortShow
--import qualified Data.Map.Strict as M
import qualified IntMapHelp as IM
testStringInit :: Universe -> [String]
testStringInit u =
[ show $ u ^? uvScreenLayers . _head . scOffset
]
++ [ shortShow $ u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crPos
]
++ map show (M.toList (u ^. uvWorld . input . pressedKeys))
[ show $ IM.keys $ u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crInv ]
-- [ show $ u ^? uvScreenLayers . _head . scOffset
-- ]
-- ++ [ shortShow $ u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crPos
-- ]
-- ++ map show (M.toList (u ^. uvWorld . input . pressedKeys))
src/Dodge/Update.hs
+6
View File
@@ -6,6 +6,7 @@ Description : Simulation update
-}
module Dodge.Update (updateUniverse) where
--import Dodge.Inventory.SelectionList
import Color
import Control.Applicative
import Data.List
@@ -293,8 +294,13 @@ functionalUpdate w =
. over uvWorld updateRBList
. over uvWorld updateCloseObjects
. over uvWorld updateWheelEvents
-- . over uvWorld updateInventorySelectionList
$ over uvWorld updatePastWorlds w
--updateInventorySelectionList :: World -> World
--updateInventorySelectionList w = w
-- & cWorld . lWorld . hud . hudElement . augmentedInventory .~ makeInventorySelectionList w
-- this can probably be unified with updateWheelEvents
menuWheelEvents :: Universe -> Universe
menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y)))
src/Dodge/Update/Input.hs
+7 -5
View File
@@ -4,6 +4,8 @@ module Dodge.Update.Input
, doInputScreenInput
) where
--import Dodge.Inventory.SelectionList
--import Dodge.Render.HUD
import Dodge.Terminal.LeftButton
import Dodge.Save
import Dodge.Debug.Terminal
@@ -93,8 +95,8 @@ spaceAction w = case w ^?! cWorld . lWorld . hud . hudElement of
Just (_, Left flit) -> pickUpItem 0 flit w
Just (_, Right but) -> doButtonEvent (_btEvent but) but w
_ -> w
DisplayInventory DisplayTerminal{} -> w & cWorld . lWorld . hud . hudElement .~ DisplayInventory NoSubInventory
_ -> w & cWorld . lWorld . hud . hudElement .~ DisplayInventory NoSubInventory
DisplayInventory DisplayTerminal{} -> w & cWorld . lWorld . hud . hudElement . subInventory .~ NoSubInventory
_ -> w & cWorld . lWorld . hud . hudElement . subInventory .~ NoSubInventory
where
--theLoc = doWorldPos (fst (_seenLocations (_cWorld w) IM.! _selLocation (_cWorld w))) w
theLoc = doWorldPos (w ^?! cWorld . lWorld . seenLocations . ix (w ^. cWorld . lWorld . selLocation) . _1) w
@@ -106,10 +108,10 @@ toggleMap w = case w ^?! cWorld . lWorld . hud . hudElement of
toggleTweakInv :: World -> World
toggleTweakInv w = case w ^. cWorld . lWorld . hud . hudElement of
DisplayInventory TweakInventory{} -> w & thepointer .~ DisplayInventory NoSubInventory
_ -> w & thepointer .~ DisplayInventory (TweakInventory mi)
DisplayInventory TweakInventory{} -> w & thepointer .~ NoSubInventory
_ -> w & thepointer .~ TweakInventory mi
where
thepointer = cWorld . lWorld . hud . hudElement
thepointer = cWorld . lWorld . hud . hudElement . subInventory
mi = 0 <$ (yourItem w >>= (^? itTweaks . tweakParams . ix 0))
toggleInspectInv :: HUDElement -> HUDElement
src/Dodge/Update/UsingInput.hs
+1 -1
View File
@@ -47,7 +47,7 @@ pressedMBEffects subinv pkeys w = case subinv of
where
maybeexitcombine
| ButtonRight `M.member` _mouseButtons (_input w) = id
| otherwise = cWorld . lWorld . hud . hudElement .~ DisplayInventory NoSubInventory
| otherwise = cWorld . lWorld . hud . hudElement . subInventory .~ NoSubInventory
pressedMBEffectsNoInventory :: M.Map MouseButton Bool -> World -> World
pressedMBEffectsNoInventory pkeys w
src/Dodge/WorldEffect.hs
+1 -1
View File
@@ -44,7 +44,7 @@ accessTerminal :: Maybe Int -> World -> World
accessTerminal mtmid w = case mtmid of
Nothing -> w
Just tmid ->
w & cWorld . lWorld . hud . hudElement .~ DisplayInventory (DisplayTerminal tmid)
w & cWorld . lWorld . hud . hudElement . subInventory .~ DisplayTerminal tmid
& cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus .~ True
& cWorld . lWorld . terminals . ix tmid %~ tryToBoot
where