108 lines
3.9 KiB
Haskell
108 lines
3.9 KiB
Haskell
module Dodge.Update.Input.ScreenLayer (
|
|
updateUseInputOnScreen,
|
|
ldpVerticalSelection,
|
|
) where
|
|
|
|
import Data.Char
|
|
import Control.Monad
|
|
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
|
|
Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
|
|
Just 0 -> fromMaybe u $ do
|
|
i <- u ^? uvWorld . input . mouseContext . mcoMenuClick
|
|
f <- sl ^? ix i . siPayload . _1
|
|
return $ f u
|
|
_ -> case u ^. uvWorld . input . mouseButtons . at ButtonRight of
|
|
Just 0 -> fromMaybe u $ do
|
|
i <- u ^? uvWorld . input . mouseContext . mcoMenuClick
|
|
f <- sl ^? ix i . siPayload . _2
|
|
return $ f u
|
|
_ -> u
|
|
|
|
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
|
|
|
|
--menuWheelEvents :: Universe -> Universe
|
|
--menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y)))
|
|
-- where
|
|
-- y = u ^. uvWorld . input . scrollAmount
|
|
|
|
---- you probably want i to be 1 or -1
|
|
--menuWheelStep :: Int -> Universe -> Universe
|
|
--menuWheelStep i u = fromMaybe u $ do
|
|
-- sl <- u ^? uvScreenLayers . _head . scSelectionList
|
|
-- selpos <- sl ^? slSelPos . _Just
|
|
-- ymax <- fmap length (sl ^? slItems)
|
|
-- let newpos = (selpos - i) `mod` ymax
|
|
-- itm <- sl ^? slItems . ix newpos
|
|
-- let newu = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ const newpos
|
|
-- if _siIsSelectable itm
|
|
-- then Just newu
|
|
-- else Just $ menuWheelStep i newu
|
|
|
|
setSelectionListRestriction :: Configuration -> ScreenLayer -> ScreenLayer
|
|
setSelectionListRestriction cfig screen = fromMaybe screen $ do
|
|
ldps <- screen ^? scListDisplayParams
|
|
return $ screen & scAvailableLines %~ const (getAvailableListLines ldps cfig)
|