module Graphics.UI.LUI.Widgets.Scroll
(new
,Mutable(..))
where
import qualified Graphics.UI.LUI.Widget as Widget
import qualified Graphics.UI.LUI.Image as Image
import Graphics.UI.LUI.Widget(Widget, WidgetFuncs(..))
import Graphics.UI.HaskGame.Key(asKeyGroup, noMods)
import Graphics.UI.LUI.Accessor(Accessor, (^.), write)
import qualified Graphics.UI.HaskGame.Vector2 as Vector2
import Graphics.UI.HaskGame.Vector2(Vector2(..))
import qualified Graphics.UI.SDL as SDL
import qualified Data.Map as Map
import Data.Monoid(Monoid(..))
import Control.Applicative(liftA2)
data Mutable = Mutable
{
mutablePos :: Vector2 Int
}
leftKeyGroup,
rightKeyGroup,
upKeyGroup,
downKeyGroup :: Widget.KeyAction
leftKeyGroup = (Widget.KeyDown, asKeyGroup noMods SDL.SDLK_LEFT)
rightKeyGroup = (Widget.KeyDown, asKeyGroup noMods SDL.SDLK_RIGHT)
upKeyGroup = (Widget.KeyDown, asKeyGroup noMods SDL.SDLK_UP)
downKeyGroup = (Widget.KeyDown, asKeyGroup noMods SDL.SDLK_DOWN)
hjump :: Int
hjump = 10
vjump :: Int
vjump = 10
makeKeymap :: Vector2 Int -> Vector2 Int ->
model -> Accessor model Mutable -> Maybe (Widget.ActionHandlers model)
makeKeymap minScroll maxScroll model acc =
let Mutable pos = model ^. acc
clip = liftA2 max minScroll . liftA2 min maxScroll
doesMove delta = pos /= clip (delta + pos)
newModel delta = write acc (Mutable . clip $ delta + pos) model
handlers =
concat
[if doesMove delta then
[(keyGroup, (desc, const $ newModel delta))]
else
[]
| (keyGroup, delta, desc) <-
[(leftKeyGroup, Vector2 (hjump) 0, "Scroll left")
,(rightKeyGroup, Vector2 vjump 0 , "Scroll right")
,(upKeyGroup, Vector2 0 (hjump), "Scroll up")
,(downKeyGroup, Vector2 0 vjump , "Scroll down")
]
]
in if null handlers then
Nothing
else
Just . Map.fromList $ handlers
noFocusDrawInfo :: Widget.DrawInfo
noFocusDrawInfo = Widget.DrawInfo False
new :: Vector2 Int -> Widget model -> Widget.New model Mutable
new size widget acc model =
let childFuncs = widget model
in WidgetFuncs
{
widgetGetKeymap = widgetGetKeymap childFuncs `mappend`
makeKeymap (Vector2 0 0)
(widgetSize childFuncs noFocusDrawInfo size)
model acc
, widgetImage = \drawInfo ->
Image.crop size .
Image.move (negate . mutablePos $ model ^. acc) $
widgetImage childFuncs drawInfo
, widgetSize = const size
}