331 lines
12 KiB
Haskell
331 lines
12 KiB
Haskell
-- {-# OPTIONS_GHC -fno-full-laziness #-}
|
|
--{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
--{-# LANGUAGE BangPatterns #-}
|
|
|
|
module Dodge.DisplayInventory (
|
|
updateInventoryPositioning,
|
|
updateCombinePositioning,
|
|
toggleCombineInv,
|
|
) where
|
|
|
|
import Dodge.Data.HUD
|
|
import Dodge.Inventory.CheckSlots
|
|
import NewInt
|
|
import Control.Applicative
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import Data.IntMap.Merge.Strict
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Data.Maybe
|
|
import Data.Monoid
|
|
import Dodge.Base.You
|
|
import Dodge.CharacterEnums
|
|
import Dodge.Combine
|
|
import Dodge.Data.Combine
|
|
import Dodge.Data.Config
|
|
import Dodge.Data.SelectionList
|
|
import Dodge.Data.Universe
|
|
import Dodge.Inventory
|
|
import Dodge.Inventory.SelectionList
|
|
import Dodge.Item.Display
|
|
import Dodge.Item.Grammar
|
|
import Dodge.ListDisplayParams
|
|
import Dodge.SelectionList
|
|
import Dodge.SelectionSections
|
|
import qualified ListHelp as List
|
|
import Picture.Base
|
|
|
|
updateCombinePositioning :: Universe -> Universe
|
|
updateCombinePositioning u =
|
|
u
|
|
& uvWorld . hud . subInventory . ciSections
|
|
%~ updateCombineSections (_uvWorld u) (_uvConfig u)
|
|
& uvWorld . hud . subInventory %~ checkCombineSelectionExists
|
|
|
|
updateCombineSections ::
|
|
World ->
|
|
Configuration ->
|
|
IM.IntMap (SelectionSection CombinableItem) ->
|
|
IM.IntMap (SelectionSection CombinableItem)
|
|
updateCombineSections w cfig =
|
|
updateSectionsPositioning
|
|
(const 0)
|
|
(w ^? hud . subInventory . ciSelection . _Just)
|
|
(getAvailableListLines secondColumnParams cfig)
|
|
(IM.fromDistinctAscList [(-1, sfclose),(0, sclose')])
|
|
where
|
|
filtcurs = w ^? hud . subInventory . ciSelection . _Just . slSec == Just (-1)
|
|
(sfclose, sclose) =
|
|
filterSectionsPair
|
|
filtcurs
|
|
(flip . andOrRegex $ regexCombs invitms)
|
|
(IM.fromDistinctAscList . zip [0 ..] $ combineList w)
|
|
"COMBINATIONS"
|
|
$ w ^? hud . subInventory . ciFilter . _Just
|
|
invitms = _unNIntMap $ fmap (\k -> w ^?! cWorld . lWorld . items . ix k) $ fold $ w ^? cWorld . lWorld . creatures . ix 0 . crInv
|
|
sclose'
|
|
| null sclose =
|
|
IM.singleton 0 $
|
|
SelItem ["No possible combinations"] 1 25 False white 0 Nothing
|
|
| otherwise = sclose
|
|
|
|
regexCombs :: IM.IntMap Item -> SelectionItem CombinableItem -> String -> Bool
|
|
regexCombs inv ci = \case
|
|
'#' : str -> any (g str) (_ciInvIDs $ fromJust $ _siPayload ci)
|
|
str -> (regexList str . _siPictures) ci
|
|
where
|
|
g str i = maybe False (regexList str . basicItemDisplay) (inv ^? ix i)
|
|
|
|
andOrRegex :: (a -> String -> Bool) -> a -> String -> Bool
|
|
andOrRegex f x = all (orRegex f x) . List.wordsBy '&'
|
|
|
|
orRegex :: (a -> String -> Bool) -> a -> String -> Bool
|
|
orRegex f x str = case words str of
|
|
[] -> True
|
|
xs -> any (f x) xs
|
|
|
|
updateInventoryPositioning :: Universe -> Universe
|
|
updateInventoryPositioning u =
|
|
u & uvWorld . hud . diSections
|
|
%~ updateDisplaySections (_uvWorld u) (_uvConfig u)
|
|
& uvWorld
|
|
%~ checkInventorySelectionExists
|
|
|
|
checkInventorySelectionExists :: World -> World
|
|
checkInventorySelectionExists w
|
|
| isJust $ w ^? hud . diSections . ix i . ssItems . ix j = w
|
|
| otherwise = scrollAugNextInSection w
|
|
where
|
|
Sel i j _ = fromMaybe (Sel 1 (-1) mempty) $ w ^? hud . diSelection . _Just
|
|
|
|
checkCombineSelectionExists :: SubInventory -> SubInventory
|
|
checkCombineSelectionExists si
|
|
| Just sss <- si ^? ciSections
|
|
, Sel i j _ <- fromMaybe (Sel 0 0 mempty) $ si ^? ciSelection . _Just
|
|
, isNothing $ si ^? ciSections . ix i . ssItems . ix j =
|
|
si & ciSelection ?~ Sel 0 (-1) mempty
|
|
& ciSelection
|
|
%~ scrollSelectionSections (-1) sss
|
|
| otherwise = si
|
|
|
|
displayIndents :: Int -> Int
|
|
displayIndents 0 = 2
|
|
displayIndents 3 = 2
|
|
displayIndents 5 = 2
|
|
displayIndents _ = 0
|
|
|
|
updateDisplaySections :: World -> Configuration -> IMSS () -> IMSS ()
|
|
updateDisplaySections w cfig =
|
|
updateSectionsPositioning
|
|
displayIndents
|
|
mselpos
|
|
(getAvailableListLines invDP cfig)
|
|
( IM.fromDistinctAscList $
|
|
zip
|
|
[-1 .. 5]
|
|
[ invhead
|
|
, sinv
|
|
, IM.singleton 0
|
|
$ SelItem [displayFreeSlots (crNumFreeSlots (w ^. cWorld . lWorld . items) cr)] 1 15 True invDimColor 2 Nothing
|
|
, nearbyhead
|
|
, sclose
|
|
, interfaceshead
|
|
, btitems
|
|
]
|
|
)
|
|
where
|
|
mselpos = w ^? hud . diSelection . _Just
|
|
invfiltcurs = mselpos ^? _Just . slSec == Just (-1)
|
|
(sfinv, sinv) =
|
|
filterSectionsPair invfiltcurs plainRegex invitems "INVENTORY" $
|
|
w ^? hud . diInvFilter . _Just
|
|
closefiltcurs = mselpos ^? _Just . slSec == Just 2
|
|
(sfclose, sclose) =
|
|
filterSectionsPair closefiltcurs plainRegex closeitms "NEARBY ITEMS" $
|
|
w ^? hud . diCloseFilter . _Just
|
|
nearbyhead
|
|
| null sfclose && not (null sclose) = makehead "NEARBY ITEMS"
|
|
| otherwise = sfclose
|
|
interfaceshead = if null btitems then mempty else makehead "NEARBY INTERFACES"
|
|
btitems =
|
|
IM.fromDistinctAscList . zip [0 ..] $
|
|
mapMaybe (closeButtonToSelectionItem w) (w ^. hud . closeButtons)
|
|
makehead str = IM.singleton 0 $ SelItem [str] 1 15 False white 0 Nothing
|
|
invhead = if null sfinv then makehead "INVENTORY" else sfinv
|
|
cr = you w
|
|
closeitms =
|
|
IM.fromDistinctAscList . zip [0 ..] $
|
|
mapMaybe (closeItemToSelectionItem w) (map _unNInt $ w ^. hud . closeItems)
|
|
invitems =
|
|
IM.map
|
|
(uncurry (invSelectionItem w))
|
|
(invIndents $ fmap (\k -> w ^?! cWorld . lWorld . items . ix k) $ _crInv cr)
|
|
|
|
filterSectionsPair ::
|
|
Bool -> -- check for whether filter is in focus, changes string at the end
|
|
(String -> SelectionItem a -> Bool) ->
|
|
IM.IntMap (SelectionItem a) ->
|
|
String ->
|
|
Maybe String ->
|
|
(IM.IntMap (SelectionItem a), IM.IntMap (SelectionItem a))
|
|
filterSectionsPair infocus filtfn itms filtdescription mfilt = (filtsis, itms')
|
|
where
|
|
filtcurs = if infocus then cFilledRect else cWireRect
|
|
filtsis = fold $ do
|
|
str <- mfilt
|
|
return $
|
|
IM.singleton
|
|
0
|
|
$ SelItem
|
|
[filtdescription ++ " FILTER/" ++ str ++ [filtcurs], numfiltitems]
|
|
2
|
|
(length (filtdescription ++ " FILTER/" ++ str ++ [filtcurs]))
|
|
True
|
|
white
|
|
0
|
|
Nothing
|
|
itms' = maybe id (IM.filter . filtfn) mfilt itms
|
|
numfiltitems = " " ++ show (length itms - length itms') ++ " FILTERED"
|
|
|
|
invDimColor :: Color
|
|
invDimColor = greyN 0.7
|
|
|
|
plainRegex :: String -> SelectionItem a -> Bool
|
|
plainRegex = flip $ andOrRegex (\si str -> regexList str (_siPictures si))
|
|
|
|
displayFreeSlots :: Int -> String
|
|
displayFreeSlots x = case x of
|
|
0 -> "INVENTORY FULL"
|
|
1 -> "1 FREE SLOT"
|
|
_ -> show x ++ " FREE SLOTS"
|
|
|
|
sectionsDesiredLines :: IM.IntMap (IM.IntMap (SelectionItem a)) -> IM.IntMap Int
|
|
sectionsDesiredLines = fmap $ alaf Sum foldMap _siHeight
|
|
|
|
sectionsSizes ::
|
|
Int -> -- total available lines
|
|
[Int] -> -- ordering in which to consider sections (others to be done lowest to highest)
|
|
IM.IntMap Int -> -- desired lines
|
|
IM.IntMap Int
|
|
sectionsSizes x is sss = doSectionSize extraavailable mintaken is sss mempty
|
|
where
|
|
mintaken = IM.mapWithKey (min . const 10) sss
|
|
extraavailable = x - sum mintaken
|
|
|
|
doSectionSize ::
|
|
Int -> -- extra available lines
|
|
IM.IntMap Int -> -- minimum line bounds for each section
|
|
[Int] -> -- ordering in which to consider sections (others to be done lowest to highest)
|
|
IM.IntMap Int -> -- desired lines in sections not yet considered
|
|
IM.IntMap Int -> -- sections already sized
|
|
IM.IntMap Int
|
|
doSectionSize extraavailable mintaken is sss done = fromMaybe done $ do
|
|
(v, others, k, ks) <- getsecusingis <|> getminsec
|
|
minv <- mintaken ^? ix k
|
|
let extradesired = v - minv
|
|
linesgiven = min extraavailable extradesired
|
|
return $
|
|
doSectionSize (extraavailable - linesgiven) mintaken ks others $
|
|
done
|
|
& at k ?~ linesgiven + minv
|
|
where
|
|
getsecusingis = do
|
|
(k, ks) <- List.uncons is
|
|
let (my, s') = IM.updateLookupWithKey (\_ _ -> Nothing) k sss
|
|
y <- my
|
|
return (y, s', k, ks)
|
|
getminsec = do
|
|
((k, v), s') <- IM.minViewWithKey sss
|
|
return (v, s', k, [])
|
|
|
|
updateSectionsPositioning ::
|
|
(Int -> Int) -> -- for determining each sections indent
|
|
Maybe Selection ->
|
|
Int ->
|
|
IM.IntMap (IM.IntMap (SelectionItem a)) ->
|
|
IM.IntMap (SelectionSection a) ->
|
|
IM.IntMap (SelectionSection a)
|
|
updateSectionsPositioning h mselpos allavailablelines lsss sss =
|
|
IM.intersectionWithKey (\k -> updateSection (h k) (m k)) ls ssizes `g` offsets
|
|
where
|
|
offsets = fmap _ssOffset sss
|
|
m k = do
|
|
Sel k' i _ <- mselpos
|
|
guard $ k == k'
|
|
return i
|
|
ls = lsss
|
|
-- defaults non-existing offsets to 0
|
|
g = merge (mapMissing (const ($ 0))) dropMissing (zipWithMatched (const ($)))
|
|
lk = mselpos ^.. _Just . slSec
|
|
ssizes = sectionsSizes allavailablelines lk $ sectionsDesiredLines ls
|
|
|
|
updateSection ::
|
|
Int ->
|
|
Maybe Int ->
|
|
IM.IntMap (SelectionItem a) ->
|
|
Int ->
|
|
Int ->
|
|
SelectionSection a
|
|
updateSection indent mcsel sis availablelines oldoffset =
|
|
SelectionSection
|
|
{ _ssItems = sis
|
|
, _ssOffset = offset
|
|
, _ssShownItems = shownitems
|
|
, _ssShownLength = min aslength availablelines
|
|
, _ssIndent = indent
|
|
}
|
|
where
|
|
shownitems = tweakfirst . tweaklast $ take availablelines shownstrings
|
|
oldoffsetbounded = max 0 . min oldoffset $ aslength - availablelines
|
|
offset = fromMaybe oldoffsetbounded $ do
|
|
csel <- mcsel
|
|
maxcsel <- fst <$> IM.lookupMax sis
|
|
xselsize <- sis ^? ix csel . siHeight
|
|
return $ case sum $ fmap _siHeight . fst . IM.split csel $ sis of
|
|
pos | pos == 0 || aslength <= availablelines -> 0
|
|
pos | pos - 1 < oldoffset -> pos - 1
|
|
pos | maxcsel == csel -> pos - availablelines + xselsize
|
|
pos
|
|
| pos + 1 + xselsize - availablelines > oldoffset ->
|
|
pos - availablelines + 1 + xselsize
|
|
_
|
|
| aslength - availablelines < oldoffset ->
|
|
aslength - availablelines
|
|
_ -> oldoffsetbounded
|
|
tweakfirst
|
|
| offset > 0 = ix 0 .~ color white (text (replicate 15 (toEnum 30)))
|
|
| otherwise = id
|
|
tweaklast
|
|
| aslength - offset > availablelines =
|
|
ix (availablelines - 1)
|
|
.~ color white (text . replicate 15 $ toEnum 31)
|
|
| otherwise = id
|
|
(allstrings, Sum aslength) = foldMap listSelectionColorPicture sis
|
|
shownstrings = drop offset allstrings
|
|
|
|
listSelectionColorPicture :: SelectionItem a -> ([Picture], Sum Int)
|
|
listSelectionColorPicture si = (g <$> _siPictures si, Sum $ _siHeight si)
|
|
where
|
|
g = translate lindent 0 . color (_siColor si) . text
|
|
lindent = 100 * fromIntegral (_siOffX si)
|
|
|
|
regexList :: String -> [String] -> Bool
|
|
regexList = any . List.isInfixOf
|
|
|
|
toggleCombineInv :: Universe -> Universe
|
|
toggleCombineInv uv =
|
|
uv & case uv ^? uvWorld . hud . subInventory of
|
|
Just CombineInventory{} -> uvWorld . hud . subInventory .~ NoSubInventory
|
|
_ -> uvWorld %~ enterCombineInv (uv ^. uvConfig)
|
|
|
|
enterCombineInv :: Configuration -> World -> World
|
|
enterCombineInv cfig w =
|
|
w & hud . subInventory
|
|
.~ CombineInventory
|
|
{ _ciSections = updateCombineSections w cfig mempty
|
|
, _ciSelection = Just (Sel 0 0 mempty)
|
|
, _ciFilter = Nothing
|
|
}
|
|
& hud . diInvFilter .~ Nothing
|