120 lines
3.9 KiB
Haskell
120 lines
3.9 KiB
Haskell
{- The menu picture. -}
|
|
module Dodge.Render.MenuScreen
|
|
( menuScreen
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.WindowLayout
|
|
import Dodge.Base.Window
|
|
import Picture
|
|
import Dodge.Menu
|
|
import Padding
|
|
|
|
import qualified Data.Text as T
|
|
|
|
menuScreen :: Universe -> ScreenLayer -> Picture
|
|
menuScreen w screen = case screen of
|
|
OptionScreen {_scTitle = titf, _scOptions = mos, _scOptionsOffset = off}
|
|
-> drawOptions w (titf w) mos off "Use keys to navigate the menu"
|
|
(WaitScreen sf _) -> drawOptions w (sf w) [] 0 ""
|
|
(InputScreen inputstr help) -> drawOptions w ('>':T.unpack inputstr) [] 0 help
|
|
(DisplayScreen sd ) -> sd w
|
|
(ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_config w) (titf w) pairs
|
|
|
|
--displayStringList :: World -> [String] -> Picture
|
|
--displayStringList w ss = pictures
|
|
-- ( polygon (screenBox w)
|
|
-- : zipWith f ys ss
|
|
-- )
|
|
-- where
|
|
-- hw = halfWidth w
|
|
-- ys = [0,22..]
|
|
-- f y s = translate (10-hw) y . scale 0.15 0.15 $ text s
|
|
|
|
drawTwoColumnsScreen :: Configuration -> String -> [(String,String)] -> Picture
|
|
drawTwoColumnsScreen cfig title lps = pictures
|
|
[darkenBackground cfig
|
|
,drawTitle cfig title
|
|
,drawTwoColumns cfig lps
|
|
]
|
|
|
|
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
|
|
|
|
drawOptions
|
|
:: Universe
|
|
-> String -- ^ Title
|
|
-> [MenuOption] -- ^ Options
|
|
-> Int -- ^ Options offset
|
|
-> String -- ^ Help Text
|
|
-> Picture
|
|
drawOptions u title ops off footer = pictures $
|
|
[ darkenBackground cfig
|
|
, drawTitle cfig title
|
|
, drawFooterText cfig red footer
|
|
] ++
|
|
zipWith (\s vpos -> placeString (-hw + 50) vpos 0.2 s)
|
|
ops''
|
|
[hh-100,hh-150 ..]
|
|
-- ++ [color yellow $ concat [line [V2 (negate hw) (hh-y), V2 hw (hh-y)] |
|
|
-- y <- map (+75) [0,50..hh*2]]
|
|
-- ]
|
|
where
|
|
maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops')
|
|
ops' = case availableMenuLines cfig of
|
|
x | x < length ops -> take (availableMenuLines cfig) (drop off visibleops)
|
|
_ -> visibleops
|
|
ops'' = case availableMenuLines cfig of
|
|
x | x < length ops -> map (menuOptionToString u maxOptionLength) ops' ++ ["SPACE: MORE OPTIONS"]
|
|
_ -> map (menuOptionToString u maxOptionLength) ops'
|
|
visibleops = filter notInvisible ops
|
|
notInvisible InvisibleToggle {} = False
|
|
notInvisible _ = True
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
cfig = _config u
|
|
|
|
optionValueOffset :: Universe -> MenuOption -> Int
|
|
optionValueOffset u mo = case _moString mo u of
|
|
Left _ -> 0
|
|
Right (s,_) -> length s
|
|
|
|
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
|
|
where
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
|
|
placeString
|
|
:: Float -- | x distance from center
|
|
-> Float -- | y distance from center
|
|
-> Float -- | scale
|
|
-> String
|
|
-> Picture
|
|
placeString x y sc = color white . translate x y . scale sc sc . text
|
|
|
|
drawFooterText :: Configuration -> Color -> String -> Picture
|
|
drawFooterText cfig col = color col . placeString (-hw + 30) (-hh+10) 0.1
|
|
where
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
|
|
menuOptionToString :: Universe -> Int -> MenuOption -> String
|
|
menuOptionToString w padAmount mo = theKeys ++ optionText
|
|
where
|
|
optionText = case _moString mo w of
|
|
Left s -> s
|
|
Right (s,t) -> rightPad padAmount '.' s ++ t
|
|
theKeys = case mo of
|
|
Toggle {_moKey = k} -> stc k : ":"
|
|
Toggle2 {_moKey1 = k1, _moKey2 = k2} -> stc k1 : '/' : stc k2 : ":"
|
|
_ -> undefined
|
|
stc = scodeToChar
|