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

Cleanup

Browse Source
This commit is contained in:
justin
2024-11-17 13:03:46 +00:00
parent 5b6c356bab
commit d5be125a3b
13 changed files with 156 additions and 169 deletions
Download Patch File Download Diff File Expand all files Collapse all files
ghcidOutput
+1 -5
View File
@@ -1,5 +1 @@
/home/justin/Haskell/loop/src/Dodge/Menu/Option.hs:53:35-41: warning: [-Wunused-matches] All good (594 modules, at 13:03:38)
Defined but not used: ‘mselpos’
|
53 | makeOptionsSelectionList maxlines mselpos u mos pmo =
| ^^^^^^^
src/Dodge/Combine/Graph.hs
+75 -62
View File
@@ -1,73 +1,82 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Dodge.Combine.Graph where
import Dodge.Data.Item
import Dodge.Combine.Combinations
import LensHelp
import GraphHelp
import Data.Text (Text) module Dodge.Combine.Graph
import Data.Text.Lazy (toStrict,pack) ( combinationsDotGraph
import qualified Data.Graph.Inductive as FGL ) where
import GraphVizHelp
import Data.GraphViz.Attributes.Complete
import Data.Bifunctor import Data.Bifunctor
import qualified Data.Graph.Inductive as FGL
import Data.GraphViz.Attributes.Complete
import Data.Text (Text)
import Data.Text.Lazy (pack, toStrict)
import Dodge.Combine.Combinations
import Dodge.Data.Item
import GraphHelp
import GraphVizHelp
import LensHelp
data CombClust data CombClust
= CraftClust = CraftClust
| ItemClust | ItemClust
| JoinClust | JoinClust
deriving (Eq,Ord,Show,Enum,Bounded) deriving (Eq, Ord, Show, Enum, Bounded)
newtype CombNode = CombNode {_unCombNode :: Either ItemType [(ItAmount,ItemType)]} newtype CombNode = CombNode {_unCombNode :: Either ItemType [(ItAmount, ItemType)]}
deriving (Eq,Ord,Show) deriving (Eq, Ord, Show)
instance Labellable CombNode where instance Labellable CombNode where
toLabelValue (CombNode Right{}) = StrLabel (pack "") toLabelValue (CombNode Right{}) = StrLabel (pack "")
toLabelValue (CombNode (Left ibt)) = StrLabel (pack $ show ibt) toLabelValue (CombNode (Left ibt)) = StrLabel (pack $ show ibt)
newtype CombEdge = CombEdge {_unCombEdge :: Int} newtype CombEdge = CombEdge {_unCombEdge :: Int}
deriving (Eq,Ord,Show) deriving (Eq, Ord, Show)
instance Labellable CombEdge where instance Labellable CombEdge where
toLabelValue (CombEdge 0) = StrLabel (pack "") toLabelValue (CombEdge 0) = StrLabel (pack "")
toLabelValue (CombEdge x) = StrLabel (pack $ show x) toLabelValue (CombEdge x) = StrLabel (pack $ show x)
bulletCombinations :: [([(ItAmount,ItemType)],Item)] --bulletCombinations :: [([(ItAmount, ItemType)], Item)]
bulletCombinations = filter --bulletCombinations =
( (`elem` map totype bulletWeapons) -- filter
. totype -- ( (`elem` map totype bulletWeapons)
. snd -- . totype
) itemCombinations -- . snd
where -- )
totype = _itType -- itemCombinations
-- where
-- totype = _itType
maxShowX :: ItemType -> Maybe Int maxShowX :: ItemType -> Maybe Int
maxShowX = \case maxShowX = \case
HELD (BANGSTICK _) -> Just 2 HELD (BANGSTICK _) -> Just 2
HELD (VOLLEYGUN _) -> Just 3 HELD (VOLLEYGUN _) -> Just 3
HELD (MINIGUNX _) -> Just 3 HELD (MINIGUNX _) -> Just 3
HELD (GRAPECANNON _) -> Just 1 HELD (GRAPECANNON _) -> Just 1
HELD (LAUNCHERX _) -> Just 2 HELD (LAUNCHERX _) -> Just 2
-- HELD (LASWIDE _) -> Just 2 -- HELD (LASWIDE _) -> Just 2
-- LASGUNFOCUS _ -> Just 2 -- LASGUNFOCUS _ -> Just 2
_ -> Nothing _ -> Nothing
itemCombinationsEdges :: [(CombNode,CombNode,Int)] itemCombinationsEdges :: [(CombNode, CombNode, Int)]
itemCombinationsEdges = concatMap (f . over _2 _itType) itemCombinations itemCombinationsEdges = concatMap (f . over _2 _itType) itemCombinations
--itemCombinationsEdges = concatMap (f . over _2 (_iyBase . _itType)) bulletCombinations
where where
f (abts,bt) --itemCombinationsEdges = concatMap (f . over _2 (_iyBase . _itType)) bulletCombinations
f (abts, bt)
| bt `elem` bts = [] | bt `elem` bts = []
| (not . all belowNumX) bts = [] | (not . all belowNumX) bts = []
| otherwise = (CombNode $ Right abts,CombNode $ Left bt,0) : map g abts | otherwise = (CombNode $ Right abts, CombNode $ Left bt, 0) : map g abts
where where
bts = map snd abts bts = map snd abts
g (am,bt') = (CombNode $ Left bt',CombNode $ Right abts,_getItAmount am) g (am, bt') = (CombNode $ Left bt', CombNode $ Right abts, _getItAmount am)
combinationsGraph :: FGL.Gr CombNode CombEdge combinationsGraph :: FGL.Gr CombNode CombEdge
combinationsGraph = FGL.labnfilter (f . _unCombNode . snd) combinationsGraph =
. second CombEdge $ mkGraphFromEdges itemCombinationsEdges FGL.labnfilter (f . _unCombNode . snd)
. second CombEdge
$ mkGraphFromEdges itemCombinationsEdges
where where
f Right {} = True f Right{} = True
f (Left (CRAFT _)) = False f (Left (CRAFT _)) = False
f (Left bt) = case maxShowX bt of f (Left bt) = case maxShowX bt of
Nothing -> True Nothing -> True
@@ -78,61 +87,65 @@ belowNumX bt = case maxShowX bt of
Nothing -> True Nothing -> True
Just i -> _xNum (_ibtHeld bt) <= i Just i -> _xNum (_ibtHeld bt) <= i
toCombNodeLabel :: CombNode -> String --toCombNodeLabel :: CombNode -> String
toCombNodeLabel (CombNode (Left ibt)) = show ibt --toCombNodeLabel (CombNode (Left ibt)) = show ibt
toCombNodeLabel (CombNode Right{}) = "" --toCombNodeLabel (CombNode Right{}) = ""
combinationsDotGraph :: Text combinationsDotGraph :: Text
--combinationsDotGraph = toStrict . printDotGraph . graphToDot nonClusteredParams $ combinationsGraph --combinationsDotGraph = toStrict . printDotGraph . graphToDot nonClusteredParams $ combinationsGraph
combinationsDotGraph = toStrict . printDotGraph . graphToDot myParams combinationsDotGraph =
$ combinationsGraph toStrict . printDotGraph . graphToDot myParams $
combinationsGraph
-- $ first toCombNodeLabel combinationsGraph -- $ first toCombNodeLabel combinationsGraph
myParams :: GraphvizParams Int CombNode CombEdge CombClust CombNode myParams :: GraphvizParams Int CombNode CombEdge CombClust CombNode
myParams = defaultParams -- {globalAttributes = [GraphAttrs [RankDir FromLeft]]} myParams =
& isDirectedL .~ True defaultParams -- {globalAttributes = [GraphAttrs [RankDir FromLeft]]}
-- & globalAttributesL .~ [GraphAttrs [RankDir FromLeft,Splines PolyLine]] & isDirectedL .~ True
& globalAttributesL .~ [GraphAttrs [RankDir FromLeft]] -- & globalAttributesL .~ [GraphAttrs [RankDir FromLeft,Splines PolyLine]]
& clusterByL .~ clusterFunc & globalAttributesL .~ [GraphAttrs [RankDir FromLeft]]
& isDotClusterL .~ const False & clusterByL .~ clusterFunc
& clusterIDL .~ setClusterID & isDotClusterL .~ const False
& fmtClusterL .~ clusterFormatting & clusterIDL .~ setClusterID
& fmtEdgeL .~ edgeFormatting & fmtClusterL .~ clusterFormatting
& fmtNodeL .~ nodeFormatting & fmtEdgeL .~ edgeFormatting
& fmtNodeL .~ nodeFormatting
setClusterID :: CombClust -> GraphID setClusterID :: CombClust -> GraphID
setClusterID = Num . Int . fromEnum setClusterID = Num . Int . fromEnum
clusterFunc :: (Int,CombNode) -> NodeCluster CombClust (Int,CombNode) clusterFunc :: (Int, CombNode) -> NodeCluster CombClust (Int, CombNode)
clusterFunc n@(_,CombNode (Left bt)) = case bt of clusterFunc n@(_, CombNode (Left bt)) = case bt of
CRAFT _ -> C CraftClust (N n) CRAFT _ -> C CraftClust (N n)
_ -> C ItemClust (N n) _ -> C ItemClust (N n)
clusterFunc n = C JoinClust (N n) clusterFunc n = C JoinClust (N n)
clusterFormatting :: CombClust -> [GlobalAttributes] clusterFormatting :: CombClust -> [GlobalAttributes]
clusterFormatting cl = case cl of clusterFormatting cl = case cl of
-- CraftClust -> [GraphAttrs [Rank SameRank]] -- CraftClust -> [GraphAttrs [Rank SameRank]]
CraftClust -> [] CraftClust -> []
_ -> [] _ -> []
edgeFormatting :: (Int,Int,CombEdge) -> Attributes edgeFormatting :: (Int, Int, CombEdge) -> Attributes
--edgeFormatting (_,_,CombEdge 0) = [] --edgeFormatting (_,_,CombEdge 0) = []
-- [ArrowHead (AType [(ArrMod OpenArrow BothSides ,NoArrow)]) -- [ArrowHead (AType [(ArrMod OpenArrow BothSides ,NoArrow)])
-- ,SameTail (pack "b") -- ,SameTail (pack "b")
-- ] -- ]
edgeFormatting (_,_,ce) = case _unCombEdge ce of edgeFormatting (_, _, ce) = case _unCombEdge ce of
0 -> [ xLabel ce 0 ->
[ xLabel ce
, TailPort (CompassPoint East) , TailPort (CompassPoint East)
] ]
_ -> [ xLabel ce _ ->
, ArrowHead (AType [(ArrMod OpenArrow BothSides ,NoArrow)]) [ xLabel ce
, ArrowHead (AType [(ArrMod OpenArrow BothSides, NoArrow)])
, HeadPort (CompassPoint West) , HeadPort (CompassPoint West)
] ]
nodeFormatting :: (Int, CombNode) -> Attributes
nodeFormatting :: (Int,CombNode) -> Attributes nodeFormatting (_, CombNode Right{}) = [Shape PointShape]
nodeFormatting (_,CombNode Right {}) = [Shape PointShape] nodeFormatting (_, CombNode cn@(Left bt)) = case bt of
nodeFormatting (_,CombNode cn@(Left bt)) = case bt of
--CRAFT _ -> [Shape DiamondShape,toLabel (CombNode cn)] --CRAFT _ -> [Shape DiamondShape,toLabel (CombNode cn)]
CRAFT _ -> [Color [WC (X11Color Green) Nothing],toLabel (CombNode cn)] CRAFT _ -> [Color [WC (X11Color Green) Nothing], toLabel (CombNode cn)]
_ -> [Shape BoxShape,toLabel (CombNode cn)] _ -> [Shape BoxShape, toLabel (CombNode cn)]
src/Dodge/Concurrent.hs
+16 -17
View File
@@ -1,30 +1,28 @@
module Dodge.Concurrent module Dodge.Concurrent (
( hardQuit hardQuit,
, addSideEffect addSideEffect,
, conEffects conEffects,
, blockingLoad blockingLoad,
) where ) where
--import qualified Data.Set as S import Data.Sequence (Seq (..))
import Dodge.Data.Universe
import Dodge.Menu.Loading import Dodge.Menu.Loading
import LensHelp import LensHelp
import Dodge.Data.Universe
import Data.Sequence (Seq (..))
--import Control.Concurrent
--import SDL.Input.Keyboard.Codes
conEffects :: Universe -> ConcurrentEffect Universe conEffects :: Universe -> ConcurrentEffect Universe
conEffects u = case u ^? uvSideEffects . _head of conEffects u = case u ^? uvSideEffects . _head of
Just NewSideEffect{_ceSideEffect = eff} -> ConcurrentEffect (u & uvSideEffects . _head %~ g) Just NewSideEffect{_ceSideEffect = eff} ->
(dopop eff) ConcurrentEffect
(u & uvSideEffects . _head %~ g)
(dopop eff)
Just HardQuit -> ImmediateEffect (return Nothing) Just HardQuit -> ImmediateEffect (return Nothing)
_ -> NoConcurrentEffect _ -> NoConcurrentEffect
where where
g seff = RunningSideEffect (_ceString seff) g seff = RunningSideEffect (_ceString seff)
dopop :: IO (Universe -> Maybe Universe) -> IO (Universe -> Maybe Universe) dopop :: IO (Universe -> Maybe Universe) -> IO (Universe -> Maybe Universe)
dopop mf = do dopop mf = do
f <- mf f <- mf
return $ f . (uvSideEffects %~ taker) return $ f . (uvSideEffects %~ taker)
taker (_ :<| xs) = xs taker (_ :<| xs) = xs
taker _ = mempty taker _ = mempty
@@ -36,8 +34,9 @@ hardQuit :: Universe -> Universe
hardQuit = uvSideEffects %~ (HardQuit <|) hardQuit = uvSideEffects %~ (HardQuit <|)
blockingLoad :: String -> IO (Universe -> Maybe Universe) -> Universe -> Universe blockingLoad :: String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
blockingLoad str f u = u & uvScreenLayers .:~ loadingScreen str blockingLoad str f u =
& addSideEffect f str u & uvScreenLayers .:~ loadingScreen str
& addSideEffect f str
--hardQuit = addSideEffect (return $ const Nothing) "QUITTING" --hardQuit = addSideEffect (return $ const Nothing) "QUITTING"
src/Dodge/Data/SelectionList.hs
-6
View File
@@ -21,11 +21,6 @@ data CursorDisplay
= BoundaryCursor {_cursSides :: [CardinalPoint]} = BoundaryCursor {_cursSides :: [CardinalPoint]}
| BackdropCursor | BackdropCursor
data SelectionList a = SelectionList
{ _slItems :: [SelectionItem a]
-- , _slSelPos :: Maybe Int
}
data SectionCursor = SectionCursor data SectionCursor = SectionCursor
{ _scurPos :: Int { _scurPos :: Int
, _scurSize :: Int , _scurSize :: Int
@@ -66,7 +61,6 @@ data SelectionItem a
} }
makeLenses ''ListDisplayParams makeLenses ''ListDisplayParams
makeLenses ''SelectionList
makeLenses ''SelectionItem makeLenses ''SelectionItem
makeLenses ''SelectionSection makeLenses ''SelectionSection
makeLenses ''SectionCursor makeLenses ''SectionCursor
src/Dodge/Data/Universe.hs
+1 -1
View File
@@ -81,7 +81,7 @@ data ScreenLayer
, _scOffset :: Int , _scOffset :: Int
, _scPositionedMenuOption :: EscapeMenuOption , _scPositionedMenuOption :: EscapeMenuOption
, _scOptionFlag :: OptionScreenFlag , _scOptionFlag :: OptionScreenFlag
, _scSelectionList :: SelectionList (Universe -> Universe,Universe->Universe) , _scSelectionList :: [SelectionItem (Universe -> Universe,Universe->Universe)]
, _scAvailableLines :: Int , _scAvailableLines :: Int
, _scListDisplayParams :: ListDisplayParams , _scListDisplayParams :: ListDisplayParams
, _scDisplayTime :: Int , _scDisplayTime :: Int
src/Dodge/Default/SelectionList.hs
-8
View File
@@ -1,8 +0,0 @@
module Dodge.Default.SelectionList where
import Dodge.Data.SelectionList
defaultSelectionList :: SelectionList a
defaultSelectionList = SelectionList
{_slItems = mempty
}
src/Dodge/Menu/Loading.hs
+16 -14
View File
@@ -1,18 +1,20 @@
module Dodge.Menu.Loading where module Dodge.Menu.Loading (
loadingScreen,
) where
import Dodge.ListDisplayParams
import Dodge.Default.SelectionList
import Dodge.Data.Universe import Dodge.Data.Universe
import Dodge.ListDisplayParams
loadingScreen :: String -> ScreenLayer loadingScreen :: String -> ScreenLayer
loadingScreen str = OptionScreen loadingScreen str =
{ _scTitle = str OptionScreen
, _scOptions = [] { _scTitle = str
, _scOffset = 0 , _scOptions = []
, _scPositionedMenuOption = NoEscapeMenuOption , _scOffset = 0
, _scOptionFlag = LoadingScreen , _scPositionedMenuOption = NoEscapeMenuOption
, _scSelectionList = defaultSelectionList , _scOptionFlag = LoadingScreen
, _scAvailableLines = 0 , _scSelectionList = []
, _scListDisplayParams = optionListDisplayParams , _scAvailableLines = 0
, _scDisplayTime = 0 , _scListDisplayParams = optionListDisplayParams
} , _scDisplayTime = 0
}
src/Dodge/Menu/Option.hs
+35 -41
View File
@@ -1,17 +1,21 @@
module Dodge.Menu.Option where module Dodge.Menu.Option (
initializeOptionMenu,
refreshOptionsSelectionList,
initializeOptionMenuBO,
) where
import Dodge.ListDisplayParams
import Control.Applicative import Control.Applicative
import Data.Maybe import Data.Maybe
import Dodge.Data.SelectionList import Dodge.Data.SelectionList
import Dodge.Data.Universe import Dodge.Data.Universe
import Dodge.Default.SelectionList import Dodge.ListDisplayParams
import Dodge.SelectionList import Dodge.SelectionList
import LensHelp import LensHelp
import Padding import Padding
import Picture.Base import Picture.Base
initializeOptionMenu :: String -> [MenuOption] -> EscapeMenuOption -> Universe -> ScreenLayer initializeOptionMenu ::
String -> [MenuOption] -> EscapeMenuOption -> Universe -> ScreenLayer
initializeOptionMenu title ops pmo u = initializeOptionMenu title ops pmo u =
OptionScreen OptionScreen
{ _scTitle = title { _scTitle = title
@@ -19,14 +23,15 @@ initializeOptionMenu title ops pmo u =
, _scOffset = 0 , _scOffset = 0
, _scPositionedMenuOption = pmo , _scPositionedMenuOption = pmo
, _scOptionFlag = NormalOptions , _scOptionFlag = NormalOptions
, _scSelectionList = makeOptionsSelectionList 10 (Just 0) u ops pmo , _scSelectionList = optionsToSelections 10 u ops pmo
, _scAvailableLines = getAvailableListLines optionListDisplayParams (u ^. uvConfig) , _scAvailableLines = getAvailableListLines optionListDisplayParams (u ^. uvConfig)
, _scListDisplayParams = optionListDisplayParams , _scListDisplayParams = optionListDisplayParams
, _scDisplayTime = 0 , _scDisplayTime = 0
} }
-- BO = Bottom Option -- BO = Bottom Option
initializeOptionMenuBO :: String -> [MenuOption] -> String -> (Universe -> Universe) -> Universe -> ScreenLayer initializeOptionMenuBO ::
String -> [MenuOption] -> String -> (Universe -> Universe) -> Universe -> ScreenLayer
initializeOptionMenuBO title ops str eff = initializeOptionMenu title ops pmo initializeOptionMenuBO title ops str eff = initializeOptionMenu title ops pmo
where where
pmo = BottomEscapeMenuOption $ (Toggle eff . const . MODString) str pmo = BottomEscapeMenuOption $ (Toggle eff . const . MODString) str
@@ -40,22 +45,9 @@ refreshOptionsSelectionList u = u & uvScreenLayers . ix 0 %~ f
, _scPositionedMenuOption = pmo , _scPositionedMenuOption = pmo
, _scAvailableLines = maxlines , _scAvailableLines = maxlines
} -> } ->
sl & scSelectionList . slItems .~ optionsToSelections maxlines u mops pmo sl & scSelectionList .~ optionsToSelections maxlines u mops pmo
_ -> sl _ -> sl
makeOptionsSelectionList ::
Int ->
Maybe Int ->
Universe ->
[MenuOption] ->
EscapeMenuOption ->
SelectionList (Universe -> Universe, Universe -> Universe)
makeOptionsSelectionList maxlines mselpos u mos pmo =
defaultSelectionList
{ _slItems = optionsToSelections maxlines u mos pmo
-- , _slSelPos = mselpos
}
optionsToSelections :: optionsToSelections ::
Int -> Int ->
Universe -> Universe ->
@@ -72,8 +64,10 @@ optionsToSelections maxlines u allops pmo = case pmo of
| maxlines >= length allops = allops | maxlines >= length allops = allops
| otherwise = take (maxlines - 2) (drop offset allops ++ repeat dummyMenuOption) ++ [cycleOptionsOption] | otherwise = take (maxlines - 2) (drop offset allops ++ repeat dummyMenuOption) ++ [cycleOptionsOption]
maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops) maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops)
cycleOptionsOption = Toggle cycleOptions cycleOptionsOption =
(const (MODString ("MORE OPTIONS " ++ show n ++ "/" ++ show m))) Toggle
cycleOptions
(const (MODString ("MORE OPTIONS " ++ show n ++ "/" ++ show m)))
l = length allops l = length allops
m = div (l - 1) (max 1 (maxlines - 2)) + 1 m = div (l - 1) (max 1 (maxlines - 2)) + 1
n = div (offset + 1) (max 1 (maxlines - 2)) + 1 n = div (offset + 1) (max 1 (maxlines - 2)) + 1
@@ -92,16 +86,16 @@ cycleOptions u = fromMaybe u $ do
| l + curoff >= n = 0 | l + curoff >= n = 0
| otherwise = l + curoff | otherwise = l + curoff
colStrToSelItem :: (Color, String) -> SelectionItem (Universe -> Universe) --colStrToSelItem :: (Color, String) -> SelectionItem (Universe -> Universe)
colStrToSelItem (col, str) = --colStrToSelItem (col, str) =
SelectionItem -- SelectionItem
{ _siPictures = [str] -- { _siPictures = [str]
, _siHeight = 1 -- , _siHeight = 1
, _siIsSelectable = True -- , _siIsSelectable = True
, _siColor = col -- , _siColor = col
, _siOffX = 0 -- , _siOffX = 0
, _siPayload = id -- , _siPayload = id
} -- }
optionValueOffset :: Universe -> MenuOption -> Int optionValueOffset :: Universe -> MenuOption -> Int
optionValueOffset u mo = case _moString mo u of optionValueOffset u mo = case _moString mo u of
@@ -135,12 +129,12 @@ menuOptionToSelectionItem w padAmount mo =
MODStringOption s t -> rightPad padAmount '.' s ++ t MODStringOption s t -> rightPad padAmount '.' s ++ t
x -> _modString x x -> _modString x
menuOptionToString :: Universe -> Int -> MenuOption -> (Color, String) --menuOptionToString :: Universe -> Int -> MenuOption -> (Color, String)
menuOptionToString w padAmount mo = (thecol, optionText) --menuOptionToString w padAmount mo = (thecol, optionText)
where -- where
thecol = case _moString mo w of -- thecol = case _moString mo w of
MODBlockedString{} -> greyN 0.5 -- MODBlockedString{} -> greyN 0.5
_ -> white -- _ -> white
optionText = case _moString mo w of -- optionText = case _moString mo w of
MODStringOption s t -> rightPad padAmount '.' s ++ t -- MODStringOption s t -> rightPad padAmount '.' s ++ t
x -> _modString x -- x -> _modString x
src/Dodge/Render/HUD.hs
+3 -5
View File
@@ -24,7 +24,6 @@ import Dodge.Data.Config
import Dodge.Data.DoubleTree import Dodge.Data.DoubleTree
import Dodge.Data.SelectionList import Dodge.Data.SelectionList
import Dodge.Data.World import Dodge.Data.World
import Dodge.Default.SelectionList
import Dodge.DoubleTree import Dodge.DoubleTree
import Dodge.Equipment.Text import Dodge.Equipment.Text
import Dodge.Inventory import Dodge.Inventory
@@ -180,15 +179,14 @@ drawExamineInventory cfig w =
<> drawSelectionList <> drawSelectionList
secondColumnParams secondColumnParams
cfig cfig
( defaultSelectionList & slItems ( (map f
.~ map f
( makeParagraph 55 $ ( makeParagraph 55 $
yourAugmentedItem yourAugmentedItem
itemInfo itemInfo
(yourInfo (you w)) (yourInfo (you w))
(closeObjectInfo (crNumFreeSlots (you w))) (closeObjectInfo (crNumFreeSlots (you w)))
w w
) ))
) )
where where
f str = f str =
@@ -359,7 +357,7 @@ drawTerminalDisplay tid cfig w = fromMaybe mempty $ do
<> color (dark $ _tmExternalColor tm) (drawTitleBackground cfig) <> color (dark $ _tmExternalColor tm) (drawTitleBackground cfig)
where where
toselitm (str, col) = SelectionItem [str] 1 True col 0 () toselitm (str, col) = SelectionItem [str] 1 True col 0 ()
thesellist tm = defaultSelectionList & slItems .~ thelist tm thesellist tm = thelist tm
thelist tm = thelist tm =
map toselitm . displayTermInput tm map toselitm . displayTermInput tm
. reverse . reverse
src/Dodge/Render/List.hs
+3 -3
View File
@@ -31,7 +31,7 @@ import LensHelp
import ListHelp import ListHelp
import Picture import Picture
drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList a -> Picture drawSelectionList :: ListDisplayParams -> Configuration -> [SelectionItem a] -> Picture
drawSelectionList ldps cfig sl = drawSelectionList ldps cfig sl =
translateScreenPos cfig (ldps ^. ldpPos) $ translateScreenPos cfig (ldps ^. ldpPos) $
drawListYgapScaleYoff drawListYgapScaleYoff
@@ -59,8 +59,8 @@ drawSelectionListBackground ldp cfig l = translateScreenPos cfig (ldp ^. ldpPos)
s = - (5 + fromIntegral l * (20 * ldp ^. ldpScale + ldp ^. ldpVerticalGap)) s = - (5 + fromIntegral l * (20 * ldp ^. ldpScale + ldp ^. ldpVerticalGap))
e = 555 -- HACK isOverTerminalScreen e = 555 -- HACK isOverTerminalScreen
makeSelectionListPictures :: SelectionList a -> [Picture] makeSelectionListPictures :: [SelectionItem a] -> [Picture]
makeSelectionListPictures = concatMap f . _slItems makeSelectionListPictures = concatMap f
where where
f si = map (color (_siColor si) . text) $ _siPictures si f si = map (color (_siColor si) . text) $ _siPictures si
src/Dodge/Render/MenuScreen.hs
+2 -2
View File
@@ -38,7 +38,7 @@ drawOptions ::
-- | Title -- | Title
String -> String ->
Maybe Int -> Maybe Int ->
SelectionList a -> [SelectionItem a] ->
Picture Picture
drawOptions ldps cfig title msel sl = drawOptions ldps cfig title msel sl =
darkenBackground cfig darkenBackground cfig
@@ -46,7 +46,7 @@ drawOptions ldps cfig title msel sl =
<> drawSelectionList ldps cfig sl <> drawSelectionList ldps cfig sl
<> translateScreenPos cfig (ldps ^. ldpPos) (drawCursorAt <> translateScreenPos cfig (ldps ^. ldpPos) (drawCursorAt
msel msel
(sl ^. slItems) sl
ldps ldps
(BoundaryCursor [North, South]) (BoundaryCursor [North, South])
) )
src/Dodge/Update.hs
+2 -3
View File
@@ -401,16 +401,15 @@ updateMouseContext cfig u =
[] -> NoMouseContext [] -> NoMouseContext
_ -> fromMaybe MouseMenuCursor $ do _ -> fromMaybe MouseMenuCursor $ do
ldps <- screen ^? scListDisplayParams ldps <- screen ^? scListDisplayParams
let ymax = maybe 0 length $ screen ^? scSelectionList . slItems let ymax = maybe 0 length $ screen ^? scSelectionList
yi <- ldpVerticalSelection (u ^. uvConfig) ldps (u ^. uvWorld . input . mousePos) yi <- ldpVerticalSelection (u ^. uvConfig) ldps (u ^. uvWorld . input . mousePos)
-- guard $ mmoving || (_scDisplayTime screen <= 1)
guard (yi >= 0 && yi < ymax) guard (yi >= 0 && yi < ymax)
return $ if isselectable yi return $ if isselectable yi
then MouseMenuClick yi then MouseMenuClick yi
else NoMouseContext else NoMouseContext
isselectable yi = isselectable yi =
fromMaybe False $ fromMaybe False $
u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yi . siIsSelectable u ^? uvScreenLayers . _head . scSelectionList . ix yi . siIsSelectable
-- mmoving = u ^. uvWorld . input . mouseMoving -- mmoving = u ^. uvWorld . input . mouseMoving
w = u ^. uvWorld w = u ^. uvWorld
aimcontext aimcontext
src/Dodge/Update/Input/ScreenLayer.hs
+2 -2
View File
@@ -62,12 +62,12 @@ mouseClickOptionsList u = fromMaybe u $ do
Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
Just 0 -> fromMaybe u $ do Just 0 -> fromMaybe u $ do
i <- u ^? uvWorld . input . mouseContext . mcoMenuClick i <- u ^? uvWorld . input . mouseContext . mcoMenuClick
f <- sl ^? slItems . ix i . siPayload . _1 f <- sl ^? ix i . siPayload . _1
return $ f u return $ f u
_ -> case u ^. uvWorld . input . mouseButtons . at ButtonRight of _ -> case u ^. uvWorld . input . mouseButtons . at ButtonRight of
Just 0 -> fromMaybe u $ do Just 0 -> fromMaybe u $ do
i <- u ^? uvWorld . input . mouseContext . mcoMenuClick i <- u ^? uvWorld . input . mouseContext . mcoMenuClick
f <- sl ^? slItems . ix i . siPayload . _2 f <- sl ^? ix i . siPayload . _2
return $ f u return $ f u
_ -> u _ -> u