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