{-# OPTIONS_GHC -Wall #-}
module DatabaseDesign.Ampersand.Fspec.Graphic.Graphics 
          (makePicture, writePicture, Picture(..), PictureReq(..),imagePath
    )where

import Data.GraphViz 
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
import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram -- (ClassDiag,classdiagram2dot)
import Data.GraphViz.Attributes.Complete
import Data.List
import Data.String

import System.FilePath hiding (addExtension)
import System.Directory

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

data PictureReq = PTClassDiagram 
                | PTRelsUsedInPat Pattern
                | PTDeclaredInPat Pattern
                | PTProcess FProcess
                | PTConcept A_Concept
                | PTSwitchBoard Activity
                | PTFinterface Activity
                | PTIsaInPattern Pattern  -- Not used at all...
                | PTSingleRule Rule
                | PTLogicalDM
                | PTTechnicalDM

data Picture = Pict { pType :: PictureReq             -- ^ the type of the picture
                    , scale :: String                 -- ^ a scale factor, intended to pass on to LaTeX, because Pandoc seems to have a problem with scaling.
                    , dotSource :: DotGraph String    -- ^ the string representing the .dot
                    , dotProgName :: GraphvizCommand  -- ^ the name of the program to use  ("dot" or "neato" or "fdp" or "Sfdp")
                    , caption :: String               -- ^ a human readable name of this picture
                    }


makePicture :: Options -> Fspc -> PictureReq -> Picture
makePicture flags fSpec pr =
  case pr of 
   PTClassDiagram      -> Pict { pType = pr
                               , scale = scale'
                               , dotSource = classdiagram2dot flags (clAnalysis fSpec flags)
                               , dotProgName = Dot
                               , caption = 
                                   case fsLang fSpec of
                                      English -> "Classification of " ++ name fSpec
                                      Dutch   -> "Classificatie van " ++ name fSpec
                               }
   PTLogicalDM         -> Pict { pType = pr
                               , scale = scale'
                               , dotSource = classdiagram2dot flags (cdAnalysis fSpec flags)
                               , dotProgName = Dot
                               , caption = 
                                   case fsLang fSpec of
                                      English -> "Logical data model of " ++ name fSpec
                                      Dutch   -> "Logisch gegevensmodel van " ++ name fSpec
                               }
   PTTechnicalDM       -> Pict { pType = pr
                               , scale = scale'
                               , dotSource = classdiagram2dot flags (tdAnalysis fSpec flags)
                               , dotProgName = Dot
                               , caption = 
                                   case fsLang fSpec of
                                      English -> "Technical data model of " ++ name fSpec
                                      Dutch   -> "Technisch gegevensmodel van " ++ name fSpec
                               }
   PTConcept cpt       -> Pict { pType = pr
                               , scale = scale'
                               , dotSource = conceptualGraph' fSpec flags pr
                               , dotProgName = graphVizCmdForConceptualGraph
                               , caption = 
                                   case fsLang fSpec of
                                      English -> "Concept diagram of the rules about " ++ name cpt
                                      Dutch   -> "Conceptueel diagram van de regels rond " ++ name cpt
                               }
   PTDeclaredInPat pat -> Pict { pType = pr
                               , scale = scale'
                               , dotSource = conceptualGraph' fSpec flags pr
                               , dotProgName = graphVizCmdForConceptualGraph
                               , caption = 
                                   case fsLang fSpec of
                                      English -> "Concept diagram of relations in " ++ name pat
                                      Dutch   -> "Conceptueel diagram van relaties in " ++ name pat
                               }
   PTIsaInPattern pat  -> Pict { pType = pr
                               , scale = scale'
                               , dotSource = conceptualGraph' fSpec flags pr
                               , dotProgName = graphVizCmdForConceptualGraph
                               , caption = 
                                   case fsLang fSpec of
                                      English -> "Classifications of " ++ name pat
                                      Dutch   -> "Classificaties van " ++ name pat
                               }
   PTRelsUsedInPat pat -> Pict { pType = pr
                               , scale = scale'
                               , dotSource = conceptualGraph' fSpec flags pr
                               , dotProgName = graphVizCmdForConceptualGraph
                               , caption = 
                                   case fsLang fSpec of
                                      English -> "Concept diagram of the rules in " ++ name pat
                                      Dutch   -> "Conceptueel diagram van de regels in " ++ name pat
                               }
   PTFinterface act    -> Pict { pType = pr
                               , scale = scale'
                               , dotSource = conceptualGraph' fSpec flags pr
                               , dotProgName = graphVizCmdForConceptualGraph
                               , caption = 
                                   case fsLang fSpec of
                                      English -> "Concept diagram of interface " ++ name act
                                      Dutch   -> "Conceptueel diagram van interface " ++ name act
                               }
   PTSingleRule rul    -> Pict { pType = pr
                               , scale = scale'
                               , dotSource = conceptualGraph' fSpec flags pr
                               , dotProgName = graphVizCmdForConceptualGraph
                               , caption = 
                                   case fsLang fSpec of
                                      English -> "Concept diagram of rule " ++ name rul
                                      Dutch   -> "Conceptueel diagram van regel " ++ name rul
                               }
   PTProcess fp        -> Pict { pType = pr
                               , scale = scale'
                               , dotSource = processModel fp
                               , dotProgName = graphVizCmdForConceptualGraph
                               , caption = 
                                   case fsLang fSpec of
                                      English -> "Process model of " ++ name fp
                                      Dutch   -> "Procesmodel van " ++ name fp
                               }
   PTSwitchBoard act   -> Pict { pType = pr
                               , scale = scale'
                               , dotSource = sbdotGraph (switchboardAct fSpec act)
                               , dotProgName = graphVizCmdForConceptualGraph
                               , caption = 
                                   case fsLang fSpec of
                                      English -> "Switchboard diagram of " ++ name act
                                      Dutch   -> "Schakelpaneel van " ++ name act
                               }
 where
   scale' =
      case pr of
            PTClassDiagram -> "1.0"
            PTRelsUsedInPat{}-> "0.7"
            PTDeclaredInPat{}-> "0.5"
            PTProcess{}      -> "0.4"
            PTSwitchBoard{}  -> "0.4"
            PTIsaInPattern{} -> "0.7"
            PTSingleRule{}   -> "0.7"
            PTConcept{}      -> "0.7"
            PTFinterface{}   -> "0.7"
            PTLogicalDM    -> "0.7"
            PTTechnicalDM  -> "0.7"
   graphVizCmdForConceptualGraph = Sfdp
   
pictureID :: PictureReq -> String
pictureID pr = 
     case pr of
      PTClassDiagram   -> "Classification"
      PTLogicalDM      -> "LogicalDataModel"
      PTTechnicalDM    -> "TechnicalDataModel"
      PTConcept cpt    -> "RulesWithConcept"++name cpt
      PTDeclaredInPat pat -> "RelationsInPattern"++name pat
      PTIsaInPattern  pat -> "IsasInPattern"++name pat
      PTRelsUsedInPat pat -> "RulesInPattern"++name pat
      PTProcess fp        -> "ProcessModel"++name fp
      PTFinterface act    -> "KnowledgeGraph"++name act
      PTSwitchBoard x     -> "SwitchBoard"++name x
      PTSingleRule r      -> "SingleRule"++name r

conceptualGraph' :: Fspc -> Options -> PictureReq -> DotGraph String
conceptualGraph' fSpec flags pr = conceptual2Dot flags cstruct
  where 
    cstruct =
      case pr of 
        PTConcept c -> 
          let gs = fsisa fSpec 
              cpts' = concs rs
              rs    = [r | r<-udefrules fSpec, c `elem` concs r]
          in
          CStruct { csCpts = nub$cpts' ++ [g |(s,g)<-gs, elem g cpts' || elem s cpts'] ++ [s |(s,g)<-gs, elem g cpts' || elem s cpts']
                  , csRels = [r | r@Sgn{} <- relsMentionedIn rs   -- the use of "relsMentionedIn" restricts relations to those actually used in rs
                             , not (isProp r)
                             ]
                  , csIdgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
                  }
        --  PTRelsUsedInPat makes a picture of at least the relations 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.
        PTRelsUsedInPat pat ->
          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)]
              xrels = nub [r | c<-orphans, r@Sgn{}<-relsDefdIn fSpec
                        , (c == source r && target r `elem` cpts) || (c == target r  && source r `elem` cpts)
                        , source r /= target r, decusr r
                        ]
              idgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts]    --  all isa edges within the concepts
              gs   = fsisa fSpec 
              cpts = cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl] -- up to two more general concepts
              cpts' = concs pat `uni` concs rels
              rels = [r | r@Sgn{}<-relsMentionedIn pat
                             , not (isProp r)    -- r is not a property
                             ]
          in
          CStruct { csCpts = cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl] -- up to two more general concepts
                  , csRels = rels `uni` xrels -- extra rels to connect concepts without rels in this picture, but with rels in the fSpec
                  , csIdgs = idgs
                  }

        -- PTDeclaredInPat makes a picture of relations and gens within pat only 
        PTDeclaredInPat pat ->
          let gs   = fsisa fSpec
              cpts = concs decs `uni` concs (gens pat)
              decs = relsDefdIn pat `uni` relsMentionedIn (udefrules pat)
          in
          CStruct { csCpts = cpts
                  , csRels = [r | r@Sgn{}<-decs
                             , not (isProp r), decusr r    -- r is not a property
                             ]
                  , csIdgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts]    --  all isa edges within the concepts
                  }
        PTIsaInPattern pat ->
          let gs    = fsisa fSpec
              cpts  = concs edges
              cpts' = concs pat >- concs gs
              edges = clos gs idgs
              idgs  = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
              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
          in
          CStruct { csCpts = cpts
                  , csRels = []
                  , csIdgs = idgs
                  }

        PTFinterface ifc ->
          let gs   = fsisa fSpec
              cpts = nub $ cpts' ++ [c |(s,g)<-idgs, c<-[g,s]]
              cpts'  = concs rs
              rs         = [r | r<-udefrules fSpec, affected r]
              affected r = (not.null) [d | d@Sgn{} <- relsMentionedIn r `isc` relsMentionedIn ifc]
              idgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
              rels = [r | r@Sgn{}<-relsMentionedIn ifc, decusr r
                        , not (isProp r)    -- r is not a property
                     ]
          in
          CStruct { csCpts = cpts -- involve all concepts involved either in the affected rules or in the isa-links
                  , csRels = rels
                  , csIdgs = idgs -- involve all isa links from concepts touched by one of the affected rules
                  }
        PTSingleRule r ->
          let idgs = [(s,g) | (s,g)<-fsisa fSpec
                     , g `elem` concs r || s `elem` concs r]  --  all isa edges
          in
          CStruct { csCpts = nub $ concs r++[c |(s,g)<-idgs, c<-[g,s]]
                  , csRels = [d | d@Sgn{}<-relsMentionedIn r, decusr d
                             , not (isProp d)    -- d is not a property
                             ]
                  , csIdgs = idgs -- involve all isa links from concepts touched by one of the affected rules
                  }
        _  -> fatal 276 "No conceptual graph defined for this type."  


