{-# 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 :: 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
    == :: DaVinciNode (String, Int, Int)
-> DaVinciNode (String, Int, Int) -> Bool
(==) = DaVinciNode (String, Int, Int)
-> DaVinciNode (String, Int, Int) -> Bool
forall (takesParm :: * -> *) value1.
Eq1 takesParm =>
takesParm value1 -> takesParm value1 -> Bool
eq1

instance Eq (DaVinciArc EdgeValue) where
    == :: DaVinciArc EdgeValue -> DaVinciArc EdgeValue -> Bool
(==) = DaVinciArc EdgeValue -> DaVinciArc EdgeValue -> Bool
forall (takesParm :: * -> *) value1.
Eq1 takesParm =>
takesParm value1 -> takesParm value1 -> Bool
eq1

graphtool :: OurGraph
graphtool :: OurGraph
graphtool = OurGraph
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
  { AbstractionGraph -> OurGraph
theGraph :: OurGraph
  , AbstractionGraph -> [(String, DaVinciNodeType (String, Int, Int))]
nodeTypes :: [(String, DaVinciNodeType (String, Int, Int))]
  , AbstractionGraph -> [(String, DaVinciArcType EdgeValue)]
edgeTypes :: [(String, DaVinciArcType EdgeValue)]
  , AbstractionGraph
-> Map Int (String, DaVinciNode (String, Int, Int))
nodes :: Map.Map Int (String, DaVinciNode (String, Int, Int))
  , AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
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 -}
  , AbstractionGraph -> CompTable
edgeComp :: CompTable
  , AbstractionGraph -> [(Int, Entry)]
eventTable :: [(Int, Entry)]
  , AbstractionGraph
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
hiddenEdges :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
  , AbstractionGraph -> [Int]
deletedNodes :: [Int]
  , AbstractionGraph -> Gr (String, String, OntoObjectType) String
ontoGraph :: Tree.Gr (String, String, OntoObjectType) String
  , AbstractionGraph -> [RelationViewSpec]
relViewSpecs :: [RelationViewSpec]
  , AbstractionGraph -> NodeMapping
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 {Entry -> [(Int, (String, DaVinciNode (String, Int, Int)))]
newNodes :: [(Descr, (String,
                                         DaVinciNode (String, Int, Int)))],
                    Entry -> [(Int, (String, String))]
oldNodes :: [(Descr, (String, String))],
                    Entry -> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
newEdges :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))],
                    Entry -> [(Int, (Int, Int, String, 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 :: [(Int, (String, DaVinciNode (String, Int, Int)))]
-> [(Int, (String, String))]
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> [(Int, (Int, Int, String, EdgeValue))]
-> Int
-> (Int, Entry)
createEntry nn :: [(Int, (String, DaVinciNode (String, Int, Int)))]
nn on :: [(Int, (String, String))]
on ne :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
ne oe :: [(Int, (Int, Int, String, EdgeValue))]
oe cnt :: Int
cnt =
  (Int
cnt, Entry :: [(Int, (String, DaVinciNode (String, Int, Int)))]
-> [(Int, (String, String))]
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> [(Int, (Int, Int, String, EdgeValue))]
-> Entry
Entry {newNodes :: [(Int, (String, DaVinciNode (String, Int, Int)))]
newNodes = [(Int, (String, DaVinciNode (String, Int, Int)))]
nn, oldNodes :: [(Int, (String, String))]
oldNodes = [(Int, (String, String))]
on, newEdges :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
newEdges = [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
ne, oldEdges :: [(Int, (Int, Int, String, EdgeValue))]
oldEdges = [(Int, (Int, Int, String, EdgeValue))]
oe})

{- zips two lists by pairing each element of the first with each element of
   the second -}
specialzip :: [a] -> [b] -> [(a, b)]
specialzip :: [a] -> [b] -> [(a, b)]
specialzip xs :: [a]
xs ys :: [b]
ys = [ (a
x, b
y) | a
x <- [a]
xs, b
y <- [b]
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 :: Int -> [(Int, a)] -> (Int, a)
get d :: Int
d list :: [(Int, a)]
list =
  case Int -> [(Int, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
d [(Int, a)]
list of
    Just r :: a
r -> (Int
d, a
r)
    Nothing -> String -> (Int, a)
forall a. HasCallStack => String -> a
error (String -> (Int, a)) -> String -> (Int, a)
forall a b. (a -> b) -> a -> b
$ "get: descriptor unknown: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
d
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ '\n' Char -> String -> String
forall a. a -> [a] -> [a]
: [Int] -> String
forall a. Show a => a -> String
show (((Int, a) -> Int) -> [(Int, a)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> Int
forall a b. (a, b) -> a
fst [(Int, a)]
list)

getFromMap :: Descr -> Map.Map Descr a -> (Descr, a)
getFromMap :: Int -> Map Int a -> (Int, a)
getFromMap d :: Int
d list :: Map Int a
list =
  case Int -> Map Int a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
d Map Int a
list of
    Just r :: a
r -> (Int
d, a
r)
    Nothing -> String -> (Int, a)
forall a. HasCallStack => String -> a
error (String -> (Int, a)) -> String -> (Int, a)
forall a b. (a -> b) -> a -> b
$ "get: descriptor unknown: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
d
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ '\n' Char -> String -> String
forall a. a -> [a] -> [a]
: [Int] -> String
forall a. Show a => a -> String
show (Map Int a -> [Int]
forall k a. Map k a -> [k]
Map.keys Map Int a
list)

remove :: Eq a => a -> [(a, b)] -> [(a, b)]
remove :: a -> [(a, b)] -> [(a, b)]
remove x :: a
x = ((a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/=) (a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
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 :: Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph gid :: Int
gid gv :: GraphInfo
gv delete :: Bool
delete cmd :: (AbstractionGraph, Int)
-> IO (AbstractionGraph, Int, Int, Maybe String)
cmd = do
  (gs :: [(Int, AbstractionGraph)]
gs, ev_cnt :: Int
ev_cnt) <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
  case Int -> [(Int, AbstractionGraph)] -> Maybe AbstractionGraph
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
gid [(Int, AbstractionGraph)]
gs of
    Just g :: AbstractionGraph
g -> do
      (g' :: AbstractionGraph
g', descr :: Int
descr, ev_cnt' :: Int
ev_cnt', err :: Maybe String
err) <- (AbstractionGraph, Int)
-> IO (AbstractionGraph, Int, Int, Maybe String)
cmd (AbstractionGraph
g, Int
ev_cnt)
      let gs'' :: [(Int, AbstractionGraph)]
gs'' = if Bool
delete then [(Int, AbstractionGraph)]
gs' else (Int
gid, AbstractionGraph
g') (Int, AbstractionGraph)
-> [(Int, AbstractionGraph)] -> [(Int, AbstractionGraph)]
forall a. a -> [a] -> [a]
: [(Int, AbstractionGraph)]
gs'
      GraphInfo -> ([(Int, AbstractionGraph)], Int) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gv ([(Int, AbstractionGraph)]
gs'', Int
ev_cnt')
      Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe String -> Result
Result Int
descr Maybe String
err)
      where gs' :: [(Int, AbstractionGraph)]
gs' = Int -> [(Int, AbstractionGraph)] -> [(Int, AbstractionGraph)]
forall a b. Eq a => a -> [(a, b)] -> [(a, b)]
remove Int
gid [(Int, AbstractionGraph)]
gs
    Nothing -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe String -> Result
Result 0 (String -> Maybe String
forall a. a -> Maybe a
Just ("Graph id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
gid String -> String -> String
forall a. [a] -> [a] -> [a]
++ " not found")))

getGraphid :: Descr -> GraphInfo -> IO OurGraph
getGraphid :: Int -> GraphInfo -> IO OurGraph
getGraphid gid :: Int
gid gv :: GraphInfo
gv = do
  (gs :: [(Int, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
  case Int -> [(Int, AbstractionGraph)] -> Maybe AbstractionGraph
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
gid [(Int, AbstractionGraph)]
gs of
    Just g :: AbstractionGraph
g -> OurGraph -> IO OurGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (OurGraph -> IO OurGraph) -> OurGraph -> IO OurGraph
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g
    Nothing -> String -> IO OurGraph
forall a. HasCallStack => String -> a
error "get_graphid: graph does not exist"

-- These are the operations of the interface

initgraphs :: IO GraphInfo
initgraphs :: IO GraphInfo
initgraphs = ([(Int, AbstractionGraph)], Int) -> IO GraphInfo
forall a. a -> IO (IORef a)
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 :: String
-> Maybe (IO ())
-> Maybe (IO ())
-> Maybe (IO ())
-> [GlobalMenu]
-> [(String, DaVinciNodeTypeParms (String, Int, Int))]
-> [(String, DaVinciArcTypeParms EdgeValue)]
-> CompTable
-> GraphInfo
-> IO Result
makegraph title :: String
title open :: Maybe (IO ())
open save :: Maybe (IO ())
save saveAs :: Maybe (IO ())
saveAs =
  String
-> Maybe (IO ())
-> Maybe (IO ())
-> Maybe (IO ())
-> IO Bool
-> Maybe (IO ())
-> [GlobalMenu]
-> [(String, DaVinciNodeTypeParms (String, Int, Int))]
-> [(String, DaVinciArcTypeParms EdgeValue)]
-> CompTable
-> GraphInfo
-> IO Result
makegraphExt String
title Maybe (IO ())
open Maybe (IO ())
save Maybe (IO ())
saveAs (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) Maybe (IO ())
forall a. Maybe a
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 :: String
-> Maybe (IO ())
-> Maybe (IO ())
-> Maybe (IO ())
-> IO Bool
-> Maybe (IO ())
-> [GlobalMenu]
-> [(String, DaVinciNodeTypeParms (String, Int, Int))]
-> [(String, DaVinciArcTypeParms EdgeValue)]
-> CompTable
-> GraphInfo
-> IO Result
makegraphExt title :: String
title open :: Maybe (IO ())
open save :: Maybe (IO ())
save saveAs :: Maybe (IO ())
saveAs close :: IO Bool
close exit :: Maybe (IO ())
exit menus :: [GlobalMenu]
menus nodetypeparams :: [(String, DaVinciNodeTypeParms (String, Int, Int))]
nodetypeparams
             edgetypeparams :: [(String, DaVinciArcTypeParms EdgeValue)]
edgetypeparams comptable :: CompTable
comptable gv :: GraphInfo
gv = do
  (gs :: [(Int, AbstractionGraph)]
gs, ev_cnt :: Int
ev_cnt) <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
  let
    graphParms :: DaVinciGraphParms
graphParms =
      (GlobalMenu -> DaVinciGraphParms -> DaVinciGraphParms)
-> DaVinciGraphParms -> [GlobalMenu] -> DaVinciGraphParms
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GlobalMenu -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
($$) (String -> GraphTitle
GraphTitle String
title GraphTitle -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                  Bool -> OptimiseLayout
OptimiseLayout Bool
False OptimiseLayout -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                  IO Bool -> AllowClose
AllowClose IO Bool
close AllowClose -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                  FileMenuOption -> Maybe (IO ()) -> FileMenuAct
FileMenuAct FileMenuOption
OpenMenuOption Maybe (IO ())
open FileMenuAct -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                  FileMenuOption -> Maybe (IO ()) -> FileMenuAct
FileMenuAct FileMenuOption
SaveMenuOption Maybe (IO ())
save FileMenuAct -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                  FileMenuOption -> Maybe (IO ()) -> FileMenuAct
FileMenuAct FileMenuOption
SaveAsMenuOption Maybe (IO ())
saveAs FileMenuAct -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                  FileMenuOption -> Maybe (IO ()) -> FileMenuAct
FileMenuAct FileMenuOption
ExitMenuOption Maybe (IO ())
exit FileMenuAct -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                  DaVinciGraphParms
forall graphParms. GraphParms graphParms => graphParms
emptyGraphParms)
                  [GlobalMenu]
menus
    abstractNodetypeparams :: DaVinciNodeTypeParms (String, Int, Int)
abstractNodetypeparams =
      MenuPrim (Maybe String) ((String, Int, Int) -> IO ())
-> LocalMenu (String, Int, Int)
forall value.
MenuPrim (Maybe String) (value -> IO ()) -> LocalMenu value
LocalMenu (
        String
-> ((String, Int, Int) -> IO ())
-> MenuPrim (Maybe String) ((String, Int, Int) -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button "Unhide abstracted nodes"
          (\ (_, descr :: Int
descr, gid :: Int
gid) -> do
             ([(Int, AbstractionGraph)], Int)
oldGv <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
             (Result _ error' :: Maybe String
error') <- Int -> Int -> GraphInfo -> IO Result
showIt Int
gid Int
descr GraphInfo
gv
             case Maybe String
error' of
               Just _ -> do
                 GraphInfo -> ([(Int, AbstractionGraph)], Int) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gv ([(Int, AbstractionGraph)], Int)
oldGv
                 () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               Nothing -> do
                 Int -> GraphInfo -> IO Result
redisplay Int
gid GraphInfo
gv
                 () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          )
        ) LocalMenu (String, Int, Int)
-> DaVinciNodeTypeParms (String, Int, Int)
-> DaVinciNodeTypeParms (String, Int, Int)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
        Shape (String, Int, Int)
forall value. Shape value
Rhombus Shape (String, Int, Int)
-> DaVinciNodeTypeParms (String, Int, Int)
-> DaVinciNodeTypeParms (String, Int, Int)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
        ((String, Int, Int) -> IO String) -> ValueTitle (String, Int, Int)
forall value. (value -> IO String) -> ValueTitle value
ValueTitle ( \ (name :: String
name, _, _) -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
name) ValueTitle (String, Int, Int)
-> DaVinciNodeTypeParms (String, Int, Int)
-> DaVinciNodeTypeParms (String, Int, Int)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
        DaVinciNodeTypeParms (String, Int, Int)
forall (nodeTypeParms :: * -> *) value.
(NodeTypeParms nodeTypeParms, Typeable value) =>
nodeTypeParms value
emptyNodeTypeParms :: DaVinciNodeTypeParms (String, Int, Int)
    (nodetypenames :: [String]
nodetypenames, nodetypeparams1 :: [DaVinciNodeTypeParms (String, Int, Int)]
nodetypeparams1) =
      [(String, DaVinciNodeTypeParms (String, Int, Int))]
-> ([String], [DaVinciNodeTypeParms (String, Int, Int)])
forall a b. [(a, b)] -> ([a], [b])
unzip (("ABSTRACT", DaVinciNodeTypeParms (String, Int, Int)
abstractNodetypeparams) (String, DaVinciNodeTypeParms (String, Int, Int))
-> [(String, DaVinciNodeTypeParms (String, Int, Int))]
-> [(String, DaVinciNodeTypeParms (String, Int, Int))]
forall a. a -> [a] -> [a]
: [(String, DaVinciNodeTypeParms (String, Int, Int))]
nodetypeparams)
    (edgetypenames :: [String]
edgetypenames, edgetypeparams1 :: [DaVinciArcTypeParms EdgeValue]
edgetypeparams1) = [(String, DaVinciArcTypeParms EdgeValue)]
-> ([String], [DaVinciArcTypeParms EdgeValue])
forall a b. [(a, b)] -> ([a], [b])
unzip [(String, DaVinciArcTypeParms EdgeValue)]
edgetypeparams
    ontoGr :: Gr a b
ontoGr = Gr a b
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
Graph.empty
    relViewSpecList :: [a]
relViewSpecList = []
  OurGraph
graph <- OurGraph -> DaVinciGraphParms -> IO OurGraph
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *).
GraphAll
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> graphParms
-> IO
     (Graph
        graph
        graphParms
        node
        nodeType
        nodeTypeParms
        arc
        arcType
        arcTypeParms)
newGraph OurGraph
graphtool DaVinciGraphParms
graphParms
  [DaVinciNodeType (String, Int, Int)]
nodetypes <- (DaVinciNodeTypeParms (String, Int, Int)
 -> IO (DaVinciNodeType (String, Int, Int)))
-> [DaVinciNodeTypeParms (String, Int, Int)]
-> IO [DaVinciNodeType (String, Int, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (OurGraph
-> DaVinciNodeTypeParms (String, Int, Int)
-> IO (DaVinciNodeType (String, Int, Int))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> nodeTypeParms value -> IO (nodeType value)
newNodeType OurGraph
graph) [DaVinciNodeTypeParms (String, Int, Int)]
nodetypeparams1
  [DaVinciArcType EdgeValue]
edgetypes <- (DaVinciArcTypeParms EdgeValue -> IO (DaVinciArcType EdgeValue))
-> [DaVinciArcTypeParms EdgeValue] -> IO [DaVinciArcType EdgeValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (OurGraph
-> DaVinciArcTypeParms EdgeValue -> IO (DaVinciArcType EdgeValue)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcTypeParms value -> IO (arcType value)
newArcType OurGraph
graph) [DaVinciArcTypeParms EdgeValue]
edgetypeparams1
  let g :: AbstractionGraph
g = AbstractionGraph :: OurGraph
-> [(String, DaVinciNodeType (String, Int, Int))]
-> [(String, DaVinciArcType EdgeValue)]
-> Map Int (String, DaVinciNode (String, Int, Int))
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> CompTable
-> [(Int, Entry)]
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> [Int]
-> Gr (String, String, OntoObjectType) String
-> [RelationViewSpec]
-> NodeMapping
-> AbstractionGraph
AbstractionGraph {
            theGraph :: OurGraph
theGraph = OurGraph
graph,
            nodeTypes :: [(String, DaVinciNodeType (String, Int, Int))]
nodeTypes = [String]
-> [DaVinciNodeType (String, Int, Int)]
-> [(String, DaVinciNodeType (String, Int, Int))]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
nodetypenames [DaVinciNodeType (String, Int, Int)]
nodetypes,
            edgeTypes :: [(String, DaVinciArcType EdgeValue)]
edgeTypes = [String]
-> [DaVinciArcType EdgeValue]
-> [(String, DaVinciArcType EdgeValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
edgetypenames [DaVinciArcType EdgeValue]
edgetypes,
            nodes :: Map Int (String, DaVinciNode (String, Int, Int))
nodes = Map Int (String, DaVinciNode (String, Int, Int))
forall k a. Map k a
Map.empty,
            edges :: Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges = Map Int (Int, Int, String, DaVinciArc EdgeValue)
forall k a. Map k a
Map.empty, -- [],
            edgeComp :: CompTable
edgeComp = CompTable
comptable,
            eventTable :: [(Int, Entry)]
eventTable = [],
            deletedNodes :: [Int]
deletedNodes = [],
            hiddenEdges :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
hiddenEdges = [],
            ontoGraph :: Gr (String, String, OntoObjectType) String
ontoGraph = Gr (String, String, OntoObjectType) String
forall a b. Gr a b
ontoGr,
            relViewSpecs :: [RelationViewSpec]
relViewSpecs = [RelationViewSpec]
forall a. [a]
relViewSpecList,
            nodeMap :: NodeMapping
nodeMap = NodeMapping
forall k a. Map k a
Map.empty }
  GraphInfo -> ([(Int, AbstractionGraph)], Int) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gv ((Int
ev_cnt, AbstractionGraph
g) (Int, AbstractionGraph)
-> [(Int, AbstractionGraph)] -> [(Int, AbstractionGraph)]
forall a. a -> [a] -> [a]
: [(Int, AbstractionGraph)]
gs, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
  Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe String -> Result
Result Int
ev_cnt Maybe String
forall a. Maybe a
Nothing)

addnode :: Descr -> String -> String -> GraphInfo -> IO Result
addnode :: Int -> String -> String -> GraphInfo -> IO Result
addnode gid :: Int
gid nodetype :: String
nodetype name :: String
name gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
-- ---------------------------- why query nodetype first
    case String
-> [(String, DaVinciNodeType (String, Int, Int))]
-> Maybe (DaVinciNodeType (String, Int, Int))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
nodetype (AbstractionGraph -> [(String, DaVinciNodeType (String, Int, Int))]
nodeTypes AbstractionGraph
g) of
      Nothing ->
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just ("addnode: illegal node type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nodetype))
      Just nt :: DaVinciNodeType (String, Int, Int)
nt -> do
            DaVinciNode (String, Int, Int)
node <- OurGraph
-> DaVinciNodeType (String, Int, Int)
-> (String, Int, Int)
-> IO (DaVinciNode (String, Int, Int))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> nodeType value -> value -> IO (node value)
newNode (AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g) DaVinciNodeType (String, Int, Int)
nt (String
name, Int
ev_cnt, Int
gid)
            (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g {nodes :: Map Int (String, DaVinciNode (String, Int, Int))
nodes = Int
-> (String, DaVinciNode (String, Int, Int))
-> Map Int (String, DaVinciNode (String, Int, Int))
-> Map Int (String, DaVinciNode (String, Int, Int))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
ev_cnt (String
nodetype, DaVinciNode (String, Int, Int)
node) (Map Int (String, DaVinciNode (String, Int, Int))
 -> Map Int (String, DaVinciNode (String, Int, Int)))
-> Map Int (String, DaVinciNode (String, Int, Int))
-> Map Int (String, DaVinciNode (String, Int, Int))
forall a b. (a -> b) -> a -> b
$ AbstractionGraph
-> Map Int (String, DaVinciNode (String, Int, Int))
nodes AbstractionGraph
g},
                    Int
ev_cnt, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
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 :: Int -> Int -> String -> GraphInfo -> IO Result
changeNodeType gid :: Int
gid node :: Int
node nodetype :: String
nodetype graph :: GraphInfo
graph =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
graph Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    case Int
-> Map Int (String, DaVinciNode (String, Int, Int))
-> Maybe (String, DaVinciNode (String, Int, Int))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
node (AbstractionGraph
-> Map Int (String, DaVinciNode (String, Int, Int))
nodes AbstractionGraph
g) of
      Nothing ->
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just ("changeNodeType: illegal node: "
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
node))
      Just n :: (String, DaVinciNode (String, Int, Int))
n ->
        case String
-> [(String, DaVinciNodeType (String, Int, Int))]
-> Maybe (DaVinciNodeType (String, Int, Int))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
nodetype (AbstractionGraph -> [(String, DaVinciNodeType (String, Int, Int))]
nodeTypes AbstractionGraph
g) of
          Nothing ->
            (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt,
                    String -> Maybe String
forall a. a -> Maybe a
Just ("changeNodeType: illegal node type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nodetype))
          Just nt :: DaVinciNodeType (String, Int, Int)
nt -> do
            OurGraph
-> DaVinciNode (String, Int, Int)
-> DaVinciNodeType (String, Int, Int)
-> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> node value -> nodeType value -> IO ()
setNodeType (AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g) ((String, DaVinciNode (String, Int, Int))
-> DaVinciNode (String, Int, Int)
forall a b. (a, b) -> b
snd (String, DaVinciNode (String, Int, Int))
n) DaVinciNodeType (String, Int, Int)
nt
            let newnodes :: Map Int (String, DaVinciNode (String, Int, Int))
newnodes =
                   (Int
 -> (String, DaVinciNode (String, Int, Int))
 -> (String, DaVinciNode (String, Int, Int)))
-> Map Int (String, DaVinciNode (String, Int, Int))
-> Map Int (String, DaVinciNode (String, Int, Int))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
                   (\ descr :: Int
descr v :: (String, DaVinciNode (String, Int, Int))
v@(_, davinciNode :: DaVinciNode (String, Int, Int)
davinciNode) -> if Int
descr Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
node
                     then (String
nodetype, DaVinciNode (String, Int, Int)
davinciNode) else (String, DaVinciNode (String, Int, Int))
v) (Map Int (String, DaVinciNode (String, Int, Int))
 -> Map Int (String, DaVinciNode (String, Int, Int)))
-> Map Int (String, DaVinciNode (String, Int, Int))
-> Map Int (String, DaVinciNode (String, Int, Int))
forall a b. (a -> b) -> a -> b
$ AbstractionGraph
-> Map Int (String, DaVinciNode (String, Int, Int))
nodes AbstractionGraph
g
            (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g {nodes :: Map Int (String, DaVinciNode (String, Int, Int))
nodes = Map Int (String, DaVinciNode (String, Int, Int))
newnodes}, Int
node, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing)
    )

writeOntoGraph :: Descr -> Tree.Gr (String, String, OntoObjectType) String
               -> GraphInfo -> IO Result
writeOntoGraph :: Int
-> Gr (String, String, OntoObjectType) String
-> GraphInfo
-> IO Result
writeOntoGraph gid :: Int
gid graph :: Gr (String, String, OntoObjectType) String
graph gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g {ontoGraph :: Gr (String, String, OntoObjectType) String
ontoGraph = Gr (String, String, OntoObjectType) String
graph}, 0, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing)
    )

writeRelViewSpecs :: Descr -> [RelationViewSpec] -> GraphInfo -> IO Result
writeRelViewSpecs :: Int -> [RelationViewSpec] -> GraphInfo -> IO Result
writeRelViewSpecs gid :: Int
gid specs :: [RelationViewSpec]
specs gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g {relViewSpecs :: [RelationViewSpec]
relViewSpecs = [RelationViewSpec]
specs}, 0, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing)
    )

writeNodeMap :: Descr -> NodeMapping -> GraphInfo -> IO Result
writeNodeMap :: Int -> NodeMapping -> GraphInfo -> IO Result
writeNodeMap gid :: Int
gid nMap :: NodeMapping
nMap gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g {nodeMap :: NodeMapping
nodeMap = NodeMapping
nMap}, 0, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing)
    )

delnode :: Descr -> Descr -> GraphInfo -> IO Result
delnode :: Int -> Int -> GraphInfo -> IO Result
delnode gid :: Int
gid node :: Int
node gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    case Int
-> Map Int (String, DaVinciNode (String, Int, Int))
-> Maybe (String, DaVinciNode (String, Int, Int))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
node (AbstractionGraph
-> Map Int (String, DaVinciNode (String, Int, Int))
nodes AbstractionGraph
g) of
      Just n :: (String, DaVinciNode (String, Int, Int))
n -> do
        OurGraph -> DaVinciNode (String, Int, Int) -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> node value -> IO ()
deleteNode (AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g) ((String, DaVinciNode (String, Int, Int))
-> DaVinciNode (String, Int, Int)
forall a b. (a, b) -> b
snd (String, DaVinciNode (String, Int, Int))
n)
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g {nodes :: Map Int (String, DaVinciNode (String, Int, Int))
nodes = Int
-> Map Int (String, DaVinciNode (String, Int, Int))
-> Map Int (String, DaVinciNode (String, Int, Int))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int
node (AbstractionGraph
-> Map Int (String, DaVinciNode (String, Int, Int))
nodes AbstractionGraph
g)
                 , deletedNodes :: [Int]
deletedNodes = AbstractionGraph -> [Int]
deletedNodes AbstractionGraph
g},
                0, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing)
      Nothing ->
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just ("delnode: illegal node: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
node))
    )

addlink :: Descr -> String -> String -> Maybe (LEdge DGLinkLab) -> Descr
        -> Descr -> GraphInfo -> IO Result
addlink :: Int
-> String
-> String
-> Maybe (LEdge DGLinkLab)
-> Int
-> Int
-> GraphInfo
-> IO Result
addlink gid :: Int
gid edgetype :: String
edgetype name :: String
name label :: Maybe (LEdge DGLinkLab)
label src :: Int
src tar :: Int
tar gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    case (String
-> [(String, DaVinciArcType EdgeValue)]
-> Maybe (DaVinciArcType EdgeValue)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
edgetype (AbstractionGraph -> [(String, DaVinciArcType EdgeValue)]
edgeTypes AbstractionGraph
g),
          Int
-> Map Int (String, DaVinciNode (String, Int, Int))
-> Maybe (String, DaVinciNode (String, Int, Int))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
src (AbstractionGraph
-> Map Int (String, DaVinciNode (String, Int, Int))
nodes AbstractionGraph
g),
          Int
-> Map Int (String, DaVinciNode (String, Int, Int))
-> Maybe (String, DaVinciNode (String, Int, Int))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
tar (AbstractionGraph
-> Map Int (String, DaVinciNode (String, Int, Int))
nodes AbstractionGraph
g)) of
      (Just et :: DaVinciArcType EdgeValue
et, Just src_node :: (String, DaVinciNode (String, Int, Int))
src_node, Just tar_node :: (String, DaVinciNode (String, Int, Int))
tar_node) -> do
        [IO EdgeValue] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [OurGraph -> DaVinciArc EdgeValue -> IO EdgeValue
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arc value -> IO value
getArcValue (AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g) DaVinciArc EdgeValue
davinciArc
                    | (srcId :: Int
srcId, tgtId :: Int
tgtId, tp :: String
tp, davinciArc :: DaVinciArc EdgeValue
davinciArc) <- Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> [(Int, Int, String, DaVinciArc EdgeValue)]
forall k a. Map k a -> [a]
Map.elems (AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g),
                    String
tp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
edgetype Bool -> Bool -> Bool
&& Int
srcId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
src Bool -> Bool -> Bool
&& Int
tgtId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tar]
        DaVinciArc EdgeValue
edge <- OurGraph
-> DaVinciArcType EdgeValue
-> EdgeValue
-> DaVinciNode (String, Int, Int)
-> DaVinciNode (String, Int, Int)
-> IO (DaVinciArc EdgeValue)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value nodeFromValue nodeToValue.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value, Typeable nodeFromValue, Typeable nodeToValue) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcType value
-> value
-> node nodeFromValue
-> node nodeToValue
-> IO (arc value)
newArc (AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g) DaVinciArcType EdgeValue
et (String
name, Int
ev_cnt, Maybe (LEdge DGLinkLab)
label) ((String, DaVinciNode (String, Int, Int))
-> DaVinciNode (String, Int, Int)
forall a b. (a, b) -> b
snd (String, DaVinciNode (String, Int, Int))
src_node)
                       ((String, DaVinciNode (String, Int, Int))
-> DaVinciNode (String, Int, Int)
forall a b. (a, b) -> b
snd (String, DaVinciNode (String, Int, Int))
tar_node)
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g {edges :: Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges = Int
-> (Int, Int, String, DaVinciArc EdgeValue)
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
ev_cnt (Int
src, Int
tar, String
edgetype, DaVinciArc EdgeValue
edge)
                            (Map Int (Int, Int, String, DaVinciArc EdgeValue)
 -> Map Int (Int, Int, String, DaVinciArc EdgeValue))
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
forall a b. (a -> b) -> a -> b
$ AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g}, Int
ev_cnt, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing)
      (Nothing, _, _) ->
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just ("addlink: illegal edge type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
edgetype))
      (_, Nothing, _) ->
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt,
                String -> Maybe String
forall a. a -> Maybe a
Just ("addlink: illegal source node id: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
src))
      (_, _, Nothing) ->
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt,
                String -> Maybe String
forall a. a -> Maybe a
Just ("addlink: illegal target node id: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tar))
    )

dellink :: Descr -> Descr -> GraphInfo -> IO Result
dellink :: Int -> Int -> GraphInfo -> IO Result
dellink gid :: Int
gid edge :: Int
edge gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    case Int
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> Maybe (Int, Int, String, DaVinciArc EdgeValue)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
edge (AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g) of
      Just (_, _, _, e :: DaVinciArc EdgeValue
e) -> do
        OurGraph -> DaVinciArc EdgeValue -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arc value -> IO ()
deleteArc (AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g) DaVinciArc EdgeValue
e
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g {edges :: Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges = Int
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int
edge (AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g)}, 0, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing)
      Nothing ->
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just ("dellink: illegal edge: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
edge))
    )

redisplay :: Descr -> GraphInfo -> IO Result
redisplay :: Int -> GraphInfo -> IO Result
redisplay gid :: Int
gid gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) -> do
    OurGraph -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *).
GraphAll
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> IO ()
redraw (AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g)
    Int -> IO ()
threadDelay Int
delayTime
    (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
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 :: AbstractionGraph -> (String, String) -> Maybe String
determineedgetype g :: AbstractionGraph
g (t1 :: String
t1, t2 :: String
t2) =
  case [ String
t | (tp1 :: String
tp1, tp2 :: String
tp2, t :: String
t) <- AbstractionGraph -> CompTable
edgeComp AbstractionGraph
g, String
tp1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
t1 Bool -> Bool -> Bool
&& String
tp2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
t2 ] of
    [] -> Maybe String
forall a. Maybe a
Nothing
    x :: String
x : _ -> String -> Maybe String
forall a. a -> Maybe a
Just String
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 :: AbstractionGraph -> Int -> Maybe ([Int], [Int])
fetchEdgesOfNode g :: AbstractionGraph
g node :: Int
node =
{- ? this checking seems meaningless...
case sequence (map ((flip Map.lookup) (edges g)) (Map.keys $ edges g)) of
  Just _ -> -}
      ([Int], [Int]) -> Maybe ([Int], [Int])
forall a. a -> Maybe a
Just ([Int
descr | (descr :: Int
descr, (_, t :: Int
t, _, _)) <- Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Int (Int, Int, String, DaVinciArc EdgeValue)
 -> [(Int, (Int, Int, String, DaVinciArc EdgeValue))])
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall a b. (a -> b) -> a -> b
$ AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g, Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
node],
            [Int
descr | (descr :: Int
descr, (s :: Int
s, _, _, _)) <- Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Int (Int, Int, String, DaVinciArc EdgeValue)
 -> [(Int, (Int, Int, String, DaVinciArc EdgeValue))])
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall a b. (a -> b) -> a -> b
$ AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g, Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
node])
    -- Nothing -> Nothing

hideSetOfNodeTypes :: Descr -> [String] -> Bool -> GraphInfo -> IO Result
hideSetOfNodeTypes :: Int -> [String] -> Bool -> GraphInfo -> IO Result
hideSetOfNodeTypes gid :: Int
gid nodetypes :: [String]
nodetypes showLast :: Bool
showLast gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    case (String -> Maybe (DaVinciNodeType (String, Int, Int)))
-> [String] -> Maybe [DaVinciNodeType (String, Int, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String
-> [(String, DaVinciNodeType (String, Int, Int))]
-> Maybe (DaVinciNodeType (String, Int, Int))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` AbstractionGraph -> [(String, DaVinciNodeType (String, Int, Int))]
nodeTypes AbstractionGraph
g) [String]
nodetypes of
      Just _ -> do
        let nodelist :: [Int]
nodelist = [Int
descr | (descr :: Int
descr, (tp :: String
tp, _)) <- Map Int (String, DaVinciNode (String, Int, Int))
-> [(Int, (String, DaVinciNode (String, Int, Int)))]
forall k a. Map k a -> [(k, a)]
Map.toList (AbstractionGraph
-> Map Int (String, DaVinciNode (String, Int, Int))
nodes AbstractionGraph
g),
                        String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
tp [String]
nodetypes Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
showLast Bool -> Bool -> Bool
|| ((Int, Int, String, DaVinciArc EdgeValue) -> Bool)
-> [(Int, Int, String, DaVinciArc EdgeValue)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
                          (\ (descr' :: Int
descr', _, _, _) -> Int
descr' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
descr)
                          (Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> [(Int, Int, String, DaVinciArc EdgeValue)]
forall k a. Map k a -> [a]
Map.elems (Map Int (Int, Int, String, DaVinciArc EdgeValue)
 -> [(Int, Int, String, DaVinciArc EdgeValue)])
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> [(Int, Int, String, DaVinciArc EdgeValue)]
forall a b. (a -> b) -> a -> b
$ AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g))]
        case [Int]
nodelist of
          [] ->
            (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, Maybe String
forall a. Maybe a
Nothing)
          _ -> do
            (Result de :: Int
de error' :: Maybe String
error') <- Int -> [Int] -> GraphInfo -> IO Result
hidenodes Int
gid [Int]
nodelist GraphInfo
gv
            ([(Int, AbstractionGraph)], Int)
info <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
            (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, AbstractionGraph) -> AbstractionGraph
forall a b. (a, b) -> b
snd (Int -> [(Int, AbstractionGraph)] -> (Int, AbstractionGraph)
forall a. Int -> [(Int, a)] -> (Int, a)
get Int
gid (([(Int, AbstractionGraph)], Int) -> [(Int, AbstractionGraph)]
forall a b. (a, b) -> a
fst ([(Int, AbstractionGraph)], Int)
info)), Int
de, ([(Int, AbstractionGraph)], Int) -> Int
forall a b. (a, b) -> b
snd ([(Int, AbstractionGraph)], Int)
info, Maybe String
error')
      Nothing ->
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just ("hidenodetype: illegal node types "
                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "in list: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String -> String
forall a. Show a => [a] -> String -> String
showList [String]
nodetypes ","))
  )

hidenodes :: Descr -> [Descr] -> GraphInfo -> IO Result
hidenodes :: Int -> [Int] -> GraphInfo -> IO Result
hidenodes gid :: Int
gid node_list :: [Int]
node_list gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    case (Int -> Maybe (String, DaVinciNode (String, Int, Int)))
-> [Int] -> Maybe [(String, DaVinciNode (String, Int, Int))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int
-> Map Int (String, DaVinciNode (String, Int, Int))
-> Maybe (String, DaVinciNode (String, Int, Int))
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` AbstractionGraph
-> Map Int (String, DaVinciNode (String, Int, Int))
nodes AbstractionGraph
g) [Int]
node_list of
      Just _ ->
        -- try to determine the path to add and the edges to remove
        case AbstractionGraph
-> [Int] -> Maybe ([(Int, Int, String)], [([Int], [Int])])
makepathsMain AbstractionGraph
g [Int]
node_list of
          -- try to create the paths
          Just (newEdges' :: [(Int, Int, String)]
newEdges', delEdges :: [([Int], [Int])]
delEdges) -> do
            -- save the old edges...
            let
              oeDescr :: [Int]
oeDescr = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (([Int], [Int]) -> [Int]) -> [([Int], [Int])] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Int], [Int]) -> [Int]
forall a b. (a, b) -> a
fst [([Int], [Int])]
delEdges [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ (([Int], [Int]) -> [Int]) -> [([Int], [Int])] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Int], [Int]) -> [Int]
forall a b. (a, b) -> b
snd [([Int], [Int])]
delEdges
              oe :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
