{-# LANGUAGE FlexibleInstances #-}

{- |

Module : $Header$

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 =

Map.mapWithKey

(\ 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

doInContext (DVT.Menu $ DVT.Layout DVT.ImproveAll) contxt

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))