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

List rendering work

Browse Source
This commit is contained in:
justin
2023-05-05 10:22:46 +01:00
parent 988bb7591d
commit 865706df3b
7 changed files with 60 additions and 58 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Debug/Picture.hs
+1 -1
View File
@@ -124,7 +124,7 @@ debugDraw :: Configuration -> World -> Picture
debugDraw cfig w debugDraw cfig w
| Enable_debug `S.member` _debug_booleans cfig = | Enable_debug `S.member` _debug_booleans cfig =
pic pic
<> setLayer FixedCoordLayer (listPicturesAt (0.5 * halfWidth cfig) 0 cfig $ map text ts) <> setLayer FixedCoordLayer (toTopLeft cfig (listPicturesAt (0.5 * halfWidth cfig) 0 $ map text ts))
| otherwise = mempty | otherwise = mempty
where where
pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig) pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
src/Dodge/Render/HUD.hs
+7 -7
View File
@@ -119,10 +119,10 @@ drawRBOptions cfig w = fromMaybe mempty $ do
sss <- w ^? hud . hudElement . diSections sss <- w ^? hud . hudElement . diSections
(i', j) <- sss ^? sssExtra . sssSelPos . _Just (i', j) <- sss ^? sssExtra . sssSelPos . _Just
curpos <- selSecSelPos i' j sss curpos <- selSecSelPos i' j sss
let midtext str = listTextPictureAtScale 10 1 252 0 cfig curpos (text str) let midtext str = toTopLeft cfig $ listTextPictureAtScale 10 1 252 0 curpos (text str)
let extratext str = listTextPictureAtScale 10 1 432 0 cfig curpos (text (str ++ deactivatetext)) let extratext str = toTopLeft cfig $ listTextPictureAtScale 10 1 432 0 curpos (text (str ++ deactivatetext))
return $ return $
listPicturesAtOff 342 0 cfig (curpos - i) (map (text . eqPosText) es) toTopLeft cfig (listPicturesAtOff 342 0 (curpos - i) (map (text . eqPosText) es))
<> case ae of <> case ae of
DoNotMoveEquipment -> mempty DoNotMoveEquipment -> mempty
PutOnEquipment{} -> PutOnEquipment{} ->
@@ -146,7 +146,7 @@ examineInventoryExtra mtweaki mitm cfig = fromMaybe mempty $ do
tweaki <- mtweaki tweaki <- mtweaki
-- consider moving this functionality out into a tweaks module -- consider moving this functionality out into a tweaks module
tparam <- mitm ^? _Just . itTweaks . tweakParams . ix tweaki tparam <- mitm ^? _Just . itTweaks . tweakParams . ix tweaki
return $ listCursorNSW subInvX 60 cfig tweaki 0 white (length $ showTweak tparam) 15 return $ toTopLeft cfig $ listCursorNSW subInvX 60 tweaki 0 white (length $ showTweak tparam) 15
combineInventoryExtra :: SelectionSections CombinableItem -> Configuration -> World -> Picture combineInventoryExtra :: SelectionSections CombinableItem -> Configuration -> World -> Picture
combineInventoryExtra sss cfig w = fromMaybe mempty $ do combineInventoryExtra sss cfig w = fromMaybe mempty $ do
@@ -158,7 +158,7 @@ combineInventoryExtra sss cfig w = fromMaybe mempty $ do
mconcat mconcat
[ fromMaybe mempty $ do [ fromMaybe mempty $ do
strs <- si ^? siPayload . ciInfo strs <- si ^? siPayload . ciInfo
return $ listPicturesAtOff (subInvX + 150) 60 cfig cpos $ map (color red . text) strs return $ toTopLeft cfig (listPicturesAtOff (subInvX + 150) 60 cpos $ map (color red . text) strs)
, fromMaybe mempty $ do , fromMaybe mempty $ do
lnks <- si ^? siPayload . ciInvIDs lnks <- si ^? siPayload . ciInvIDs
return $ return $
@@ -169,7 +169,7 @@ combineInventoryExtra sss cfig w = fromMaybe mempty $ do
where where
invcursor i = fromMaybe mempty $ do invcursor i = fromMaybe mempty $ do
sss' <- w ^? hud . hudElement . diSections sss' <- w ^? hud . hudElement . diSections
return $ selSecDrawCursor 17 [North, South, East] cfig (invDisplayParams w) sss' 0 i return $ toTopLeft cfig $ selSecDrawCursor 17 [North, South, East] (invDisplayParams w) sss' 0 i
displayTerminal :: Int -> Configuration -> LWorld -> Picture displayTerminal :: Int -> Configuration -> LWorld -> Picture
displayTerminal tid cfig w = fromMaybe mempty $ do displayTerminal tid cfig w = fromMaybe mempty $ do
@@ -240,7 +240,7 @@ invHead cfig =
drawCarte :: Configuration -> World -> Picture drawCarte :: Configuration -> World -> Picture
drawCarte cfig w = drawCarte cfig w =
pictures $ pictures $
renderListAt 0 0 cfig locs : toTopLeft cfig (renderListAt 0 0 locs) :
mapOverlay w mapOverlay w
++ [mainListCursor white iPos cfig] ++ [mainListCursor white iPos cfig]
where where
src/Dodge/Render/InfoBox.hs
+2 -2
View File
@@ -13,9 +13,9 @@ import Picture
renderInfoListAt :: Float -> Float -> Configuration -> Camera -> (Point2, [String]) -> Picture renderInfoListAt :: Float -> Float -> Configuration -> Camera -> (Point2, [String]) -> Picture
renderInfoListAt x y cfig cam (p, ss) = renderInfoListAt x y cfig cam (p, ss) =
renderListAt x y cfig (zip ss (repeat white)) toTopLeft cfig (renderListAt x y (zip ss (repeat white)))
<> color white (lConnect (V2 (x - hw) (hh -25 - y)) (worldPosToScreen cam p)) <> color white (lConnect (V2 (x - hw) (hh -25 - y)) (worldPosToScreen cam p))
<> listCursorNSW x y cfig 0 0 white 19 (length ss) <> toTopLeft cfig (listCursorNSW x y 0 0 white 19 (length ss))
where where
hw = halfWidth cfig hw = halfWidth cfig
hh = halfHeight cfig hh = halfHeight cfig
src/Dodge/Render/List.hs
+43 -40
View File
@@ -9,6 +9,7 @@ module Dodge.Render.List (
dShadCol, dShadCol,
listPicturesAtOff, listPicturesAtOff,
stackPicturesAt, stackPicturesAt,
toTopLeft,
) where ) where
import Data.Maybe import Data.Maybe
@@ -25,23 +26,23 @@ import Picture
drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList a -> Picture drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
drawSelectionList ldps cfig sl = drawSelectionList ldps cfig sl =
listPicturesAtScaleOff toTopLeft cfig (listPicturesAtScaleOff
(_ldpVerticalGap ldps) (_ldpVerticalGap ldps)
(_ldpScale ldps) (_ldpScale ldps)
(_ldpPosX ldps) (_ldpPosX ldps)
(_ldpPosY ldps) (_ldpPosY ldps)
cfig
0 --(_slOffset sl) 0 --(_slOffset sl)
(makeSelectionListPictures sl) (makeSelectionListPictures sl)
<> drawSelectionCursor ldps cfig sl <> drawSelectionCursor ldps sl
)
makeSelectionListPictures :: SelectionList a -> [Picture] makeSelectionListPictures :: SelectionList a -> [Picture]
makeSelectionListPictures sl = concatMap f $ getShownItems sl makeSelectionListPictures = concatMap f . getShownItems
where where
f si = map (color (_siColor si) . text) $ _siPictures si f si = map (color (_siColor si) . text) $ _siPictures si
drawCursorAt :: ListDisplayParams -> Configuration -> Maybe Int -> [SelectionItem a] -> Picture drawCursorAt :: ListDisplayParams -> Maybe Int -> [SelectionItem a] -> Picture
drawCursorAt ldps cfig mi lis = fromMaybe mempty $ do drawCursorAt ldps mi lis = fromMaybe mempty $ do
i <- mi i <- mi
selit <- lis !? i selit <- lis !? i
f <- case _ldpCursorType ldps of f <- case _ldpCursorType ldps of
@@ -49,14 +50,14 @@ drawCursorAt ldps cfig mi lis = fromMaybe mempty $ do
NoCursor -> Nothing NoCursor -> Nothing
let j = sum . map _siHeight $ take i lis let j = sum . map _siHeight $ take i lis
col = _siColor selit col = _siColor selit
return $ f (_ldpPosX ldps + (9 * fromIntegral (_siOffX selit))) (_ldpPosY ldps) cfig j 0 col wdth (_siHeight selit) return $ f (_ldpPosX ldps + (9 * fromIntegral (_siOffX selit))) (_ldpPosY ldps) j 0 col wdth (_siHeight selit)
where where
wdth = case _ldpWidth ldps of wdth = case _ldpWidth ldps of
FixedSelectionWidth x -> x FixedSelectionWidth x -> x
_ -> 1 _ -> 1
drawSelectionCursor :: ListDisplayParams -> Configuration -> SelectionList a -> Picture drawSelectionCursor :: ListDisplayParams -> SelectionList a -> Picture
drawSelectionCursor ldps cfig sl = drawCursorAt ldps cfig (f $ sl ^. slSelPos) (getShownItems sl) drawSelectionCursor ldps sl = drawCursorAt ldps (f $ sl ^. slSelPos) (getShownItems sl)
where where
-- the following is quite hacky -- the following is quite hacky
f = case sl ^. slRegex of f = case sl ^. slRegex of
@@ -64,36 +65,31 @@ drawSelectionCursor ldps cfig sl = drawCursorAt ldps cfig (f $ sl ^. slSelPos) (
"" | not (sl ^. slRegexInput) -> id "" | not (sl ^. slRegexInput) -> id
_ -> fmap (+ 1) _ -> fmap (+ 1)
-- 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 = listPicturesAtScaleOff 10 1 tx ty cfig 0
listPicturesAtOff :: Float -> Float -> Configuration -> Int -> [Picture] -> Picture listPicturesAtOff :: Float -> Float -> Int -> [Picture] -> Picture
listPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAtScale 10 1 tx ty cfig) [i ..] listPicturesAtOff tx ty i = mconcat . zipWith (listTextPictureAtScale 10 1 tx ty) [i ..]
listPicturesAtScaleOff :: Float -> Float -> Float -> Float -> Configuration -> Int -> [Picture] -> Picture listPicturesAtScaleOff :: Float -> Float -> Float -> Float -> Int -> [Picture] -> Picture
listPicturesAtScaleOff ygap s tx ty cfig i = listPicturesAtScaleOff ygap s tx ty i =
mconcat mconcat
. zipWith (listTextPictureAtScale ygap s tx ty cfig) [i ..] . zipWith (listTextPictureAtScale ygap s tx ty) [i ..]
stackPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture stackPicturesAt :: Float -> Float -> [Picture] -> Picture
stackPicturesAt tx ty cfig = stackPicturesAtOff tx ty cfig 0 stackPicturesAt tx ty = stackPicturesAtOff tx ty 0
stackPicturesAtOff :: Float -> Float -> Configuration -> Int -> [Picture] -> Picture stackPicturesAtOff :: Float -> Float -> Int -> [Picture] -> Picture
stackPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAtScale 10 1 tx ty cfig) [i, i -1 ..] stackPicturesAtOff tx ty i = mconcat . zipWith (listTextPictureAtScale 10 1 tx ty) [i, i -1 ..]
selSecDrawCursor :: Int -> [CardinalPoint] -> Configuration -> ListDisplayParams -> SelectionSections a -> Int -> Int -> Picture selSecDrawCursor :: Int -> [CardinalPoint] -> ListDisplayParams -> SelectionSections a -> Int -> Int -> Picture
selSecDrawCursor xsize borders cfig ldp sss i j = fromMaybe mempty $ do selSecDrawCursor xsize borders ldp sss i j = fromMaybe mempty $ do
yint <- selSecSelPos i j sss yint <- selSecSelPos i j sss
xint <- sss ^? sssSections . ix i . ssIndent xint <- sss ^? sssSections . ix i . ssIndent
si <- sss ^? sssSections . ix i . ssItems . ix j si <- sss ^? sssSections . ix i . ssItems . ix j
return $ listCursorDisplayParams ldp borders cfig yint xint (_siColor si) xsize (length $ _siPictures si) return $ listCursorDisplayParams ldp borders yint xint (_siColor si) xsize (length $ _siPictures si)
listCursorDisplayParams :: listCursorDisplayParams ::
ListDisplayParams -> ListDisplayParams ->
[CardinalPoint] -> [CardinalPoint] ->
Configuration ->
Int -> Int ->
Int -> Int ->
Color -> Color ->
@@ -117,18 +113,17 @@ listCursorChooseBorderScale ::
[CardinalPoint] -> [CardinalPoint] ->
Float -> Float ->
Float -> Float ->
Configuration ->
Int -> Int ->
Int -> Int ->
Color -> Color ->
Int -> Int ->
Int -> Int ->
Picture Picture
listCursorChooseBorderScale ygap s borders xoff yoff cfig yint xint col cursxsize cursysize = listCursorChooseBorderScale ygap s borders xoff yoff yint xint col cursxsize cursysize =
translate translate
--(15 + (9 * s * (fromIntegral xint - 1)) + xoff - halfWidth cfig) --(15 + (9 * s * (fromIntegral xint - 1)) + xoff - halfWidth cfig)
(xoff + (10 * s * (fromIntegral xint -1)) - halfWidth cfig) (xoff + (10 * s * (fromIntegral xint -1)))
(halfHeight cfig - (yoff + (s * 10 + ygap) * (fromIntegral yint + 1))) ( - (yoff + (s * 10 + ygap) * (fromIntegral yint + 1)))
. color col . color col
$ chooseCursorBorders (s * wth) (s * hgt) borders $ chooseCursorBorders (s * wth) (s * hgt) borders
where where
@@ -138,7 +133,7 @@ listCursorChooseBorderScale ygap s borders xoff yoff cfig yint xint col cursxsiz
-- displays a cursor that should match up to list text pictures -- displays a cursor that should match up to list text pictures
listCursorChooseBorder :: listCursorChooseBorder ::
[CardinalPoint] -> Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture [CardinalPoint] -> Float -> Float -> Int -> Int -> Color -> Int -> Int -> Picture
listCursorChooseBorder = listCursorChooseBorderScale 10 1 listCursorChooseBorder = listCursorChooseBorderScale 10 1
-- note we cannot simply scale lines because they are drawn as solid rectangles -- note we cannot simply scale lines because they are drawn as solid rectangles
@@ -150,7 +145,7 @@ chooseCursorBorders w h = foldMap (line . toLine)
toLine South = [V2 w 0, V2 0 0] toLine South = [V2 w 0, V2 0 0]
toLine West = [V2 0 0, V2 0 h] toLine West = [V2 0 0, V2 0 h]
listCursorNSW :: Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture listCursorNSW :: Float -> Float -> Int -> Int -> Color -> Int -> Int -> Picture
listCursorNSW = listCursorChooseBorder [North, South, West] listCursorNSW = listCursorChooseBorder [North, South, West]
--fillScreenText :: Configuration -> String -> Picture --fillScreenText :: Configuration -> String -> Picture
@@ -173,16 +168,18 @@ listCursorNSW = listCursorChooseBorder [North, South, West]
-- thescale = hw * 0.02 / fromIntegral (length str) -- thescale = hw * 0.02 / fromIntegral (length str)
-- hw = halfWidth cfig -- hw = halfWidth cfig
listTextPictureAtScale :: Float -> Float -> Float -> Float -> Configuration -> Int -> Picture -> Picture listTextPictureAtScale :: Float -> Float -> Float -> Float -> Int -> Picture -> Picture
listTextPictureAtScale ygap s xoff yoff cfig yint = listTextPictureAtScale ygap s xoff yoff yint =
translate (xoff - hw) (negate yoff + hh - ((s * 10 + ygap) * (fromIntegral yint + 1))) translate (xoff) (negate yoff - ((s * 10 + ygap) * (fromIntegral yint + 1)))
. scale (s * 0.1) (s * 0.1) . scale (s * 0.1) (s * 0.1)
where
hw = halfWidth cfig
hh = halfHeight cfig
renderListAt :: Float -> Float -> Configuration -> [(String, Color)] -> Picture renderListAt :: Float -> Float -> [(String, Color)] -> Picture
renderListAt tx ty cfig = listPicturesAt tx ty cfig . map (\(str, col) -> color col $ text str) renderListAt tx ty = listPicturesAt tx ty . map (\(str, col) -> color col $ text str)
-- 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 -> [Picture] -> Picture
listPicturesAt tx ty = listPicturesAtScaleOff 10 1 tx ty 0
--TODO put the following functions in an appropriate place --TODO put the following functions in an appropriate place
@@ -190,3 +187,9 @@ renderListAt tx ty cfig = listPicturesAt tx ty cfig . map (\(str, col) -> color
dShadCol :: Color -> Picture -> Picture dShadCol :: Color -> Picture -> Picture
{-# INLINE dShadCol #-} {-# INLINE dShadCol #-}
dShadCol c p = color black (translate 1.2 (-1.2) p) <> color c p dShadCol c p = color black (translate 1.2 (-1.2) p) <> color c p
toTopLeft :: Configuration -> Picture -> Picture
toTopLeft cfig = translate (-hw) (hh)
where
hw = halfWidth cfig
hh = halfHeight cfig
src/Dodge/Render/Picture.hs
+3 -4
View File
@@ -19,7 +19,7 @@ fixedCoordPictures u =
drawMenuOrHUD cfig u drawMenuOrHUD cfig u
<> drawConcurrentMessage u <> drawConcurrentMessage u
<> customMouseCursor u <> customMouseCursor u
<> listPicturesAt (halfWidth cfig) 0 cfig (map text (_uvTestString u u)) <> toTopLeft cfig (listPicturesAt (halfWidth cfig) 0 (map text (_uvTestString u u)))
<> displayFrameTicks u <> displayFrameTicks u
where where
cfig = _uvConfig u cfig = _uvConfig u
@@ -52,9 +52,8 @@ drawMenuOrHUD cfig u = case u ^. uvScreenLayers of
drawConcurrentMessage :: Universe -> Picture drawConcurrentMessage :: Universe -> Picture
drawConcurrentMessage u = drawConcurrentMessage u =
stackPicturesAt stackPicturesAt
(halfWidth cfig) 0
(windowYFloat cfig - 50) (halfHeight cfig - 50)
cfig
(map (centerText . f) $ u ^.. uvSideEffects . each) (map (centerText . f) $ u ^.. uvSideEffects . each)
where where
cfig = _uvConfig u cfig = _uvConfig u
src/Dodge/Render/ShapePicture.hs
+1 -1
View File
@@ -142,7 +142,7 @@ extraPics cfig u =
<> debugDraw cfig w <> debugDraw cfig w
<> foldMap (`_debugPic` u) (_uvDebug u) <> foldMap (`_debugPic` u) (_uvDebug u)
<> setLayer FixedCoordLayer <> setLayer FixedCoordLayer
(listPicturesAt (1.3 * halfWidth cfig) 0 cfig (toTopLeft cfig . listPicturesAt (1.3 * halfWidth cfig) 0
. take 50 . drop (u ^. uvDebugMessageOffset) . take 50 . drop (u ^. uvDebugMessageOffset)
. map text $ foldMap (`_debugMessage` u) (_uvDebug u)) . map text $ foldMap (`_debugMessage` u) (_uvDebug u))
where where
src/Dodge/SelectionSections/Draw.hs
+3 -3
View File
@@ -10,17 +10,17 @@ import Dodge.Data.SelectionList
drawSelectionSections :: SelectionSections a -> ListDisplayParams -> Configuration -> Picture drawSelectionSections :: SelectionSections a -> ListDisplayParams -> Configuration -> Picture
drawSelectionSections sss ldps cfig = drawSelectionSections sss ldps cfig =
listPicturesAtScaleOff toTopLeft cfig (listPicturesAtScaleOff
(_ldpVerticalGap ldps) (_ldpVerticalGap ldps)
(_ldpScale ldps) (_ldpScale ldps)
(_ldpPosX ldps) (_ldpPosX ldps)
(_ldpPosY ldps) (_ldpPosY ldps)
cfig
0 0
pics pics
<> thecursor' <> thecursor'
)
where where
thecursor' = fromMaybe mempty $ do thecursor' = fromMaybe mempty $ do
(i, j) <- sss ^? sssExtra . sssSelPos . _Just (i, j) <- sss ^? sssExtra . sssSelPos . _Just
return $ selSecDrawCursor 15 [North, South, West] cfig ldps sss i j return $ selSecDrawCursor 15 [North, South, West] ldps sss i j
pics = foldMap _ssShownItems (_sssSections sss) pics = foldMap _ssShownItems (_sssSections sss)