124 lines
4.5 KiB
Haskell
124 lines
4.5 KiB
Haskell
module Dodge.Update.Input.ScreenLayer (
|
|
updateUseInputOnScreen,
|
|
) where
|
|
|
|
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 & doTextInputOver (uvScreenLayers . _head . scInput)
|
|
& checkEndStatus
|
|
where
|
|
ispressed = (`M.member` (u ^. uvWorld . input . pressedKeys))
|
|
checkEndStatus
|
|
| ispressed ScancodeReturn =
|
|
(uvScreenLayers %~ tail)
|
|
. applyTerminalString (words s)
|
|
. (uvWorld . worldEventFlags . at InventoryChange ?~ ())
|
|
| ispressed ScancodeEscape = uvScreenLayers %~ tail
|
|
| otherwise = id
|
|
|
|
optionScreenUpdate :: Universe -> Universe
|
|
optionScreenUpdate u =
|
|
(uvScreenLayers . ix 0 . scDisplayTime +~ 1)
|
|
. refreshOptionsSelectionList
|
|
. mouseOverSelectionList
|
|
. optionScreenDefaultEffect
|
|
. mouseClickOptionsList
|
|
. menuWheelEvents
|
|
. 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 <- sl ^. slSelPos
|
|
f <- sl ^? slItems . ix i . siPayload . _1
|
|
return $ f u
|
|
_ -> case u ^. uvWorld . input . mouseButtons . at ButtonRight of
|
|
Just 0 -> fromMaybe u $ do
|
|
i <- sl ^. slSelPos
|
|
f <- sl ^? slItems . ix i . siPayload . _2
|
|
return $ f u
|
|
_ -> u
|
|
|
|
mouseOverSelectionList :: Universe -> Universe
|
|
mouseOverSelectionList u = fromMaybe u $ do
|
|
screen <- u ^? uvScreenLayers . ix 0
|
|
ldps <- screen ^? scListDisplayParams
|
|
let ymax = maybe 0 length $ screen ^? scSelectionList . slItems
|
|
yi <- ldpVerticalSelection (u ^. uvConfig) ldps (u ^. uvWorld . input . mousePos)
|
|
guard $ mmoving || (_scDisplayTime screen <= 1)
|
|
let myi = do
|
|
guard (yi >= 0 && yi < ymax && isselectable yi)
|
|
return yi
|
|
return $ u & uvScreenLayers . _head . scSelectionList . slSelPos .~ myi
|
|
where
|
|
isselectable yi =
|
|
fromMaybe False $
|
|
u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yi . siIsSelectable
|
|
mmoving = u ^. uvWorld . input . mouseMoving
|
|
|
|
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)
|