1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder{-# LANGUAGE FlexibleInstances #-}

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder{- |

f9e0b18852b238ddb649d341194e05d7200d1bbeChristian MaederModule : $Header$

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian MaederDescription : Interface for graph viewing and abstraction

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian MaederCopyright : (c) Thiemo Wiedemeyer, T. Mossakowski, Uni Bremen 2002-2008

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian MaederLicense : GPLv2 or higher, see LICENSE.txt

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian MaederMaintainer : raider@informatik.uni-bremen.de

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian MaederStability : provisional

f9e0b18852b238ddb649d341194e05d7200d1bbeChristian MaederPortability : non-portable (relies on Logic via DevGraph)

f9e0b18852b238ddb649d341194e05d7200d1bbeChristian Maeder

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian MaederInterface for graph viewing and abstraction.

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder-}

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maedermodule GUI.GraphAbstraction

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder ( -- * Types

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder NodeId

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder , NodeValue

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder , EdgeValue

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder , GraphInfo

f9e0b18852b238ddb649d341194e05d7200d1bbeChristian Maeder -- * Creation and display

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder , initGraph

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder , makeGraph

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder , redisplay

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder -- * Node interface

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder , isHiddenNode

67869d63d1725c79e4c07b51acd466a31932b275Christian Maeder , focusNode

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder -- * Edge interface

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder , hideSetOfEdgeTypes

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder , isHiddenEdge

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder -- * Conversion and update of graph

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder , applyChanges

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder , convert

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder -- * Direct manipulation of uDrawGraph

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder , layoutImproveAll

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder , showTemporaryMessage

4c7f058cdd19ce67b2b5d4b7f69703d0f8a21e38Christian Maeder , deactivateGraphWindow

4c7f058cdd19ce67b2b5d4b7f69703d0f8a21e38Christian Maeder , activateGraphWindow

4c7f058cdd19ce67b2b5d4b7f69703d0f8a21e38Christian Maeder , closeGraphWindow

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder ) where

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maederimport GUI.UDGUtils

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maederimport GUI.Utils (pulseBar)

67869d63d1725c79e4c07b51acd466a31932b275Christian Maederimport qualified UDrawGraph.Types as DVT

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maederimport Events.Destructible (destroy)

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maederimport Events.Synchronized (synchronize)

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder

64e1905404e5135e98a26d2ab4150b6764956576Christian Maederimport ATC.DevGraph ()

64e1905404e5135e98a26d2ab4150b6764956576Christian Maederimport Static.DevGraph

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder

64e1905404e5135e98a26d2ab4150b6764956576Christian Maederimport Data.IORef

64e1905404e5135e98a26d2ab4150b6764956576Christian Maederimport Data.List (partition)

64e1905404e5135e98a26d2ab4150b6764956576Christian Maederimport qualified Data.Map as Map

64e1905404e5135e98a26d2ab4150b6764956576Christian Maederimport Data.Graph.Inductive.Graph (LEdge)

64e1905404e5135e98a26d2ab4150b6764956576Christian Maederimport Data.Maybe (isNothing)

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maederimport Control.Monad (foldM)

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maederimport Control.Concurrent (threadDelay)

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder

67869d63d1725c79e4c07b51acd466a31932b275Christian Maeder-- | uDrawGraph graph

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maedertype OurGraph =

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder Graph DaVinciGraph

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder DaVinciGraphParms

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder DaVinciNode

62eaa2fb831613d8a6e59687f83a45be1041ab17Christian Maeder DaVinciNodeType

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder DaVinciNodeTypeParms

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder DaVinciArc

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder DaVinciArcType

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder DaVinciArcTypeParms

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder

67869d63d1725c79e4c07b51acd466a31932b275Christian Maeder-- | Node id type

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maedertype NodeId = Int

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder-- | Node value

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maedertype NodeValue = (String, NodeId)

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder-- | Edge value

67869d63d1725c79e4c07b51acd466a31932b275Christian Maedertype EdgeValue = (String, EdgeId, Maybe (LEdge DGLinkLab))

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder-- | Datastructure for changes, storing all needed information for change

64e1905404e5135e98a26d2ab4150b6764956576Christian Maederdata GAChange

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder -- Node changes

62eaa2fb831613d8a6e59687f83a45be1041ab17Christian Maeder = AddNode NodeId DGNodeType String Bool

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder | DelNode NodeId

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder | ChangeNodeType NodeId DGNodeType

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder | ShowNode NodeId

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder | HideNode NodeId

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder -- Edge changes

67869d63d1725c79e4c07b51acd466a31932b275Christian Maeder | AddEdge EdgeId DGEdgeType NodeId NodeId String (Maybe (LEdge DGLinkLab))

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder Bool

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder | DelEdge EdgeId

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder | ShowEdge EdgeId

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder | HideEdge EdgeId

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder -- Compressed edge changes

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder | AddCompEdge (NodeId, NodeId, DGEdgeType, Bool)

67869d63d1725c79e4c07b51acd466a31932b275Christian Maeder | DelCompEdge (NodeId, NodeId, DGEdgeType, Bool)

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder-- | Internal node

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maederdata GANode = GANode

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder { udgNode :: Maybe (DaVinciNode NodeValue) -- ^ uDrawGraph node

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder , ganType :: DGNodeType -- ^ ID of nodetype

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder , ganValue :: NodeValue -- ^ Holds the nodevalue for uDrawGraph node

67869d63d1725c79e4c07b51acd466a31932b275Christian Maeder }

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder-- | Internal edge

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maederdata GAEdge = GAEdge

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder { udgEdge :: Maybe (DaVinciArc EdgeValue) -- ^ uDrawGraph edge

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder , ganFrom :: NodeId -- ^ ID of source node

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder , ganTo :: NodeId -- ^ID of target node

67869d63d1725c79e4c07b51acd466a31932b275Christian Maeder , gaeType :: DGEdgeType -- ^ ID of edgetype

1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder , gaeValue :: EdgeValue -- ^ Holds the edgevalue for uDrawGraph edge

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder }

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder-- | Internal node type

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maederdata GANodeType = GANodeType

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder { udgNodeType :: DaVinciNodeType NodeValue

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder }

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder-- | Internal edge type

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maederdata GAEdgeType = GAEdgeType

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder { udgEdgeType :: DaVinciArcType EdgeValue

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder , udgCompressed :: (DaVinciArcType EdgeValue, DaVinciArcType EdgeValue)

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder , gaeHidden :: Bool

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder }

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder{- | Main datastructure for carrying around the graph,

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder both internally (nodes as integers), and at the daVinci level -}

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maederdata AbstractionGraph = AbstractionGraph

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder { theGraph :: OurGraph

ecf557c0b4f953106755a239da2c0b168064d3f4Christian Maeder , nodes :: Map.Map NodeId GANode

de66af0f4b27f08f81c7ca9c573ef9cdf7ca7a07Christian Maeder , edges :: Map.Map EdgeId GAEdge

de66af0f4b27f08f81c7ca9c573ef9cdf7ca7a07Christian Maeder , nodeTypes :: Map.Map DGNodeType GANodeType

de66af0f4b27f08f81c7ca9c573ef9cdf7ca7a07Christian Maeder , edgeTypes :: Map.Map DGEdgeType GAEdgeType

de66af0f4b27f08f81c7ca9c573ef9cdf7ca7a07Christian Maeder , compressedEdges :: Map.Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge

de66af0f4b27f08f81c7ca9c573ef9cdf7ca7a07Christian Maeder }

de66af0f4b27f08f81c7ca9c573ef9cdf7ca7a07Christian Maeder

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder-- | IORef for main datastructure

64e1905404e5135e98a26d2ab4150b6764956576Christian Maedertype GraphInfo = IORef AbstractionGraph

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder

64e1905404e5135e98a26d2ab4150b6764956576Christian Maederinstance Eq (DaVinciNode NodeValue) where

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder (==) = eq1

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder

64e1905404e5135e98a26d2ab4150b6764956576Christian Maederinstance Eq (DaVinciArc EdgeValue) where

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder (==) = eq1

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder

64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder-- | Wrapper for functions with read access

wrapperRead :: (AbstractionGraph -> IO ()) -- ^ Function to call

-> GraphInfo -- ^ The graph

-> IO ()

wrapperRead func gi = readIORef gi >>= func

-- | Wrapper for functions with read and write access

wrapperWrite :: (AbstractionGraph -> IO AbstractionGraph) -- ^ Function to call

-> GraphInfo -- ^ The graph

-> IO ()

wrapperWrite func gi = do

g <- readIORef gi

g' <- func g

writeIORef gi g'

-- | Wrapper for functions returning a boolean

wrapperBool :: (AbstractionGraph -> Bool) -- ^ Function to call

-> GraphInfo -- ^ The graph

-> IO Bool -- ^ Return value

wrapperBool func gi = do

g <- readIORef gi

return $ func g

-- | Forces a redraw of the uDrawGraph and wait an amount of time

redisplay' :: AbstractionGraph -- ^ The graph

-> IO ()

redisplay' g = do

redraw (theGraph g)

threadDelay 300000

redisplay :: GraphInfo -- ^ The graph

-> IO ()

redisplay = wrapperRead redisplay'

-- | Creates an empty graph structure

graphtool :: OurGraph -- ^ uDrawGraph graph

graphtool = daVinciSort

-- | Creates the empty AbstractionGraph

initGraph :: IO GraphInfo -- ^ The graph

initGraph = do

let g = AbstractionGraph

{ theGraph = graphtool

, nodes = Map.empty

, edges = Map.empty

, nodeTypes = Map.empty

, edgeTypes = Map.empty

, compressedEdges = Map.empty

}

newIORef g

-- | Creates the uDrawGraph graph

makeGraph :: GraphInfo -- ^ The graph

-> String -- ^ Title

-> Maybe (IO ()) -- ^ FileOpen menu

-> Maybe (IO ()) -- ^ FileSave menu

-> Maybe (IO ()) -- ^ FileSaveAs menu

-> IO Bool -- ^ FileClose menu

-> Maybe (IO ()) -- ^ FileExit menu

-> [GlobalMenu] -- ^ Edit menu

-> [(DGNodeType,DaVinciNodeTypeParms NodeValue)] -- ^ Node types

-> [(DGEdgeType,DaVinciArcTypeParms EdgeValue)] -- ^ Edge types

-> String -- ^ Compressed edge color

-> IO () -- ^ Expand menu action

-> IO ()

makeGraph gi title open save saveAs close exit menus nTypeParms eTypeParms

color expand' = do

let graphParms =

foldr ($$) (GraphTitle title $$

OptimiseLayout False $$

AllowClose close $$

FileMenuAct OpenMenuOption open $$

FileMenuAct SaveMenuOption save $$

FileMenuAct SaveAsMenuOption saveAs $$

FileMenuAct ExitMenuOption exit $$

emptyGraphParms)

menus

(nTypeNames,nTypeParms') = unzip nTypeParms

(eTypeNames,eTypeParms') = unzip eTypeParms

expand = (LocalMenu (Button "Expand" (const expand')) $$$)

eTypeParmsCO = map expand eTypeParms'

eTypeParmsCP = map (expand . (Color color $$$)) eTypeParms'

graph <- newGraph graphtool graphParms

nTypes <- mapM (newNodeType graph) nTypeParms'

eTypes <- mapM (newArcType graph) eTypeParms'

cTypesO <- mapM (newArcType graph) eTypeParmsCO

cTypesP <- mapM (newArcType graph) eTypeParmsCP

writeIORef gi AbstractionGraph

{ theGraph = graph

, nodes = Map.empty

, edges = Map.empty

, nodeTypes = Map.fromList $ zip nTypeNames

$ map (\ nt -> GANodeType { udgNodeType = nt }) nTypes

, edgeTypes = Map.fromList $ zip eTypeNames

$ map (\ (et,ctO,ctP) -> GAEdgeType { udgEdgeType = et

, udgCompressed = (ctO,ctP)

, gaeHidden = False })

$ zip3 eTypes cTypesO cTypesP

, compressedEdges = Map.empty

}

{- | similar to lookup (for Map), but returns just the value if lookup was

successful otherwise an error is raised. -}

get :: (Show k, Ord k) => k -> Map.Map k a -> a

get key = Map.findWithDefault (error $ "get: id unknown: " ++ show key) key

{- Functions for adding, deleting, changing and hidding nodes.-}

-- | Adds a node (type id)

addNode :: AbstractionGraph -- ^ The graph

-> NodeId -- ^ ID of the node

-> DGNodeType -- ^ ID of the nodetype

-> String -- ^ Name of the node

-> Bool -- ^ Hidden

-> IO AbstractionGraph

addNode g nId nType nName hidden = if Map.member nId $ nodes g

then error $ "addNode: Node with id " ++ show nId ++ " already exist!"

else do

node' <- if hidden then return Nothing else do

node'' <- newNode (theGraph g) (udgNodeType $ get nType $ nodeTypes g)

(nName,nId)

return $ Just node''

let node = GANode { udgNode = node'

, ganType = nType

, ganValue = (nName, nId)

}

return g { nodes = Map.insert nId node $ nodes g }

-- | Deletes a node

delNode :: AbstractionGraph -- ^ The graph

-> NodeId -- ^ ID of the node

-> IO AbstractionGraph

delNode g nId = do

case udgNode $ get nId $ nodes g of

Just node -> deleteNode (theGraph g) node

Nothing -> return ()

return g { nodes = Map.delete nId $ nodes g }

-- | Hides a node

hideNode :: AbstractionGraph -- ^ The graph

-> NodeId -- ^ ID of the node

-> IO AbstractionGraph

hideNode g nId = do

let node = get nId $ nodes g

case udgNode node of

Nothing -> return g

Just node' -> do

deleteNode (theGraph g) node'

return g { nodes = Map.insert nId node {udgNode = Nothing} $ nodes g }

-- | Checks whether a node is hidden or not

isHiddenNode' :: AbstractionGraph -- ^ The graph

-> NodeId -- ^ ID of the node

-> Bool

isHiddenNode' g nId = isNothing $ udgNode $ get nId $ nodes g

-- | Checks whether a node is hidden or not

isHiddenNode :: GraphInfo -- ^ The graph

-> NodeId -- ^ ID of the node

-> IO Bool -- ^ Is hidden

isHiddenNode gi nId = wrapperBool (flip isHiddenNode' nId) gi

-- | Shows a hidden node again

showNode :: AbstractionGraph -- ^ The graph

-> NodeId -- ^ ID of the node

-> IO AbstractionGraph

showNode g nId = do

let node = get nId $ nodes g

case udgNode node of

Just _ -> return g

Nothing -> do

node' <- newNode (theGraph g)

(udgNodeType $ get (ganType node) $ nodeTypes g)

$ ganValue node

return

g { nodes = Map.insert nId node { udgNode = Just node' } $ nodes g }

-- | Change the node type of the given node

changeNodeType :: AbstractionGraph -- ^ The graph

-> NodeId -- ^ ID of the node

-> DGNodeType -- ^ ID of the nodetype

-> IO AbstractionGraph

changeNodeType g nId nType = do

let node = get nId $ nodes g

case udgNode node of

Just node' -> setNodeType (theGraph g) node' $ udgNodeType $ get nType

$ nodeTypes g

Nothing -> return ()

return g { nodes = Map.insert nId node { ganType = nType } $ nodes g }

-- | Focus a node

focusNode' :: AbstractionGraph -- ^ The graph

-> NodeId -- ^ ID of the node

-> IO ()

focusNode' g nId = maybe (error "focusNode: node is hidden!")

(setNodeFocus (theGraph g)) $ udgNode $ get nId $ nodes g

-- | Focus a node

focusNode :: GraphInfo -- ^ The graph

-> NodeId -- ^ ID of the node

-> IO ()

focusNode gi nId = wrapperRead (flip focusNode' nId) gi

{- Functions for adding, deleting, changing and hidding edges.-}

-- | Adds an edge (type id)

addEdge :: AbstractionGraph -- ^ The graph

-> EdgeId -- ^ ID of the edge

-> DGEdgeType -- ^ ID of the edgetype

-> NodeId -- ^ ID of source node

-> NodeId -- ^ ID of target node

-> String -- ^ Name of the edge

-> Maybe (LEdge DGLinkLab) -- ^ Label of the edge

-> Bool -- ^ Hidden

-> IO AbstractionGraph

addEdge g eId eType nIdFrom nIdTo eName eLabel hidden =

if Map.member eId $ edges g

then error $ "addEdge: Edge with id " ++ show eId ++ " already exist!"

else do

let gaeV = (eName, eId, eLabel)

edge' <- if hidden then return Nothing else

case getEdgeAux g nIdFrom nIdTo eType of

Just (nFrom, nTo, gaeT) ->

fmap Just $ newArc (theGraph g) (udgEdgeType gaeT) gaeV nFrom nTo

Nothing -> return Nothing

let edge = GAEdge { udgEdge = edge'

, gaeType = eType

, ganFrom = nIdFrom

, ganTo = nIdTo

, gaeValue = gaeV }

return g { edges = Map.insert eId edge $ edges g }

-- | Gets uDrawGraph source and target node, edge type

getEdgeAux :: AbstractionGraph -- ^ The graph

-> NodeId -- ^ ID of source node

-> NodeId -- ^ ID of target node

-> DGEdgeType -- ^ ID of the edgetype

-> Maybe (DaVinciNode NodeValue, DaVinciNode NodeValue, GAEdgeType)

-- ^ uDrawGraph source and target node, edge type

getEdgeAux g nIdFrom nIdTo eType =

let ns = nodes g

gaeT = get eType $ edgeTypes g

in case (udgNode $ get nIdFrom ns, udgNode $ get nIdTo ns) of

(Just nFrom, Just nTo) | f gaeT nIdFrom nIdTo -> Just (nFrom, nTo, gaeT)

_ -> Nothing

where

f et nf nt = not (gaeHidden et || isHiddenNode' g nf || isHiddenNode' g nt)

-- | Deletes an edge

delEdge :: AbstractionGraph -- ^ The graph

-> EdgeId -- ^ ID of the node

-> IO AbstractionGraph

delEdge g eId = do

case udgEdge $ get eId $ edges g of

Just edge -> deleteArc (theGraph g) edge

Nothing -> return ()

return g { edges = Map.delete eId $ edges g }

-- | Adds an compressed edge

addCompressedEdge :: AbstractionGraph -- ^ The graph

-> (NodeId, NodeId, DGEdgeType, Bool) -- ^ Compressed edge id

-> IO AbstractionGraph

addCompressedEdge g ce@(nIdFrom, nIdTo, eType, orig) = do

let gaeV = ("", EdgeId 0, Nothing)

edge' <- case getEdgeAux g nIdFrom nIdTo eType of

Just (nFrom, nTo, gaeT) ->

fmap Just $ newArc (theGraph g)

((if orig then fst else snd) $ udgCompressed gaeT)

gaeV nFrom nTo

Nothing -> return Nothing

let edge = GAEdge { udgEdge = edge'

, gaeType = eType

, ganFrom = nIdFrom

, ganTo = nIdTo

, gaeValue = gaeV }

return g { compressedEdges = Map.insert ce edge $ compressedEdges g }

-- | Deletes an compressed edge

delCompressedEdge :: AbstractionGraph -- ^ The graph

-> (NodeId, NodeId, DGEdgeType, Bool) -- ^ Compressed edge id

-> IO AbstractionGraph

delCompressedEdge g ce = do

case udgEdge $ get ce $ compressedEdges g of

Just edge -> deleteArc (theGraph g) edge

Nothing -> return ()

return g { compressedEdges = Map.delete ce $ compressedEdges g }

-- | Hides an edge

hideEdge :: AbstractionGraph -- ^ The graph

-> EdgeId -- ^ ID of the edge

-> IO AbstractionGraph

hideEdge g eId = do

let edge = get eId $ edges g

case udgEdge edge of

Nothing -> return g

Just edge' -> do

deleteArc (theGraph g) edge'

return g { edges = Map.insert eId edge { udgEdge = Nothing } $ edges g }

-- | Hides a set of edgetypes (type ids)

hideSetOfEdgeTypes' :: AbstractionGraph -- ^ The graph

-> [DGEdgeType] -- ^ IDs of the edgetypes to hide

-> IO AbstractionGraph

hideSetOfEdgeTypes' g eTypes = do

let (hEdges, sEdges) = Map.foldrWithKey (\ eid e (he, se) ->

if elem (gaeType e) eTypes then (eid : he, se) else (he, eid : se))

([], []) $ edges g'

g' = g { edgeTypes = Map.mapWithKey

(\ etId et -> et { gaeHidden = elem etId eTypes }) $ edgeTypes g }

g'' <- foldM hideEdge g' hEdges

foldM showEdge g'' sEdges

-- | Hides a set of edgetypes (type ids)

hideSetOfEdgeTypes :: GraphInfo -- ^ The graph

-> [DGEdgeType] -- ^ IDs of the edgetypes to hide

-> IO ()

hideSetOfEdgeTypes gi eT = do

(update, exit) <- pulseBar "Updating graph" "hiding/showing edge types..."

wrapperWrite (flip hideSetOfEdgeTypes' eT) gi

update "finished"

exit

-- | Checks whether an edge is hidden or not

isHiddenEdge' :: AbstractionGraph -- ^ The graph

-> EdgeId -- ^ ID of the edge

-> Bool -- ^ Is edge hidden

isHiddenEdge' g eId = isNothing $ udgEdge $ get eId $ edges g

-- | Checks whether an edge is hidden or not

isHiddenEdge :: GraphInfo -- ^ The graph

-> EdgeId -- ^ ID of the edge

-> IO Bool -- ^ Is edge hidden

isHiddenEdge gi eId = wrapperBool (flip isHiddenEdge' eId) gi

-- | Shows a hidden edge again

showEdge :: AbstractionGraph -- ^ The graph

-> EdgeId -- ^ ID of the edge

-> IO AbstractionGraph

showEdge g eId = do

let es = edges g

edge = get eId es

case udgEdge edge of

Just _ -> return g

Nothing -> case getEdgeAux g (ganFrom edge) (ganTo edge) (gaeType edge) of

Just (nFrom, nTo, gaeT) -> do

edge' <- newArc (theGraph g) (udgEdgeType gaeT) (gaeValue edge) nFrom

nTo

return g { edges = Map.insert eId edge { udgEdge = Just edge' } es }

Nothing -> return g

-- * Conversion and update of graph

-- | Apply changes to the uDrawGraph graph

applyChanges' :: AbstractionGraph -- ^ The graph

-> [DGChange] -- ^ List of changes

-> [NodeId] -- ^ IDs of the nodes to hide

-> [EdgeId] -- ^ IDs of the edges to hide

-> [(NodeId, NodeId, DGEdgeType, Bool)] -- ^ A list of new edges

-> IO AbstractionGraph

applyChanges' g dgchanges hnIds heIds' ce = do

let

-- split and convert changes

(an',dn,cnt',ae',de) = convertChanges dgchanges ([],[],[],[],[])

-- get Ids

anIds = map (\(AddNode nId _ _ _) -> nId) an'

dnIds = map (\(DelNode nId) -> nId) dn

aeIds = map (\(AddEdge eId _ _ _ _ _ _) -> eId) ae'

deIds = map (\(DelEdge eId) -> eId) de

heIds = heIds' ++ map fst (filter (\ (eId,e) -> notElem eId deIds &&

notElem eId heIds' && (elem (ganTo e) hnIds || elem (ganFrom e) hnIds))

$ Map.toList $ edges g)

-- filter multiple changes and changes for deleted and new nodes

(cnt, new) = partition (\(ChangeNodeType nId _) -> notElem nId anIds)

$ filter (\(ChangeNodeType nId _) -> notElem nId dnIds) $ fst

$ foldl (\(cs, nIds) c@(ChangeNodeType nId _) -> if elem nId nIds

then (cs, nIds) else (c:cs, nId:nIds)) ([],[]) $ reverse cnt'

-- fuction for geting new nt if node type change is submitted for node

nnT nId nT = foldl (\nT' (ChangeNodeType nId' nT'') ->

if nId == nId' then nT'' else nT') nT new

-- update node type and mark as hidden if they would be hidden afterwards

an = map (\(AddNode nId nT nN _) -> AddNode nId (nnT nId nT) nN

$ elem nId hnIds) an'

-- old compressed edges

oce = Map.keys $ compressedEdges g

-- delete compressed edges not needed anymore

dce = foldl (\es e -> if elem e ce then es else DelCompEdge e:es) [] oce

-- get hidden nodes that are not hidden after update

sn = map ShowNode $ filter

(\n -> isHiddenNode' g n && not (elem n hnIds || elem n dnIds))

$ Map.keys $ nodes g

-- edges to hide

he = map HideEdge $ filter

(\eId -> notElem eId aeIds && not (isHiddenEdge' g eId)) heIds

-- mark as hidden if they would be hidden afterwards

ae = map (\(AddEdge eId eT nIdF nIdT eN eL _) ->

AddEdge eId eT nIdF nIdT eN eL $ elem nIdF hnIds || elem nIdT hnIds ||

elem eId heIds) ae'

-- nodes to hide

hn = map HideNode $ filter

(\nId -> notElem nId anIds && not (isHiddenNode' g nId)) hnIds

-- edges to show

se = map ShowEdge

$ filter (\ e -> isHiddenEdge' g e && notElem e heIds && notElem e deIds)

$ Map.keys $ edges g

-- get compressed edges to add

ace = foldl (\es e -> if elem e oce then es else AddCompEdge e:es) [] ce

-- concat changes

changes = de ++ dce ++ dn ++ cnt ++ sn ++ an ++ he ++ hn ++ se ++ ae ++ ace

foldM applyChange g changes

-- | Apply changes to the uDrawGraph graph

applyChanges :: GraphInfo -- ^ The graph

-> [DGChange] -- ^ List of changes

-> [NodeId] -- ^ IDs of the nodes to hide

-> [EdgeId] -- ^ IDs of the edges to hide

-> [(NodeId, NodeId, DGEdgeType, Bool)] -- ^ A list of new edges

-> IO ()

applyChanges gi changes nIds eIds compedges = do

wrapperWrite (\ g -> applyChanges' g changes nIds eIds compedges) gi

-- | Converts and splits DGChanges to GAChanges

convertChanges :: [DGChange] -- ^ Development graph changes

-> ([GAChange], [GAChange], [GAChange], [GAChange], [GAChange])

-- ^ Graph abstraction changes

-> ([GAChange], [GAChange], [GAChange], [GAChange], [GAChange])

-- ^ Graph abstraction changes

convertChanges [] changes = changes

convertChanges (c:r) (an, dn, cnt, ae, de) = case change of

AddNode _ _ _ _ -> convertChanges r (change : an, dn, cnt, ae, de)

DelNode _ -> convertChanges r (an, change : dn, cnt, ae, de)

ChangeNodeType _ _ -> convertChanges r (an, dn, change : cnt, ae, de)

AddEdge _ _ _ _ _ _ _ -> convertChanges r (an, dn, cnt, change : ae, de)

DelEdge _ -> convertChanges r (an, dn, cnt, ae, change : de)

_ -> error "convertChanges: internal error!"

where

change = convertChange c

-- | Converts a DGChange to a GAChange

convertChange :: DGChange -- ^ Development graph change

-> GAChange -- ^ Graph abstraction change

convertChange change = case change of

InsertNode (node, nodelab) ->

AddNode node (getRealDGNodeType nodelab) (getDGNodeName nodelab) False

DeleteNode (node, _) ->

DelNode node

SetNodeLab _ (node, newLab) ->

ChangeNodeType node $ getRealDGNodeType newLab

InsertEdge e@(src, tgt, lbl) ->

AddEdge (dgl_id lbl) (getRealDGLinkType lbl) src tgt "" (Just e) False

DeleteEdge (_, _, lbl) ->

DelEdge $ dgl_id lbl

-- | Applies a change to the graph

applyChange :: AbstractionGraph -- ^ The graph

-> GAChange -- ^ Change to apply

-> IO AbstractionGraph

applyChange g change = case change of

AddNode nId nT nN nH -> addNode g nId nT nN nH

DelNode nId -> delNode g nId

ChangeNodeType nId nT -> changeNodeType g nId nT

ShowNode nId -> showNode g nId

HideNode nId -> hideNode g nId

AddEdge eId eT nIdF nIdT eN eL eH -> addEdge g eId eT nIdF nIdT eN eL eH

DelEdge eId -> delEdge g eId

ShowEdge eId -> showEdge g eId

HideEdge eId -> hideEdge g eId

AddCompEdge ceId -> addCompressedEdge g ceId

DelCompEdge ceId -> delCompressedEdge g ceId

-- | Converts a DGraph to a list of changes

convert :: DGraph -- ^ The development graph

-> [DGChange] -- ^ List of changes

convert dg = map InsertNode (labNodesDG dg)

++ map InsertEdge (labEdgesDG dg)

-- * direct manipulation of uDrawGraph

-- | execute in the context of the given graph

doInGraphContext :: DVT.DaVinciCmd -- ^ uDrawGraph command

-> GraphInfo -- ^ The graph

-> IO ()

doInGraphContext cmd gi = do

g <- readIORef gi

let Graph dg = theGraph g

synchronize (pendingChangesLock dg) $ doInContext cmd

$ getDaVinciGraphContext dg

-- | Improve the layout of a graph like calling \"Layout->Improve All\"

layoutImproveAll :: GraphInfo -- ^ The graph

-> IO ()

layoutImproveAll = doInGraphContext (DVT.Menu $ DVT.Layout DVT.ImproveAll)

-- | Display a message in a uDrawGraph window controlled by AbstractGraphView

showTemporaryMessage :: GraphInfo -- ^ The graph

-> String -- ^ message to be displayed

-> IO ()

showTemporaryMessage gi message =

doInGraphContext (DVT.Window $ DVT.ShowMessage message) gi

-- | Deactivate the input of all uDrawGraph windows;

--

-- Warning: every deactivate event must be paired an activate event

deactivateGraphWindow :: GraphInfo -- ^ The graph

-> IO ()

deactivateGraphWindow = doInGraphContext (DVT.Window DVT.Deactivate)

-- | Activate the input of a uDrawGraph display

activateGraphWindow :: GraphInfo -- ^ The graph

-> IO ()

activateGraphWindow = doInGraphContext (DVT.Window DVT.Activate)

-- | Closes the Window

closeGraphWindow :: GraphInfo -- ^ The graph

-> IO ()

closeGraphWindow gi = readIORef gi >>= destroyGraph . theGraph

-- | destroy graph

destroyGraph :: OurGraph -- ^ uDrawGraph graph

-> IO ()

destroyGraph (Graph dg) = destroy $ getDaVinciGraphContext dg