{-# 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}