{-# LANGUAGE FlexibleInstances #-}
{- |
Module : ./Taxonomy/AbstractGraphView.hs
Description : Interface for graph viewing and abstraction
Copyright : (c) Till Mossakowski, Uni Bremen 2002-2007
License : GPLv2 or higher, see LICENSE.txt
Maintainer : raider@informatik.uni-bremen.de
Stability : provisional
Portability : non-portable (relies on Logic via DevGraph)
Interface for graph viewing and abstraction.
It is possible to hide sets of nodes and edges.
Using a composition table for edge types,
paths through hidden nodes can be displayed.
Graphs, nodes, and edges are handled via
descriptors (here: integers), while node and
edge types are handled by user-supplied strings.
-}
module Taxonomy.AbstractGraphView
( OurGraph
, initgraphs
, Result (Result)
, makegraph
, makegraphExt
, redisplay
, getGraphid
, Descr
, GraphInfo
, RelationViewSpec (RelViewSpec)
, writeRelViewSpecs
, AbstractionGraph (theGraph, edges,
ontoGraph, nodeMap, nodes, relViewSpecs)
, NodeMapping
, writeNodeMap
, addnode
, addlink
, delnode
, dellink
, EdgeValue
, writeOntoGraph
, showIt
, CompTable
, hidenodes
, changeNodeType
, checkHasHiddenNodes
, hideSetOfNodeTypes
, hideSetOfEdgeTypes
-- * Direct manipulation of uDrawGraph
, layoutImproveAll
, showTemporaryMessage
, deactivateGraphWindow
, activateGraphWindow
) where
import GUI.UDGUtils
import qualified UDrawGraph.Types as DVT
import ATC.DevGraph ()
import Static.DevGraph (DGLinkLab)
import Common.Taxonomy
import Common.Lib.Graph as Tree
import Data.IORef
import Data.List (nub)
import qualified Data.Map as Map
import Data.Graph.Inductive.Graph (LEdge)
import qualified Data.Graph.Inductive.Graph as Graph
import Control.Concurrent
-- | wait for this amount of microseconds to let uDrawGraph redraw
delayTime :: Int
delayTime = 300000
{- methods using fetchGraph return a quadruple containing the
modified graph, a descriptor of the last modification (e.g. a new
node), the descriptor that can be used for the next modification and a
possible error message -}
-- Which graph display tool to be used, perhaps make it more tool independent?
instance Eq (DaVinciNode (String, Int, Int)) where
(==) = eq1
instance Eq (DaVinciArc EdgeValue) where
(==) = eq1
graphtool :: OurGraph
graphtool = daVinciSort
type OurGraph =
Graph DaVinciGraph
DaVinciGraphParms
DaVinciNode
DaVinciNodeType
DaVinciNodeTypeParms
DaVinciArc
DaVinciArcType
DaVinciArcTypeParms
{- Main datastructure for carrying around the graph,
both internally (nodes as integers), and at the daVinci level -}
type CompTable = [(String, String, String)]
data AbstractionGraph = AbstractionGraph
{ theGraph :: OurGraph
, nodeTypes :: [(String, DaVinciNodeType (String, Int, Int))]
, edgeTypes :: [(String, DaVinciArcType EdgeValue)]
, nodes :: Map.Map Int (String, DaVinciNode (String, Int, Int))
, edges :: Map.Map Int (Int, Int, String, DaVinciArc EdgeValue)
{- probably, also the abstracted graph needs to be stored,
and a list of hide/abstract events with the hidden nodes/edges (for
each event), which is used to restore things when showIt is called -}
, edgeComp :: CompTable
, eventTable :: [(Int, Entry)]
, hiddenEdges :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
, deletedNodes :: [Int]
, ontoGraph :: Tree.Gr (String, String, OntoObjectType) String
, relViewSpecs :: [RelationViewSpec]
, nodeMap :: NodeMapping
}
type NodeMapping = Map.Map Int Descr
type Descr = Int
type EdgeValue = (String, Int, Maybe (LEdge DGLinkLab))
type GraphInfo = IORef ([(Descr, AbstractionGraph)], Descr)
{- for each graph the descriptor and the graph,
plus a global counter for new descriptors -}
data Result = Result Descr -- graph, node or edge descriptor
(Maybe String) -- a possible error message
data Entry = Entry {newNodes :: [(Descr, (String,
DaVinciNode (String, Int, Int)))],
oldNodes :: [(Descr, (String, String))],
newEdges :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))],
oldEdges :: [(Int, (Int, Int, String, EdgeValue))]
}
data RelationViewSpec = RelViewSpec String Bool Bool
{- creates a new entry of the eventTable and fills it with the data contained
in its parameters -}
createEntry :: [(Descr, (String, DaVinciNode (String, Int, Int)))]
-> [(Descr, (String, String))]
-> [(Descr, (Int, Int, String, DaVinciArc EdgeValue))]
-> [(Descr, (Int, Int, String, EdgeValue))] -> Descr -> (Int, Entry)
createEntry nn on ne oe cnt =
(cnt, Entry {newNodes = nn, oldNodes = on, newEdges = ne, oldEdges = oe})
{- zips two lists by pairing each element of the first with each element of
the second -}
specialzip :: [a] -> [b] -> [(a, b)]
specialzip xs ys = [ (x, y) | x <- xs, y <- ys ]
{- similar to lookup, but also returns the decriptor
should only be used, if lookup will be successful (otherwise an error is
thrown) -}
get :: Descr -> [(Descr, a)] -> (Descr, a)
get d list =
case lookup d list of
Just r -> (d, r)
Nothing -> error $ "get: descriptor unknown: " ++ show d
++ '\n' : show (map fst list)
getFromMap :: Descr -> Map.Map Descr a -> (Descr, a)
getFromMap d list =
case Map.lookup d list of
Just r -> (d, r)
Nothing -> error $ "get: descriptor unknown: " ++ show d
++ '\n' : show (Map.keys list)
remove :: Eq a => a -> [(a, b)] -> [(a, b)]
remove x = filter ((x /=) . fst)
{- lookup a graph descriptor and execute a command on the graph
the delete flag specifies if the graph should be removed from the graph
list afterwards -}
fetchGraph :: Descr -> GraphInfo -> Bool -> ((AbstractionGraph, Descr)
-> IO (AbstractionGraph, Descr, Descr, Maybe String)) -> IO Result
fetchGraph gid gv delete cmd = do
(gs, ev_cnt) <- readIORef gv
case lookup gid gs of
Just g -> do
(g', descr, ev_cnt', err) <- cmd (g, ev_cnt)
let gs'' = if delete then gs' else (gid, g') : gs'
writeIORef gv (gs'', ev_cnt')
return (Result descr err)
where gs' = remove gid gs
Nothing -> return (Result 0 (Just ("Graph id " ++ show gid ++ " not found")))
getGraphid :: Descr -> GraphInfo -> IO OurGraph
getGraphid gid gv = do
(gs, _) <- readIORef gv
case lookup gid gs of
Just g -> return $ theGraph g
Nothing -> error "get_graphid: graph does not exist"
-- These are the operations of the interface
initgraphs :: IO GraphInfo
initgraphs = newIORef ([], 0)
makegraph :: String -- Title
-> Maybe (IO ()) -- FileOpen Menu
-> Maybe (IO ()) -- FileSave Menu
-> Maybe (IO ()) -- FileSaveAs Menu
-> [GlobalMenu]
-> [(String, DaVinciNodeTypeParms (String, Descr, Descr))]
-> [(String, DaVinciArcTypeParms EdgeValue)] -> CompTable
-> GraphInfo -> IO Result
makegraph title open save saveAs =
makegraphExt title open save saveAs (return True) Nothing
makegraphExt :: String -- Title
-> Maybe (IO ()) -- FileOpen Menu
-> Maybe (IO ()) -- FileSave Menu
-> Maybe (IO ()) -- FileSaveAs Menu
-> IO Bool -- FileClose Menu
-> Maybe (IO ()) -- FileExit Menu
-> [GlobalMenu]
-> [(String, DaVinciNodeTypeParms (String, Descr, Descr))]
-> [(String, DaVinciArcTypeParms EdgeValue)] -> CompTable
-> GraphInfo -> IO Result
makegraphExt title open save saveAs close exit menus nodetypeparams
edgetypeparams comptable gv = do
(gs, ev_cnt) <- readIORef gv
let
graphParms =
foldr ($$) (GraphTitle title $$
OptimiseLayout False $$
AllowClose close $$
FileMenuAct OpenMenuOption open $$
FileMenuAct SaveMenuOption save $$
FileMenuAct SaveAsMenuOption saveAs $$
FileMenuAct ExitMenuOption exit $$
emptyGraphParms)
menus
abstractNodetypeparams =
LocalMenu (
Button "Unhide abstracted nodes"
(\ (_, descr, gid) -> do
oldGv <- readIORef gv
(Result _ error') <- showIt gid descr gv
case error' of
Just _ -> do
writeIORef gv oldGv
return ()
Nothing -> do
redisplay gid gv
return ()
)
) $$$
Rhombus $$$
ValueTitle ( \ (name, _, _) -> return name) $$$
emptyNodeTypeParms :: DaVinciNodeTypeParms (String, Int, Int)
(nodetypenames, nodetypeparams1) =
unzip (("ABSTRACT", abstractNodetypeparams) : nodetypeparams)
(edgetypenames, edgetypeparams1) = unzip edgetypeparams
ontoGr = Graph.empty
relViewSpecList = []
graph <- newGraph graphtool graphParms
nodetypes <- mapM (newNodeType graph) nodetypeparams1
edgetypes <- mapM (newArcType graph) edgetypeparams1
let g = AbstractionGraph {
theGraph = graph,
nodeTypes = zip nodetypenames nodetypes,
edgeTypes = zip edgetypenames edgetypes,
nodes = Map.empty,
edges = Map.empty, -- [],
edgeComp = comptable,
eventTable = [],
deletedNodes = [],
hiddenEdges = [],
ontoGraph = ontoGr,
relViewSpecs = relViewSpecList,
nodeMap = Map.empty }
writeIORef gv ((ev_cnt, g) : gs, ev_cnt + 1)
return (Result ev_cnt Nothing)
addnode :: Descr -> String -> String -> GraphInfo -> IO Result
addnode gid nodetype name gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
-- ---------------------------- why query nodetype first
case lookup nodetype (nodeTypes g) of
Nothing ->
return (g, 0, ev_cnt, Just ("addnode: illegal node type: " ++ nodetype))
Just nt -> do
node <- newNode (theGraph g) nt (name, ev_cnt, gid)
return (g {nodes = Map.insert ev_cnt (nodetype, node) $ nodes g},
ev_cnt, ev_cnt + 1, Nothing)
)
{- | change the node type of the given node in the given graph.
it firstly checks if the node exists in the graph and if
the given node type is valid, then does the setting.
-}
changeNodeType :: Descr -- ^ the graph id
-> Descr -- ^ the id of the to be set node
-> String -- ^ the new node type
-> GraphInfo -- ^ the enviroment
-> IO Result
changeNodeType gid node nodetype graph =
fetchGraph gid graph False (\ (g, ev_cnt) ->
case Map.lookup node (nodes g) of
Nothing ->
return (g, 0, ev_cnt, Just ("changeNodeType: illegal node: "
++ show node))
Just n ->
case lookup nodetype (nodeTypes g) of
Nothing ->
return (g, 0, ev_cnt,
Just ("changeNodeType: illegal node type: " ++ nodetype))
Just nt -> do
setNodeType (theGraph g) (snd n) nt
let newnodes =
(\ descr v@(_, davinciNode) -> if descr == node
then (nodetype, davinciNode) else v) $ nodes g
return (g {nodes = newnodes}, node, ev_cnt + 1, Nothing)
)
writeOntoGraph :: Descr -> Tree.Gr (String, String, OntoObjectType) String
-> GraphInfo -> IO Result
writeOntoGraph gid graph gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
return (g {ontoGraph = graph}, 0, ev_cnt + 1, Nothing)
)
writeRelViewSpecs :: Descr -> [RelationViewSpec] -> GraphInfo -> IO Result
writeRelViewSpecs gid specs gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
return (g {relViewSpecs = specs}, 0, ev_cnt + 1, Nothing)
)
writeNodeMap :: Descr -> NodeMapping -> GraphInfo -> IO Result
writeNodeMap gid nMap gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
return (g {nodeMap = nMap}, 0, ev_cnt + 1, Nothing)
)
delnode :: Descr -> Descr -> GraphInfo -> IO Result
delnode gid node gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
case Map.lookup node (nodes g) of
Just n -> do
deleteNode (theGraph g) (snd n)
return (g {nodes = Map.delete node (nodes g)
, deletedNodes = deletedNodes g},
0, ev_cnt + 1, Nothing)
Nothing ->
return (g, 0, ev_cnt, Just ("delnode: illegal node: " ++ show node))
)
addlink :: Descr -> String -> String -> Maybe (LEdge DGLinkLab) -> Descr
-> Descr -> GraphInfo -> IO Result
addlink gid edgetype name label src tar gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
case (lookup edgetype (edgeTypes g),
Map.lookup src (nodes g),
Map.lookup tar (nodes g)) of
(Just et, Just src_node, Just tar_node) -> do
sequence_ [getArcValue (theGraph g) davinciArc
| (srcId, tgtId, tp, davinciArc) <- Map.elems (edges g),
tp == edgetype && srcId == src && tgtId == tar]
edge <- newArc (theGraph g) et (name, ev_cnt, label) (snd src_node)
(snd tar_node)
return (g {edges = Map.insert ev_cnt (src, tar, edgetype, edge)
$ edges g}, ev_cnt, ev_cnt + 1, Nothing)
(Nothing, _, _) ->
return (g, 0, ev_cnt, Just ("addlink: illegal edge type: " ++ edgetype))
(_, Nothing, _) ->
return (g, 0, ev_cnt,
Just ("addlink: illegal source node id: " ++ show src))
(_, _, Nothing) ->
return (g, 0, ev_cnt,
Just ("addlink: illegal target node id: " ++ show tar))
)
dellink :: Descr -> Descr -> GraphInfo -> IO Result
dellink gid edge gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
case Map.lookup edge (edges g) of
Just (_, _, _, e) -> do
deleteArc (theGraph g) e
return (g {edges = Map.delete edge (edges g)}, 0, ev_cnt + 1, Nothing)
Nothing ->
return (g, 0, ev_cnt, Just ("dellink: illegal edge: " ++ show edge))
)
redisplay :: Descr -> GraphInfo -> IO Result
redisplay gid gv =
fetchGraph gid gv False (\ (g, ev_cnt) -> do
redraw (theGraph g)
threadDelay delayTime
return (g, 0, ev_cnt + 1, Nothing)
)
{- determines from the types of two edges the type of the path replacing them
(using the edgeComp table of the graph) -}
determineedgetype :: AbstractionGraph -> (String, String) -> Maybe String
determineedgetype g (t1, t2) =
case [ t | (tp1, tp2, t) <- edgeComp g, tp1 == t1 && tp2 == t2 ] of
[] -> Nothing
x : _ -> Just x
{- returns a pair of lists: one list of all in- and one of all out-going edges
of the node -}
fetchEdgesOfNode :: AbstractionGraph -> Descr -> Maybe ([Descr], [Descr])
fetchEdgesOfNode g node =
{- ? this checking seems meaningless...
case sequence (map ((flip Map.lookup) (edges g)) (Map.keys $ edges g)) of
Just _ -> -}
Just ([descr | (descr, (_, t, _, _)) <- Map.toList $ edges g, t == node],
[descr | (descr, (s, _, _, _)) <- Map.toList $ edges g, s == node])
-- Nothing -> Nothing
hideSetOfNodeTypes :: Descr -> [String] -> Bool -> GraphInfo -> IO Result
hideSetOfNodeTypes gid nodetypes showLast gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
case mapM (`lookup` nodeTypes g) nodetypes of
Just _ -> do
let nodelist = [descr | (descr, (tp, _)) <- Map.toList (nodes g),
elem tp nodetypes && (not showLast || any
(\ (descr', _, _, _) -> descr' == descr)
(Map.elems $ edges g))]
case nodelist of
[] ->
return (g, 0, ev_cnt, Nothing)
_ -> do
(Result de error') <- hidenodes gid nodelist gv
info <- readIORef gv
return (snd (get gid (fst info)), de, snd info, error')
Nothing ->
return (g, 0, ev_cnt, Just ("hidenodetype: illegal node types "
++ "in list: " ++ showList nodetypes ","))
)
hidenodes :: Descr -> [Descr] -> GraphInfo -> IO Result
hidenodes gid node_list gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
case mapM (`Map.lookup` nodes g) node_list of
Just _ ->
-- try to determine the path to add and the edges to remove
case makepathsMain g node_list of
-- try to create the paths
Just (newEdges', delEdges) -> do
-- save the old edges...
let
oeDescr = nub $ concatMap fst delEdges ++ concatMap snd delEdges
oe = map (`getFromMap` edges g) oeDescr
oldEdges' <- saveOldEdges g oe
-- ... then try to remove them from the graph
(gs, _) <- readIORef gv
writeIORef gv (gs, ev_cnt + 1)
(Result _ error1) <- hideedgesaux gid oeDescr gv
info1 <- readIORef gv
case error1 of
Nothing -> do
-- determine the _new_ edges...
let
existingEdges =
[(src, tgt, tp) | (src, tgt, tp, _) <-
Map.elems $ edges (snd (get gid (fst info1)))]
filteredNewEdges =
[path | path@(src, tgt, tp) <- newEdges',
notElem (src, tgt, tp) existingEdges]
-- ... and try to add them
(Result _ error2) <-
addpaths gid filteredNewEdges gv -- info1
case error2 of
Nothing -> do
-- save the old nodes...
let on = map (`getFromMap` nodes g) node_list
oldNodes' <- saveOldNodes g on
-- ... then try to remove them from the graph
(Result _ error3) <-
hidenodesaux gid node_list gv -- info2
info3 <- readIORef gv
case error3 of
Nothing -> do
-- save the changes in an entry
let
g' = snd (get gid (fst info3))
newEdges'' = [edge | edge <- Map.toList (edges g'),
Map.notMember (fst edge) (edges g)]
newEvent = createEntry [] oldNodes' newEdges''
oldEdges' ev_cnt
return (g' {eventTable = newEvent : eventTable g'}
, ev_cnt, snd info3 + 1, Nothing)
Just t ->
return (g, 0, ev_cnt,
Just ("hidenodes: error hiding nodes: " ++ t))
Just text ->
return (g, 0, ev_cnt,
Just ("hidenodes: error adding paths: " ++ text))
Just text ->
return (g, 0, ev_cnt,
Just ("hidenodes: error deleting edges: " ++ text))
Nothing ->
return (g, 0, ev_cnt,
Just ("hidenodes: error making paths\n(possible reasons: "
++ "an error occured getting the edges of the nodes\n "
++ "or a pathtype could not be determined (missing "
++ "entry in edgeComp table))"))
Nothing -> return (g, 0, ev_cnt, Just "hidenodes: unknown node(s)")
)
-- auxiliary function, which removes the nodes from the graph
hidenodesaux :: Descr -> [Descr] -> GraphInfo -> IO Result
hidenodesaux _ [] gv = do
(_, ev_cnt) <- readIORef gv
return (Result ev_cnt Nothing)
hidenodesaux gid (d : delNodes) gv = do
deletedNode@(Result _ error') <- delnode gid d gv
case error' of
Nothing -> hidenodesaux gid delNodes gv
Just _ -> return deletedNode
-- returns the paths to add and the edges to remove
makepathsMain :: AbstractionGraph -> [Descr]
-> Maybe ([(Descr, Descr, String)], [([Descr], [Descr])])
makepathsMain g node_list =
-- try to determine the in- and outgoing edges of the nodes
case mapM (fetchEdgesOfNode g) node_list of
-- try to make paths of these edges
Just edgelistPairs ->
case mapM (makepaths g node_list) edgelistPairs of
-- the paths to add (dangling ones are removed) and the edges to remove
Just paths ->
Just (removeDanglingEdges (nub (concat paths)) node_list,
edgelistPairs)
Nothing -> Nothing
Nothing -> Nothing
-- removes those edges whose source or target node will be hidden
removeDanglingEdges :: [(Descr, Descr, String)] -> [Descr]
-> [(Descr, Descr, String)]
removeDanglingEdges edges' nodes' =
[edge | edge@(src, tgt, _) <- edges', notElem src nodes' && notElem tgt nodes']
-- returns a list of paths (ie source, target and type) to be added
makepaths :: AbstractionGraph -> [Descr] -> ([Descr], [Descr])
-> Maybe [(Descr, Descr, String)]
makepaths g node_list (inEdges, outEdges) =
-- try to lookup the edges of the node
case (mapM (`Map.lookup` edges g) inEdges,
mapM (`Map.lookup` edges g) outEdges) of
(Just ie, Just oe) ->
-- try to make paths out of them
case mapM (makepathsaux g node_list []) (specialzip ie oe) of
-- return the paths
Just paths -> Just (concat paths)
Nothing -> Nothing
(Nothing, _) -> Nothing
(_, Nothing) -> Nothing
{- determines source, target and type of the path to be added and checks it
using method checkpath -}
makepathsaux :: AbstractionGraph -> [Descr] -> [Descr]
-> ((Descr, Descr, String, DaVinciArc EdgeValue),
(Descr, Descr, String, DaVinciArc EdgeValue))
-> Maybe [(Descr, Descr, String)]
makepathsaux g node_list alreadyPassedNodes ((s1, _, ty1, ed1), (_, t2, ty2, _)) =
-- try to determine the type of the path
case determineedgetype g (ty1, ty2) of
-- return the checked path
Just ty -> checkpath g node_list alreadyPassedNodes (s1, t2, ty, ed1)
-- ed1 is just a dummy value (Dummiewert)
Nothing -> Nothing
{- check, if the source or the target of an edge are element of the list of
nodes that are to be hidden
if so, find out the "next" sources/targets and check again
remember which nodes have been passed to avoid infinite loops -}
checkpath :: AbstractionGraph -> [Descr] -> [Descr]
-> (Descr, Descr, String, DaVinciArc EdgeValue)
-> Maybe [(Descr, Descr, String)]
checkpath g node_list alreadyPassedNodes path@(src, tgt, ty, _)
| elem src alreadyPassedNodes || elem tgt alreadyPassedNodes = Just []
| elem src node_list =
-- try to determine the in- and outgoing edges of the source node
case fetchEdgesOfNode g src of
-- try to lookup ingoing edges
Just (inEdges, _) ->
case mapM (`Map.lookup` edges g) inEdges of
{- try to make paths of these edges and the "tail" of the path (and
recursively check them) -}
Just el ->
case mapM (makepathsaux g node_list (src : alreadyPassedNodes))
(specialzip el [path]) of
Just p -> Just (concat p)
Nothing -> Nothing
Nothing -> Nothing
Nothing -> Nothing
| elem tgt node_list =
-- try to determine the in- and outgoing edges of the target node
case fetchEdgesOfNode g tgt of
-- try to lookup the outgoing edges
Just (_, outEdges) ->
case mapM (`Map.lookup` edges g) outEdges of
{- try to make paths of these edges and the "init" of the path (and
recursively check them) -}
Just el ->
case mapM (makepathsaux g node_list
(tgt : alreadyPassedNodes))
(specialzip [path] el) of
Just p -> Just (concat p)
Nothing -> Nothing
Nothing -> Nothing
Nothing -> Nothing
| otherwise =
-- nothing to be done
Just [(src, tgt, ty)]
-- adds the paths (given source, target and type)
addpaths :: Descr -> [(Descr, Descr, String)] -> GraphInfo -> IO Result
addpaths _ [] gv = do
(_, ev_cnt) <- readIORef gv
return (Result ev_cnt Nothing)
addpaths gid ((src, tgt, ty) : newEdges') gv = do
edge@(Result _ error') <- addlink gid ty "" Nothing src tgt gv
case error' of
Nothing -> addpaths gid newEdges' gv
Just _ -> return edge
hideSetOfEdgeTypes :: Descr -> [String] -> GraphInfo -> IO Result
hideSetOfEdgeTypes gid edgetypes gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
case sequence [lookup edgetype (edgeTypes g) | edgetype <- edgetypes] of
Just _ -> do
let edgelist = [descr | (descr, (_ , _ , tp, _)) <- Map.toList (edges g),
elem tp edgetypes]
showlist = filter (\ (_, (_, _, tp, _)) -> notElem tp edgetypes)
$ hiddenEdges g
case edgelist of
[] -> return (g, 0, ev_cnt, Nothing)
_ -> do
(Result de err) <- hideedges gid edgelist gv
case err of
Nothing -> do
info <- readIORef gv
let gs = snd (get de $ fst info)
gs' = gs {hiddenEdges = filter (`notElem` showlist)
$ hiddenEdges gs}
sl' <- saveOldEdges gs showlist
writeIORef gv ((de + 1, gs') : fst info, de + 1)
(Result de' err') <- showedges (de + 1) sl' gv
case err' of
Nothing -> do
info' <- readIORef gv
return (snd $ get de' $ fst info', de', snd info', Nothing)
Just _ -> return (g, 0, ev_cnt, err')
Just _ -> return (g, 0, ev_cnt, err)
Nothing ->
return (g, 0, ev_cnt, Just ("hideedgestype: illegal edge types "
++ "in list: " ++ showList edgetypes ","))
)
hideedges :: Descr -> [Descr] -> GraphInfo -> IO Result
hideedges gid edge_list gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
case mapM (\ e -> case Map.lookup e (edges g) of
Just x -> Just (e, x)
Nothing -> Nothing) edge_list of
Just edges' -> do
Result de err <- hideedgesaux gid edge_list gv
case err of
Nothing -> do
info <- readIORef gv
return ((snd $ get gid $ fst info) {hiddenEdges = hiddenEdges g
++ edges'},
de, snd info + 1, Nothing)
Just _ -> return (g, 0, ev_cnt, Just "hideedges: error deleting edges")
Nothing -> return (g, 0, ev_cnt, Just "hideedges: unknown edge(s)")
)
-- an auxiliary function, which removes the edges from the graph
hideedgesaux :: Descr -> [Descr] -> GraphInfo -> IO Result
hideedgesaux _ [] gv = do
(_, ev_cnt) <- readIORef gv
return (Result ev_cnt Nothing)
hideedgesaux gid (d : delEdges) gv = do
dle@(Result _ error') <- dellink gid d gv
case error' of
Nothing -> hideedgesaux gid delEdges gv -- info
Just _ -> return dle
-- | function to check whether the internal nodes are hidden or not
checkHasHiddenNodes :: Descr -> Descr -> GraphInfo -> IO Result
checkHasHiddenNodes gid hide_event gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
case lookup hide_event (eventTable g) of
Just _ -> return (g, 0, ev_cnt, Nothing)
Nothing -> return (g, 0, ev_cnt,
Just "checkHasHiddenNodes: hide events not found")
)
-- function to undo hide-events
showIt :: Descr -> Descr -> GraphInfo -> IO Result
showIt gid hide_event gv =
fetchGraph gid gv False (\ (g, ev_cnt) ->
-- try to lookup the hide-event
case lookup hide_event (eventTable g) of
Just entry -> do
-- try to remove the paths that had been added
(Result _ error1) <- hideedgesaux gid (map fst (newEdges entry)) gv
case error1 of
Nothing -> do
-- try to add the nodes that had been hidden
(Result _ error2) <- shownodes gid (oldNodes entry) gv
case error2 of
Nothing -> do
-- try to remove the nodes that had been added
(Result _ error3) <- hidenodesaux gid
(map fst (newNodes entry)) gv
case error3 of
Nothing -> do
-- try to add the edges that had been hidden
(Result _ error4) <- showedges gid (oldEdges entry) gv
info4 <- readIORef gv
case error4 of
Nothing -> do
-- remove the event from the eventTable
let g' = snd (get gid (fst info4))
return (g' {eventTable = remove hide_event
(eventTable g')}, 0, ev_cnt + 1, Nothing)
Just t4 ->
return (g, 0, ev_cnt, Just ("showIt: error restoring old "
++ "edges:\n-> " ++ t4))
Just t3 ->
return (g, 0, ev_cnt,
Just ("showIt: error removing nodes:\n-> " ++ t3))
Just t2 ->
return (g, 0, ev_cnt, Just ("showIt: error restoring nodes:\n-> "
++ t2))
Just t1 ->
return (g, 0, ev_cnt, Just ("showIt: error removing edges:\n-> " ++ t1))
Nothing ->
return (g, 0, ev_cnt, Just ("showIt: invalid event descriptor: "
++ show hide_event))
)
-- adds nodes that had been hidden
shownodes :: Descr -> [(Descr, (String, String))] -> GraphInfo -> IO Result
shownodes _ [] gv = do
(_, ev_cnt) <- readIORef gv
return (Result ev_cnt Nothing)
shownodes gid ((d, (tp, name)) : list) gv = do
(gs, _) <- readIORef gv
-- try to add the first node
writeIORef gv (gs, d)
nd@(Result _ error') <- addnode gid tp name gv
case error' of
Nothing -> -- try to add the rest
shownodes gid list gv
Just _ -> return nd
-- adds edges that had been hidden
showedges :: Descr -> [(Int, (Int, Int, String, EdgeValue))] -> GraphInfo
-> IO Result
showedges _ [] gv = do
(_, ev_cnt) <- readIORef gv
return (Result ev_cnt Nothing)
showedges gid ((d, (src, tgt, tp, value)) : list) gv = do
(gs, _) <- readIORef gv
-- try to add the first edge
writeIORef gv (gs, d)
let
name = getEdgeName value
label = getEdgeLabel value
ed@(Result _ err) <- addlink gid tp name label src tgt gv
case err of
Nothing -> -- try to add the rest
showedges gid list gv
Just _ -> return ed
{- | creates a list of the nodes that will be hidden (ie descriptor,type and
name) -}
saveOldNodes :: AbstractionGraph
-> [(Int, (String, DaVinciNode (String, Int, Int)))]
-> IO [(Int, (String, String))]
saveOldNodes _ [] = return []
saveOldNodes g ((de, (tp, davincinode)) : list) = do
(name, _, _) <- getNodeValue (theGraph g) davincinode
restOfList <- saveOldNodes g list
return ((de, (tp, name)) : restOfList)
{- | creates a list of the edges that will be hidden (ie descriptor,source,
target,type and name) -}
saveOldEdges :: AbstractionGraph
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> IO [(Int, (Int, Int, String, EdgeValue))]
saveOldEdges _ [] = return []
saveOldEdges g ((de, (src, tgt, tp, davinciarc)) : list) = do
value <- getArcValue (theGraph g) davinciarc
restOfList <- saveOldEdges g list
return ((de, (src, tgt, tp, value)) : restOfList)
getEdgeName :: EdgeValue -> String
getEdgeName (name, _, _) = name
getEdgeLabel :: EdgeValue -> Maybe (LEdge DGLinkLab)
getEdgeLabel (_, _, label) = label
-- | improve the layout of a graph like calling \"Layout->Improve All\"
layoutImproveAll :: Descr -> GraphInfo -> IO Result
layoutImproveAll gid gv =
fetchGraph gid gv False (\ (g, ev_cnt) -> do
let contxt = case theGraph g of
Graph dg -> getDaVinciGraphContext dg
return (g, 0, ev_cnt + 1, Nothing))
-- | display a message in a uDrawGraph window controlled by AbstractGraphView
showTemporaryMessage :: Descr -> GraphInfo
-> String -- ^ message to be displayed
-> IO Result
showTemporaryMessage gid gv message =
fetchGraph gid gv False (\ (g, ev_cnt) -> do
let contxt = case theGraph g of
Graph dg -> getDaVinciGraphContext dg
doInContext (DVT.Window $ DVT.ShowMessage message) contxt
return (g, 0, ev_cnt + 1, Nothing))
-- | deactivate the input of all uDrawGraph windows;
--
-- Warning: every deactivate event must be paired an activate event
deactivateGraphWindow :: Descr -> GraphInfo -> IO Result
deactivateGraphWindow gid gv =
fetchGraph gid gv False (\ (g, ev_cnt) -> do
let contxt = case theGraph g of
Graph dg -> getDaVinciGraphContext dg
doInContext (DVT.Window DVT.Deactivate) contxt
return (g, 0, ev_cnt + 1, Nothing))
-- | activate the input of a uDrawGraph display
activateGraphWindow :: Descr -> GraphInfo -> IO Result
activateGraphWindow gid gv =
fetchGraph gid gv False (\ (g, ev_cnt) -> do
let contxt = case theGraph g of
Graph dg -> getDaVinciGraphContext dg
doInContext (DVT.Window DVT.Activate) contxt
return (g, 0, ev_cnt + 1, Nothing))