141 lines
4.5 KiB
Haskell
141 lines
4.5 KiB
Haskell
--{-# 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
|
|
LASWIDE _ -> 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 = []
|
|
| (not . all 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]]
|
|
CraftClust -> []
|
|
_ -> []
|
|
|
|
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)]
|