Add various capabilities for generating graphs, fixes to lasgun

src/Dodge/Combine/Graph.hs

@@ -0,0 +1,139 @@
+--{-# LANGUAGE TypeSynonymInstances #-}
+--{-# LANGUAGE FlexibleInstances #-}
+module Dodge.Combine.Graph where
+import Dodge.Data hiding (East,West,North,South)
+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
+import Data.Bifunctor
+
+data CombClust
+    = CraftClust
+    | ItemClust
+    | JoinClust
+  deriving (Eq,Ord,Show,Enum,Bounded)
+
+newtype CombNode = CombNode {_unCombNode :: Either ItemBaseType [(IcAmount,ItemBaseType)]}
+  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)
+instance Labellable CombEdge where
+    toLabelValue (CombEdge 0) = StrLabel (pack "")
+    toLabelValue (CombEdge x) = StrLabel (pack $ show x)
+
+bulletCombinations :: [([(IcAmount,ItemBaseType)],Item)]
+bulletCombinations = filter 
+    ( (`elem` map totype bulletWeapons)
+    . totype
+    . snd
+    ) itemCombinations
+  where
+    totype = _iyBase . _itType
+
+maxShowX :: ItemBaseType -> Maybe Int
+maxShowX bt = case bt of
+    BANGSTICK _ -> Just 2
+    REVOLVERX _ -> Just 1
+    VOLLEYGUN _ -> Just 3
+    MINIGUNX  _ -> Just 3
+    GRAPECANNON _ -> Just 1
+    LAUNCHERX _ -> Just 2
+--    LASGUNWIDE _ -> Just 2
+--    LASGUNFOCUS _ -> Just 2
+    _ -> Nothing
+
+itemCombinationsEdges :: [(CombNode,CombNode,Int)]
+itemCombinationsEdges = concatMap (f . over _2 (_iyBase . _itType)) itemCombinations
+--itemCombinationsEdges = concatMap (f . over _2 (_iyBase . _itType)) bulletCombinations
+  where
+    f (abts,bt) 
+        | bt `elem` bts = []
+        | any (not . belowNumX) bts = []
+        | 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,_toInt am)
+
+combinationsGraph :: FGL.Gr CombNode CombEdge
+combinationsGraph = FGL.labnfilter (f . _unCombNode . snd) 
+    . second CombEdge $ mkGraphFromEdges itemCombinationsEdges
+  where
+    f Right {} = True
+    f (Left (CRAFT _)) = False
+    f (Left bt) = case maxShowX bt of
+        Nothing -> True
+        Just i -> _xNum bt <= i
+
+belowNumX :: ItemBaseType -> Bool
+belowNumX bt = case maxShowX bt of
+    Nothing -> True
+    Just i -> _xNum bt <= i
+
+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
+--    $ 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
+
+setClusterID :: CombClust -> GraphID
+setClusterID = Num . Int . fromEnum
+
+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]]
+    _ -> []
+
+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
+        , TailPort (CompassPoint East)
+        ]
+    _ -> [ 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
+    --CRAFT _ -> [Shape DiamondShape,toLabel (CombNode cn)]
+    CRAFT _ -> [Color [WC (X11Color Green) Nothing],toLabel (CombNode cn)]
+    _ -> [Shape BoxShape,toLabel (CombNode cn)]