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

Work on selection lists and option menus

Browse Source
This commit is contained in:
justin
2022-12-23 22:43:30 +00:00
parent b072dc9e9a
commit 5356d21778
5 changed files with 49 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Universe.hs
+7 -1
View File
@@ -48,12 +48,17 @@ data SideEffect
data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions
deriving (Eq, Ord, Show, Read) --Generic, Flat)
data PositionedMenuOption
= BottomMenuOption { _pmoMenuOption :: MenuOption }
| TopMenuOption { _pmoMenuOption :: MenuOption }
| NoPositionedMenuOption
data ScreenLayer
= OptionScreen
{ _scTitle :: String
, _scOptions :: [MenuOption]
, _scOffset :: Int
, _scMaybeOption :: Maybe MenuOption
, _scPositionedMenuOption :: PositionedMenuOption
, _scOptionFlag :: OptionScreenFlag
, _scSelectionList :: SelectionList
, _scAvailableLines :: Int
@@ -100,3 +105,4 @@ makeLenses ''ScreenLayer
makeLenses ''SideEffect
makeLenses ''MenuOptionDisplay
makeLenses ''MenuOption
makeLenses ''PositionedMenuOption
src/Dodge/Menu/Option.hs
+25 -14
View File
@@ -3,6 +3,7 @@ module Dodge.Menu.Option
--import Dodge.ScodeToChar
--import Data.Maybe
--import Dodge.WindowLayout
import Dodge.SelectionList
import Padding
import Picture.Base
import Dodge.Data.CardinalPoint
@@ -11,18 +12,8 @@ import Dodge.Data.Universe
import qualified Data.Set as Set
import LensHelp
initializeOptionMenu :: String -> [MenuOption] -> Maybe String -> (Universe -> Universe) -> Universe -> ScreenLayer
initializeOptionMenu title ops defstr eff u =
OptionScreen
{ _scTitle = title
, _scOptions = ops
, _scOffset = 0
, _scMaybeOption = fmap (Toggle eff . const . MODString) defstr
, _scOptionFlag = NormalOptions
, _scSelectionList = makeOptionsSelectionList 10 (Just 0) u ops
, _scAvailableLines = 10
, _scShownItems = []
, _scListDisplayParams = ListDisplayParams
optionListDisplayParams :: ListDisplayParams
optionListDisplayParams = ListDisplayParams
{ _ldpPosX = 50
, _ldpPosY = 50
, _ldpScale = 2
@@ -31,7 +22,6 @@ initializeOptionMenu title ops defstr eff u =
, _ldpSizeRestriction = SelectionSizeRestriction overflowit
, _ldpCursorType = BorderCursor (Set.fromList [North,South,West])
}
}
where
overflowit = SelectionItem
{ _siPictures = [text "MORE OPTIONS"]
@@ -42,6 +32,22 @@ initializeOptionMenu title ops defstr eff u =
, _siOffX = 0
}
initializeOptionMenu :: String -> [MenuOption] -> Maybe String -> (Universe -> Universe) -> Universe -> ScreenLayer
initializeOptionMenu title ops defstr eff u =
OptionScreen
{ _scTitle = title
, _scOptions = ops
, _scOffset = 0
, _scPositionedMenuOption = case defstr of
Nothing -> NoPositionedMenuOption
Just str -> BottomMenuOption $ (Toggle eff . const . MODString) str
, _scOptionFlag = NormalOptions
, _scSelectionList = makeOptionsSelectionList 10 (Just 0) u ops
, _scAvailableLines = getAvailableListLines optionListDisplayParams (u ^. uvConfig)
, _scShownItems = []
, _scListDisplayParams = optionListDisplayParams
}
refreshOptionsSelectionList :: Universe -> Universe
refreshOptionsSelectionList u = u & uvScreenLayers . ix 0 %~ f
where
@@ -61,9 +67,14 @@ makeOptionsSelectionList maxlines mselpos u mos = SelectionList
optionsToSelections :: Int -> Universe -> [MenuOption] -> [SelectionItem]
optionsToSelections maxlines u allops = map colStrToSelItem colstrs
where
ops = take maxlines allops
ops | maxlines >= length allops = allops
| otherwise = take (maxlines - 1) allops ++ [cycleOptionsOption]
maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops)
colstrs = map (menuOptionToString u maxOptionLength) ops
cycleOptionsOption = Toggle cycleOptions (const (MODString "MORE OPTIONS"))
cycleOptions :: Universe -> Universe
cycleOptions = id
colStrToSelItem :: (Color,String) -> SelectionItem
colStrToSelItem (col,str) = SelectionItem
src/Dodge/Render/List.hs
+1 -2
View File
@@ -1,6 +1,5 @@
module Dodge.Render.List where
--import LensHelp
import Data.Foldable
import Data.Maybe
import Data.Set (Set)
@@ -13,7 +12,7 @@ import Dodge.Data.SelectionList
import Geometry
import ListHelp
import Picture
import LensHelp
--import LensHelp
drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList -> Picture
drawSelectionList ldps cfig sl =
src/Dodge/SelectionList.hs
+10
View File
@@ -24,3 +24,13 @@ setShownSelectionItems' maxlines offset sl = case sl ^? scListDisplayParams . ld
where
-- dummyitem = (SelectionItem [] 1 False 0 white 0, DummySelectionItem)
allitems = zipWith (\x y -> (x,ListedSelectionItem y)) (sl ^. scSelectionList . slItems) [0..]
getAvailableListLines :: ListDisplayParams -> Configuration -> Int
getAvailableListLines ldps cfig = nlines
where
nlines = floor ((dToBot - vgap) / itmHeight)
vgap = ldps ^. ldpVerticalGap
itmHeight = 10 * ldps ^. ldpScale + vgap
dToBot = cfig ^. windowY - (ldps ^. ldpPosY + dFromScreenBot)
dFromScreenBot = 5 -- fromMaybe 0 $ sl ^? slSizeRestriction . ssrType . ssrFromScreenBottom
src/Dodge/Update.hs
+6 -16
View File
@@ -115,7 +115,7 @@ mouseOverSelectionList ldps sl u
&& ylower >= 0 && ylower < ymax = u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper
| otherwise = u
where
ymax = maybe 0 length $ u ^? uvScreenLayers . _head . scSelectionList . slItems
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
@@ -128,23 +128,13 @@ mouseOverSelectionList ldps sl u
setSelectionListRestriction' :: Configuration -> ScreenLayer -> ScreenLayer
setSelectionListRestriction' cfig screen = fromMaybe screen $ do
sl <- screen ^? scSelectionList
ldps <- screen ^? scListDisplayParams
return $ screen & scAvailableLines %~ const (setSelectionListRestriction ldps cfig sl)
setSelectionListRestriction :: ListDisplayParams -> Configuration -> SelectionList -> Int
setSelectionListRestriction ldps cfig sl = nlines
where
nlines = floor ((dToBot - vgap) / itmHeight)
vgap = ldps ^. ldpVerticalGap
itmHeight = 10 * ldps ^. ldpScale + vgap
dToBot = cfig ^. windowY - (ldps ^. ldpPosY + dFromScreenBot)
dFromScreenBot = 5 -- fromMaybe 0 $ sl ^? slSizeRestriction . ssrType . ssrFromScreenBottom
return $ screen & scAvailableLines %~ const (getAvailableListLines ldps cfig)
updateUseInput :: Universe -> Universe
updateUseInput u = case u ^? uvScreenLayers . _head of
Just (InputScreen thetext _) -> doInputScreenInput thetext u
Just screen@OptionScreen{_scOptions = mos, _scMaybeOption = mop, _scOptionFlag = flag, _scSelectionList = sellist, _scListDisplayParams = ldps}
Just screen@OptionScreen{_scOptions = mos, _scPositionedMenuOption = mop, _scOptionFlag = flag, _scSelectionList = sellist, _scListDisplayParams = ldps}
-> optionScreenUpdate screen mos mop flag ldps sellist u
-- Just ColumnsScreen{} -> u & uvScreenLayers %~ tail
_ -> case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of
@@ -153,7 +143,7 @@ updateUseInput u = case u ^? uvScreenLayers . _head of
where
pkeys = u ^. uvWorld . input . pressedKeys
optionScreenUpdate :: ScreenLayer -> [MenuOption] -> Maybe MenuOption -> OptionScreenFlag
optionScreenUpdate :: ScreenLayer -> [MenuOption] -> PositionedMenuOption -> OptionScreenFlag
-> ListDisplayParams
-> SelectionList
-> Universe -> Universe
@@ -168,9 +158,9 @@ optionScreenUpdate screen mos mop _ ldps sl u =
where
cfig = u ^. uvConfig
optionScreenDefEff :: Maybe MenuOption -> Universe -> Universe
optionScreenDefEff :: PositionedMenuOption -> Universe -> Universe
optionScreenDefEff f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
Just InitialPress -> fromMaybe id (f ^? _Just . moEff) u
Just InitialPress -> fromMaybe id (f ^? pmoMenuOption . moEff) u
_ -> u
updateUniverseLast :: Universe -> Universe