module NLP.GenI.GraphvizShowPolarity
where
import Data.List (intercalate)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import qualified Data.Text.Lazy as TL
import Data.GraphViz
import Data.GraphViz.Attributes.Complete
import NLP.GenI.General (showInterval)
import NLP.GenI.Graphviz (GraphvizShow (..),
gvUnlines)
import NLP.GenI.Polarity (NFA (states, transitions),
PolAut, PolState (PolSt),
finalSt)
import NLP.GenI.Pretty
import NLP.GenI.Tag (idname)
instance GraphvizShow PolAut where
graphvizShowGraph aut =
DotGraph False True Nothing $ DotStmts
atts
(graphvizShowAsSubgraph "aut" aut)
[]
[]
where
atts =
[ GraphAttrs [RankDir FromLeft, RankSep [0.02], Pack (PackMargin 1)]
, NodeAttrs [FontSize 10]
, EdgeAttrs [FontSize 10]
]
graphvizShowAsSubgraph prefix aut =
[ DotSG False Nothing
$ DotStmts [ NodeAttrs [ Shape Ellipse, Peripheries 1 ] ]
[]
(zipWith (gvShowState fin) ids st)
(concat $ zipWith (gvShowTrans aut stmap) ids st)
]
where
st = (concat.states) aut
fin = finalSt aut
ids = map (\x -> prefix <> TL.pack (show x)) ([0..] :: [Int])
stmap = Map.fromList $ zip st ids
gvShowState :: [PolState] -> TL.Text -> PolState -> DotNode TL.Text
gvShowState fin stId st =
DotNode stId $ decorate [ Label . StrLabel . showSt $ st ]
where
showSt (PolSt _ ex po) = gvUnlines . catMaybes $
[ Nothing
, if null ex then Nothing else Just (TL.fromChunks [pretty ex])
, Just . TL.pack . intercalate "," $ map showInterval po
]
decorate =
if st `elem` fin then (Peripheries 2 :) else id
gvShowTrans :: PolAut -> Map.Map PolState TL.Text
-> TL.Text -> PolState -> [DotEdge TL.Text]
gvShowTrans aut stmap idFrom st =
map drawTrans (Map.toList trans)
where
trans = Map.findWithDefault Map.empty st $ transitions aut
drawTrans (stTo,x) =
case Map.lookup stTo stmap of
Nothing -> drawTrans' ("id_error_" `TL.append` (TL.pack (sem_ stTo))) x
Just idTo -> drawTrans' idTo x
where
sem_ (PolSt i _ _) = show i
drawTrans' idTo x = DotEdge idFrom idTo [Label (drawLabel x)]
drawLabel labels =
StrLabel . gvUnlines $ labs
where
lablen = length labels
maxlabs = 6
excess = TL.pack $ "...and " ++ show (lablen maxlabs) ++ " more"
name t = TL.fromChunks [ idname t ]
labstrs = map (maybe "EMPTY" name) labels
labs = if lablen > maxlabs
then take maxlabs labstrs ++ [ excess ]
else labstrs