{-# OPTIONS_GHC -Wall #-}
module DatabaseDesign.Ampersand.Fspec.Graphic.Graphics 
          (Dotable(..), makePictureObj, printDotGraph, DrawingType(..)
    --      ,GraphvizCommand(..)
    --      ,GraphvizOutput(..)
    --      ,runGraphvizCommand) 
    )where
-- TODO url links for atlas

import Data.GraphViz hiding (addExtension )
import DatabaseDesign.Ampersand.ADL1 
import DatabaseDesign.Ampersand.Fspec.Fspec
import DatabaseDesign.Ampersand.Classes 
import DatabaseDesign.Ampersand.Fspec.Switchboard
import DatabaseDesign.Ampersand.Misc
import DatabaseDesign.Ampersand.Basics (fatalMsg,eqCl,Collection(..),Identified(..))
import DatabaseDesign.Ampersand.Fspec.Graphic.Picture
import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram (ClassDiag,classdiagram2dot)
import Data.GraphViz.Attributes.Complete
import Data.List (nub)
import Data.String

fatal :: Int -> String -> a
fatal = fatalMsg "Fspec.Graphic.Graphics"

class Identified a => Navigatable a where
   interfacename :: a -> String
   itemstring :: a -> String 
   theURL :: Options -> a -> EscString    -- url of the web page in Atlas used when clicked on a node or edge in a .map file
   theURL flags x 
     = fromString ("Atlas.php?content=" ++ interfacename x
                   ++  "&User=" ++ user
                   ++  "&Script=" ++ script
                   ++  "&"++interfacename x ++"="++qualify++itemstring x
                  )
      where --copied from atlas.hs
      script = fileName flags
      user = namespace flags
      qualify = "("++user ++ "." ++ script ++ ")"  


instance Navigatable A_Concept where
   interfacename _ = "Concept" --see Atlas.adl
   itemstring = name  --copied from atlas.hs
 
instance Navigatable Declaration where 
   interfacename _ = "Relatiedetails"
   itemstring x = name x ++ "["
                  ++ (if source x==target x then name(source x) else name(source x)++"*"++name(target x))
                  ++ "]"

data DrawingType
      = Plain_CG   -- Plain Conceptual graph. No frills
      | Rel_CG     -- Conceptual graph that focuses on relations
      | Gen_CG     -- Conceptual graph that focuses on generalizations

-- Chapter 1: All objects that can be transformed to a conceptual diagram are Dotable...
class Identified a => Dotable a where
   conceptualGraph :: Fspc
                      -> Options              -- the options
                      -> DrawingType          -- this parameter allows for different alternative graphs for the same a
                      -> a -> DotGraph String -- yields a function that maps a to a DotGraph
   -- makePicture is an abbreviation of three steps:
   --  1. conceptualGraph:  creates a DotGraph data structure
   --  2. printDotGraph:    makes a string, which is the contents of the dot-file for GraphViz
   --  3. makePictureObj:   creates a Picture data structure, containing the required metadata needed for production.
   makePicture :: Options
               -> Fspc
               -> DrawingType
               -> a
               -> Picture

{- This instance of Dotable is meant for drawing data models -}
instance Dotable ClassDiag where
   conceptualGraph _ _ _ _ = fatal 58 "TODO: ClassDiagram moet nog netjes naar nieuwe Graphviz worden verbouwd."
   makePicture flags _ _ cd =
          makePictureObj flags (name cd) PTClassDiagram (classdiagram2dot flags cd) 

instance Dotable A_Concept where
   conceptualGraph fSpec flags _ c = conceptual2Dot flags (name c) cpts rels idgs
         where 
          rs    = [r | r<-udefrules fSpec, c `elem` concs r]
          idgs  = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
          gs    = fsisa fSpec
