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
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
| PTSingleRule Rule
| PTLogicalDM
| PTTechnicalDM
data Picture = Pict { pType :: PictureReq
, scale :: String
, dotSource :: DotGraph String
, dotProgName :: GraphvizCommand
, caption :: String
}
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
, not (isProp r)
]
, csIdgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']
}
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]
gs = fsisa fSpec
cpts = cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl]
cpts' = concs pat `uni` concs rels
rels = [r | r@Sgn{}<-relsMentionedIn pat
, not (isProp r)
]
in
CStruct { csCpts = cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl]
, csRels = rels `uni` xrels
, csIdgs = idgs
}
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
]
, csIdgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts]
}
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']
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']
rels = [r | r@Sgn{}<-relsMentionedIn ifc, decusr r
, not (isProp r)
]
in
CStruct { csCpts = cpts
, csRels = rels
, csIdgs = idgs
}
PTSingleRule r ->
let idgs = [(s,g) | (s,g)<-fsisa fSpec
, g `elem` concs r || s `elem` concs r]
in
CStruct { csCpts = nub $ concs r++[c |(s,g)<-idgs, c<-[g,s]]
, csRels = [d | d@Sgn{}<-relsMentionedIn r, decusr d
, not (isProp d)
]
, csIdgs = idgs
}
_ -> 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 | 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
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
theURL flags x
= fromString ("Atlas.php?content=" ++ interfacename x
++ "&User=" ++ user
++ "&Script=" ++ script
++ "&"++interfacename x ++"="++qualify++itemstring x
)
where
script = fileName flags
user = namespace flags
qualify = "("++user ++ "." ++ script ++ ")"
instance Navigatable A_Concept where
interfacename _ = "Concept"
itemstring = name
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]
, csRels :: [Declaration]
, csIdgs :: [(A_Concept, A_Concept)]
}
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
baseNodeId c
= case lookup c (zip cpts [(1::Int)..]) of
Just i -> "cpt_"++show i
_ -> fatal 169 $ "element "++name c++" not found by nodeLabel."
relationNodesAndEdges ::
(Declaration,Int)
-> ([DotNode String],[DotEdge String])
relationNodesAndEdges (r,n)
| doubleEdges flags
= ( [ relNameNode ]
, [ constrEdge (baseNodeId (source r)) (nodeID relNameNode) (RelSrcEdge r) flags
, constrEdge (nodeID relNameNode) (baseNodeId (target r)) (RelTgtEdge r) flags]
)
| otherwise
= ( []
, [constrEdge (baseNodeId (source r)) (baseNodeId (target r)) (RelOnlyOneEdge r) flags]
)
where
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))
]++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
, Color [WC(X11Color Gray35)Nothing]
, LabelFontColor (X11Color Black)
, LabelFloat False
, Decorate False
]++handleFlags pObj flags
}
data PictureObject = CptOnlyOneNode A_Concept
| CptConnectorNode A_Concept
| CptNameNode A_Concept
| CptEdge
| RelOnlyOneEdge Declaration
| RelSrcEdge Declaration
| RelTgtEdge Declaration
| RelIntermediateNode Declaration
| IsaOnlyOneEdge
| TotalPicture
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
]
++[ ArrowTail noArrow, ArrowHead noArrow
, Dir Forward
, 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
]
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)]
)
,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))
, OutputOrder EdgesFirst
, Overlap ScaleXYOverlaps
, Splines PolyLine
, 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}