ampersand-3.0.0: src/lib/DatabaseDesign/Ampersand/Fspec/Graphic/Graphics.hs
{-# 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}