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

Work on a selection list datatype

Browse Source
This commit is contained in:
justin
2022-11-02 21:47:15 +00:00
parent 7c8958cea7
commit 0872a2dd40
4 changed files with 139 additions and 65 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/SelectionList.hs
+10
View File
@@ -1,5 +1,6 @@
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.SelectionList where
import Color
import Picture.Data
import Control.Lens
@@ -12,14 +13,23 @@ data SelectionList = SelectionList
, _slItems :: [SelectionItem]
, _slSelPos :: Maybe Int
, _slCursorType :: CursorType
, _slWidth :: SelectionWidth
}
data SelectionWidth = FixedSelectionWidth Int
| VariableSelectionWidth [Int]
data CursorType = NoCursor
| NSEWCursor
| NSWCursor
| NSCursor
data SelectionItem = SelectionItem
{ _siPictures :: [Picture]
, _siHeight :: Int
, _siIsSelectable :: Bool
, _siColor :: Color
, _siOffX :: Int
}
makeLenses ''SelectionList
src/Dodge/Render/HUD.hs
+86 -65
View File
@@ -31,18 +31,18 @@ hudDrawings :: Universe -> Picture
hudDrawings uv = case w ^. cWorld . lWorld . hud . hudElement of
DisplayCarte -> drawCarte cfig w
DisplayInventory subinv ->
drawInGameHUD uv
drawInGameHUD subinv uv
<> subInventoryDisplay subinv cfig w
where
w = _uvWorld uv
cfig = _uvConfig uv
drawInGameHUD :: Universe -> Picture
drawInGameHUD uv =
drawInGameHUD :: SubInventory -> Universe -> Picture
drawInGameHUD subinv uv =
pictures
[ winScale cfig . dShadCol white $ displayHP 0 cfig w
, listPicturesAt (halfWidth cfig) 0 cfig $ map text (_uvTestString uv uv)
, inventoryDisplay cfig w
, inventoryDisplay subinv cfig w
]
where
w = _uvWorld uv
@@ -58,11 +58,25 @@ defaultSelectionList = SelectionList
, _slItems = []
, _slSelPos = Nothing
, _slCursorType = NoCursor
, _slWidth = FixedSelectionWidth 15
}
subInvSelectionList :: SelectionList
subInvSelectionList = SelectionList
{ _slVerticalGap = 10
, _slScale = 1
, _slPosX = subInvX
, _slPosY = 60
, _slOffset = 0
, _slItems = []
, _slSelPos = Nothing
, _slCursorType = NoCursor
, _slWidth = FixedSelectionWidth 15
}
inventorySelectionList :: World -> [SelectionItem]
inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv)
++ [SelectionItem displayFreeSlots 1 False]
++ [SelectionItem displayFreeSlots 1 False white 0]
++ map (closeObjectToSelectionItem nfreeslots) (w ^. cWorld . lWorld . closeObjects)
where
cr = you w
@@ -73,58 +87,48 @@ inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv)
1 -> [color invDimColor . text $ " +1 FREE SLOT"]
x -> [color invDimColor . text $ " +" ++ show x ++ " FREE SLOTS"]
inventoryDisplay :: Configuration -> World -> Picture
inventoryDisplay cfig w = drawSelectionList cfig (defaultSelectionList & slItems .~ inventorySelectionList w)
--inventoryDisplay cfig w = listPicturesAt 0 0 cfig invlist
inventoryCursorPos :: SubInventory -> World -> Maybe Int
inventoryCursorPos subinv w = case subinv of
CombineInventory {} -> Nothing
_ -> Just $ yourInvSel w
inventoryDisplay :: SubInventory -> Configuration -> World -> Picture
inventoryDisplay subinv cfig w = drawSelectionList cfig $
defaultSelectionList & slItems .~ inventorySelectionList w
& slWidth .~ FixedSelectionWidth topInvW
& slCursorType .~ selcursortype
& slSelPos .~ inventoryCursorPos subinv w
& slWidth .~ FixedSelectionWidth (determineInvSelCursorWidth w)
where
cr = you w
inv = _crInv cr
invlist =
concatMap (itemText' cr) (IM.toList inv)
++ displayFreeSlots
++ concatMap (closeObjectToTextPictures nfreeslots) (w ^. cWorld . lWorld . closeObjects)
-- ++ map floorItemsColor (concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w))
-- floorItemsColor = case _hudElement (_hud w) of
-- DisplayInventory NoSubInventory -> id
-- _ -> color invDimColor
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"]
selcursortype
| ButtonRight `M.member` _mouseButtons (_input w) = NSEWCursor
| otherwise = NSWCursor
subInventoryDisplay :: SubInventory -> Configuration -> World -> Picture
subInventoryDisplay subinv cfig w = case subinv of
LockedInventory -> mempty -- topInvCursor col cursPos cfig w
NoSubInventory ->
pictures
[ selcursor
, closeobjectcursor
[ closeobjectcursor
, equipcursors
, equipcursor -- the order is important, this should go on top of the other equipcursors
, rboptions
]
TweakInventory mtweaki ->
pictures
--[ mCurs it cfig w
titledSub "TWEAK" (subInvSelectionList & slItems .~ ammoTweakSelectionItems it)
[ selcursor' listCursorNESW
, -- , cursorsZ cfig curpos it
fromMaybe mempty $ do
, fromMaybe mempty $ do
tweaki <- mtweaki
-- consider moving this functionality out into a tweaks module
tparam <- it ^? _Just . itTweaks . tweakParams . ix tweaki
return $
lnkMidInvSel cfig w curpos tweaki
<> listCursorNSW subInvX 60 cfig tweaki white (length $ showTweak tparam) 1
, invHead cfig "TWEAK"
, listPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it)
]
DisplayTerminal tid -> displayTerminal tid cfig (w ^. cWorld . lWorld)
CombineInventory mi ->
pictures
[ invHead cfig "COMBINE"
, listPicturesAt subInvX 60 cfig $ combineListStringPictures w
, fromMaybe mempty $ do
titledSub "COMBINE" (combineListSelection w)
[ fromMaybe mempty $ do
i <- mi
cpos <- combinePoss w !? i
col <- (combineItemListYou w !? i) <&> _itInvColor . snd
@@ -145,12 +149,13 @@ subInventoryDisplay subinv cfig w = case subinv of
]
]
InspectInventory ->
mconcat
titledSub "INSPECT" (subInvSelectionList & slItems .~ textSelItems (itmInfo it))
[ selcursor' listCursorNESW
, invHead cfig "INSPECT"
, listPicturesAt subInvX 60 cfig $ map text (itmInfo it)
]
where
titledSub subtitle subitems extrapics = pictures $ [invHead cfig subtitle
,drawSelectionList cfig subitems] <>
extrapics
closeobjectcursor = case selectedCloseObject w of
Nothing -> mempty
Just (i, co) ->
@@ -166,10 +171,6 @@ subInventoryDisplay subinv cfig w = case subinv of
cr = you w
it = yourItem w
selcursor' ct = fromMaybe mempty $ ct 0 0 cfig curpos itcol (determineInvSelCursorWidth w) cury <$ it
selcursor = selcursor' selcursortype
selcursortype
| ButtonRight `M.member` _mouseButtons (_input w) = listCursorNESW
| otherwise = listCursorNSW
curpos = invSelPos w
cury = fromMaybe 1 $ augmentedInvSizes w IM.!? crSel (you w)
equipcursor = case _crLeftInvSel cr of
@@ -308,14 +309,20 @@ determineInvSelCursorWidth w = case _rbOptions w of
then 47
else topInvW
--listSelHeight :: Configuration -> World -> Int -> Float
--listSelHeight
combineListSelection :: World -> SelectionList
combineListSelection w = subInvSelectionList & slItems .~ combineListSelectionItems w
combineListStringPictures :: World -> [Picture]
combineListStringPictures w = case concatMap (itemText . snd) . combineItemListYou $ w of
[] -> [text "NO POSSIBLE COMBINATIONS"]
combineListSelectionItems :: World -> [SelectionItem]
combineListSelectionItems w = case combineListSelectionItems' w of
[] -> [SelectionItem [text "NO POSSIBLE COMBINATIONS"] 1 False white 0]
xs -> xs
combineListSelectionItems' :: World -> [SelectionItem]
combineListSelectionItems' w = map (picsToSelectable . itemText . snd) $ combineItemListYou w
ammoTweakSelectionItems :: Maybe Item -> [SelectionItem]
ammoTweakSelectionItems = textSelItems . ammoTweakStrings
ammoTweakStrings :: Maybe Item -> [String]
ammoTweakStrings it = case it ^? _Just . itTweaks . tweakParams of
Just l -> map tweakString $ IM.elems l
@@ -340,19 +347,25 @@ closeObjectToSelectionItem n e = SelectionItem
{ _siPictures = pics
, _siHeight = length pics
, _siIsSelectable = True
, _siColor = col
, _siOffX = 2
}
where
pics = closeObjectToTextPictures n e
(pics,col) = 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
Right bt -> [color yellow $ textindent $ _btText bt]
closeObjectToTextPictures' :: Int -> Either FloorItem Button -> ([Picture],Color)
closeObjectToTextPictures' nfreeslots e = case e of
Left flit -> let it = _flIt flit
in (map (applycolor it . textindent) $ itemDisplay it, thecol it)
Right bt -> ([color yellow $ textindent $ _btText bt], yellow)
where
textindent = text . (replicate clObjIntIn ' ' ++)
applycolor it
| nfreeslots >= itSlotsTaken it = color $ _itInvColor it
| otherwise = color invDimColor
thecol it
| nfreeslots >= itSlotsTaken it = _itInvColor it
| otherwise = invDimColor
clObjIntIn :: Int
clObjIntIn = 2
@@ -432,24 +445,32 @@ 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
picsToSelectable :: [Picture] -> SelectionItem
picsToSelectable pics = SelectionItem
{ _siPictures = pics
, _siHeight = length pics
, _siIsSelectable = True
, _siColor = white
, _siOffX = 0
}
textSelItems :: [String] -> [SelectionItem]
textSelItems = map (picsToSelectable . (:[]) . text)
invSelectionItem :: Creature -> (Int,Item) -> SelectionItem
invSelectionItem cr (i,it) = SelectionItem
{ _siPictures = pics
, _siHeight = length pics
, _siIsSelectable = True
, _siColor = col
, _siOffX = 0
}
where
pics = itemText' cr x
itemText' :: Creature -> (Int, Item) -> [Picture]
{-# INLINE itemText' #-}
itemText' cr (i, it) = f $ case _itCurseStatus it of
UndroppableIdentified -> map (color yellow . text) (itemDisplay it)
_ | crSel cr == i -> map (color thecolor . text) (selectedItemDisplay cr it)
_ -> map (color thecolor . text) (itemDisplay it)
where
thecolor = _itInvColor it
f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*"))
col = _itInvColor it
pics = take (itSlotsTaken it) . (++ replicate 10 (color col $ text "*")) $ case _itCurseStatus it of
UndroppableIdentified -> map (color yellow . text) (itemDisplay it)
_ | crSel cr == i -> map (color col . text) (selectedItemDisplay cr it)
_ -> map (color col . text) (itemDisplay it)
itemText :: Item -> [Picture]
{-# INLINE itemText #-}
src/Dodge/Render/List.hs
+20
View File
@@ -1,5 +1,6 @@
module Dodge.Render.List where
import ListHelp
import Dodge.Data.SelectionList
import Data.Foldable
import Data.Maybe
@@ -18,6 +19,25 @@ drawSelectionList cfig sl = listPicturesAtScaleOff
cfig
(_slOffset sl)
(concatMap _siPictures (_slItems sl))
<> drawSelectionCursor cfig sl
drawSelectionCursor :: Configuration -> SelectionList -> Picture
drawSelectionCursor cfig sl = fromMaybe mempty $ do
i <- _slSelPos sl
selit <- (filter _siIsSelectable lis) !? i
f <- case _slCursorType sl of
NSEWCursor -> Just listCursorNESW
NSWCursor -> Just listCursorNSW
NSCursor -> Just listCursorNS
NoCursor -> Nothing
let j = sum . map _siHeight $ takeWhileArb (<= i) (\x itsel -> x + if _siIsSelectable itsel then 1 else 0) 0 lis
col = _siColor selit
return $ f (_slPosX sl + (9 * fromIntegral (_siOffX selit))) (_slPosY sl) cfig j col wdth (_siHeight selit)
where
lis = _slItems sl
wdth = case _slWidth sl of
FixedSelectionWidth x -> x
_ -> 1
-- given a list of pictures that are each the size of a "text" call, displays them as
-- a list on the screen
src/ListHelp.hs
+23
View File
@@ -14,9 +14,14 @@ module ListHelp
, merge
, mergeBy
, mergeOn
, takeWhileArb
, takeWhileArb'
, foldrWhileArb
) where
import Data.List
import Data.Ord
import FoldableHelp
loopPairs :: [a] -> [(a,a)]
loopPairs (a:as) = snd $ foldr f (Just a,[]) (a:as)
@@ -85,3 +90,21 @@ mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn f xs = map snd . mergeBy (comparing fst) (g xs) . g
where
g = map (\x -> let y = f x in y `seq` (y,x))
-- | A generalised version of takeWhile
takeWhileArb :: (a -> Bool) -> (a -> b -> a) -> a -> [b] -> [b]
takeWhileArb _ _ _ [] = []
takeWhileArb t f y (x:xs) = case f y x of
y' | t y' -> x : takeWhileArb t f y' xs
| otherwise -> []
-- this may fuse better
-- should do tests
takeWhileArb' :: (a -> Bool) -> (a -> b -> a) -> a -> [b] -> [b]
takeWhileArb' t f a0 = snd . ssfold (t . fst) (\(a0',xs) x -> (f a0' x,x:xs)) (a0,[])
foldrWhileArb :: (b -> c -> c) -> c -> (a -> Bool) -> (a -> b -> a) -> a -> [b] -> c
foldrWhileArb _ z _ _ _ [] = z
foldrWhileArb h z t f y (x:xs) = case f y x of
y' | t y' -> h x $ foldrWhileArb h z t f y' xs
| otherwise -> h x z