89 lines
3.1 KiB
Haskell
89 lines
3.1 KiB
Haskell
module Dodge.Update.Input.ScreenLayer (
|
|
updateUseInputOnScreen,
|
|
ldpVerticalSelection,
|
|
) where
|
|
|
|
import Control.Monad
|
|
import Data.Char
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Dodge.Data.ScreenPos
|
|
import Dodge.Data.Universe
|
|
import Dodge.Debug.Terminal
|
|
import Dodge.Menu.Option
|
|
import Dodge.SelectionList
|
|
import Dodge.Update.Input.Text
|
|
import Geometry
|
|
import LensHelp
|
|
import Linear
|
|
import SDL
|
|
|
|
updateUseInputOnScreen :: ScreenLayer -> Universe -> Universe
|
|
updateUseInputOnScreen sl = case sl of
|
|
InputScreen{} -> doInputScreenInput (sl ^. scInput)
|
|
_ -> optionScreenUpdate
|
|
|
|
doInputScreenInput :: String -> Universe -> Universe
|
|
doInputScreenInput s u =
|
|
u & doTextInputOverUniverse (uvScreenLayers . _head . scInput)
|
|
& checkEndStatus
|
|
where
|
|
ispressed = (`M.member` (u ^. uvWorld . input . pressedKeys))
|
|
checkEndStatus
|
|
| ispressed ScancodeReturn =
|
|
(uvScreenLayers %~ tail)
|
|
. applyTerminalString (words $ map toUpper s)
|
|
. (uvWorld . worldEventFlags . at InventoryChange ?~ ())
|
|
| ispressed ScancodeEscape = uvScreenLayers %~ tail
|
|
| otherwise = id
|
|
|
|
-- note mouse over handled by updateMouseContext
|
|
optionScreenUpdate :: Universe -> Universe
|
|
optionScreenUpdate u =
|
|
(uvScreenLayers . ix 0 . scDisplayTime +~ 1)
|
|
. refreshOptionsSelectionList
|
|
. optionScreenDefaultEffect
|
|
. mouseClickOptionsList
|
|
. over (uvScreenLayers . _head) (setSelectionListRestriction (u ^. uvConfig))
|
|
$ u
|
|
|
|
optionScreenDefaultEffect :: Universe -> Universe
|
|
optionScreenDefaultEffect u = fromMaybe u $ do
|
|
f <- u ^? uvScreenLayers . ix 0 . scPositionedMenuOption
|
|
ptype <- u ^. uvWorld . input . pressedKeys . at ScancodeEscape
|
|
guard $ ptype == InitialPress
|
|
(f ^? emoMenuOption . moEff) <*> return u
|
|
|
|
-- ouch this is not good
|
|
mouseClickOptionsList :: Universe -> Universe
|
|
mouseClickOptionsList u = fromMaybe u $ do
|
|
sl <- u ^? uvScreenLayers . ix 0 . scSelectionList
|
|
case u ^. uvWorld . input . mouseButtons of
|
|
mbs | mbs ^. at ButtonLeft == Just 0 -> do
|
|
i <- u ^? uvWorld . input . mouseContext . mcoMenuClick
|
|
f <- sl ^? ix i . siPayload . _1
|
|
return $ f u
|
|
mbs | mbs ^. at ButtonRight == Just 0 -> do
|
|
i <- u ^? uvWorld . input . mouseContext . mcoMenuClick
|
|
f <- sl ^? ix i . siPayload . _2
|
|
return $ f u
|
|
_ -> Nothing
|
|
|
|
ldpVerticalSelection :: Configuration -> ListDisplayParams -> Point2 -> Maybe Int
|
|
ldpVerticalSelection cfig ldp (V2 _ y)
|
|
| yupper == ylower = Just yupper
|
|
| otherwise = Nothing
|
|
where
|
|
winy = cfig ^. windowY
|
|
ygap = ldp ^. ldpVerticalGap
|
|
yoff = ygap + 20 * ldp ^. ldpScale
|
|
top :: Float
|
|
top = fromIntegral winy * (ldp ^. ldpPos . spScreenOff . _y) + ldp ^. ldpPos . spPixelOff . _y
|
|
yupper = floor $ (top - (y + ygap)) / yoff
|
|
ylower = ceiling ((top - y) / yoff) - 1
|
|
|
|
setSelectionListRestriction :: Configuration -> ScreenLayer -> ScreenLayer
|
|
setSelectionListRestriction cfig screen = fromMaybe screen $ do
|
|
ldps <- screen ^? scListDisplayParams
|
|
return $ screen & scAvailableLines %~ const (getAvailableListLines ldps cfig)
|