writePicture :: Options -> Picture -> IO()
writePicture flags pict
    = sequence_ (
      [createDirectoryIfMissing True  (takeDirectory (imagePath flags pict)) | genAtlas flags ]++
      [writeDot Canon  | {- genFspec flags || -} genAtlas flags ]++
--      [writeDot XDot   | genFspec flags || genAtlas flags ]++
      [writeDot Png    | genFspec flags || genAtlas flags ]++
      [writeDot Cmapx  |                   genAtlas flags ]
          )
   where 
     writeDot :: GraphvizOutput
              -> IO ()
     writeDot  gvOutput  = 
         do verboseLn flags ("Generating "++show gvOutput++" using "++show gvCommand++".")
            path <- addExtension (runGraphvizCommand gvCommand (dotSource pict)) gvOutput ((dropExtension . imagePath flags) pict)
            verboseLn flags (path++" written.")
       where  gvCommand = dotProgName pict
              
             
class ReferableFromPandoc a where
  imagePath :: Options ->a -> FilePath   -- ^ the full file path to the image file

instance ReferableFromPandoc Picture where
  imagePath flags p = 
     (if genAtlas flags then dirPrototype flags </> "images" else dirOutput flags)
     </> (escapeNonAlphaNum . pictureID . pType ) p <.> "png"

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 ConceptualStructure = CStruct { csCpts :: [A_Concept]               -- ^ The concepts to draw in the graph
                                   , csRels :: [Declaration]   -- ^ The relations, (the edges in the graph)
                                   , csIdgs :: [(A_Concept, A_Concept)]  -- ^ list of Isa relations
                                   }

conceptual2Dot :: Options -> ConceptualStructure -> DotGraph String
conceptual2Dot flags (CStruct cpts' rels idgs)
     = DotGraph { strictGraph = False
                , directedGraph = True
                , graphID = Nothing
                , 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}