-- TODO: removal of redundant isa edges might be done more efficiently
          cpts  = nub$cpts' ++ [g |(s,g)<-gs, elem g cpts' || elem s cpts'] ++ [s |(s,g)<-gs, elem g cpts' || elem s cpts']
          cpts' = concs rs
          rels  = [r | r<-declsUsedIn rs   -- the use of "declsUsedIn" restricts relations to those actually used in rs
                     , not (isProp r)    -- r is not a property
                     ]
   makePicture flags fSpec variant x =
          (makePictureObj flags (name x) PTConcept . conceptualGraph fSpec flags variant) x

instance Dotable Pattern where
   -- | The Plain_CG of pat makes a picture of at least the declsUsedIn within pat; 
   --   extended with a limited number of more general concepts;
   --  and rels to prevent disconnected concepts, which can be connected given the entire context.
   conceptualGraph fSpec flags Plain_CG pat = conceptual2Dot flags (name pat) cpts (rels `uni` xrels) idgs
        where 
         --DESCR -> get concepts and arcs from pattern
          idgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts]    --  all isa edges within the concepts
          gs   = fsisa fSpec 
          cpts = let cpts' = concs pat `uni` concs rels
                 in cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl] -- up to two more general concepts
          rels = [r | r@Sgn{}<-declsUsedIn pat
                    , not (isProp r)    -- r is not a property
                    ]
          -- extra rels to connect concepts without rels in this picture, but with rels in the fspec
          xrels = let orphans = [c | c<-cpts, not(c `elem` map fst idgs || c `elem` map snd idgs || c `elem` map source rels  || c `elem` map target rels)]
                  in nub [r | c<-orphans, r@Sgn{}<-declarations fSpec
                        , (c == source r && target r `elem` cpts) || (c == target r  && source r `elem` cpts)
                        , source r /= target r, decusr r
                        ]
   -- | The Rel_CG of pat makes a picture of declarations and gens within pat only 
   conceptualGraph fSpec flags Rel_CG pat = conceptual2Dot flags (name pat) cpts rels idgs
        where 
         --DESCR -> get concepts and arcs from pattern
          idgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts]    --  all isa edges within the concepts
          gs   = fsisa fSpec 
          cpts = concs (declarations pat) `uni` concs (gens pat)
          rels = [r | r@Sgn{}<-declarations pat
                    , not (isProp r), decusr r    -- r is not a property
                    ]
   conceptualGraph fSpec flags Gen_CG pat = conceptual2Dot flags (name pat) cpts [] edges
        where 
         --DESCR -> get concepts and arcs from pattern
          idgs  = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
          gs    = fsisa fSpec 
          edges = clos gs idgs
          cpts  = concs edges
          cpts' = concs pat >- concs gs
          clos tuples ts = f (tuples>-ts) ts []
           where f  []  new result = result++new
                 f  _   []  result = result
                 f tups new result = f (tups>-new) [ t |t<-tups, (not.null) (concs t `isc` concs result') ] result'
                                     where result' = result++new
   makePicture flags fSpec variant pat =
          (makePictureObj flags (name pat) PTPattern . conceptualGraph fSpec flags variant) pat

instance Dotable FProcess where
   conceptualGraph fSpec flags _ fproc = conceptual2Dot flags (name fproc) cpts rels idgs
        where 
         --DESCR -> get concepts and arcs from process
          idgs  = [(s,g) |(s,g)<-gs,  g `elem` cpts']  --  all isa edges
          gs    = fsisa fSpec 
          cpts  = nub(cpts' ++ [g |(g,_)<-idgs] ++ [s |(_,s)<-idgs])
          cpts' = concs (fpProc fproc)
          rels  = [r | r@Sgn{}<-declsUsedIn (fpProc fproc), decusr r
                     , not (isProp r)    -- r is not a property
                     ]
   makePicture flags _ _ x =
          (makePictureObj flags (name x) PTProcess . processModel) x
{- inspired by:
   makePicture flags _ _ cd =
          makePictureObj flags (name cd) PTClassDiagram (classdiagram2dot flags cd) -}

instance Dotable Activity where
   conceptualGraph fSpec flags _ ifc = conceptual2Dot flags (name ifc) cpts rels idgs
         where
         -- involve all rules from the specification that are affected by this interface
          rs         = [r | r<-udefrules fSpec, affected r]
          affected r = not (null (declsUsedIn r `isc` declsUsedIn ifc))
         -- involve all isa links from concepts touched by one of the affected rules
          idgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
          gs   = fsisa fSpec
         -- involve all concepts involved either in the affected rules or in the isa-links
          cpts = nub $ cpts' ++ [c |(s,g)<-idgs, c<-[g,s]]
          cpts'  = concs rs
          rels = [r | r@Sgn{}<-declsUsedIn ifc, decusr r
                    , not (isProp r)    -- r is not a property
                    ]
   makePicture flags fSpec variant x =
          (makePictureObj flags (name x) PTFinterface . conceptualGraph fSpec flags variant) x

instance Dotable SwitchBdDiagram where
   conceptualGraph _ _ _ = sbdotGraph
   makePicture flags fSpec variant x =
          (makePictureObj flags (name x) PTSwitchBoard . conceptualGraph fSpec flags variant) x

instance Dotable Rule where
   conceptualGraph fSpec flags _ r = conceptual2Dot flags (name r) cpts rels idgs
    where 
     idgs = [(s,g) | (s,g)<-fsisa fSpec
                   , g `elem` concs r || s `elem` concs r]  --  all isa edges
     cpts = nub $ concs r++[c |(s,g)<-idgs, c<-[g,s]]
     rels = [d | d@Sgn{}<-declsUsedIn r, decusr d
               , not (isProp d)    -- d is not a property
               ]
   makePicture flags fSpec variant x =
          (makePictureObj flags (name x)  PTRule . conceptualGraph fSpec flags variant) x

-- Chapter 2: Formation of a conceptual graph as a DotGraph data structure.
conceptual2Dot :: Options                   -- ^ the flags 
               -> String                    -- ^ the name of the Graph
               -> [A_Concept]               -- ^ The concepts to draw in the graph
               -> [Declaration]   -- ^ The relations, (the edges in the graph)
               -> [(A_Concept, A_Concept)]  -- ^ list of Isa relations 
               -> DotGraph String           -- ^ The resulting DotGraph
conceptual2Dot flags graphName cpts' rels idgs
     = DotGraph { strictGraph = False
                , directedGraph = True
                , graphID = Just (Str (fromString graphName))
                , graphStatements 
                      = DotStmts { attrStmts = [GraphAttrs (handleFlags TotalPicture flags)]
                                 , subGraphs = []
                                 , nodeStmts = conceptNodes ++ relationNodes
                                 , edgeStmts = relationEdges ++ isaEdges
                                 }
                }
       where
        cpts = cpts' `uni` concs rels `uni` concs idgs
        conceptNodes = [constrNode (baseNodeId c) (CptOnlyOneNode c) flags | c<-cpts]
        (relationNodes,relationEdges) = (concat a, concat b) 
              where (a,b) = unzip [relationNodesAndEdges r | r<-zip rels [1..]]
        isaEdges = [constrEdge (baseNodeId s) (baseNodeId g) IsaOnlyOneEdge  flags | (s,g)<-idgs]
              
        baseNodeId :: A_Concept -> String  -- returns the NodeId of the node where edges to this node should connect to. 
        baseNodeId c 
            = case lookup c (zip cpts [(1::Int)..]) of
                Just i -> "cpt_"++show i
                _      -> fatal 169 $ "element "++name c++" not found by nodeLabel."

        -- | This function constructs a list of NodeStatements that must be drawn for a concept.
        relationNodesAndEdges ::
             (Declaration,Int)           -- ^ tuple contains the declaration and its rank
          -> ([DotNode String],[DotEdge String]) -- ^ the resulting tuple contains the NodeStatements and EdgeStatements
        relationNodesAndEdges (r,n)
          | doubleEdges flags
             = (  [ relNameNode ]    -- node to place the name of the relation
               ,  [ constrEdge (baseNodeId (source r)) (nodeID relNameNode)   (RelSrcEdge r) flags     -- edge to connect the source with the hinge
                  , constrEdge (nodeID relNameNode)   (baseNodeId (target r)) (RelTgtEdge r) flags]     -- edge to connect the hinge to the target
               )
          | otherwise
               = ( [] --No intermediate node
                 , [constrEdge (baseNodeId (source r)) (baseNodeId (target r)) (RelOnlyOneEdge r)  flags]
                 )
          where
        --    relHingeNode   = constrNode ("relHinge_"++show n) RelHingeNode   flags
            relNameNode    = constrNode ("relName_"++show n) (RelIntermediateNode r) flags
                                   
constrNode :: a -> PictureObject -> Options -> DotNode a
constrNode nodeId pObj flags
  = DotNode { nodeID = nodeId
            , nodeAttributes = [ FontSize 10
                               , FontName (fromString(pangoFont flags))
                           --    , Width 0.1
                           --    , Height  0.1
                               ]++handleFlags pObj flags
            }

constrEdge :: a -> a -> PictureObject -> Options -> DotEdge a
constrEdge nodeFrom nodeTo pObj flags 
  = DotEdge { fromNode = nodeFrom
            , toNode   = nodeTo
            , edgeAttributes = [ FontSize 12
                               , FontName (fromString(pangoFont flags))
                               , Dir Forward
                            --   , LabelAngle (-25.0)
                               , Color [WC(X11Color Gray35)Nothing]
                               , LabelFontColor (X11Color Black)
                               , LabelFloat False
                               , Decorate False
                            --   , LabelDistance 2.0
                            --   , (HeadLabel . StrLabel . fromString) "Test"
                               ]++handleFlags pObj flags
            }
--DESCR -> a picture consists of arcs (relations), concepts, and ISA relations between concepts
--         arcs are attached to a source or target concept
--         arcs and concepts are points attached to a label
-- for Haddock support on GraphViz, click on:
--       http://hackage.haskell.org/packages/archive/graphviz/2999.6.0.0/doc/html/doc-index.html     or
--       http://hackage.haskell.org/packages/archive/graphviz/latest/doc/html/doc-index.html

data PictureObject = CptOnlyOneNode A_Concept    -- ^ Node of a concept that serves as connector and shows the name
                   | CptConnectorNode A_Concept  -- ^ Node of a concept that serves as connector of relations to that concept
                   | CptNameNode A_Concept       -- ^ Node of a concept that shows the name
                   | CptEdge                     -- ^ Edge of a concept to connect its nodes
                   | RelOnlyOneEdge Declaration  -- ^ Edge of a relation that connects to the source and the target
                   | RelSrcEdge     Declaration  -- ^ Edge of a relation that connects to the source
                   | RelTgtEdge     Declaration  -- ^ Edge of a relation that connects to the target
                   | RelIntermediateNode    Declaration  -- ^ Intermediate node, as a hindge for the relation edges
                   | IsaOnlyOneEdge              -- ^ Edge of an ISA relation without a hinge node
                   | TotalPicture                -- ^ Graph attributes
         
handleFlags :: PictureObject  -> Options -> [Attribute]
handleFlags po flags = 
    case po of
      CptConnectorNode c 
         -> if crowfoot flags
            then 
                 [ (Label . StrLabel . fromString . name) c
                 , Shape PlainText
                 , Style [filled]
                 , URL (theURL flags c)
                 ]
            else [ Shape PointShape
                 , Style [filled]
                 ]
      CptNameNode c  -> if crowfoot flags
                        then [ Shape PointShape
                             , Style [invis]]
                        else 
                             [ (Label . StrLabel . fromString . name) c
                             , Shape PlainText
                             , Style [filled]
                             , URL (theURL flags c)
                             ]
      CptEdge    -> [Style [invis]
                    ]
      CptOnlyOneNode c -> 
                          [(Label . StrLabel . fromString . name) c
                          , Shape BoxShape
                          , Style [filled] 
                          , URL (theURL flags c)
                          ]
      RelOnlyOneEdge r -> [ URL (theURL flags r)
                          , (XLabel . StrLabel .fromString.name) r
                          ]
                    --    ++[ (HeadLabel . StrLabel .fromString) "1" | isTot r && isUni r]
                    --    ++[ (TailLabel . StrLabel .fromString) "1" | isSur r && isInj r]
                        ++[ ArrowTail noArrow, ArrowHead noArrow
                          , Dir Forward  -- Note that the tail arrow is not supported , so no crowfoot notation possible with a single edge.
                          , Style [SItem Tapered []] , PenWidth 5
                          ]
      RelSrcEdge r -> [ ArrowHead ( if crowfoot flags  then normal                    else
                                    if isFunction r    then noArrow                   else
                                    if isInvFunction r then noArrow                   else
                                    noArrow
                                  )
                      , ArrowTail ( if crowfoot flags  then crowfootArrowType False r else
                                    if isFunction r    then noArrow                   else
                                    if isInvFunction r then normal                    else
                                    noArrow
                                  )
                      ,HeadClip False
                --      , Dir Both  -- Needed because of change in graphviz. See http://www.graphviz.org/bugs/b1951.html
                      ]
      RelTgtEdge r -> [ (Label . StrLabel . fromString . name) r
                      , ArrowHead ( if crowfoot flags  then crowfootArrowType True r  else
                                    if isFunction r    then normal                    else
                                    if isInvFunction r then noArrow                   else
                                    noArrow
                                  )
                      , ArrowTail ( if crowfoot flags  then noArrow                   else
                                    if isFunction r    then noArrow                   else
                                    if isInvFunction r then AType [(noMod ,Inv)]      else
                                    AType [(noMod ,Inv)]
                                  )
                   --   , Dir Both  -- Needed because of change in graphviz. See http://www.graphviz.org/bugs/b1951.html
                      ,TailClip False
                      ] 
      RelIntermediateNode r -> 
                       [ Label (StrLabel (fromString("")))
                       , Shape PlainText
                       , bgColor White
                       , URL (theURL flags r) 
                       ]
      IsaOnlyOneEdge-> [ ArrowHead (AType [(open,Normal)])
                       , ArrowTail noArrow
                       , if blackWhite flags then Style [dotted] else Color [WC(X11Color Red)Nothing]
                       ]
      TotalPicture -> [ Sep (DVal (if doubleEdges flags then 1/2 else 2)) -- The minimal amount of whitespace between nodes
                      , OutputOrder  EdgesFirst --make sure the nodes are always on top...
                      , Overlap ScaleXYOverlaps
                      , Splines PolyLine  -- SplineEdges could work as well.
                      , Landscape False
                      ]

isInvFunction :: Declaration -> Bool
isInvFunction d = isInj d && isSur d


crowfootArrowType :: Bool -> Declaration -> ArrowType
crowfootArrowType isHead r 
   = AType (case isHead of
               True  -> getCrowfootShape (isUni r) (isTot r)
               False -> getCrowfootShape (isInj r) (isSur r)
           )
       where 
         getCrowfootShape :: Bool -> Bool -> [( ArrowModifier , ArrowShape )]
         getCrowfootShape a b =
           case (a,b) of
            (True ,True ) -> [my_tee          ]
            (False,True ) -> [my_crow, my_tee ]
            (True ,False) -> [my_odot, my_tee ]
            (False,False) -> [my_crow, my_odot]
             
         my_tee :: ( ArrowModifier , ArrowShape )
         my_tee = ( noMod , Tee )
         my_odot :: ( ArrowModifier , ArrowShape )
         my_odot= ( open, DotArrow )
         my_crow :: ( ArrowModifier , ArrowShape )
         my_crow= ( open, Crow )

noMod :: ArrowModifier
noMod = ArrMod { arrowFill = FilledArrow
               , arrowSide = BothSides
               }
open :: ArrowModifier
open  = noMod {arrowFill = OpenArrow}