126 lines
4.3 KiB
Haskell
126 lines
4.3 KiB
Haskell
module Dodge.Update.Input.ScreenLayer (
|
|
updateUseInputOnScreen,
|
|
) where
|
|
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Dodge.Base.Window
|
|
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 SDL
|
|
|
|
updateUseInputOnScreen :: ScreenLayer -> Universe -> Universe
|
|
updateUseInputOnScreen sl = case sl of
|
|
InputScreen thetext _ -> doInputScreenInput thetext
|
|
screen -> optionScreenUpdate screen
|
|
|
|
doInputScreenInput :: String -> Universe -> Universe
|
|
doInputScreenInput s u =
|
|
u & doTextInputOver (uvScreenLayers . _head . scInput)
|
|
& checkEndStatus
|
|
where
|
|
pkeys = u ^. uvWorld . input . pressedKeys
|
|
checkEndStatus
|
|
| ScancodeReturn `M.member` pkeys =
|
|
(uvScreenLayers %~ tail)
|
|
. applyTerminalString (words s)
|
|
. (uvWorld . worldEventFlags . at InventoryChange ?~ ())
|
|
| ScancodeEscape `M.member` pkeys = uvScreenLayers %~ tail
|
|
| otherwise = id
|
|
|
|
optionScreenUpdate ::
|
|
ScreenLayer ->
|
|
Universe ->
|
|
Universe
|
|
optionScreenUpdate screen u =
|
|
(uvScreenLayers . ix 0 . scDisplayTime +~ 1)
|
|
. refreshOptionsSelectionList
|
|
. optionScreenDefaultEffect mop
|
|
. mouseClickOptionsList screen
|
|
. mouseOverSelectionList ldps screen
|
|
. menuWheelEvents
|
|
. over (uvScreenLayers . _head) (setSelectionListRestriction (u ^. uvConfig))
|
|
$ u
|
|
where
|
|
mop = _scPositionedMenuOption screen
|
|
ldps = _scListDisplayParams screen
|
|
|
|
optionScreenDefaultEffect :: PositionedMenuOption -> Universe -> Universe
|
|
optionScreenDefaultEffect f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
|
|
Just InitialPress -> fromMaybe id (f ^? pmoMenuOption . moEff) u
|
|
_ -> u
|
|
|
|
-- ouch this is not good
|
|
mouseClickOptionsList :: ScreenLayer -> Universe -> Universe
|
|
mouseClickOptionsList screen u = fromMaybe u $ do
|
|
sl <- screen ^? scSelectionList
|
|
Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
|
|
Just False -> fromMaybe u $ do
|
|
i <- sl ^. slSelPos
|
|
f <- sl ^? slItems . ix i . siPayload . _1
|
|
return $ f u
|
|
_ -> case u ^. uvWorld . input . mouseButtons . at ButtonRight of
|
|
Just False -> fromMaybe u $ do
|
|
i <- sl ^. slSelPos
|
|
f <- sl ^? slItems . ix i . siPayload . _2
|
|
return $ f u
|
|
_ -> u
|
|
|
|
mouseOverSelectionList ::
|
|
ListDisplayParams ->
|
|
ScreenLayer ->
|
|
Universe ->
|
|
Universe
|
|
mouseOverSelectionList ldps screen u
|
|
| x > xl && x < xr
|
|
&& ylower == yupper
|
|
&& (mmoving || (_scDisplayTime screen == 0))
|
|
&& ylower >= 0
|
|
&& ylower < ymax
|
|
&& isselectable =
|
|
u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper
|
|
| otherwise = u
|
|
where
|
|
sl = _scSelectionList screen
|
|
isselectable =
|
|
fromMaybe False $
|
|
u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yupper . siIsSelectable
|
|
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
|
|
xl = _ldpPosX ldps - hw
|
|
xr = xl + _ldpScale ldps * 26 * 9
|
|
V2 x y = u ^. uvWorld . input . mousePos
|
|
cfig = u ^. uvConfig
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
|
|
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)
|