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

Work on menus

Browse Source
This commit is contained in:
justin
2022-11-22 10:14:25 +00:00
parent 054405244f
commit 860d63df45
13 changed files with 251 additions and 167 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appDodge/Main.hs
+13 -1
View File
@@ -80,13 +80,25 @@ firstWorldLoad theConfig = do
--return $ startNewGame $ Universe
cancontinue <- doesFileExist "saveSlot/0"
mseed <- loadSeed
let u = Universe
{ --{_uvWorld = initialWorld
_uvWorld = splashScreen
, _uvConfig = theConfig
, _preloadData = pdata
, _uvScreenLayers = []
, _uvIOEffects = return
, _uvTestString = testStringInit
, _uvSideEffects = mempty
, _uvCanContinue = cancontinue
, _uvMSeed = mseed
}
return $
Universe
{ --{_uvWorld = initialWorld
_uvWorld = splashScreen
, _uvConfig = theConfig
, _preloadData = pdata
, _uvScreenLayers = [splashMenu]
, _uvScreenLayers = [splashMenu u]
, _uvIOEffects = return
, _uvTestString = testStringInit
, _uvSideEffects = mempty
src/Dodge/Data/SelectionList.hs
+27 -1
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data.SelectionList where
import Color
import Picture.Data
@@ -13,14 +14,36 @@ data SelectionList = SelectionList
, _slScale :: Float
, _slVerticalGap :: Float
, _slItems :: [SelectionItem]
, _slShownItems :: [(SelectionItem,SelectionItemIndex)]
, _slSelPos :: Maybe Int
, _slCursorType :: CursorType
, _slWidth :: SelectionWidth
, _slLength :: Int
, _slSizeRestriction :: SelectionSizeRestriction
, _slSpecialItem :: SpecialSelectionItem
}
data SelectionItemIndex = ListedSelectionItem Int
| ScrollUpSelectionItem
| ScrollDownSelectionItem
| SpecialSelectionItem
data SpecialSelectionItem = NoSpecialSelectionItem
| BottomSelectionItem {_bottomSelectionItem :: SelectionItem}
data SelectionSizeRestriction = NoSelectionSizeRestriction
| SelectionSizeRestriction
{ _maxSelectionLines :: Int
, _overflowItemTop :: SelectionItem
, _overflowItemBottom :: SelectionItem
, _ssrType :: SSRType
}
newtype SSRType = SSRFromScreenBottom {_ssrFromScreenBottom :: Float}
data SelectionWidth = FixedSelectionWidth Int
| VariableSelectionWidth [Int]
| VariableSelectionWidth (Int -> Int)
| UseMaxSelectionItemWidth
data CursorType = NoCursor
| BorderCursor (Set CardinalPoint)
@@ -36,3 +59,6 @@ data SelectionItem = SelectionItem
makeLenses ''SelectionList
makeLenses ''SelectionItem
makeLenses ''SpecialSelectionItem
makeLenses ''SelectionSizeRestriction
makeLenses ''SSRType
src/Dodge/Data/Universe.hs
+7 -6
View File
@@ -12,6 +12,7 @@ module Dodge.Data.Universe (
module Loop.Data,
) where
import Dodge.Data.SelectionList
import Control.Lens
--import qualified Data.Map.Strict as M
import Data.Preload
@@ -21,7 +22,7 @@ import Dodge.Data.Config
import Dodge.Data.World
import Loop.Data
import Picture.Data
import SDL (Scancode)
--import SDL (Scancode)
data Universe = Universe
{ _uvWorld :: World
@@ -48,15 +49,14 @@ data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions
data ScreenLayer
= OptionScreen
{ _scTitle :: Universe -> String
{ _scTitle :: String
, _scOptions :: [MenuOption]
, _scDefaultEff :: Universe -> Universe
, _scMaybeOption :: Maybe MenuOption
, _scOptionFlag :: OptionScreenFlag
, _scOptionsOffset :: Int
, _scSelPos :: Maybe Int
, _scSelectionList :: SelectionList
}
| ColumnsScreen
{ _scTitle :: Universe -> String
{ _scTitle :: String
, _scColumns :: [(String, String)]
}
| InputScreen
@@ -94,3 +94,4 @@ makeLenses ''Universe
makeLenses ''ScreenLayer
makeLenses ''SideEffect
makeLenses ''MenuOptionDisplay
makeLenses ''MenuOption
src/Dodge/Menu.hs
+23 -23
View File
@@ -4,6 +4,7 @@ module Dodge.Menu (
splashMenu,
) where
import Dodge.Data.SelectionList
import ShortShow
import Control.Monad
import Dodge.Concurrent
@@ -24,15 +25,15 @@ import System.Clipboard
import Text.Read
import Data.Maybe
splashMenu :: ScreenLayer
splashMenu =
slTitleOptionsEff "AMNESIS" splashMenuOptions id
splashMenu :: Universe -> ScreenLayer
splashMenu u =
slTitleOptionsEff "AMNESIS" splashMenuOptions Nothing id u
& scOptionFlag .~ SplashOptions
splashMenuOptions :: [MenuOption]
splashMenuOptions =
[ Toggle ( loadSaveSlot (SaveSlotNum 0)) displaycontinue
, Toggle id (\u -> MODString $ show $ u ^? uvScreenLayers . _head . scSelPos . _Just)
, Toggle id (\u -> MODString $ show $ u ^? uvScreenLayers . _head . scSelectionList . slSelPos . _Just)
, Toggle id (\u -> MODString $ shortShow $ u ^. uvWorld . input . mousePos)
, Toggle ( startNewGameInSlot 0) (opText "NEW WITH RANDOM SEED")
, Toggle reloadLevelStart (displaywhenseed "NEW WITH LAST SEED")
@@ -49,8 +50,8 @@ splashMenuOptions =
displaywhenseed str u | isNothing (_uvMSeed u) = MODBlockedString str
| otherwise = MODString str
pauseMenu :: ScreenLayer
pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions unpause
pauseMenu :: Universe -> ScreenLayer
pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (Just "CONTINUE") unpause
pauseMenuOptions :: [MenuOption]
pauseMenuOptions =
@@ -75,8 +76,8 @@ saveQuitConc u = do
void $ writeSaveSlot (SaveSlotNum 0) u
return $ const Nothing
seedStartMenu :: String -> ScreenLayer
seedStartMenu str = slTitleOptionsEff str seedStartOptions popScreen
seedStartMenu :: String -> Universe -> ScreenLayer
seedStartMenu str = slTitleOptionsEff str seedStartOptions (Just "BACK") popScreen
seedStartOptions :: [MenuOption]
seedStartOptions =
@@ -94,11 +95,11 @@ trySeedFromClipboard u = do
(u & uvScreenLayers %~ tail)
Just i -> return $ startSeedGame 0 i u
slTitleOptions :: String -> [MenuOption] -> ScreenLayer
slTitleOptions title ops = slTitleOptionsEff title ops (popScreen . writeConfig)
slTitleOptions :: String -> [MenuOption] -> Universe -> ScreenLayer
slTitleOptions title ops = slTitleOptionsEff title ops (Just "BACK") (popScreen . writeConfig)
optionMenu :: ScreenLayer
optionMenu = slTitleOptionsEff "OPTIONS" optionsOptions popScreen
optionMenu :: Universe -> ScreenLayer
optionMenu = slTitleOptionsEff "OPTIONS" optionsOptions (Just "BACK") popScreen
optionsOptions :: [MenuOption]
optionsOptions =
@@ -106,10 +107,9 @@ optionsOptions =
, makeSubmenuOption graphicsMenu $ MODString "GRAPHICS"
, makeSubmenuOption gameplayMenu $ MODString "GAMEPLAY"
, makeSubmenuOption debugMenu $ MODString "DEBUG OPTIONS"
, Toggle popScreen $ const $ MODString "BACK"
]
debugMenu :: ScreenLayer
debugMenu :: Universe -> ScreenLayer
debugMenu =
slTitleOptions
"OPTIONS:GAMEPLAY"
@@ -117,7 +117,7 @@ debugMenu =
debugMenuOptions :: [MenuOption]
debugMenuOptions =
(map f [minBound ..] ++ [makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" id])
map f [minBound ..] ++ [makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" id]
where
f :: DebugBool -> MenuOption
f bd =
@@ -141,7 +141,7 @@ debugMenuOptions =
-- , makeBoolOption debug_cull_more_lights "CULL MORE LIGHTS"
-- ]
-- $ map Scancode [4 ..]
gameplayMenu :: ScreenLayer
gameplayMenu :: Universe -> ScreenLayer
gameplayMenu =
slTitleOptions
"OPTIONS:GAMEPLAY"
@@ -152,7 +152,7 @@ gameplayMenuOptions =
[ makeBoolOption gameplay_rotate_to_wall "ROTATE TO WALL"
]
soundMenu :: ScreenLayer
soundMenu :: Universe -> ScreenLayer
soundMenu =
slTitleOptions
"OPTIONS:VOLUME"
@@ -179,7 +179,7 @@ soundMenuOptions =
writeConfig :: Universe -> Universe
writeConfig w = w & uvIOEffects %~ saveConfig (_uvConfig w)
graphicsMenu :: ScreenLayer
graphicsMenu :: Universe -> ScreenLayer
graphicsMenu = slTitleOptions "OPTIONS:GRAPHICS" graphicsMenuOptions
graphicsMenuOptions :: [MenuOption]
@@ -190,9 +190,9 @@ graphicsMenuOptions =
, makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS"
]
gameOverMenu :: ScreenLayer
gameOverMenu =
slTitleOptionsEff "GAME OVER" pauseMenuOptions id
gameOverMenu :: Universe -> ScreenLayer
gameOverMenu u =
slTitleOptionsEff "GAME OVER" pauseMenuOptions Nothing id u
& scOptionFlag .~ GameOverOptions
-- OptionScreen
@@ -209,8 +209,8 @@ gameOverMenu =
unpause :: Universe -> Universe
unpause w = resumeSound $ w & uvScreenLayers .~ []
displayControls :: ScreenLayer
displayControls = ColumnsScreen (const "CONTROLS") listControls
displayControls :: Universe -> ScreenLayer
displayControls = const $ ColumnsScreen "CONTROLS" listControls
listControls :: [(String, String)]
listControls =
src/Dodge/Menu/Option.hs
+37 -12
View File
@@ -1,43 +1,68 @@
module Dodge.Menu.Option
where
import Dodge.ScodeToChar
--import Dodge.ScodeToChar
import Data.Maybe
import Dodge.WindowLayout
import Padding
import Picture.Base
import Dodge.Data.CardinalPoint
import Dodge.Data.SelectionList
import Dodge.Data.Universe
import qualified Data.Set as Set
import LensHelp
slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> Universe) -> ScreenLayer
slTitleOptionsEff title ops eff =
slTitleOptionsEff :: String -> [MenuOption] -> Maybe String -> (Universe -> Universe) -> Universe -> ScreenLayer
slTitleOptionsEff title ops defstr eff u =
OptionScreen
{ _scTitle = const title
{ _scTitle = title
, _scOptions = ops
, _scDefaultEff = eff
, _scMaybeOption = fmap (Toggle eff . const . MODString) defstr
, _scOptionFlag = NormalOptions
, _scOptionsOffset = 0
, _scSelPos = Just 0
, _scSelectionList = makeOptionsSelectionList (Just 0) u ops defstr
}
makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> SelectionList
makeOptionsSelectionList mselpos u mos = SelectionList
makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> Maybe String -> SelectionList
makeOptionsSelectionList mselpos u mos defstr = SelectionList
{ _slPosX = 50
, _slPosY = 50
, _slOffset = 0
, _slScale = 2
, _slVerticalGap = 30
, _slItems = optionsToSelections u mos
, _slShownItems = []
, _slSelPos = mselpos
, _slCursorType = BorderCursor (Set.fromList [North,South,West])
, _slWidth = FixedSelectionWidth 15
, _slLength = length $ optionsToSelections u mos
, _slSizeRestriction = SelectionSizeRestriction (availableMenuLines cfig) overflowit overflowit
(SSRFromScreenBottom 5)
, _slSpecialItem = fromMaybe NoSpecialSelectionItem $ do
str <- defstr
return $ BottomSelectionItem SelectionItem
{ _siPictures = [color white $ text str]
, _siHeight = 1
, _siIsSelectable = True
, _siWidth = length str
, _siColor = white
, _siOffX = 0
}
}
where
cfig = u ^. uvConfig
overflowit = SelectionItem
{ _siPictures = [text "MORE OPTIONS"]
, _siHeight = 1
, _siIsSelectable = True
, _siWidth = length "MORE OPTIONS"
, _siColor = white
, _siOffX = 0
}
optionsToSelections :: Universe -> [MenuOption] -> [SelectionItem]
optionsToSelections u ops = map colStrToSelItem colstrs
where
maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops)
colstrs = zipWith (menuOptionToString u maxOptionLength) ['A'..] ops
colstrs = map (menuOptionToString u maxOptionLength) ops
colStrToSelItem :: (Color,String) -> SelectionItem
colStrToSelItem (col,str) = SelectionItem
@@ -54,8 +79,8 @@ optionValueOffset u mo = case _moString mo u of
MODStringOption s _ -> length s
_ -> 0
menuOptionToString :: Universe -> Int -> Char -> MenuOption -> (Color, String)
menuOptionToString w padAmount char mo = (thecol, (char:":") ++ optionText)
menuOptionToString :: Universe -> Int -> MenuOption -> (Color, String)
menuOptionToString w padAmount mo = (thecol, optionText)
where
thecol = case _moString mo w of
MODBlockedString{} -> greyN 0.5
src/Dodge/Menu/PushPop.hs
+2 -2
View File
@@ -6,6 +6,6 @@ import LensHelp
popScreen :: Universe -> Universe
popScreen = uvScreenLayers %~ tail
pushScreen :: ScreenLayer -> Universe -> Universe
pushScreen ml = uvScreenLayers .:~ ml
pushScreen :: (Universe -> ScreenLayer) -> Universe -> Universe
pushScreen ml u = u & uvScreenLayers .:~ ml u
src/Dodge/Render/HUD.hs
+14 -6
View File
@@ -1,6 +1,6 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Render.HUD (
hudDrawings,
drawHUD,
) where
import Dodge.Data.CardinalPoint
@@ -29,12 +29,12 @@ import Picture
import SDL (MouseButton (..))
import qualified Data.Set as Set
hudDrawings :: Universe -> Picture
hudDrawings uv = case w ^. cWorld . lWorld . hud . hudElement of
drawHUD :: Universe -> Picture
drawHUD uv = case w ^. cWorld . lWorld . hud . hudElement of
DisplayCarte -> drawCarte cfig w
DisplayInventory subinv ->
drawInGameHUD subinv uv
<> subInventoryDisplay subinv cfig w
<> drawSubInventory subinv cfig w
where
w = _uvWorld uv
cfig = _uvConfig uv
@@ -58,9 +58,13 @@ defaultSelectionList = SelectionList
, _slPosY = 0
, _slOffset = 0
, _slItems = []
, _slShownItems = []
, _slSelPos = Nothing
, _slCursorType = NoCursor
, _slWidth = FixedSelectionWidth 15
, _slLength = 0
, _slSizeRestriction = NoSelectionSizeRestriction
, _slSpecialItem = NoSpecialSelectionItem
}
subInvSelectionList :: SelectionList
@@ -71,9 +75,13 @@ subInvSelectionList = SelectionList
, _slPosY = 60
, _slOffset = 0
, _slItems = []
, _slShownItems = []
, _slSelPos = Nothing
, _slCursorType = NoCursor
, _slWidth = FixedSelectionWidth 15
, _slLength = 0
, _slSizeRestriction = NoSelectionSizeRestriction
, _slSpecialItem = NoSpecialSelectionItem
}
inventorySelectionList :: World -> [SelectionItem]
@@ -107,8 +115,8 @@ inventoryDisplay subinv cfig w = drawSelectionList cfig $
| ButtonRight `M.member` _mouseButtons (_input w) = [North,South,East,West]
| otherwise = [North,South,West]
subInventoryDisplay :: SubInventory -> Configuration -> World -> Picture
subInventoryDisplay subinv cfig w = case subinv of
drawSubInventory :: SubInventory -> Configuration -> World -> Picture
drawSubInventory subinv cfig w = case subinv of
LockedInventory -> mempty -- topInvCursor col cursPos cfig w
NoSubInventory ->
pictures
src/Dodge/Render/List.hs
+9 -2
View File
@@ -1,5 +1,6 @@
module Dodge.Render.List where
--import LensHelp
import Data.Foldable
import Data.Maybe
import Data.Set (Set)
@@ -12,6 +13,7 @@ import Dodge.Data.SelectionList
import Geometry
import ListHelp
import Picture
import LensHelp
drawSelectionList :: Configuration -> SelectionList -> Picture
drawSelectionList cfig sl =
@@ -22,13 +24,18 @@ drawSelectionList cfig sl =
(_slPosY sl)
cfig
(_slOffset sl)
(concatMap _siPictures (_slItems sl))
(makeSelectionListPictures sl)
<> drawSelectionCursor cfig sl
makeSelectionListPictures :: SelectionList -> [Picture]
makeSelectionListPictures sl = case sl ^. slSizeRestriction of
SelectionSizeRestriction {} -> concatMap (_siPictures . fst) $ _slShownItems sl
_ -> concatMap _siPictures $ _slItems sl
drawSelectionCursor :: Configuration -> SelectionList -> Picture
drawSelectionCursor cfig sl = fromMaybe mempty $ do
i <- _slSelPos sl
selit <- (filter _siIsSelectable lis) !? i
selit <- filter _siIsSelectable lis !? i
f <- case _slCursorType sl of
BorderCursor cps -> Just $ listCursorChooseBorderScale (_slVerticalGap sl) (_slScale sl) cps
NoCursor -> Nothing
src/Dodge/Render/MenuScreen.hs
+53 -81
View File
@@ -4,33 +4,32 @@ module Dodge.Render.MenuScreen (
menuScreen',
) where
import Dodge.Menu.Option
import Dodge.Render.List
--import LensHelp
import Dodge.Base.WinScale
import Dodge.Data.SelectionList
--import Dodge.Menu.Option
import Dodge.Render.List
import qualified Data.Text as T
import Dodge.Base.Window
import Dodge.Data.Universe
import Dodge.WindowLayout
import Padding
import Picture
menuScreen' :: Universe -> ScreenLayer -> Picture
menuScreen' w screen = case screen of
OptionScreen{_scTitle = titf, _scOptions = mos, _scOptionsOffset = off, _scSelPos = selpos} ->
drawOptions w (titf w) mos off selpos "Use keys to navigate the menu"
menuScreen' :: Configuration -> ScreenLayer -> Picture
menuScreen' cfig screen = case screen of
OptionScreen{_scTitle = titf, _scSelectionList = selpos} ->
drawOptions cfig titf selpos "Use keys to navigate the menu"
-- (WaitScreen sf _) -> drawOptions w (sf w) [] 0 ""
(InputScreen inputstr help) -> drawOptions w ('>' : T.unpack inputstr) [] 0 Nothing help
(InputScreen inputstr help) -> drawInputMenu cfig ('>' : T.unpack inputstr) help
-- (DisplayScreen sd) -> sd w
(ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_uvConfig w) (titf w) pairs
(ColumnsScreen titf pairs) -> drawTwoColumnsScreen cfig titf pairs
menuScreen :: Universe -> ScreenLayer -> Picture
menuScreen w screen = case screen of
OptionScreen{_scTitle = titf, _scOptions = mos, _scOptionsOffset = off, _scSelPos = selpos} ->
drawOptions w (titf w) mos off selpos "Use keys to navigate the menu"
-- (WaitScreen sf _) -> drawOptions w (sf w) [] 0 ""
(InputScreen inputstr help) -> drawOptions w ('>' : T.unpack inputstr) [] 0 Nothing help
-- (DisplayScreen sd) -> sd w
(ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_uvConfig w) (titf w) pairs
menuScreen :: Configuration -> ScreenLayer -> Picture
menuScreen cfig screen = case screen of
OptionScreen{_scTitle = titf, _scSelectionList = selpos} ->
drawOptions cfig titf selpos "Use keys to navigate the menu"
(InputScreen inputstr help) -> drawInputMenu cfig ('>' : T.unpack inputstr) help
(ColumnsScreen titf pairs) -> drawTwoColumnsScreen cfig titf pairs
--displayStringList :: World -> [String] -> Picture
--displayStringList w ss = pictures
@@ -51,81 +50,65 @@ drawTwoColumnsScreen cfig title lps =
]
drawTwoColumns :: Configuration -> [(String, String)] -> Picture
drawTwoColumns cfig lps = pictures $ zipWith f [hh -100, hh -130 ..] lps
drawTwoColumns cfig lps = listPicturesAtScaleOff 30 2 50 50 cfig 0 $ map f lps
where
f y (s1, s2) = placeString (50 - hw) y 0.15 $ rightPad ln '.' s1 ++ s2
hh = halfHeight cfig
hw = halfWidth cfig
f (s1, s2) = color white $ text $ rightPad ln '.' s1 ++ s2
ln = maximum (map (length . fst) lps) + 3
drawOptions ::
Universe ->
--drawTwoColumns' :: Configuration -> [(String, String)] -> Picture
--drawTwoColumns' cfig lps = pictures $ zipWith f [hh -100, hh -130 ..] lps
-- where
-- f y (s1, s2) = placeString (50 - hw) y 0.15 $ rightPad ln '.' s1 ++ s2
-- hh = halfHeight cfig
-- hw = halfWidth cfig
-- ln = maximum (map (length . fst) lps) + 3
drawInputMenu ::
Configuration ->
-- | Title
String ->
-- | Options
[MenuOption] ->
-- | Options offset
Int ->
-- | Select position
Maybe Int ->
-- | Help Text
String ->
Picture
drawOptions u title ops off mselpos footer =
pictures $
drawInputMenu cfig title footer =
pictures
[ --darkenBackground cfig
drawTitle cfig title
, drawFooterText cfig red footer
, drawSelectionList cfig (makeOptionsSelectionList mselpos u ops)
]
-- ++ zipWith
-- (\s vpos -> placeColorString (- hw + 50) vpos 0.2 s)
-- ops''
-- [hh -100, hh -150 ..]
where
-- ++ [color yellow $ concat [line [V2 (negate hw) (hh-y), V2 hw (hh-y)] |
-- y <- map (+75) [0,50..hh*2]]
-- ]
maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops')
ops' = case availableMenuLines cfig of
x | x < length ops -> take (availableMenuLines cfig) (drop off ops)
_ -> ops
ops'' = case availableMenuLines cfig of
x | x < length ops -> zipWith (menuOptionToString u maxOptionLength) ['A'..] ops' ++ [(white, "SPACE: MORE OPTIONS")]
_ -> zipWith (menuOptionToString u maxOptionLength) ['A'..] ops'
hh = halfHeight cfig
hw = halfWidth cfig
cfig = _uvConfig u
defaultSelectionItem :: SelectionItem
defaultSelectionItem = SelectionItem
{ _siPictures = [color white $ text "HELLOW"]
, _siHeight = 1
, _siIsSelectable = True
, _siColor = white
, _siOffX = 0
}
colStrToSelItem :: (Color,String) -> SelectionItem
colStrToSelItem (col,str) = SelectionItem
{ _siPictures = [color col $ text str]
, _siHeight = 1
, _siIsSelectable = True
, _siColor = col
, _siOffX = 0
}
drawOptions ::
Configuration ->
-- | Title
String ->
-- | Select position
SelectionList ->
-- | Help Text
String ->
Picture
drawOptions cfig title sl footer =
pictures
[ --darkenBackground cfig
drawTitle cfig title
, drawFooterText cfig red footer
, drawSelectionList cfig sl
]
darkenBackground :: Configuration -> Picture
darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox
drawTitle :: Configuration -> String -> Picture
drawTitle cfig = placeString (- hw + 30) (hh - 50) 0.4
drawTitle cfig = winScale cfig . translate (30 - hw) (hh-50) . scale 0.4 0.4 . text
where
hh = halfHeight cfig
hw = halfWidth cfig
--drawTitle' :: Configuration -> String -> Picture
--drawTitle' cfig = placeString (- hw + 30) (hh - 50) 0.4
-- where
-- hh = halfHeight cfig
-- hw = halfWidth cfig
placeString ::
-- | x distance from center
Float ->
@@ -137,17 +120,6 @@ placeString ::
Picture
placeString x y sc = color white . translate x y . scale sc sc . text
placeColorString ::
-- | x distance from center
Float ->
-- | y distance from center
Float ->
-- | scale
Float ->
(Color, String) ->
Picture
placeColorString x y sc (col, str) = color col . translate x y . scale sc sc . text $ str
drawFooterText :: Configuration -> Color -> String -> Picture
drawFooterText cfig col = color col . placeString (- hw + 30) (- hh + 10) 0.1
where
src/Dodge/Render/Picture.hs
+7 -7
View File
@@ -14,10 +14,10 @@ import Picture
fixedCoordPictures :: Universe -> Picture
fixedCoordPictures u =
drawConcurrentMessage u <> customMouseCursor cfig (u ^. uvWorld) <> case u ^. uvScreenLayers of
[] -> hudDrawings u
(lay : _) -> (setDepth (-1) $ menuScreen' u lay)
<> (setDepth (-1) . winScale cfig $ menuScreen u lay)
drawConcurrentMessage u <> customMouseCursor cfig (u ^. uvWorld . input) <> case u ^. uvScreenLayers of
[] -> drawHUD u
(lay : _) -> setDepth (-1) (menuScreen' cfig lay)
-- <> (setDepth (-1) . winScale cfig $ menuScreen cfig lay)
where
cfig = _uvConfig u
@@ -33,9 +33,9 @@ drawConcurrentMessage u =
f (RunningSideEffect ce) = ce ++ " IN PROGRESS"
f x = _ceString x ++ " QUEUED"
customMouseCursor :: Configuration -> World -> Picture
customMouseCursor cfig w =
customMouseCursor :: Configuration -> Input -> Picture
customMouseCursor cfig inp =
winScale cfig
. uncurryV translate (_mousePos (_input w))
. uncurryV translate (_mousePos inp)
. color white
$ pictures [line [V2 (-5) 0, V2 5 0], line [V2 0 (-5), V2 0 5]]
src/Dodge/SelectionList.hs
+16
View File
@@ -0,0 +1,16 @@
module Dodge.SelectionList where
import Dodge.Data.SelectionList
import LensHelp
setShownSelectionItems :: SelectionList -> SelectionList
setShownSelectionItems sl = case sl ^? slSizeRestriction of
Just (SelectionSizeRestriction maxlines topit botit _)
| length allitems <= maxlines -> sl & slShownItems .~ allitems
| otherwise -> if offset > 0
then sl & slShownItems .~ ((topit,ScrollUpSelectionItem) : take (maxlines - 2) (drop offset allitems))
else sl & slShownItems .~ (take (maxlines - 2) allitems ++ [(botit,ScrollDownSelectionItem)])
_ -> sl & slShownItems .~ allitems
where
offset = sl ^. slOffset
allitems = zipWith (\x y -> (x,ListedSelectionItem y)) (sl ^. slItems) [0..]
src/Dodge/Update.hs
+42 -25
View File
@@ -6,7 +6,8 @@ Description : Simulation update
-}
module Dodge.Update (updateUniverse) where
import Dodge.Menu.Option
--import Dodge.Menu.Option
import Dodge.SelectionList
import Dodge.Data.SelectionList
import Dodge.InputFocus
import Color
@@ -65,7 +66,7 @@ import SDL
import Sound.Data
import StrictHelp
import qualified Data.Text as T
import ListHelp
--import ListHelp
updateUniverse :: Universe -> Universe
updateUniverse u =
@@ -91,20 +92,24 @@ gotoTerminal w = case _uvScreenLayers w of
(InputScreen{} : _) -> w
_ -> w & uvScreenLayers .:~ InputScreen T.empty "Enter command"
mouseClickOptionsList :: [MenuOption] -> Maybe Int -> Universe -> Universe
mouseClickOptionsList mos mi u = case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
mouseClickOptionsList :: [MenuOption] -> SelectionList -> Maybe MenuOption -> Universe -> Universe
mouseClickOptionsList mos sl mop u = case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
Just False -> fromMaybe u $ do
i <- mi
mo <- mos !? i
return $ _moEff mo u
i <- sl ^. slSelPos
si <- sl ^? slShownItems . ix i . _2
return $ maybe u ($ u) $ case si of
ListedSelectionItem j -> mos ^? ix j . moEff
ScrollUpSelectionItem -> Just $ uvScreenLayers . _head . scSelectionList . slOffset %~ (min 0 . subtract 10)
ScrollDownSelectionItem -> Just $ uvScreenLayers . _head . scSelectionList . slOffset +~ 10
_ -> u
mouseOverSelectionList :: SelectionList -> Universe -> Universe
mouseOverSelectionList sl u
| x > xl && x < xr && ylower == yupper && mmoving
&& ylower >= 0 && ylower < _slLength sl = u & uvScreenLayers . _head . scSelPos ?~ yupper
&& ylower >= 0 && ylower < ymax = u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper
| otherwise = u
where
ymax = maybe 0 length $ u ^? uvScreenLayers . _head . scSelectionList . slShownItems
mmoving = u ^. uvWorld . input . mouseMoving
ylower = ceiling $ (hh - (75 + y + _slPosY sl)) / 50
yupper = floor $ (hh - (15 + y + _slPosY sl)) / 50
@@ -115,32 +120,44 @@ mouseOverSelectionList sl u
hh = halfHeight cfig
hw = halfWidth cfig
setSelectionListRestriction :: Configuration -> SelectionList -> SelectionList
setSelectionListRestriction cfig sl = sl & slSizeRestriction . maxSelectionLines %~ const nlines
where
nlines = floor ((dToBot - vgap) / itmHeight)
vgap = sl ^. slVerticalGap
itmHeight = 10 * sl ^. slScale + vgap
dToBot = cfig ^. windowY - (sl ^. slPosY + dFromScreenBot)
dFromScreenBot = fromMaybe 0 $ sl ^? slSizeRestriction . ssrType . ssrFromScreenBottom
updateUseInput :: Universe -> Universe
updateUseInput u = case u ^? uvScreenLayers . _head of
Just (InputScreen thetext _) -> doInputScreenInput thetext u
Just OptionScreen{_scOptions = mos, _scDefaultEff = defeff, _scOptionFlag = flag, _scSelPos = mselpos}
-> optionScreenUpdate mos defeff flag mselpos u
-- foldl' (\u' scode -> optionListToEffects defeff scode mos u') u (M.keys $ M.filter (== InitialPress) pkeys)
Just ColumnsScreen{} -> u & uvScreenLayers %~ tail
Just OptionScreen{_scOptions = mos, _scMaybeOption = mop, _scOptionFlag = flag, _scSelectionList = sellist}
-> optionScreenUpdate mos mop flag sellist u
-- Just ColumnsScreen{} -> u & uvScreenLayers %~ tail
_ -> case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of
Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid u-- M.foldlWithKey' (updateKeyInTerminal tmid) u pkeys
Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid u
_ -> M.foldlWithKey' updateKeyInGame u pkeys
where
pkeys = u ^. uvWorld . input . pressedKeys
optionScreenUpdate :: [MenuOption] -> (Universe -> Universe) -> OptionScreenFlag -> Maybe Int
optionScreenUpdate :: [MenuOption] -> Maybe MenuOption -> OptionScreenFlag
-> SelectionList
-> Universe -> Universe
optionScreenUpdate mos defeff _ mselpos u =
optionScreenDefEff defeff
. mouseClickOptionsList mos mselpos
. mouseOverSelectionList
(makeOptionsSelectionList mselpos u mos)
$ menuWheelEvents
optionScreenUpdate mos mop _ sl u =
optionScreenDefEff mop
. mouseClickOptionsList mos sl mop
. mouseOverSelectionList sl
. menuWheelEvents
. over (uvScreenLayers . _head . scSelectionList) (setSelectionListRestriction cfig)
$ over (uvScreenLayers . _head . scSelectionList) setShownSelectionItems
u
where
cfig = u ^. uvConfig
optionScreenDefEff :: (Universe -> Universe) -> Universe -> Universe
optionScreenDefEff :: Maybe MenuOption -> Universe -> Universe
optionScreenDefEff f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
Just InitialPress -> f u
Just InitialPress -> fromMaybe id (f ^? _Just . moEff) u
_ -> u
updateUniverseLast :: Universe -> Universe
@@ -276,9 +293,9 @@ functionalUpdate w =
$ over uvWorld updatePastWorlds w
menuWheelEvents :: Universe -> Universe
menuWheelEvents u = u & uvScreenLayers . _head . scSelPos . _Just %~ (\y' -> (y' - y) `mod` ymax)
menuWheelEvents u = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ (\y' -> (y' - y) `mod` ymax)
where
ymax = maybe 0 length (u ^? uvScreenLayers . _head . scOptions)
ymax = max 1 $ maybe 1 length (u ^? uvScreenLayers . _head . scSelectionList . slShownItems)
y = u ^. uvWorld . input . scrollAmount
updateWheelEvents :: World -> World
@@ -622,7 +639,7 @@ checkEndGame :: Universe -> Universe
checkEndGame uv = case w ^? cWorld . timeFlow . deathDelay of
Just x
| x < 0 ->
uv & uvScreenLayers .~ [gameOverMenu]
uv & uvScreenLayers .~ [gameOverMenu uv]
Just _ -> uv & uvWorld . cWorld . timeFlow . deathDelay -~ 1
_ | _crHP (you w) < 1 -> uv & uvWorld . cWorld . timeFlow .~ DeathTime 50
_ -> uv
src/Dodge/Update/Input.hs
+1 -1
View File
@@ -84,7 +84,7 @@ updateKeyInGame uv sc InitialPress = case sc of
updateKeyInGame uv _ _ = uv
pauseGame :: Universe -> Universe
pauseGame = uvScreenLayers .~ [pauseMenu]
pauseGame u = u & uvScreenLayers .~ [pauseMenu u]
spaceAction :: World -> World
spaceAction w = case w ^?! cWorld . lWorld . hud . hudElement of