justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Start to unify selection lists

Browse Source
This commit is contained in:
justin
2022-11-02 09:36:16 +00:00
parent 7d358fde29
commit 7c8958cea7
7 changed files with 122 additions and 24 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/SelectionList.hs
+26
View File
@@ -0,0 +1,26 @@
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.SelectionList where
import Picture.Data
import Control.Lens
data SelectionList = SelectionList
{ _slPosX :: Float
, _slPosY :: Float
, _slOffset :: Int
, _slScale :: Float
, _slVerticalGap :: Float
, _slItems :: [SelectionItem]
, _slSelPos :: Maybe Int
, _slCursorType :: CursorType
}
data CursorType = NoCursor
data SelectionItem = SelectionItem
{ _siPictures :: [Picture]
, _siHeight :: Int
, _siIsSelectable :: Bool
}
makeLenses ''SelectionList
makeLenses ''SelectionItem
src/Dodge/Data/Universe.hs
+1
View File
@@ -53,6 +53,7 @@ data ScreenLayer
, _scDefaultEff :: Universe -> Universe
, _scOptionFlag :: OptionScreenFlag
, _scOptionsOffset :: Int
, _scSelPos :: Maybe Int
}
| ColumnsScreen
{ _scTitle :: Universe -> String
src/Dodge/Event/Input.hs
+9 -9
View File
@@ -8,8 +8,8 @@ module Dodge.Event.Input (
) where
import qualified Data.Text as T
import Dodge.Data.Input
import Dodge.Data.Config
import Dodge.Data.Input
import LensHelp
import SDL
@@ -18,23 +18,23 @@ import SDL
handleTextInput :: T.Text -> Input -> Input
handleTextInput text = textInput %~ (`T.append` text)
{- | Handles keyboard press and release.
-}
-- | Handles keyboard press and release.
handleKeyboardEvent :: KeyboardEventData -> Input -> Input
handleKeyboardEvent kev = case keyboardEventKeyMotion kev of
Released -> pressedKeys . at scode .~ Nothing
Pressed -> pressedKeys . at scode ?~ val
where
val | keyboardEventRepeat kev = LongPress
val
| keyboardEventRepeat kev = LongPress
| otherwise = InitialPress
scode = (keysymScancode . keyboardEventKeysym) kev
handleMouseMotionEvent :: MouseMotionEventData -> Configuration -> Input -> Input
handleMouseMotionEvent mmev cfig inp =
inp & mousePos
.~ V2
(fromIntegral x - 0.5 * _windowX cfig)
(0.5 * _windowY cfig - fromIntegral y)
handleMouseMotionEvent mmev cfig =
mousePos
.~ V2
(fromIntegral x - 0.5 * _windowX cfig)
(0.5 * _windowY cfig - fromIntegral y)
where
P (V2 x y) = mouseMotionEventPos mmev
src/Dodge/Menu/Option.hs
+1
View File
@@ -10,4 +10,5 @@ slTitleOptionsEff title ops eff =
, _scDefaultEff = eff
, _scOptionFlag = NormalOptions
, _scOptionsOffset = 0
, _scSelPos = Just 0
}
src/Dodge/Render/HUD.hs
+46 -1
View File
@@ -3,6 +3,7 @@ module Dodge.Render.HUD (
hudDrawings,
) where
import Dodge.Data.SelectionList
import Control.Lens
import qualified Data.Map.Strict as M
import Data.Maybe
@@ -47,8 +48,34 @@ drawInGameHUD uv =
w = _uvWorld uv
cfig = _uvConfig uv
defaultSelectionList :: SelectionList
defaultSelectionList = SelectionList
{ _slVerticalGap = 10
, _slScale = 1
, _slPosX = 0
, _slPosY = 0
, _slOffset = 0
, _slItems = []
, _slSelPos = Nothing
, _slCursorType = NoCursor
}
inventorySelectionList :: World -> [SelectionItem]
inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv)
++ [SelectionItem displayFreeSlots 1 False]
++ map (closeObjectToSelectionItem nfreeslots) (w ^. cWorld . lWorld . closeObjects)
where
cr = you w
inv = _crInv cr
nfreeslots = crNumFreeSlots cr
displayFreeSlots = case nfreeslots of
0 -> [color invDimColor . text $ " INVENTORY FULL"]
1 -> [color invDimColor . text $ " +1 FREE SLOT"]
x -> [color invDimColor . text $ " +" ++ show x ++ " FREE SLOTS"]
inventoryDisplay :: Configuration -> World -> Picture
inventoryDisplay cfig w = listPicturesAt 0 0 cfig invlist
inventoryDisplay cfig w = drawSelectionList cfig (defaultSelectionList & slItems .~ inventorySelectionList w)
--inventoryDisplay cfig w = listPicturesAt 0 0 cfig invlist
where
cr = you w
inv = _crInv cr
@@ -308,6 +335,15 @@ invHead cfig s =
invDimColor :: Color
invDimColor = greyN 0.7
closeObjectToSelectionItem :: Int -> Either FloorItem Button -> SelectionItem
closeObjectToSelectionItem n e = SelectionItem
{ _siPictures = pics
, _siHeight = length pics
, _siIsSelectable = True
}
where
pics = closeObjectToTextPictures n e
closeObjectToTextPictures :: Int -> Either FloorItem Button -> [Picture]
closeObjectToTextPictures nfreeslots e = case e of
Left flit -> let it = _flIt flit in map (applycolor it . textindent) $ itemDisplay it
@@ -396,6 +432,15 @@ mapWall cfig thehud wl =
mainListCursor :: Color -> Int -> Configuration -> Picture
mainListCursor c = openCursorAt 120 c 5 0
invSelectionItem :: Creature -> (Int,Item) -> SelectionItem
invSelectionItem cr x = SelectionItem
{ _siPictures = pics
, _siHeight = length pics
, _siIsSelectable = True
}
where
pics = itemText' cr x
itemText' :: Creature -> (Int, Item) -> [Picture]
{-# INLINE itemText' #-}
itemText' cr (i, it) = f $ case _itCurseStatus it of
src/Dodge/Render/List.hs
+24 -1
View File
@@ -1,5 +1,6 @@
module Dodge.Render.List where
import Dodge.Data.SelectionList
import Data.Foldable
import Data.Maybe
import Dodge.Base.WinScale
@@ -8,14 +9,27 @@ import Dodge.Data.Config
import Geometry
import Picture
drawSelectionList :: Configuration -> SelectionList -> Picture
drawSelectionList cfig sl = listPicturesAtScaleOff
(_slVerticalGap sl)
(_slScale sl)
(_slPosX sl)
(_slPosY sl)
cfig
(_slOffset sl)
(concatMap _siPictures (_slItems sl))
-- given a list of pictures that are each the size of a "text" call, displays them as
-- a list on the screen
listPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture
listPicturesAt tx ty cfig = listPicturesAtOff tx ty cfig 0
listPicturesAt tx ty cfig = listPicturesAtScaleOff 10 1 tx ty cfig 0
listPicturesAtOff :: Float -> Float -> Configuration -> Int -> [Picture] -> Picture
listPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig) [i ..]
listPicturesAtScaleOff :: Float -> Float -> Float -> Float -> Configuration -> Int -> [Picture] -> Picture
listPicturesAtScaleOff ygap s tx ty cfig i = mconcat . zipWith (listTextPictureAtScale ygap s tx ty cfig) [i ..]
stackPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture
stackPicturesAt tx ty cfig = stackPicturesAtOff tx ty cfig 0
@@ -97,6 +111,15 @@ listTextPictureAt xoff yoff cfig yint =
hw = halfWidth cfig
hh = halfHeight cfig
listTextPictureAtScale :: Float -> Float -> Float -> Float -> Configuration -> Int -> Picture -> Picture
listTextPictureAtScale ygap s xoff yoff cfig yint =
winScale cfig
. translate (xoff + 15 - hw) (negate yoff + hh - ((s * 10 + ygap) * (fromIntegral yint + 1)))
. scale (s * 0.1) (s * 0.1)
where
hw = halfWidth cfig
hh = halfHeight cfig
renderListAt :: Float -> Float -> Configuration -> [(String, Color)] -> Picture
renderListAt tx ty cfig = listPicturesAt tx ty cfig . map (\(str, col) -> color col $ text str)
src/Dodge/Render/MenuScreen.hs
+15 -13
View File
@@ -3,21 +3,21 @@ module Dodge.Render.MenuScreen (
menuScreen,
) where
import Dodge.ScodeToChar
import qualified Data.Text as T
import Dodge.Base.Window
import Dodge.Data.Universe
import Dodge.ScodeToChar
import Dodge.WindowLayout
import Padding
import Picture
menuScreen :: Universe -> ScreenLayer -> Picture
menuScreen w screen = case screen of
OptionScreen{_scTitle = titf, _scOptions = mos, _scOptionsOffset = off} ->
drawOptions w (titf w) mos off "Use keys to navigate the menu"
-- (WaitScreen sf _) -> drawOptions w (sf w) [] 0 ""
(InputScreen inputstr help) -> drawOptions w ('>' : T.unpack inputstr) [] 0 help
-- (DisplayScreen sd) -> sd w
OptionScreen{_scTitle = titf, _scOptions = mos, _scOptionsOffset = off, _scSelPos = selpos} ->
drawOptions w (titf w) mos off selpos "Use keys to navigate the menu"
-- (WaitScreen sf _) -> drawOptions w (sf w) [] 0 ""
(InputScreen inputstr help) -> drawOptions w ('>' : T.unpack inputstr) [] 0 Nothing help
-- (DisplayScreen sd) -> sd w
(ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_uvConfig w) (titf w) pairs
--displayStringList :: World -> [String] -> Picture
@@ -54,10 +54,12 @@ drawOptions ::
[MenuOption] ->
-- | Options offset
Int ->
-- | Select position
Maybe Int ->
-- | Help Text
String ->
Picture
drawOptions u title ops off footer =
drawOptions u title ops off mselpos footer =
pictures $
[ darkenBackground cfig
, drawTitle cfig title
@@ -77,7 +79,7 @@ drawOptions u title ops off footer =
x | x < length ops -> take (availableMenuLines cfig) (drop off visibleops)
_ -> visibleops
ops'' = case availableMenuLines cfig of
x | x < length ops -> map (menuOptionToString u maxOptionLength) ops' ++ [(white,"SPACE: MORE OPTIONS")]
x | x < length ops -> map (menuOptionToString u maxOptionLength) ops' ++ [(white, "SPACE: MORE OPTIONS")]
_ -> map (menuOptionToString u maxOptionLength) ops'
visibleops = filter notInvisible ops
notInvisible InvisibleToggle{} = False
@@ -118,9 +120,9 @@ placeColorString ::
Float ->
-- | scale
Float ->
(Color,String) ->
(Color, String) ->
Picture
placeColorString x y sc (col,str) = color col . translate x y . scale sc sc . text $ str
placeColorString x y sc (col, str) = color col . translate x y . scale sc sc . text $ str
drawFooterText :: Configuration -> Color -> String -> Picture
drawFooterText cfig col = color col . placeString (- hw + 30) (- hh + 10) 0.1
@@ -128,11 +130,11 @@ drawFooterText cfig col = color col . placeString (- hw + 30) (- hh + 10) 0.1
hh = halfHeight cfig
hw = halfWidth cfig
menuOptionToString :: Universe -> Int -> MenuOption -> (Color,String)
menuOptionToString w padAmount mo = (thecol,theKeys ++ optionText)
menuOptionToString :: Universe -> Int -> MenuOption -> (Color, String)
menuOptionToString w padAmount mo = (thecol, theKeys ++ optionText)
where
thecol = case _moString mo w of
MODBlockedString {} -> greyN 0.5
MODBlockedString{} -> greyN 0.5
_ -> white
optionText = case _moString mo w of
MODStringOption s t -> rightPad padAmount '.' s ++ t