GraphvizShowPolarity.hs

-- GenI surface realiser
-- Copyright (C) 2005 Carlos Areces and Eric Kow
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License
-- as published by the Free Software Foundation; either version 2
-- of the License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
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
    -- we want a directed graph (arrows)
    graphvizShowGraph aut =
        DotGraph False True Nothing $ DotStmts
            atts
            (graphvizShowAsSubgraph "aut" aut)
            [] -- all nodes are in the subgraph
            []
     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])
        -- map which permits us to assign an id to a state
        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 -- Just (snd3 pr)
        , 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
    -- outgoing transition labels from st
    trans = Map.findWithDefault Map.empty st $ transitions aut
    -- returns the graphviz dot command to draw a labeled transition
    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
        --showSem (PolSt (_,pred,_) _ _) = pred
    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