376 lines
14 KiB
Haskell
376 lines
14 KiB
Haskell
-- {-# OPTIONS_GHC -fno-full-laziness #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
module Dodge.DisplayInventory (
|
|
toggleCombineInv,
|
|
updateInventoryPositioning,
|
|
updateCombinePositioning,
|
|
) where
|
|
|
|
import Data.Monoid
|
|
import qualified Data.List as List
|
|
import Dodge.CharacterEnums
|
|
import Control.Applicative
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import Data.Bifunctor
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Data.Maybe
|
|
import Dodge.Base.You
|
|
import Dodge.Combine
|
|
import Dodge.Data.Combine
|
|
import Dodge.Data.Config
|
|
import Dodge.Data.DoubleTree
|
|
import Dodge.Data.SelectionList
|
|
import Dodge.Data.Universe
|
|
import Dodge.Inventory
|
|
import Dodge.Inventory.SelectionList
|
|
import Dodge.Item.Grammar
|
|
import Dodge.ListDisplayParams
|
|
import Dodge.SelectionList
|
|
import Dodge.SelectionSections
|
|
import ListHelp
|
|
import Picture.Base
|
|
|
|
toggleCombineInv :: Universe -> Universe
|
|
toggleCombineInv uv = case uv ^? uvWorld . hud . hudElement . subInventory of
|
|
Just CombineInventory{} ->
|
|
uv & uvWorld . hud . hudElement . subInventory
|
|
.~ NoSubInventory --MouseInvNothing
|
|
_ -> uv & uvWorld %~ enterCombineInv (uv ^. uvConfig)
|
|
|
|
updateCombinePositioning :: Universe -> Universe
|
|
updateCombinePositioning u =
|
|
u & uvWorld . hud . hudElement . subInventory . ciSections
|
|
%~ updateCombineSections (_uvWorld u) (_uvConfig u)
|
|
& checkCombineSelectionExists
|
|
|
|
updateCombineSections ::
|
|
World ->
|
|
Configuration ->
|
|
IM.IntMap (SelectionSection CombinableItem) ->
|
|
IM.IntMap (SelectionSection CombinableItem)
|
|
updateCombineSections w cfig =
|
|
updateSectionsPositioning
|
|
(const 5)
|
|
(w ^? hud . hudElement . subInventory . ciSelection . _Just)
|
|
(getAvailableListLines secondColumnParams cfig)
|
|
[(0, sclose), (-1, sfclose)]
|
|
where
|
|
filtcurs = case w ^? hud . hudElement . subInventory . ciSelection . _Just . _1 of
|
|
Just (-1) -> [cFilledRect]
|
|
_ -> [cWireRect]
|
|
(sfclose, sclose) =
|
|
filterSectionsPair
|
|
filtcurs
|
|
(flip . andOrRegex $ regexCombs invitms)
|
|
(IM.fromDistinctAscList . zip [0 ..] $ combineList w)
|
|
"COMBINATIONS"
|
|
$ w ^? hud . hudElement . subInventory . ciFilter . _Just
|
|
invitms = fold $ w ^? hud . hudElement . diSections . ix 0 . ssItems
|
|
|
|
regexCombs :: IM.IntMap (SelectionItem ()) -> SelectionItem CombinableItem -> String -> Bool
|
|
regexCombs inv ci str = case str of
|
|
'<' : str' -> f str' ci
|
|
_ -> (regexList str . _siPictures) ci
|
|
where
|
|
f str' si = any (g str') (_ciInvIDs $ _siPayload si)
|
|
g str' i = fromMaybe False $ do
|
|
si' <- inv ^? ix i
|
|
return $ regexList str' $ _siPictures si'
|
|
|
|
andOrRegex :: (a -> String -> Bool) -> a -> String -> Bool
|
|
andOrRegex f x = all (orRegex f x) . 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 . hudElement . diSections
|
|
%~ updateDisplaySections (_uvWorld u) (_uvConfig u)
|
|
& checkInventorySelectionExists
|
|
|
|
-- this is possibly not completely correct
|
|
checkInventorySelectionExists :: Universe -> Universe
|
|
checkInventorySelectionExists u = fromMaybe u $ do
|
|
(i, j) <- (u ^? uvWorld . hud . hudElement . diSelection . _Just) <|> Just (0, -1)
|
|
Just $ case u ^? uvWorld . hud . hudElement . diSections . ix i . ssItems . ix j of
|
|
Nothing -> u & uvWorld %~ scrollAugNextInSection
|
|
_ -> u
|
|
|
|
checkCombineSelectionExists :: Universe -> Universe
|
|
checkCombineSelectionExists u = fromMaybe u $ do
|
|
sss <- u ^? uvWorld . hud . hudElement . subInventory . ciSections
|
|
(i, j) <-
|
|
u ^? uvWorld . hud . hudElement . subInventory . ciSelection . _Just
|
|
<|> Just (0, 0)
|
|
Just $ case u ^? uvWorld . hud . hudElement . subInventory . ciSections . ix i . ssItems . ix j of
|
|
Nothing ->
|
|
u & uvWorld . hud . hudElement . subInventory . ciSelection ?~ (0,-1)
|
|
& uvWorld . hud . hudElement . subInventory . ciSelection
|
|
%~ scrollSelectionSections (-1) sss
|
|
_ -> u
|
|
|
|
displaySectionsSizes :: Int -> Int
|
|
displaySectionsSizes 0 = 10
|
|
displaySectionsSizes 3 = 10
|
|
displaySectionsSizes _ = 3
|
|
|
|
updateDisplaySections ::
|
|
World ->
|
|
Configuration ->
|
|
IM.IntMap (SelectionSection ()) ->
|
|
IM.IntMap (SelectionSection ())
|
|
updateDisplaySections w cfig =
|
|
updateSectionsPositioning
|
|
displaySectionsSizes
|
|
mselpos
|
|
(getAvailableListLines (invDisplayParams w) cfig)
|
|
addorder
|
|
where
|
|
mselpos = w ^? hud . hudElement . diSelection . _Just
|
|
addorder = case mselpos of
|
|
Just (-1, _) -> reverse [filtinv, filtclose, invx, youx, closex]
|
|
Just (0, _) -> reverse [filtinv, filtclose, invx, youx, closex]
|
|
Just (1, _) -> reverse [filtinv, filtclose, invx, youx, closex]
|
|
Just (2, _) -> reverse [filtinv, filtclose, closex, invx, youx]
|
|
Just (3, _) -> reverse [filtinv, filtclose, closex, invx, youx]
|
|
_ -> reverse [filtinv, filtclose, invx, closex, youx]
|
|
invfiltcurs = case mselpos ^? _Just . _1 of
|
|
Just (-1) -> [toEnum 219] -- filled rect
|
|
_ -> [toEnum 128] -- wire rect
|
|
(sfinv, sinv) =
|
|
filterSectionsPair invfiltcurs plainRegex invitems "INVENTORY" $
|
|
w ^? hud . hudElement . diInvFilter . _Just
|
|
(filtinv, invx) = ((-1, sfinv), (0, sinv))
|
|
closefiltcurs = case mselpos ^? _Just . _1 of
|
|
Just (2) -> [toEnum 219] -- filled rect
|
|
_ -> [toEnum 128] -- wire rect
|
|
(sfclose, sclose) =
|
|
filterSectionsPair closefiltcurs plainRegex closeitms "NEARBY" $
|
|
w ^? hud . hudElement . diCloseFilter . _Just
|
|
(filtclose, closex) = ((2, sfclose), (3, sclose))
|
|
youx = (1, youitems)
|
|
youitems = IM.singleton 0 $ SelectionItem [thetext] 1 True invDimColor 2 ()
|
|
thetext = displayFreeSlots (crNumFreeSlots cr)
|
|
closeitms =
|
|
IM.fromDistinctAscList . zip [0 ..] $
|
|
map closeObjectToSelectionItem (w ^. hud . closeObjects)
|
|
invitems =
|
|
IM.mapWithKey
|
|
(\k (indent, x) -> invSelectionItem indent cr k (x ^. locLDT . ldtValue))
|
|
(fmap (first removeindentiffiltering) . allInvLocs $ _crInv cr)
|
|
-- this clearly deserves refactoring, also check if drawInventory/iextra
|
|
-- needs it at the same time
|
|
removeindentiffiltering =
|
|
if maybe False isFilteringInv (w ^? hud . hudElement . diSections)
|
|
then const 0
|
|
else id
|
|
cr = you w
|
|
|
|
filterSectionsPair ::
|
|
String -> -- string at the end of the input
|
|
(String -> SelectionItem a -> Bool) ->
|
|
IM.IntMap (SelectionItem a) ->
|
|
String ->
|
|
Maybe String ->
|
|
(IM.IntMap (SelectionItem a), IM.IntMap (SelectionItem a))
|
|
filterSectionsPair endstr filtfn itms filtdescription mfilt =
|
|
( filtsis
|
|
, itms'
|
|
)
|
|
where
|
|
filtsis = fold $ do
|
|
str <- mfilt
|
|
return $
|
|
IM.singleton
|
|
0
|
|
$ SelectionInfo
|
|
[filtdescription ++ " FILTER/" ++ str ++ endstr, numfiltitems]
|
|
2
|
|
True
|
|
white
|
|
0
|
|
itms' = fromMaybe itms $ do
|
|
str <- mfilt
|
|
return $ IM.filter (filtfn str) 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 (SelectionSection a) ->
|
|
IM.IntMap Int
|
|
sectionsDesiredLines = fmap $ alaf Sum foldMap _siHeight . _ssItems
|
|
|
|
sectionsSizes ::
|
|
Int -> -- total available lines
|
|
(Int -> 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
|
|
IM.IntMap Int
|
|
sectionsSizes x f is sss = doSectionSize extraavailable mintaken is sss mempty
|
|
where
|
|
mintaken = IM.mapWithKey (\k y -> min (f k) y) 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 minimum size
|
|
Maybe (Int, Int) ->
|
|
Int ->
|
|
[(Int, IM.IntMap (SelectionItem a))] ->
|
|
IM.IntMap (SelectionSection a) ->
|
|
IM.IntMap (SelectionSection a)
|
|
updateSectionsPositioning f mselpos allavailablelines lsss sss =
|
|
IM.intersectionWith updateSection ls mss `h` ssizes `h` sss
|
|
where
|
|
mss = IM.mapWithKey m sss
|
|
m k _ = do
|
|
(k',i) <- mselpos
|
|
guard $ k == k'
|
|
return i
|
|
ls = IM.fromList lsss
|
|
h = IM.intersectionWith ($)
|
|
lk = fromMaybe [] $ fmap ((:[]) . fst) mselpos
|
|
ssizes = sectionsSizes allavailablelines f
|
|
lk $ sectionsDesiredLines $ IM.intersectionWith (set ssItems) ls sss
|
|
|
|
updateSection ::
|
|
IM.IntMap (SelectionItem a) ->
|
|
Maybe Int ->
|
|
Int ->
|
|
SelectionSection a ->
|
|
SelectionSection a
|
|
updateSection sis mcsel availablelines ss =
|
|
ss
|
|
& ssItems .~ sis
|
|
& ssOffset .~ offset
|
|
& ssShownItems .~ tweakfirst shownitems
|
|
where
|
|
oldoffset = ss ^. ssOffset
|
|
nocursoroffset =
|
|
if length allstrings - oldoffset <= availablelines
|
|
then max 0 (length allstrings - availablelines)
|
|
else oldoffset
|
|
offset = fromMaybe nocursoroffset $ do
|
|
csel <- mcsel
|
|
maxcsel <- fst <$> IM.lookupMax sis
|
|
si <- sis ^? ix csel
|
|
let xselsize = length $ _siPictures si
|
|
return $ case sum $ fmap (length . _siPictures) . fst . IM.split csel $ sis of
|
|
pos | pos == 0 || length allstrings <= availablelines -> 0
|
|
pos | pos - 1 < oldoffset -> pos - 1
|
|
pos | maxcsel == csel -> pos - availablelines + xselsize
|
|
pos | pos + 1 + xselsize - availablelines > oldoffset ->
|
|
pos - availablelines + 1 + xselsize
|
|
_ | length allstrings - oldoffset < availablelines ->
|
|
length allstrings - availablelines
|
|
_ -> oldoffset
|
|
tweakfirst (x : xs)
|
|
| offset > 0 =
|
|
color moreupcolor (text (theindent ++ replicate 15 (toEnum 30))) :
|
|
xs
|
|
| otherwise = x : xs
|
|
tweakfirst [] = []
|
|
moreupcolor = fromMaybe white $ allstrings ^? ix offset . _1
|
|
shownitems
|
|
| length shownstrings > availablelines =
|
|
map h (take (availablelines - 1) shownstrings)
|
|
++ [color moredowncolor . text $ theindent ++ replicate 15 (toEnum 31)]
|
|
| otherwise = map h shownstrings
|
|
moredowncolor = fromMaybe white $ allstrings ^? ix (offset + availablelines - 1) . _1
|
|
allstrings = listSelectionColorPicture sis
|
|
shownstrings = drop offset allstrings
|
|
h (_, str) = translate (fromIntegral (_ssIndent ss) * 100) 0 str
|
|
theindent = replicate (_ssIndent ss) ' '
|
|
|
|
listSelectionColorPicture :: Foldable t => t (SelectionItem a) -> [(Color, Picture)]
|
|
listSelectionColorPicture = foldMap f
|
|
where
|
|
f si = map g (_siPictures si)
|
|
where
|
|
indent = 100 * fromIntegral (_siOffX si)
|
|
g str = (_siColor si, translate indent 0 . color (_siColor si) $ text str)
|
|
|
|
enterCombineInv :: Configuration -> World -> World
|
|
enterCombineInv cfig w =
|
|
w & hud . hudElement . subInventory
|
|
.~ CombineInventory
|
|
{ _ciSections = sss
|
|
, _ciSelection = selpos
|
|
, _ciFilter = Nothing
|
|
}
|
|
& hud . hudElement . diInvFilter
|
|
.~ Nothing
|
|
where
|
|
cm' = IM.fromDistinctAscList . zip [0 ..] $ combineList w
|
|
cm
|
|
| null cm' = IM.singleton 0 $ SelectionInfo ["No possible combinations"] 1 False white 0
|
|
| otherwise = cm'
|
|
sss = IM.fromDistinctAscList [(-1, filtsection), (0, combsection)]
|
|
selpos
|
|
| null cm' = Nothing
|
|
| otherwise = Just (0, 0)
|
|
availablelines = getAvailableListLines secondColumnParams cfig
|
|
filtsection =
|
|
SelectionSection
|
|
{ _ssItems = mempty
|
|
-- , _ssMinSize = 0
|
|
, _ssOffset = 0
|
|
, _ssShownItems = mempty
|
|
, _ssIndent = 0
|
|
, _ssDescriptor = "COMB FILTER"
|
|
}
|
|
combsection =
|
|
updateSection
|
|
cm
|
|
(Just 0)
|
|
availablelines
|
|
SelectionSection
|
|
{ _ssItems = cm
|
|
-- , _ssMinSize = 5
|
|
, _ssOffset = 0
|
|
, _ssShownItems = mempty
|
|
, _ssIndent = 0
|
|
, _ssDescriptor = "COMBINATIONS"
|
|
}
|
|
|
|
regexList :: String -> [String] -> Bool
|
|
regexList x = any (isInfixOf x)
|