oe = (Int -> (Int, (Int, Int, String, DaVinciArc EdgeValue)))
-> [Int] -> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall a b. (a -> b) -> [a] -> [b]
map (Int
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> (Int, (Int, Int, String, DaVinciArc EdgeValue))
forall a. Int -> Map Int a -> (Int, a)
`getFromMap` AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g) [Int]
oeDescr
            [(Int, (Int, Int, String, EdgeValue))]
oldEdges' <- AbstractionGraph
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> IO [(Int, (Int, Int, String, EdgeValue))]
saveOldEdges AbstractionGraph
g [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
oe
            -- ... then try to remove them from the graph
            (gs :: [(Int, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
            GraphInfo -> ([(Int, AbstractionGraph)], Int) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gv ([(Int, AbstractionGraph)]
gs, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
            (Result _ error1 :: Maybe String
error1) <- Int -> [Int] -> GraphInfo -> IO Result
hideedgesaux Int
gid [Int]
oeDescr GraphInfo
gv
            ([(Int, AbstractionGraph)], Int)
info1 <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
            case Maybe String
error1 of
              Nothing -> do
                -- determine the _new_ edges...
                let
                  existingEdges :: [(Int, Int, String)]
existingEdges =
                    [(Int
src, Int
tgt, String
tp) | (src :: Int
src, tgt :: Int
tgt, tp :: String
tp, _) <-
                     Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> [(Int, Int, String, DaVinciArc EdgeValue)]
forall k a. Map k a -> [a]
Map.elems (Map Int (Int, Int, String, DaVinciArc EdgeValue)
 -> [(Int, Int, String, DaVinciArc EdgeValue)])
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> [(Int, Int, String, DaVinciArc EdgeValue)]
forall a b. (a -> b) -> a -> b
$ AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges ((Int, AbstractionGraph) -> AbstractionGraph
forall a b. (a, b) -> b
snd (Int -> [(Int, AbstractionGraph)] -> (Int, AbstractionGraph)
forall a. Int -> [(Int, a)] -> (Int, a)
get Int
gid (([(Int, AbstractionGraph)], Int) -> [(Int, AbstractionGraph)]
forall a b. (a, b) -> a
fst ([(Int, AbstractionGraph)], Int)
info1)))]
                  filteredNewEdges :: [(Int, Int, String)]
filteredNewEdges =
                    [(Int, Int, String)
path | path :: (Int, Int, String)
path@(src :: Int
src, tgt :: Int
tgt, tp :: String
tp) <- [(Int, Int, String)]
newEdges',
                     (Int, Int, String) -> [(Int, Int, String)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem (Int
src, Int
tgt, String
tp) [(Int, Int, String)]
existingEdges]
                -- ... and try to add them
                (Result _ error2 :: Maybe String
error2) <-
                  Int -> [(Int, Int, String)] -> GraphInfo -> IO Result
addpaths Int
gid [(Int, Int, String)]
filteredNewEdges GraphInfo
gv -- info1
                case Maybe String
error2 of
                  Nothing -> do
                    -- save the old nodes...
                    let on :: [(Int, (String, DaVinciNode (String, Int, Int)))]
on = (Int -> (Int, (String, DaVinciNode (String, Int, Int))))
-> [Int] -> [(Int, (String, DaVinciNode (String, Int, Int)))]
forall a b. (a -> b) -> [a] -> [b]
map (Int
-> Map Int (String, DaVinciNode (String, Int, Int))
-> (Int, (String, DaVinciNode (String, Int, Int)))
forall a. Int -> Map Int a -> (Int, a)
`getFromMap` AbstractionGraph
-> Map Int (String, DaVinciNode (String, Int, Int))
nodes AbstractionGraph
g) [Int]
node_list
                    [(Int, (String, String))]
oldNodes' <- AbstractionGraph
-> [(Int, (String, DaVinciNode (String, Int, Int)))]
-> IO [(Int, (String, String))]
saveOldNodes AbstractionGraph
g [(Int, (String, DaVinciNode (String, Int, Int)))]
on
                    -- ... then try to remove them from the graph
                    (Result _ error3 :: Maybe String
error3) <-
                      Int -> [Int] -> GraphInfo -> IO Result
hidenodesaux Int
gid [Int]
node_list GraphInfo
gv -- info2
                    ([(Int, AbstractionGraph)], Int)
info3 <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
                    case Maybe String
error3 of
                      Nothing -> do
                        -- save the changes in an entry
                        let
                          g' :: AbstractionGraph
g' = (Int, AbstractionGraph) -> AbstractionGraph
forall a b. (a, b) -> b
snd (Int -> [(Int, AbstractionGraph)] -> (Int, AbstractionGraph)
forall a. Int -> [(Int, a)] -> (Int, a)
get Int
gid (([(Int, AbstractionGraph)], Int) -> [(Int, AbstractionGraph)]
forall a b. (a, b) -> a
fst ([(Int, AbstractionGraph)], Int)
info3))
                          newEdges'' :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
newEdges'' = [(Int, (Int, Int, String, DaVinciArc EdgeValue))
edge | (Int, (Int, Int, String, DaVinciArc EdgeValue))
edge <- Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall k a. Map k a -> [(k, a)]
Map.toList (AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g'),
                                       Int -> Map Int (Int, Int, String, DaVinciArc EdgeValue) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ((Int, (Int, Int, String, DaVinciArc EdgeValue)) -> Int
forall a b. (a, b) -> a
fst (Int, (Int, Int, String, DaVinciArc EdgeValue))
edge) (AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g)]
                          newEvent :: (Int, Entry)
newEvent = [(Int, (String, DaVinciNode (String, Int, Int)))]
-> [(Int, (String, String))]
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> [(Int, (Int, Int, String, EdgeValue))]
-> Int
-> (Int, Entry)
createEntry [] [(Int, (String, String))]
oldNodes' [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
newEdges''
                                       [(Int, (Int, Int, String, EdgeValue))]
oldEdges' Int
ev_cnt
                        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g' {eventTable :: [(Int, Entry)]
eventTable = (Int, Entry)
newEvent (Int, Entry) -> [(Int, Entry)] -> [(Int, Entry)]
forall a. a -> [a] -> [a]
: AbstractionGraph -> [(Int, Entry)]
eventTable AbstractionGraph
g'}
                               , Int
ev_cnt, ([(Int, AbstractionGraph)], Int) -> Int
forall a b. (a, b) -> b
snd ([(Int, AbstractionGraph)], Int)
info3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing)
                      Just t :: String
t ->
                        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt,
                                String -> Maybe String
forall a. a -> Maybe a
Just ("hidenodes: error hiding nodes: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t))
                  Just text :: String
text ->
                    (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt,
                            String -> Maybe String
forall a. a -> Maybe a
Just ("hidenodes: error adding paths: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
text))
              Just text :: String
text ->
                (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt,
                        String -> Maybe String
forall a. a -> Maybe a
Just ("hidenodes: error deleting edges: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
text))
          Nothing ->
            (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt,
                    String -> Maybe String
forall a. a -> Maybe a
Just ("hidenodes: error making paths\n(possible reasons: "
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ "an error occured getting the edges of the nodes\n "
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ "or a pathtype could not be determined (missing "
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ "entry in edgeComp table))"))
      Nothing -> (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just "hidenodes: unknown node(s)")
    )

-- auxiliary function, which removes the nodes from the graph
hidenodesaux :: Descr -> [Descr] -> GraphInfo -> IO Result
hidenodesaux :: Int -> [Int] -> GraphInfo -> IO Result
hidenodesaux _ [] gv :: GraphInfo
gv = do
  (_, ev_cnt :: Int
ev_cnt) <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
  Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe String -> Result
Result Int
ev_cnt Maybe String
forall a. Maybe a
Nothing)
hidenodesaux gid :: Int
gid (d :: Int
d : delNodes :: [Int]
delNodes) gv :: GraphInfo
gv = do
  deletedNode :: Result
deletedNode@(Result _ error' :: Maybe String
error') <- Int -> Int -> GraphInfo -> IO Result
delnode Int
gid Int
d GraphInfo
gv
  case Maybe String
error' of
    Nothing -> Int -> [Int] -> GraphInfo -> IO Result
hidenodesaux Int
gid [Int]
delNodes GraphInfo
gv
    Just _ -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
deletedNode

-- returns the paths to add and the edges to remove
makepathsMain :: AbstractionGraph -> [Descr]
              -> Maybe ([(Descr, Descr, String)], [([Descr], [Descr])])
makepathsMain :: AbstractionGraph
-> [Int] -> Maybe ([(Int, Int, String)], [([Int], [Int])])
makepathsMain g :: AbstractionGraph
g node_list :: [Int]
node_list =
  -- try to determine the in- and outgoing edges of the nodes
  case (Int -> Maybe ([Int], [Int])) -> [Int] -> Maybe [([Int], [Int])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AbstractionGraph -> Int -> Maybe ([Int], [Int])
fetchEdgesOfNode AbstractionGraph
g) [Int]
node_list of
    -- try to make paths of these edges
    Just edgelistPairs :: [([Int], [Int])]
edgelistPairs ->
      case (([Int], [Int]) -> Maybe [(Int, Int, String)])
-> [([Int], [Int])] -> Maybe [[(Int, Int, String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AbstractionGraph
-> [Int] -> ([Int], [Int]) -> Maybe [(Int, Int, String)]
makepaths AbstractionGraph
g [Int]
node_list) [([Int], [Int])]
edgelistPairs of
        -- the paths to add (dangling ones are removed) and the edges to remove
        Just paths :: [[(Int, Int, String)]]
paths ->
          ([(Int, Int, String)], [([Int], [Int])])
-> Maybe ([(Int, Int, String)], [([Int], [Int])])
forall a. a -> Maybe a
Just ([(Int, Int, String)] -> [Int] -> [(Int, Int, String)]
removeDanglingEdges ([(Int, Int, String)] -> [(Int, Int, String)]
forall a. Eq a => [a] -> [a]
nub ([[(Int, Int, String)]] -> [(Int, Int, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, Int, String)]]
paths)) [Int]
node_list,
                [([Int], [Int])]
edgelistPairs)
        Nothing -> Maybe ([(Int, Int, String)], [([Int], [Int])])
forall a. Maybe a
Nothing
    Nothing -> Maybe ([(Int, Int, String)], [([Int], [Int])])
forall a. Maybe a
Nothing

-- removes those edges whose source or target node will be hidden
removeDanglingEdges :: [(Descr, Descr, String)] -> [Descr]
                    -> [(Descr, Descr, String)]
removeDanglingEdges :: [(Int, Int, String)] -> [Int] -> [(Int, Int, String)]
removeDanglingEdges edges' :: [(Int, Int, String)]
edges' nodes' :: [Int]
nodes' =
  [(Int, Int, String)
edge | edge :: (Int, Int, String)
edge@(src :: Int
src, tgt :: Int
tgt, _) <- [(Int, Int, String)]
edges', Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem Int
src [Int]
nodes' Bool -> Bool -> Bool
&& Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem Int
tgt [Int]
nodes']

-- returns a list of paths (ie source, target and type) to be added
makepaths :: AbstractionGraph -> [Descr] -> ([Descr], [Descr])
          -> Maybe [(Descr, Descr, String)]
makepaths :: AbstractionGraph
-> [Int] -> ([Int], [Int]) -> Maybe [(Int, Int, String)]
makepaths g :: AbstractionGraph
g node_list :: [Int]
node_list (inEdges :: [Int]
inEdges, outEdges :: [Int]
outEdges) =
  -- try to lookup the edges of the node
  case ((Int -> Maybe (Int, Int, String, DaVinciArc EdgeValue))
-> [Int] -> Maybe [(Int, Int, String, DaVinciArc EdgeValue)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> Maybe (Int, Int, String, DaVinciArc EdgeValue)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g) [Int]
inEdges,
        (Int -> Maybe (Int, Int, String, DaVinciArc EdgeValue))
-> [Int] -> Maybe [(Int, Int, String, DaVinciArc EdgeValue)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> Maybe (Int, Int, String, DaVinciArc EdgeValue)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g) [Int]
outEdges) of
    (Just ie :: [(Int, Int, String, DaVinciArc EdgeValue)]
ie, Just oe :: [(Int, Int, String, DaVinciArc EdgeValue)]
oe) ->
      -- try to make paths out of them
      case (((Int, Int, String, DaVinciArc EdgeValue),
  (Int, Int, String, DaVinciArc EdgeValue))
 -> Maybe [(Int, Int, String)])
-> [((Int, Int, String, DaVinciArc EdgeValue),
     (Int, Int, String, DaVinciArc EdgeValue))]
-> Maybe [[(Int, Int, String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AbstractionGraph
-> [Int]
-> [Int]
-> ((Int, Int, String, DaVinciArc EdgeValue),
    (Int, Int, String, DaVinciArc EdgeValue))
-> Maybe [(Int, Int, String)]
makepathsaux AbstractionGraph
g [Int]
node_list []) ([(Int, Int, String, DaVinciArc EdgeValue)]
-> [(Int, Int, String, DaVinciArc EdgeValue)]
-> [((Int, Int, String, DaVinciArc EdgeValue),
     (Int, Int, String, DaVinciArc EdgeValue))]
forall a b. [a] -> [b] -> [(a, b)]
specialzip [(Int, Int, String, DaVinciArc EdgeValue)]
ie [(Int, Int, String, DaVinciArc EdgeValue)]
oe) of
        -- return the paths
        Just paths :: [[(Int, Int, String)]]
paths -> [(Int, Int, String)] -> Maybe [(Int, Int, String)]
forall a. a -> Maybe a
Just ([[(Int, Int, String)]] -> [(Int, Int, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, Int, String)]]
paths)
        Nothing -> Maybe [(Int, Int, String)]
forall a. Maybe a
Nothing
    (Nothing, _) -> Maybe [(Int, Int, String)]
forall a. Maybe a
Nothing
    (_, Nothing) -> Maybe [(Int, Int, String)]
forall a. Maybe a
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 :: AbstractionGraph
-> [Int]
-> [Int]
-> ((Int, Int, String, DaVinciArc EdgeValue),
    (Int, Int, String, DaVinciArc EdgeValue))
-> Maybe [(Int, Int, String)]
makepathsaux g :: AbstractionGraph
g node_list :: [Int]
node_list alreadyPassedNodes :: [Int]
alreadyPassedNodes ((s1 :: Int
s1, _, ty1 :: String
ty1, ed1 :: DaVinciArc EdgeValue
ed1), (_, t2 :: Int
t2, ty2 :: String
ty2, _)) =
  -- try to determine the type of the path
  case AbstractionGraph -> (String, String) -> Maybe String
determineedgetype AbstractionGraph
g (String
ty1, String
ty2) of
    -- return the checked path
    Just ty :: String
ty -> AbstractionGraph
-> [Int]
-> [Int]
-> (Int, Int, String, DaVinciArc EdgeValue)
-> Maybe [(Int, Int, String)]
checkpath AbstractionGraph
g [Int]
node_list [Int]
alreadyPassedNodes (Int
s1, Int
t2, String
ty, DaVinciArc EdgeValue
ed1)
               -- ed1 is just a dummy value (Dummiewert)
    Nothing -> Maybe [(Int, Int, String)]
forall a. Maybe a
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 :: AbstractionGraph
-> [Int]
-> [Int]
-> (Int, Int, String, DaVinciArc EdgeValue)
-> Maybe [(Int, Int, String)]
checkpath g :: AbstractionGraph
g node_list :: [Int]
node_list alreadyPassedNodes :: [Int]
alreadyPassedNodes path :: (Int, Int, String, DaVinciArc EdgeValue)
path@(src :: Int
src, tgt :: Int
tgt, ty :: String
ty, _)
  | Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Int
src [Int]
alreadyPassedNodes Bool -> Bool -> Bool
|| Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Int
tgt [Int]
alreadyPassedNodes = [(Int, Int, String)] -> Maybe [(Int, Int, String)]
forall a. a -> Maybe a
Just []
  | Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Int
src [Int]
node_list =
    -- try to determine the in- and outgoing edges of the source node
    case AbstractionGraph -> Int -> Maybe ([Int], [Int])
fetchEdgesOfNode AbstractionGraph
g Int
src of
      -- try to lookup ingoing edges
      Just (inEdges :: [Int]
inEdges, _) ->
        case (Int -> Maybe (Int, Int, String, DaVinciArc EdgeValue))
-> [Int] -> Maybe [(Int, Int, String, DaVinciArc EdgeValue)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> Maybe (Int, Int, String, DaVinciArc EdgeValue)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g) [Int]
inEdges of
          {- try to make paths of these edges and the "tail" of the path (and
             recursively check them) -}
          Just el :: [(Int, Int, String, DaVinciArc EdgeValue)]
el ->
            case (((Int, Int, String, DaVinciArc EdgeValue),
  (Int, Int, String, DaVinciArc EdgeValue))
 -> Maybe [(Int, Int, String)])
-> [((Int, Int, String, DaVinciArc EdgeValue),
     (Int, Int, String, DaVinciArc EdgeValue))]
-> Maybe [[(Int, Int, String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AbstractionGraph
-> [Int]
-> [Int]
-> ((Int, Int, String, DaVinciArc EdgeValue),
    (Int, Int, String, DaVinciArc EdgeValue))
-> Maybe [(Int, Int, String)]
makepathsaux AbstractionGraph
g [Int]
node_list (Int
src Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
alreadyPassedNodes))
              ([(Int, Int, String, DaVinciArc EdgeValue)]
-> [(Int, Int, String, DaVinciArc EdgeValue)]
-> [((Int, Int, String, DaVinciArc EdgeValue),
     (Int, Int, String, DaVinciArc EdgeValue))]
forall a b. [a] -> [b] -> [(a, b)]
specialzip [(Int, Int, String, DaVinciArc EdgeValue)]
el [(Int, Int, String, DaVinciArc EdgeValue)
path]) of
              Just p :: [[(Int, Int, String)]]
p -> [(Int, Int, String)] -> Maybe [(Int, Int, String)]
forall a. a -> Maybe a
Just ([[(Int, Int, String)]] -> [(Int, Int, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, Int, String)]]
p)
              Nothing -> Maybe [(Int, Int, String)]
forall a. Maybe a
Nothing
          Nothing -> Maybe [(Int, Int, String)]
forall a. Maybe a
Nothing
      Nothing -> Maybe [(Int, Int, String)]
forall a. Maybe a
Nothing
  | Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Int
tgt [Int]
node_list =
    -- try to determine the in- and outgoing edges of the target node
    case AbstractionGraph -> Int -> Maybe ([Int], [Int])
fetchEdgesOfNode AbstractionGraph
g Int
tgt of
      -- try to lookup the outgoing edges
      Just (_, outEdges :: [Int]
outEdges) ->
        case (Int -> Maybe (Int, Int, String, DaVinciArc EdgeValue))
-> [Int] -> Maybe [(Int, Int, String, DaVinciArc EdgeValue)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> Maybe (Int, Int, String, DaVinciArc EdgeValue)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g) [Int]
outEdges of
          {- try to make paths of these edges and the "init" of the path (and
             recursively check them) -}
          Just el :: [(Int, Int, String, DaVinciArc EdgeValue)]
el ->
            case (((Int, Int, String, DaVinciArc EdgeValue),
  (Int, Int, String, DaVinciArc EdgeValue))
 -> Maybe [(Int, Int, String)])
-> [((Int, Int, String, DaVinciArc EdgeValue),
     (Int, Int, String, DaVinciArc EdgeValue))]
-> Maybe [[(Int, Int, String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AbstractionGraph
-> [Int]
-> [Int]
-> ((Int, Int, String, DaVinciArc EdgeValue),
    (Int, Int, String, DaVinciArc EdgeValue))
-> Maybe [(Int, Int, String)]
makepathsaux AbstractionGraph
g [Int]
node_list
                                 (Int
tgt Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
alreadyPassedNodes))
                          ([(Int, Int, String, DaVinciArc EdgeValue)]
-> [(Int, Int, String, DaVinciArc EdgeValue)]
-> [((Int, Int, String, DaVinciArc EdgeValue),
     (Int, Int, String, DaVinciArc EdgeValue))]
forall a b. [a] -> [b] -> [(a, b)]
specialzip [(Int, Int, String, DaVinciArc EdgeValue)
path] [(Int, Int, String, DaVinciArc EdgeValue)]
el) of
              Just p :: [[(Int, Int, String)]]
p -> [(Int, Int, String)] -> Maybe [(Int, Int, String)]
forall a. a -> Maybe a
Just ([[(Int, Int, String)]] -> [(Int, Int, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, Int, String)]]
p)
              Nothing -> Maybe [(Int, Int, String)]
forall a. Maybe a
Nothing
          Nothing -> Maybe [(Int, Int, String)]
forall a. Maybe a
Nothing
      Nothing -> Maybe [(Int, Int, String)]
forall a. Maybe a
Nothing
  | Bool
otherwise =
    -- nothing to be done
    [(Int, Int, String)] -> Maybe [(Int, Int, String)]
forall a. a -> Maybe a
Just [(Int
src, Int
tgt, String
ty)]

-- adds the paths (given source, target and type)
addpaths :: Descr -> [(Descr, Descr, String)] -> GraphInfo -> IO Result
addpaths :: Int -> [(Int, Int, String)] -> GraphInfo -> IO Result
addpaths _ [] gv :: GraphInfo
gv = do
  (_, ev_cnt :: Int
ev_cnt) <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
  Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe String -> Result
Result Int
ev_cnt Maybe String
forall a. Maybe a
Nothing)
addpaths gid :: Int
gid ((src :: Int
src, tgt :: Int
tgt, ty :: String
ty) : newEdges' :: [(Int, Int, String)]
newEdges') gv :: GraphInfo
gv = do
  edge :: Result
edge@(Result _ error' :: Maybe String
error') <- Int
-> String
-> String
-> Maybe (LEdge DGLinkLab)
-> Int
-> Int
-> GraphInfo
-> IO Result
addlink Int
gid String
ty "" Maybe (LEdge DGLinkLab)
forall a. Maybe a
Nothing Int
src Int
tgt GraphInfo
gv
  case Maybe String
error' of
    Nothing -> Int -> [(Int, Int, String)] -> GraphInfo -> IO Result
addpaths Int
gid [(Int, Int, String)]
newEdges' GraphInfo
gv
    Just _ -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
edge

hideSetOfEdgeTypes :: Descr -> [String] -> GraphInfo -> IO Result
hideSetOfEdgeTypes :: Int -> [String] -> GraphInfo -> IO Result
hideSetOfEdgeTypes gid :: Int
gid edgetypes :: [String]
edgetypes gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    case [Maybe (DaVinciArcType EdgeValue)]
-> Maybe [DaVinciArcType EdgeValue]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [String
-> [(String, DaVinciArcType EdgeValue)]
-> Maybe (DaVinciArcType EdgeValue)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
edgetype (AbstractionGraph -> [(String, DaVinciArcType EdgeValue)]
edgeTypes AbstractionGraph
g) | String
edgetype <- [String]
edgetypes] of
      Just _ -> do
        let edgelist :: [Int]
edgelist = [Int
descr | (descr :: Int
descr, (_ , _ , tp :: String
tp, _)) <- Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall k a. Map k a -> [(k, a)]
Map.toList (AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g),
                              String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
tp [String]
edgetypes]
            showlist :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
showlist = ((Int, (Int, Int, String, DaVinciArc EdgeValue)) -> Bool)
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (_, (_, _, tp :: String
tp, _)) -> String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem String
tp [String]
edgetypes)
                              ([(Int, (Int, Int, String, DaVinciArc EdgeValue))]
 -> [(Int, (Int, Int, String, DaVinciArc EdgeValue))])
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall a b. (a -> b) -> a -> b
$ AbstractionGraph
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
hiddenEdges AbstractionGraph
g
        case [Int]
edgelist of
          [] -> (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, Maybe String
forall a. Maybe a
Nothing)
          _ -> do
            (Result de :: Int
de err :: Maybe String
err) <- Int -> [Int] -> GraphInfo -> IO Result
hideedges Int
gid [Int]
edgelist GraphInfo
gv
            case Maybe String
err of
              Nothing -> do
                ([(Int, AbstractionGraph)], Int)
info <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
                let gs :: AbstractionGraph
gs = (Int, AbstractionGraph) -> AbstractionGraph
forall a b. (a, b) -> b
snd (Int -> [(Int, AbstractionGraph)] -> (Int, AbstractionGraph)
forall a. Int -> [(Int, a)] -> (Int, a)
get Int
de ([(Int, AbstractionGraph)] -> (Int, AbstractionGraph))
-> [(Int, AbstractionGraph)] -> (Int, AbstractionGraph)
forall a b. (a -> b) -> a -> b
$ ([(Int, AbstractionGraph)], Int) -> [(Int, AbstractionGraph)]
forall a b. (a, b) -> a
fst ([(Int, AbstractionGraph)], Int)
info)
                    gs' :: AbstractionGraph
gs' = AbstractionGraph
gs {hiddenEdges :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
hiddenEdges = ((Int, (Int, Int, String, DaVinciArc EdgeValue)) -> Bool)
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int, (Int, Int, String, DaVinciArc EdgeValue))
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
showlist)
                                           ([(Int, (Int, Int, String, DaVinciArc EdgeValue))]
 -> [(Int, (Int, Int, String, DaVinciArc EdgeValue))])
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall a b. (a -> b) -> a -> b
$ AbstractionGraph
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
hiddenEdges AbstractionGraph
gs}
                [(Int, (Int, Int, String, EdgeValue))]
sl' <- AbstractionGraph
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> IO [(Int, (Int, Int, String, EdgeValue))]
saveOldEdges AbstractionGraph
gs [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
showlist
                GraphInfo -> ([(Int, AbstractionGraph)], Int) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gv ((Int
de Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, AbstractionGraph
gs') (Int, AbstractionGraph)
-> [(Int, AbstractionGraph)] -> [(Int, AbstractionGraph)]
forall a. a -> [a] -> [a]
: ([(Int, AbstractionGraph)], Int) -> [(Int, AbstractionGraph)]
forall a b. (a, b) -> a
fst ([(Int, AbstractionGraph)], Int)
info, Int
de Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
                (Result de' :: Int
de' err' :: Maybe String
err') <- Int
-> [(Int, (Int, Int, String, EdgeValue))] -> GraphInfo -> IO Result
showedges (Int
de Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) [(Int, (Int, Int, String, EdgeValue))]
sl' GraphInfo
gv
                case Maybe String
err' of
                  Nothing -> do
                    ([(Int, AbstractionGraph)], Int)
info' <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
                    (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, AbstractionGraph) -> AbstractionGraph
forall a b. (a, b) -> b
snd ((Int, AbstractionGraph) -> AbstractionGraph)
-> (Int, AbstractionGraph) -> AbstractionGraph
forall a b. (a -> b) -> a -> b
$ Int -> [(Int, AbstractionGraph)] -> (Int, AbstractionGraph)
forall a. Int -> [(Int, a)] -> (Int, a)
get Int
de' ([(Int, AbstractionGraph)] -> (Int, AbstractionGraph))
-> [(Int, AbstractionGraph)] -> (Int, AbstractionGraph)
forall a b. (a -> b) -> a -> b
$ ([(Int, AbstractionGraph)], Int) -> [(Int, AbstractionGraph)]
forall a b. (a, b) -> a
fst ([(Int, AbstractionGraph)], Int)
info', Int
de', ([(Int, AbstractionGraph)], Int) -> Int
forall a b. (a, b) -> b
snd ([(Int, AbstractionGraph)], Int)
info', Maybe String
forall a. Maybe a
Nothing)
                  Just _ -> (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, Maybe String
err')
              Just _ -> (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, Maybe String
err)
      Nothing ->
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just ("hideedgestype: illegal edge types "
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ "in list: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String -> String
forall a. Show a => [a] -> String -> String
showList [String]
edgetypes ","))
  )

hideedges :: Descr -> [Descr] -> GraphInfo -> IO Result
hideedges :: Int -> [Int] -> GraphInfo -> IO Result
hideedges gid :: Int
gid edge_list :: [Int]
edge_list gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    case (Int -> Maybe (Int, (Int, Int, String, DaVinciArc EdgeValue)))
-> [Int] -> Maybe [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ e :: Int
e -> case Int
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
-> Maybe (Int, Int, String, DaVinciArc EdgeValue)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
e (AbstractionGraph
-> Map Int (Int, Int, String, DaVinciArc EdgeValue)
edges AbstractionGraph
g) of
                                Just x :: (Int, Int, String, DaVinciArc EdgeValue)
x -> (Int, (Int, Int, String, DaVinciArc EdgeValue))
-> Maybe (Int, (Int, Int, String, DaVinciArc EdgeValue))
forall a. a -> Maybe a
Just (Int
e, (Int, Int, String, DaVinciArc EdgeValue)
x)
                                Nothing -> Maybe (Int, (Int, Int, String, DaVinciArc EdgeValue))
forall a. Maybe a
Nothing) [Int]
edge_list of
      Just edges' :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
edges' -> do
        Result de :: Int
de err :: Maybe String
err <- Int -> [Int] -> GraphInfo -> IO Result
hideedgesaux Int
gid [Int]
edge_list GraphInfo
gv
        case Maybe String
err of
          Nothing -> do
            ([(Int, AbstractionGraph)], Int)
info <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
            (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (((Int, AbstractionGraph) -> AbstractionGraph
forall a b. (a, b) -> b
snd ((Int, AbstractionGraph) -> AbstractionGraph)
-> (Int, AbstractionGraph) -> AbstractionGraph
forall a b. (a -> b) -> a -> b
$ Int -> [(Int, AbstractionGraph)] -> (Int, AbstractionGraph)
forall a. Int -> [(Int, a)] -> (Int, a)
get Int
gid ([(Int, AbstractionGraph)] -> (Int, AbstractionGraph))
-> [(Int, AbstractionGraph)] -> (Int, AbstractionGraph)
forall a b. (a -> b) -> a -> b
$ ([(Int, AbstractionGraph)], Int) -> [(Int, AbstractionGraph)]
forall a b. (a, b) -> a
fst ([(Int, AbstractionGraph)], Int)
info) {hiddenEdges :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
hiddenEdges = AbstractionGraph
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
hiddenEdges AbstractionGraph
g
                                                             [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
forall a. [a] -> [a] -> [a]
++ [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
edges'},
                    Int
de, ([(Int, AbstractionGraph)], Int) -> Int
forall a b. (a, b) -> b
snd ([(Int, AbstractionGraph)], Int)
info Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing)
          Just _ -> (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just "hideedges: error deleting edges")
      Nothing -> (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just "hideedges: unknown edge(s)")
  )

-- an auxiliary function, which removes the edges from the graph
hideedgesaux :: Descr -> [Descr] -> GraphInfo -> IO Result
hideedgesaux :: Int -> [Int] -> GraphInfo -> IO Result
hideedgesaux _ [] gv :: GraphInfo
gv = do
  (_, ev_cnt :: Int
ev_cnt) <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
  Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe String -> Result
Result Int
ev_cnt Maybe String
forall a. Maybe a
Nothing)
hideedgesaux gid :: Int
gid (d :: Int
d : delEdges :: [Int]
delEdges) gv :: GraphInfo
gv = do
  dle :: Result
dle@(Result _ error' :: Maybe String
error') <- Int -> Int -> GraphInfo -> IO Result
dellink Int
gid Int
d GraphInfo
gv
  case Maybe String
error' of
    Nothing -> Int -> [Int] -> GraphInfo -> IO Result
hideedgesaux Int
gid [Int]
delEdges GraphInfo
gv -- info
    Just _ -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
dle

-- | function to check whether the internal nodes are hidden or not
checkHasHiddenNodes :: Descr -> Descr -> GraphInfo -> IO Result
checkHasHiddenNodes :: Int -> Int -> GraphInfo -> IO Result
checkHasHiddenNodes gid :: Int
gid hide_event :: Int
hide_event gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    case Int -> [(Int, Entry)] -> Maybe Entry
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
hide_event (AbstractionGraph -> [(Int, Entry)]
eventTable AbstractionGraph
g) of
      Just _ -> (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, Maybe String
forall a. Maybe a
Nothing)
      Nothing -> (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt,
                         String -> Maybe String
forall a. a -> Maybe a
Just "checkHasHiddenNodes: hide events not found")
    )

-- function to undo hide-events
showIt :: Descr -> Descr -> GraphInfo -> IO Result
showIt :: Int -> Int -> GraphInfo -> IO Result
showIt gid :: Int
gid hide_event :: Int
hide_event gv :: GraphInfo
gv =
  Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) ->
    -- try to lookup the hide-event
    case Int -> [(Int, Entry)] -> Maybe Entry
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
hide_event (AbstractionGraph -> [(Int, Entry)]
eventTable AbstractionGraph
g) of
      Just entry :: Entry
entry -> do
        -- try to remove the paths that had been added
        (Result _ error1 :: Maybe String
error1) <- Int -> [Int] -> GraphInfo -> IO Result
hideedgesaux Int
gid (((Int, (Int, Int, String, DaVinciArc EdgeValue)) -> Int)
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (Int, Int, String, DaVinciArc EdgeValue)) -> Int
forall a b. (a, b) -> a
fst (Entry -> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
newEdges Entry
entry)) GraphInfo
gv
        case Maybe String
error1 of
          Nothing -> do
            -- try to add the nodes that had been hidden
            (Result _ error2 :: Maybe String
error2) <- Int -> [(Int, (String, String))] -> GraphInfo -> IO Result
shownodes Int
gid (Entry -> [(Int, (String, String))]
oldNodes Entry
entry) GraphInfo
gv
            case Maybe String
error2 of
              Nothing -> do
                -- try to remove the nodes that had been added
                (Result _ error3 :: Maybe String
error3) <- Int -> [Int] -> GraphInfo -> IO Result
hidenodesaux Int
gid
                                         (((Int, (String, DaVinciNode (String, Int, Int))) -> Int)
-> [(Int, (String, DaVinciNode (String, Int, Int)))] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (String, DaVinciNode (String, Int, Int))) -> Int
forall a b. (a, b) -> a
fst (Entry -> [(Int, (String, DaVinciNode (String, Int, Int)))]
newNodes Entry
entry)) GraphInfo
gv
                case Maybe String
error3 of
                  Nothing -> do
                    -- try to add the edges that had been hidden
                    (Result _ error4 :: Maybe String
error4) <- Int
-> [(Int, (Int, Int, String, EdgeValue))] -> GraphInfo -> IO Result
showedges Int
gid (Entry -> [(Int, (Int, Int, String, EdgeValue))]
oldEdges Entry
entry) GraphInfo
gv
                    ([(Int, AbstractionGraph)], Int)
info4 <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
                    case Maybe String
error4 of
                      Nothing -> do
                        -- remove the event from the eventTable
                        let g' :: AbstractionGraph
g' = (Int, AbstractionGraph) -> AbstractionGraph
forall a b. (a, b) -> b
snd (Int -> [(Int, AbstractionGraph)] -> (Int, AbstractionGraph)
forall a. Int -> [(Int, a)] -> (Int, a)
get Int
gid (([(Int, AbstractionGraph)], Int) -> [(Int, AbstractionGraph)]
forall a b. (a, b) -> a
fst ([(Int, AbstractionGraph)], Int)
info4))
                        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g' {eventTable :: [(Int, Entry)]
eventTable = Int -> [(Int, Entry)] -> [(Int, Entry)]
forall a b. Eq a => a -> [(a, b)] -> [(a, b)]
remove Int
hide_event
                                (AbstractionGraph -> [(Int, Entry)]
eventTable AbstractionGraph
g')}, 0, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing)
                      Just t4 :: String
t4 ->
                        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just ("showIt: error restoring old "
                                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "edges:\n-> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t4))
                  Just t3 :: String
t3 ->
                    (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt,
                            String -> Maybe String
forall a. a -> Maybe a
Just ("showIt: error removing nodes:\n-> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t3))
              Just t2 :: String
t2 ->
                (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just ("showIt: error restoring nodes:\n-> "
                                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t2))
          Just t1 :: String
t1 ->
            (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just ("showIt: error removing edges:\n-> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t1))
      Nothing ->
        (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt, String -> Maybe String
forall a. a -> Maybe a
Just ("showIt: invalid event descriptor: "
                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
hide_event))
    )

-- adds nodes that had been hidden
shownodes :: Descr -> [(Descr, (String, String))] -> GraphInfo -> IO Result
shownodes :: Int -> [(Int, (String, String))] -> GraphInfo -> IO Result
shownodes _ [] gv :: GraphInfo
gv = do
  (_, ev_cnt :: Int
ev_cnt) <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
  Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe String -> Result
Result Int
ev_cnt Maybe String
forall a. Maybe a
Nothing)
shownodes gid :: Int
gid ((d :: Int
d, (tp :: String
tp, name :: String
name)) : list :: [(Int, (String, String))]
list) gv :: GraphInfo
gv = do
  (gs :: [(Int, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
  -- try to add the first node
  GraphInfo -> ([(Int, AbstractionGraph)], Int) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gv ([(Int, AbstractionGraph)]
gs, Int
d)
  nd :: Result
nd@(Result _ error' :: Maybe String
error') <- Int -> String -> String -> GraphInfo -> IO Result
addnode Int
gid String
tp String
name GraphInfo
gv
  case Maybe String
error' of
    Nothing -> -- try to add the rest
      Int -> [(Int, (String, String))] -> GraphInfo -> IO Result
shownodes Int
gid [(Int, (String, String))]
list GraphInfo
gv
    Just _ -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
nd

-- adds edges that had been hidden
showedges :: Descr -> [(Int, (Int, Int, String, EdgeValue))] -> GraphInfo
          -> IO Result
showedges :: Int
-> [(Int, (Int, Int, String, EdgeValue))] -> GraphInfo -> IO Result
showedges _ [] gv :: GraphInfo
gv = do
  (_, ev_cnt :: Int
ev_cnt) <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
  Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe String -> Result
Result Int
ev_cnt Maybe String
forall a. Maybe a
Nothing)
showedges gid :: Int
gid ((d :: Int
d, (src :: Int
src, tgt :: Int
tgt, tp :: String
tp, value :: EdgeValue
value)) : list :: [(Int, (Int, Int, String, EdgeValue))]
list) gv :: GraphInfo
gv = do
  (gs :: [(Int, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Int, AbstractionGraph)], Int)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
  -- try to add the first edge
  GraphInfo -> ([(Int, AbstractionGraph)], Int) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gv ([(Int, AbstractionGraph)]
gs, Int
d)
  let
    name :: String
name = EdgeValue -> String
getEdgeName EdgeValue
value
    label :: Maybe (LEdge DGLinkLab)
label = EdgeValue -> Maybe (LEdge DGLinkLab)
getEdgeLabel EdgeValue
value
  ed :: Result
ed@(Result _ err :: Maybe String
err) <- Int
-> String
-> String
-> Maybe (LEdge DGLinkLab)
-> Int
-> Int
-> GraphInfo
-> IO Result
addlink Int
gid String
tp String
name Maybe (LEdge DGLinkLab)
label Int
src Int
tgt GraphInfo
gv
  case Maybe String
err of
    Nothing -> -- try to add the rest
      Int
-> [(Int, (Int, Int, String, EdgeValue))] -> GraphInfo -> IO Result
showedges Int
gid [(Int, (Int, Int, String, EdgeValue))]
list GraphInfo
gv
    Just _ -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
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 :: AbstractionGraph
-> [(Int, (String, DaVinciNode (String, Int, Int)))]
-> IO [(Int, (String, String))]
saveOldNodes _ [] = [(Int, (String, String))] -> IO [(Int, (String, String))]
forall (m :: * -> *) a. Monad m => a -> m a
return []
saveOldNodes g :: AbstractionGraph
g ((de :: Int
de, (tp :: String
tp, davincinode :: DaVinciNode (String, Int, Int)
davincinode)) : list :: [(Int, (String, DaVinciNode (String, Int, Int)))]
list) = do
  (name :: String
name, _, _) <- OurGraph -> DaVinciNode (String, Int, Int) -> IO (String, Int, Int)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> node value -> IO value
getNodeValue (AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g) DaVinciNode (String, Int, Int)
davincinode
  [(Int, (String, String))]
restOfList <- AbstractionGraph
-> [(Int, (String, DaVinciNode (String, Int, Int)))]
-> IO [(Int, (String, String))]
saveOldNodes AbstractionGraph
g [(Int, (String, DaVinciNode (String, Int, Int)))]
list
  [(Int, (String, String))] -> IO [(Int, (String, String))]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int
de, (String
tp, String
name)) (Int, (String, String))
-> [(Int, (String, String))] -> [(Int, (String, String))]
forall a. a -> [a] -> [a]
: [(Int, (String, String))]
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 :: AbstractionGraph
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> IO [(Int, (Int, Int, String, EdgeValue))]
saveOldEdges _ [] = [(Int, (Int, Int, String, EdgeValue))]
-> IO [(Int, (Int, Int, String, EdgeValue))]
forall (m :: * -> *) a. Monad m => a -> m a
return []
saveOldEdges g :: AbstractionGraph
g ((de :: Int
de, (src :: Int
src, tgt :: Int
tgt, tp :: String
tp, davinciarc :: DaVinciArc EdgeValue
davinciarc)) : list :: [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
list) = do
  EdgeValue
value <- OurGraph -> DaVinciArc EdgeValue -> IO EdgeValue
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arc value -> IO value
getArcValue (AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g) DaVinciArc EdgeValue
davinciarc
  [(Int, (Int, Int, String, EdgeValue))]
restOfList <- AbstractionGraph
-> [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
-> IO [(Int, (Int, Int, String, EdgeValue))]
saveOldEdges AbstractionGraph
g [(Int, (Int, Int, String, DaVinciArc EdgeValue))]
list
  [(Int, (Int, Int, String, EdgeValue))]
-> IO [(Int, (Int, Int, String, EdgeValue))]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int
de, (Int
src, Int
tgt, String
tp, EdgeValue
value)) (Int, (Int, Int, String, EdgeValue))
-> [(Int, (Int, Int, String, EdgeValue))]
-> [(Int, (Int, Int, String, EdgeValue))]
forall a. a -> [a] -> [a]
: [(Int, (Int, Int, String, EdgeValue))]
restOfList)

getEdgeName :: EdgeValue -> String
getEdgeName :: EdgeValue -> String
getEdgeName (name :: String
name, _, _) = String
name

getEdgeLabel :: EdgeValue -> Maybe (LEdge DGLinkLab)
getEdgeLabel :: EdgeValue -> Maybe (LEdge DGLinkLab)
getEdgeLabel (_, _, label :: Maybe (LEdge DGLinkLab)
label) = Maybe (LEdge DGLinkLab)
label

-- | improve the layout of a graph like calling \"Layout->Improve All\"
layoutImproveAll :: Descr -> GraphInfo -> IO Result
layoutImproveAll :: Int -> GraphInfo -> IO Result
layoutImproveAll gid :: Int
gid gv :: GraphInfo
gv =
    Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) -> do
             let contxt :: Context
contxt = case AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g of
                            Graph dg :: DaVinciGraph
dg -> DaVinciGraph -> Context
getDaVinciGraphContext DaVinciGraph
dg
             DaVinciCmd -> Context -> IO ()
doInContext (MenuCmd -> DaVinciCmd
DVT.Menu (MenuCmd -> DaVinciCmd) -> MenuCmd -> DaVinciCmd
forall a b. (a -> b) -> a -> b
$ LayoutMenuCmd -> MenuCmd
DVT.Layout LayoutMenuCmd
DVT.ImproveAll) Context
contxt
             (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing))

-- | display a message in a uDrawGraph window controlled by AbstractGraphView
showTemporaryMessage :: Descr -> GraphInfo
                     -> String -- ^ message to be displayed
                     -> IO Result
showTemporaryMessage :: Int -> GraphInfo -> String -> IO Result
showTemporaryMessage gid :: Int
gid gv :: GraphInfo
gv message :: String
message =
    Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) -> do
             let contxt :: Context
contxt = case AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g of
                            Graph dg :: DaVinciGraph
dg -> DaVinciGraph -> Context
getDaVinciGraphContext DaVinciGraph
dg
             DaVinciCmd -> Context -> IO ()
doInContext (WindowCmd -> DaVinciCmd
DVT.Window (WindowCmd -> DaVinciCmd) -> WindowCmd -> DaVinciCmd
forall a b. (a -> b) -> a -> b
$ String -> WindowCmd
DVT.ShowMessage String
message) Context
contxt
             (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing))

-- | deactivate the input of all uDrawGraph windows;
--
-- Warning: every deactivate event must be paired an activate event
deactivateGraphWindow :: Descr -> GraphInfo -> IO Result
deactivateGraphWindow :: Int -> GraphInfo -> IO Result
deactivateGraphWindow gid :: Int
gid gv :: GraphInfo
gv =
    Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) -> do
             let contxt :: Context
contxt = case AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g of
                            Graph dg :: DaVinciGraph
dg -> DaVinciGraph -> Context
getDaVinciGraphContext DaVinciGraph
dg
             DaVinciCmd -> Context -> IO ()
doInContext (WindowCmd -> DaVinciCmd
DVT.Window WindowCmd
DVT.Deactivate) Context
contxt
             (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing))

-- | activate the input of a uDrawGraph display
activateGraphWindow :: Descr -> GraphInfo -> IO Result
activateGraphWindow :: Int -> GraphInfo -> IO Result
activateGraphWindow gid :: Int
gid gv :: GraphInfo
gv =
    Int
-> GraphInfo
-> Bool
-> ((AbstractionGraph, Int)
    -> IO (AbstractionGraph, Int, Int, Maybe String))
-> IO Result
fetchGraph Int
gid GraphInfo
gv Bool
False (\ (g :: AbstractionGraph
g, ev_cnt :: Int
ev_cnt) -> do
             let contxt :: Context
contxt = case AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g of
                            Graph dg :: DaVinciGraph
dg -> DaVinciGraph -> Context
getDaVinciGraphContext DaVinciGraph
dg
             DaVinciCmd -> Context -> IO ()
doInContext (WindowCmd -> DaVinciCmd
DVT.Window WindowCmd
DVT.Activate) Context
contxt
             (AbstractionGraph, Int, Int, Maybe String)
-> IO (AbstractionGraph, Int, Int, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractionGraph
g, 0, Int
ev_cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Maybe String
forall a. Maybe a
Nothing))