diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs index 6546c5bca..5bdfba728 100644 --- a/src/Dodge/Data/Universe.hs +++ b/src/Dodge/Data/Universe.hs @@ -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 diff --git a/src/Dodge/Menu/Option.hs b/src/Dodge/Menu/Option.hs index 0c9f6d0e8..6dc94ba20 100644 --- a/src/Dodge/Menu/Option.hs +++ b/src/Dodge/Menu/Option.hs @@ -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 diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index ab6c87e08..97e61868b 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -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 = diff --git a/src/Dodge/SelectionList.hs b/src/Dodge/SelectionList.hs index f760c6065..fcd8f9b79 100644 --- a/src/Dodge/SelectionList.hs +++ b/src/Dodge/SelectionList.hs @@ -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 + diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 8604a1e5d..6f2c46a24 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -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