{-# LANGUAGE FlexibleInstances #-}
{- |
Module      :  ./GUI/GraphAbstraction.hs
Description :  Interface for graph viewing and abstraction
Copyright   :  (c) Thiemo Wiedemeyer, T. Mossakowski, Uni Bremen 2002-2008
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.
-}

module GUI.GraphAbstraction
  ( -- * Types
    OurGraph
  , NodeId
  , NodeValue
  , EdgeValue
  , GraphInfo
    -- * Creation and display
  , initGraph
  , makeGraph
  , redisplay
    -- * Node interface
  , isHiddenNode
  , focusNode
    -- * Edge interface
  , hideSetOfEdgeTypes
  , isHiddenEdge
    -- * Conversion and update of graph
  , applyChanges
  , convert
    -- * Direct manipulation of uDrawGraph
  , layoutImproveAll
  , showTemporaryMessage
  , deactivateGraphWindow
  , activateGraphWindow
  , closeGraphWindow
  ) where

import GUI.UDGUtils
import GUI.Utils (pulseBar)
import qualified UDrawGraph.Types as DVT
import Events.Destructible (destroy)
import Events.Synchronized (synchronize)

import ATC.DevGraph ()

import Static.DevGraph
import Static.DgUtils

import Data.IORef
import Data.List (partition)
import qualified Data.Map as Map
import Data.Graph.Inductive.Graph (LEdge)
import Data.Maybe (isNothing)

import Control.Monad (foldM)
import Control.Concurrent (threadDelay)

-- | uDrawGraph graph
type OurGraph =
     Graph DaVinciGraph
             DaVinciGraphParms
             DaVinciNode
             DaVinciNodeType
             DaVinciNodeTypeParms
             DaVinciArc
             DaVinciArcType
             DaVinciArcTypeParms

-- | Node id type
type NodeId = Int

-- | Node value
type NodeValue = (String, NodeId)

-- | Edge value
type EdgeValue = (String, EdgeId, Maybe (LEdge DGLinkLab))

-- | Datastructure for changes, storing all needed information for change
data GAChange
  -- Node changes
  = AddNode NodeId DGNodeType String Bool
  | DelNode NodeId
  | ChangeNodeType NodeId DGNodeType
  | ShowNode NodeId
  | HideNode NodeId
  -- Edge changes
  | AddEdge EdgeId DGEdgeType NodeId NodeId String (Maybe (LEdge DGLinkLab))
            Bool
  | DelEdge EdgeId
  | ShowEdge EdgeId
  | HideEdge EdgeId
  -- Compressed edge changes
  | AddCompEdge (NodeId, NodeId, DGEdgeType, Bool)
  | DelCompEdge (NodeId, NodeId, DGEdgeType, Bool)

-- | Internal node
data GANode = GANode
  { GANode -> Maybe (DaVinciNode NodeValue)
udgNode :: Maybe (DaVinciNode NodeValue) -- ^ uDrawGraph node
  , GANode -> DGNodeType
ganType :: DGNodeType -- ^ ID of nodetype
  , GANode -> NodeValue
ganValue :: NodeValue -- ^ Holds the nodevalue for uDrawGraph node
  }

-- | Internal edge
data GAEdge = GAEdge
  { GAEdge -> Maybe (DaVinciArc EdgeValue)
udgEdge :: Maybe (DaVinciArc EdgeValue) -- ^ uDrawGraph edge
  , GAEdge -> NodeId
ganFrom :: NodeId -- ^ ID of source node
  , GAEdge -> NodeId
ganTo :: NodeId -- ^ID of target node
  , GAEdge -> DGEdgeType
gaeType :: DGEdgeType -- ^ ID of edgetype
  , GAEdge -> EdgeValue
gaeValue :: EdgeValue -- ^ Holds the edgevalue for uDrawGraph edge
  }

-- | Internal node type
data GANodeType = GANodeType
  { GANodeType -> DaVinciNodeType NodeValue
udgNodeType :: DaVinciNodeType NodeValue
  }

-- | Internal edge type
data GAEdgeType = GAEdgeType
  { GAEdgeType -> DaVinciArcType EdgeValue
udgEdgeType :: DaVinciArcType EdgeValue
  , GAEdgeType -> (DaVinciArcType EdgeValue, DaVinciArcType EdgeValue)
udgCompressed :: (DaVinciArcType EdgeValue, DaVinciArcType EdgeValue)
  , GAEdgeType -> Bool
gaeHidden :: Bool
  }

{- | Main datastructure for carrying around the graph,
     both internally (nodes as integers), and at the daVinci level -}
data AbstractionGraph = AbstractionGraph
  { AbstractionGraph -> OurGraph
theGraph :: OurGraph
  , AbstractionGraph -> Map NodeId GANode
nodes :: Map.Map NodeId GANode
  , AbstractionGraph -> Map EdgeId GAEdge
edges :: Map.Map EdgeId GAEdge
  , AbstractionGraph -> Map DGNodeType GANodeType
nodeTypes :: Map.Map DGNodeType GANodeType
  , AbstractionGraph -> Map DGEdgeType GAEdgeType
edgeTypes :: Map.Map DGEdgeType GAEdgeType
  , AbstractionGraph -> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
compressedEdges :: Map.Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
  }

-- | IORef for main datastructure
type GraphInfo = IORef AbstractionGraph

instance Eq (DaVinciNode NodeValue) where
    == :: DaVinciNode NodeValue -> DaVinciNode NodeValue -> Bool
(==) = DaVinciNode NodeValue -> DaVinciNode NodeValue -> 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

-- | Wrapper for functions with read access
wrapperRead :: (AbstractionGraph -> IO ()) -- ^ Function to call
            -> GraphInfo -- ^ The graph
            -> IO ()
wrapperRead :: (AbstractionGraph -> IO ()) -> GraphInfo -> IO ()
wrapperRead func :: AbstractionGraph -> IO ()
func gi :: GraphInfo
gi = GraphInfo -> IO AbstractionGraph
forall a. IORef a -> IO a
readIORef GraphInfo
gi IO AbstractionGraph -> (AbstractionGraph -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AbstractionGraph -> IO ()
func

-- | Wrapper for functions with read and write access
wrapperWrite :: (AbstractionGraph -> IO AbstractionGraph) -- ^ Function to call
             -> GraphInfo -- ^ The graph
             -> IO ()
wrapperWrite :: (AbstractionGraph -> IO AbstractionGraph) -> GraphInfo -> IO ()
wrapperWrite func :: AbstractionGraph -> IO AbstractionGraph
func gi :: GraphInfo
gi = do
  AbstractionGraph
g <- GraphInfo -> IO AbstractionGraph
forall a. IORef a -> IO a
readIORef GraphInfo
gi
  AbstractionGraph
g' <- AbstractionGraph -> IO AbstractionGraph
func AbstractionGraph
g
  GraphInfo -> AbstractionGraph -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gi AbstractionGraph
g'

-- | Wrapper for functions returning a boolean
wrapperBool :: (AbstractionGraph -> Bool) -- ^ Function to call
            -> GraphInfo -- ^ The graph
            -> IO Bool -- ^ Return value
wrapperBool :: (AbstractionGraph -> Bool) -> GraphInfo -> IO Bool
wrapperBool func :: AbstractionGraph -> Bool
func gi :: GraphInfo
gi = do
  AbstractionGraph
g <- GraphInfo -> IO AbstractionGraph
forall a. IORef a -> IO a
readIORef GraphInfo
gi
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Bool
func AbstractionGraph
g

-- | Forces a redraw of the uDrawGraph and wait an amount of time
redisplay' :: AbstractionGraph -- ^ The graph
           -> IO ()
redisplay' :: AbstractionGraph -> IO ()
redisplay' g :: AbstractionGraph
g = 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)
  NodeId -> IO ()
threadDelay 300000

redisplay :: GraphInfo -- ^ The graph
          -> IO ()
redisplay :: GraphInfo -> IO ()
redisplay = (AbstractionGraph -> IO ()) -> GraphInfo -> IO ()
wrapperRead AbstractionGraph -> IO ()
redisplay'

-- | Creates an empty graph structure
graphtool :: OurGraph -- ^ uDrawGraph graph
graphtool :: OurGraph
graphtool = OurGraph
daVinciSort

-- | Creates the empty AbstractionGraph
initGraph :: IO GraphInfo -- ^ The graph
initGraph :: IO GraphInfo
initGraph = do
  let g :: AbstractionGraph
g = AbstractionGraph :: OurGraph
-> Map NodeId GANode
-> Map EdgeId GAEdge
-> Map DGNodeType GANodeType
-> Map DGEdgeType GAEdgeType
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
-> AbstractionGraph
AbstractionGraph
            { theGraph :: OurGraph
theGraph = OurGraph
graphtool
            , nodes :: Map NodeId GANode
nodes = Map NodeId GANode
forall k a. Map k a
Map.empty
            , edges :: Map EdgeId GAEdge
edges = Map EdgeId GAEdge
forall k a. Map k a
Map.empty
            , nodeTypes :: Map DGNodeType GANodeType
nodeTypes = Map DGNodeType GANodeType
forall k a. Map k a
Map.empty
            , edgeTypes :: Map DGEdgeType GAEdgeType
edgeTypes = Map DGEdgeType GAEdgeType
forall k a. Map k a
Map.empty
            , compressedEdges :: Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
compressedEdges = Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
forall k a. Map k a
Map.empty
            }
  AbstractionGraph -> IO GraphInfo
forall a. a -> IO (IORef a)
newIORef AbstractionGraph
g

-- | Creates the uDrawGraph graph
makeGraph :: GraphInfo -- ^ The graph
          -> String     -- ^ Title
          -> Maybe (IO ()) -- ^ FileOpen menu
          -> Maybe (IO ()) -- ^ FileSave menu
          -> Maybe (IO ()) -- ^ FileSaveAs menu
          -> IO Bool       -- ^ FileClose menu
          -> Maybe (IO ()) -- ^ FileExit menu
          -> [GlobalMenu] -- ^ Edit menu
          -> [(DGNodeType, DaVinciNodeTypeParms NodeValue)] -- ^ Node types
          -> [(DGEdgeType, DaVinciArcTypeParms EdgeValue)] -- ^ Edge types
          -> String -- ^ Compressed edge color
          -> IO () -- ^ Expand menu action
          -> IO ()
makeGraph :: GraphInfo
-> String
-> Maybe (IO ())
-> Maybe (IO ())
-> Maybe (IO ())
-> IO Bool
-> Maybe (IO ())
-> [GlobalMenu]
-> [(DGNodeType, DaVinciNodeTypeParms NodeValue)]
-> [(DGEdgeType, DaVinciArcTypeParms EdgeValue)]
-> String
-> IO ()
-> IO ()
makeGraph gi :: GraphInfo
gi 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 nTypeParms :: [(DGNodeType, DaVinciNodeTypeParms NodeValue)]
nTypeParms eTypeParms :: [(DGEdgeType, DaVinciArcTypeParms EdgeValue)]
eTypeParms
          color :: String
color expand' :: IO ()
expand' = do
  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
      (nTypeNames :: [DGNodeType]
nTypeNames, nTypeParms' :: [DaVinciNodeTypeParms NodeValue]
nTypeParms') = [(DGNodeType, DaVinciNodeTypeParms NodeValue)]
-> ([DGNodeType], [DaVinciNodeTypeParms NodeValue])
forall a b. [(a, b)] -> ([a], [b])
unzip [(DGNodeType, DaVinciNodeTypeParms NodeValue)]
nTypeParms
      (eTypeNames :: [DGEdgeType]
eTypeNames, eTypeParms' :: [DaVinciArcTypeParms EdgeValue]
eTypeParms') = [(DGEdgeType, DaVinciArcTypeParms EdgeValue)]
-> ([DGEdgeType], [DaVinciArcTypeParms EdgeValue])
forall a b. [(a, b)] -> ([a], [b])
unzip [(DGEdgeType, DaVinciArcTypeParms EdgeValue)]
eTypeParms
      expand :: DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
expand = (MenuPrim (Maybe String) (EdgeValue -> IO ()) -> LocalMenu EdgeValue
forall value.
MenuPrim (Maybe String) (value -> IO ()) -> LocalMenu value
LocalMenu (String
-> (EdgeValue -> IO ())
-> MenuPrim (Maybe String) (EdgeValue -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button "Expand" (IO () -> EdgeValue -> IO ()
forall a b. a -> b -> a
const IO ()
expand')) LocalMenu EdgeValue
-> DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$)
      eTypeParmsCO :: [DaVinciArcTypeParms EdgeValue]
eTypeParmsCO = (DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue)
-> [DaVinciArcTypeParms EdgeValue]
-> [DaVinciArcTypeParms EdgeValue]
forall a b. (a -> b) -> [a] -> [b]
map DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
expand [DaVinciArcTypeParms EdgeValue]
eTypeParms'
      eTypeParmsCP :: [DaVinciArcTypeParms EdgeValue]
eTypeParmsCP = (DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue)
-> [DaVinciArcTypeParms EdgeValue]
-> [DaVinciArcTypeParms EdgeValue]
forall a b. (a -> b) -> [a] -> [b]
map (DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
expand (DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue)
-> (DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue)
-> DaVinciArcTypeParms EdgeValue
-> DaVinciArcTypeParms EdgeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Color EdgeValue
forall value. String -> Color value
Color String
color Color EdgeValue
-> DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$)) [DaVinciArcTypeParms EdgeValue]
eTypeParms'
  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 NodeValue]
nTypes <- (DaVinciNodeTypeParms NodeValue -> IO (DaVinciNodeType NodeValue))
-> [DaVinciNodeTypeParms NodeValue]
-> IO [DaVinciNodeType NodeValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (OurGraph
-> DaVinciNodeTypeParms NodeValue -> IO (DaVinciNodeType NodeValue)
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 NodeValue]
nTypeParms'
  [DaVinciArcType EdgeValue]
eTypes <- (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]
eTypeParms'
  [DaVinciArcType EdgeValue]
cTypesO <- (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]
eTypeParmsCO
  [DaVinciArcType EdgeValue]
cTypesP <- (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]
eTypeParmsCP
  GraphInfo -> AbstractionGraph -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gi AbstractionGraph :: OurGraph
-> Map NodeId GANode
-> Map EdgeId GAEdge
-> Map DGNodeType GANodeType
-> Map DGEdgeType GAEdgeType
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
-> AbstractionGraph
AbstractionGraph
    { theGraph :: OurGraph
theGraph = OurGraph
graph
    , nodes :: Map NodeId GANode
nodes = Map NodeId GANode
forall k a. Map k a
Map.empty
    , edges :: Map EdgeId GAEdge
edges = Map EdgeId GAEdge
forall k a. Map k a
Map.empty
    , nodeTypes :: Map DGNodeType GANodeType
nodeTypes = [(DGNodeType, GANodeType)] -> Map DGNodeType GANodeType
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(DGNodeType, GANodeType)] -> Map DGNodeType GANodeType)
-> [(DGNodeType, GANodeType)] -> Map DGNodeType GANodeType
forall a b. (a -> b) -> a -> b
$ [DGNodeType] -> [GANodeType] -> [(DGNodeType, GANodeType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DGNodeType]
nTypeNames
        ([GANodeType] -> [(DGNodeType, GANodeType)])
-> [GANodeType] -> [(DGNodeType, GANodeType)]
forall a b. (a -> b) -> a -> b
$ (DaVinciNodeType NodeValue -> GANodeType)
-> [DaVinciNodeType NodeValue] -> [GANodeType]
forall a b. (a -> b) -> [a] -> [b]
map (\ nt :: DaVinciNodeType NodeValue
nt -> GANodeType :: DaVinciNodeType NodeValue -> GANodeType
GANodeType { udgNodeType :: DaVinciNodeType NodeValue
udgNodeType = DaVinciNodeType NodeValue
nt }) [DaVinciNodeType NodeValue]
nTypes
    , edgeTypes :: Map DGEdgeType GAEdgeType
edgeTypes = [(DGEdgeType, GAEdgeType)] -> Map DGEdgeType GAEdgeType
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(DGEdgeType, GAEdgeType)] -> Map DGEdgeType GAEdgeType)
-> [(DGEdgeType, GAEdgeType)] -> Map DGEdgeType GAEdgeType
forall a b. (a -> b) -> a -> b
$ [DGEdgeType] -> [GAEdgeType] -> [(DGEdgeType, GAEdgeType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DGEdgeType]
eTypeNames
        ([GAEdgeType] -> [(DGEdgeType, GAEdgeType)])
-> [GAEdgeType] -> [(DGEdgeType, GAEdgeType)]
forall a b. (a -> b) -> a -> b
$ ((DaVinciArcType EdgeValue, DaVinciArcType EdgeValue,
  DaVinciArcType EdgeValue)
 -> GAEdgeType)
-> [(DaVinciArcType EdgeValue, DaVinciArcType EdgeValue,
     DaVinciArcType EdgeValue)]
-> [GAEdgeType]
forall a b. (a -> b) -> [a] -> [b]
map (\ (et :: DaVinciArcType EdgeValue
et, ctO :: DaVinciArcType EdgeValue
ctO, ctP :: DaVinciArcType EdgeValue
ctP) -> GAEdgeType :: DaVinciArcType EdgeValue
-> (DaVinciArcType EdgeValue, DaVinciArcType EdgeValue)
-> Bool
-> GAEdgeType
GAEdgeType
               { udgEdgeType :: DaVinciArcType EdgeValue
udgEdgeType = DaVinciArcType EdgeValue
et
               , udgCompressed :: (DaVinciArcType EdgeValue, DaVinciArcType EdgeValue)
udgCompressed = (DaVinciArcType EdgeValue
ctO, DaVinciArcType EdgeValue
ctP)
               , gaeHidden :: Bool
gaeHidden = Bool
False })
        ([(DaVinciArcType EdgeValue, DaVinciArcType EdgeValue,
   DaVinciArcType EdgeValue)]
 -> [GAEdgeType])
-> [(DaVinciArcType EdgeValue, DaVinciArcType EdgeValue,
     DaVinciArcType EdgeValue)]
-> [GAEdgeType]
forall a b. (a -> b) -> a -> b
$ [DaVinciArcType EdgeValue]
-> [DaVinciArcType EdgeValue]
-> [DaVinciArcType EdgeValue]
-> [(DaVinciArcType EdgeValue, DaVinciArcType EdgeValue,
     DaVinciArcType EdgeValue)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [DaVinciArcType EdgeValue]
eTypes [DaVinciArcType EdgeValue]
cTypesO [DaVinciArcType EdgeValue]
cTypesP
    , compressedEdges :: Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
compressedEdges = Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
forall k a. Map k a
Map.empty
    }

{- | similar to lookup (for Map), but returns just the value if lookup was
     successful otherwise an error is raised. -}
get :: (Show k, Ord k) => k -> Map.Map k a -> a
get :: k -> Map k a -> a
get key :: k
key = a -> k -> Map k a -> a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ "get: id unknown: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Show a => a -> String
show k
key) k
key

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

-- | Adds a node (type id)
addNode :: AbstractionGraph -- ^ The graph
        -> NodeId -- ^ ID of the node
        -> DGNodeType -- ^ ID of the nodetype
        -> String -- ^ Name of the node
        -> Bool -- ^ Hidden
        -> IO AbstractionGraph
addNode :: AbstractionGraph
-> NodeId -> DGNodeType -> String -> Bool -> IO AbstractionGraph
addNode g :: AbstractionGraph
g nId :: NodeId
nId nType :: DGNodeType
nType nName :: String
nName hidden :: Bool
hidden = if NodeId -> Map NodeId GANode -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member NodeId
nId (Map NodeId GANode -> Bool) -> Map NodeId GANode -> Bool
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g
  then String -> IO AbstractionGraph
forall a. HasCallStack => String -> a
error (String -> IO AbstractionGraph) -> String -> IO AbstractionGraph
forall a b. (a -> b) -> a -> b
$ "addNode: Node with id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NodeId -> String
forall a. Show a => a -> String
show NodeId
nId String -> String -> String
forall a. [a] -> [a] -> [a]
++ " already exist!"
  else do
    Maybe (DaVinciNode NodeValue)
node' <- if Bool
hidden then Maybe (DaVinciNode NodeValue) -> IO (Maybe (DaVinciNode NodeValue))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (DaVinciNode NodeValue)
forall a. Maybe a
Nothing else do
      DaVinciNode NodeValue
node'' <- OurGraph
-> DaVinciNodeType NodeValue
-> NodeValue
-> IO (DaVinciNode NodeValue)
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) (GANodeType -> DaVinciNodeType NodeValue
udgNodeType (GANodeType -> DaVinciNodeType NodeValue)
-> GANodeType -> DaVinciNodeType NodeValue
forall a b. (a -> b) -> a -> b
$ DGNodeType -> Map DGNodeType GANodeType -> GANodeType
forall k a. (Show k, Ord k) => k -> Map k a -> a
get DGNodeType
nType (Map DGNodeType GANodeType -> GANodeType)
-> Map DGNodeType GANodeType -> GANodeType
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map DGNodeType GANodeType
nodeTypes AbstractionGraph
g)
                        (String
nName, NodeId
nId)
      Maybe (DaVinciNode NodeValue) -> IO (Maybe (DaVinciNode NodeValue))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (DaVinciNode NodeValue)
 -> IO (Maybe (DaVinciNode NodeValue)))
-> Maybe (DaVinciNode NodeValue)
-> IO (Maybe (DaVinciNode NodeValue))
forall a b. (a -> b) -> a -> b
$ DaVinciNode NodeValue -> Maybe (DaVinciNode NodeValue)
forall a. a -> Maybe a
Just DaVinciNode NodeValue
node''
    let node :: GANode
node = GANode :: Maybe (DaVinciNode NodeValue) -> DGNodeType -> NodeValue -> GANode
GANode { udgNode :: Maybe (DaVinciNode NodeValue)
udgNode = Maybe (DaVinciNode NodeValue)
node'
                      , ganType :: DGNodeType
ganType = DGNodeType
nType
                      , ganValue :: NodeValue
ganValue = (String
nName, NodeId
nId)
                      }
    AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g { nodes :: Map NodeId GANode
nodes = NodeId -> GANode -> Map NodeId GANode -> Map NodeId GANode
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NodeId
nId GANode
node (Map NodeId GANode -> Map NodeId GANode)
-> Map NodeId GANode -> Map NodeId GANode
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g }

-- | Deletes a node
delNode :: AbstractionGraph -- ^ The graph
        -> NodeId -- ^ ID of the node
        -> IO AbstractionGraph
delNode :: AbstractionGraph -> NodeId -> IO AbstractionGraph
delNode g :: AbstractionGraph
g nId :: NodeId
nId = do
  case GANode -> Maybe (DaVinciNode NodeValue)
udgNode (GANode -> Maybe (DaVinciNode NodeValue))
-> GANode -> Maybe (DaVinciNode NodeValue)
forall a b. (a -> b) -> a -> b
$ NodeId -> Map NodeId GANode -> GANode
forall k a. (Show k, Ord k) => k -> Map k a -> a
get NodeId
nId (Map NodeId GANode -> GANode) -> Map NodeId GANode -> GANode
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g of
    Just node :: DaVinciNode NodeValue
node -> OurGraph -> DaVinciNode NodeValue -> 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) DaVinciNode NodeValue
node
    Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g { nodes :: Map NodeId GANode
nodes = NodeId -> Map NodeId GANode -> Map NodeId GANode
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete NodeId
nId (Map NodeId GANode -> Map NodeId GANode)
-> Map NodeId GANode -> Map NodeId GANode
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g }

-- | Hides a node
hideNode :: AbstractionGraph -- ^ The graph
         -> NodeId -- ^ ID of the node
         -> IO AbstractionGraph
hideNode :: AbstractionGraph -> NodeId -> IO AbstractionGraph
hideNode g :: AbstractionGraph
g nId :: NodeId
nId = do
  let node :: GANode
node = NodeId -> Map NodeId GANode -> GANode
forall k a. (Show k, Ord k) => k -> Map k a -> a
get NodeId
nId (Map NodeId GANode -> GANode) -> Map NodeId GANode -> GANode
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g
  case GANode -> Maybe (DaVinciNode NodeValue)
udgNode GANode
node of
    Nothing -> AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g
    Just node' :: DaVinciNode NodeValue
node' -> do
      OurGraph -> DaVinciNode NodeValue -> 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) DaVinciNode NodeValue
node'
      AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g { nodes :: Map NodeId GANode
nodes = NodeId -> GANode -> Map NodeId GANode -> Map NodeId GANode
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NodeId
nId GANode
node {udgNode :: Maybe (DaVinciNode NodeValue)
udgNode = Maybe (DaVinciNode NodeValue)
forall a. Maybe a
Nothing} (Map NodeId GANode -> Map NodeId GANode)
-> Map NodeId GANode -> Map NodeId GANode
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g }

-- | Checks whether a node is hidden or not
isHiddenNode' :: AbstractionGraph -- ^ The graph
              -> NodeId -- ^ ID of the node
              -> Bool
isHiddenNode' :: AbstractionGraph -> NodeId -> Bool
isHiddenNode' g :: AbstractionGraph
g nId :: NodeId
nId = Maybe (DaVinciNode NodeValue) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (DaVinciNode NodeValue) -> Bool)
-> Maybe (DaVinciNode NodeValue) -> Bool
forall a b. (a -> b) -> a -> b
$ GANode -> Maybe (DaVinciNode NodeValue)
udgNode (GANode -> Maybe (DaVinciNode NodeValue))
-> GANode -> Maybe (DaVinciNode NodeValue)
forall a b. (a -> b) -> a -> b
$ NodeId -> Map NodeId GANode -> GANode
forall k a. (Show k, Ord k) => k -> Map k a -> a
get NodeId
nId (Map NodeId GANode -> GANode) -> Map NodeId GANode -> GANode
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g

-- | Checks whether a node is hidden or not
isHiddenNode :: GraphInfo -- ^ The graph
             -> NodeId -- ^ ID of the node
             -> IO Bool -- ^ Is hidden
isHiddenNode :: GraphInfo -> NodeId -> IO Bool
isHiddenNode gi :: GraphInfo
gi nId :: NodeId
nId = (AbstractionGraph -> Bool) -> GraphInfo -> IO Bool
wrapperBool (AbstractionGraph -> NodeId -> Bool
`isHiddenNode'` NodeId
nId) GraphInfo
gi

-- | Shows a hidden node again
showNode :: AbstractionGraph -- ^ The graph
         -> NodeId -- ^ ID of the node
         -> IO AbstractionGraph
showNode :: AbstractionGraph -> NodeId -> IO AbstractionGraph
showNode g :: AbstractionGraph
g nId :: NodeId
nId = do
  let node :: GANode
node = NodeId -> Map NodeId GANode -> GANode
forall k a. (Show k, Ord k) => k -> Map k a -> a
get NodeId
nId (Map NodeId GANode -> GANode) -> Map NodeId GANode -> GANode
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g
  case GANode -> Maybe (DaVinciNode NodeValue)
udgNode GANode
node of
    Just _ -> AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g
    Nothing -> do
      DaVinciNode NodeValue
node' <- OurGraph
-> DaVinciNodeType NodeValue
-> NodeValue
-> IO (DaVinciNode NodeValue)
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)
                       (GANodeType -> DaVinciNodeType NodeValue
udgNodeType (GANodeType -> DaVinciNodeType NodeValue)
-> GANodeType -> DaVinciNodeType NodeValue
forall a b. (a -> b) -> a -> b
$ DGNodeType -> Map DGNodeType GANodeType -> GANodeType
forall k a. (Show k, Ord k) => k -> Map k a -> a
get (GANode -> DGNodeType
ganType GANode
node) (Map DGNodeType GANodeType -> GANodeType)
-> Map DGNodeType GANodeType -> GANodeType
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map DGNodeType GANodeType
nodeTypes AbstractionGraph
g)
                       (NodeValue -> IO (DaVinciNode NodeValue))
-> NodeValue -> IO (DaVinciNode NodeValue)
forall a b. (a -> b) -> a -> b
$ GANode -> NodeValue
ganValue GANode
node
      AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return
        AbstractionGraph
g { nodes :: Map NodeId GANode
nodes = NodeId -> GANode -> Map NodeId GANode -> Map NodeId GANode
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NodeId
nId GANode
node { udgNode :: Maybe (DaVinciNode NodeValue)
udgNode = DaVinciNode NodeValue -> Maybe (DaVinciNode NodeValue)
forall a. a -> Maybe a
Just DaVinciNode NodeValue
node' } (Map NodeId GANode -> Map NodeId GANode)
-> Map NodeId GANode -> Map NodeId GANode
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g }

-- | Change the node type of the given node
changeNodeType :: AbstractionGraph -- ^ The graph
               -> NodeId -- ^ ID of the node
               -> DGNodeType -- ^ ID of the nodetype
               -> IO AbstractionGraph
changeNodeType :: AbstractionGraph -> NodeId -> DGNodeType -> IO AbstractionGraph
changeNodeType g :: AbstractionGraph
g nId :: NodeId
nId nType :: DGNodeType
nType = do
  let node :: GANode
node = NodeId -> Map NodeId GANode -> GANode
forall k a. (Show k, Ord k) => k -> Map k a -> a
get NodeId
nId (Map NodeId GANode -> GANode) -> Map NodeId GANode -> GANode
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g
  case GANode -> Maybe (DaVinciNode NodeValue)
udgNode GANode
node of
    Just node' :: DaVinciNode NodeValue
node' -> OurGraph
-> DaVinciNode NodeValue -> DaVinciNodeType NodeValue -> 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) DaVinciNode NodeValue
node' (DaVinciNodeType NodeValue -> IO ())
-> DaVinciNodeType NodeValue -> IO ()
forall a b. (a -> b) -> a -> b
$ GANodeType -> DaVinciNodeType NodeValue
udgNodeType (GANodeType -> DaVinciNodeType NodeValue)
-> GANodeType -> DaVinciNodeType NodeValue
forall a b. (a -> b) -> a -> b
$ DGNodeType -> Map DGNodeType GANodeType -> GANodeType
forall k a. (Show k, Ord k) => k -> Map k a -> a
get DGNodeType
nType
                                                               (Map DGNodeType GANodeType -> GANodeType)
-> Map DGNodeType GANodeType -> GANodeType
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map DGNodeType GANodeType
nodeTypes AbstractionGraph
g
    Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g { nodes :: Map NodeId GANode
nodes = NodeId -> GANode -> Map NodeId GANode -> Map NodeId GANode
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NodeId
nId GANode
node { ganType :: DGNodeType
ganType = DGNodeType
nType } (Map NodeId GANode -> Map NodeId GANode)
-> Map NodeId GANode -> Map NodeId GANode
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g }

-- | Focus a node
focusNode' :: AbstractionGraph -- ^ The graph
           -> NodeId -- ^ ID of the node
           -> IO ()
focusNode' :: AbstractionGraph -> NodeId -> IO ()
focusNode' g :: AbstractionGraph
g nId :: NodeId
nId = IO ()
-> (DaVinciNode NodeValue -> IO ())
-> Maybe (DaVinciNode NodeValue)
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO ()
forall a. HasCallStack => String -> a
error "focusNode: node is hidden!")
                     (OurGraph -> DaVinciNode NodeValue -> 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 ()
setNodeFocus (AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g)) (Maybe (DaVinciNode NodeValue) -> IO ())
-> Maybe (DaVinciNode NodeValue) -> IO ()
forall a b. (a -> b) -> a -> b
$ GANode -> Maybe (DaVinciNode NodeValue)
udgNode (GANode -> Maybe (DaVinciNode NodeValue))
-> GANode -> Maybe (DaVinciNode NodeValue)
forall a b. (a -> b) -> a -> b
$ NodeId -> Map NodeId GANode -> GANode
forall k a. (Show k, Ord k) => k -> Map k a -> a
get NodeId
nId (Map NodeId GANode -> GANode) -> Map NodeId GANode -> GANode
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g

-- | Focus a node
focusNode :: GraphInfo -- ^ The graph
          -> NodeId -- ^ ID of the node
          -> IO ()
focusNode :: GraphInfo -> NodeId -> IO ()
focusNode gi :: GraphInfo
gi nId :: NodeId
nId = (AbstractionGraph -> IO ()) -> GraphInfo -> IO ()
wrapperRead (AbstractionGraph -> NodeId -> IO ()
`focusNode'` NodeId
nId) GraphInfo
gi

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

-- | Adds an edge (type id)
addEdge :: AbstractionGraph -- ^ The graph
        -> EdgeId -- ^ ID of the edge
        -> DGEdgeType -- ^ ID of the edgetype
        -> NodeId -- ^ ID of source node
        -> NodeId -- ^ ID of target node
        -> String -- ^ Name of the edge
        -> Maybe (LEdge DGLinkLab) -- ^ Label of the edge
        -> Bool -- ^ Hidden
        -> IO AbstractionGraph
addEdge :: AbstractionGraph
-> EdgeId
-> DGEdgeType
-> NodeId
-> NodeId
-> String
-> Maybe (LEdge DGLinkLab)
-> Bool
-> IO AbstractionGraph
addEdge g :: AbstractionGraph
g eId :: EdgeId
eId eType :: DGEdgeType
eType nIdFrom :: NodeId
nIdFrom nIdTo :: NodeId
nIdTo eName :: String
eName eLabel :: Maybe (LEdge DGLinkLab)
eLabel hidden :: Bool
hidden =
  if EdgeId -> Map EdgeId GAEdge -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member EdgeId
eId (Map EdgeId GAEdge -> Bool) -> Map EdgeId GAEdge -> Bool
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map EdgeId GAEdge
edges AbstractionGraph
g
    then String -> IO AbstractionGraph
forall a. HasCallStack => String -> a
error (String -> IO AbstractionGraph) -> String -> IO AbstractionGraph
forall a b. (a -> b) -> a -> b
$ "addEdge: Edge with id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EdgeId -> String
forall a. Show a => a -> String
show EdgeId
eId String -> String -> String
forall a. [a] -> [a] -> [a]
++ " already exist!"
    else do
      let gaeV :: EdgeValue
gaeV = (String
eName, EdgeId
eId, Maybe (LEdge DGLinkLab)
eLabel)
      Maybe (DaVinciArc EdgeValue)
edge' <- if Bool
hidden then Maybe (DaVinciArc EdgeValue) -> IO (Maybe (DaVinciArc EdgeValue))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (DaVinciArc EdgeValue)
forall a. Maybe a
Nothing else
        case AbstractionGraph
-> NodeId
-> NodeId
-> DGEdgeType
-> Maybe (DaVinciNode NodeValue, DaVinciNode NodeValue, GAEdgeType)
getEdgeAux AbstractionGraph
g NodeId
nIdFrom NodeId
nIdTo DGEdgeType
eType of
          Just (nFrom :: DaVinciNode NodeValue
nFrom, nTo :: DaVinciNode NodeValue
nTo, gaeT :: GAEdgeType
gaeT) ->
            (DaVinciArc EdgeValue -> Maybe (DaVinciArc EdgeValue))
-> IO (DaVinciArc EdgeValue) -> IO (Maybe (DaVinciArc EdgeValue))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DaVinciArc EdgeValue -> Maybe (DaVinciArc EdgeValue)
forall a. a -> Maybe a
Just (IO (DaVinciArc EdgeValue) -> IO (Maybe (DaVinciArc EdgeValue)))
-> IO (DaVinciArc EdgeValue) -> IO (Maybe (DaVinciArc EdgeValue))
forall a b. (a -> b) -> a -> b
$ OurGraph
-> DaVinciArcType EdgeValue
-> EdgeValue
-> DaVinciNode NodeValue
-> DaVinciNode NodeValue
-> 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) (GAEdgeType -> DaVinciArcType EdgeValue
udgEdgeType GAEdgeType
gaeT) EdgeValue
gaeV DaVinciNode NodeValue
nFrom DaVinciNode NodeValue
nTo
          Nothing -> Maybe (DaVinciArc EdgeValue) -> IO (Maybe (DaVinciArc EdgeValue))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (DaVinciArc EdgeValue)
forall a. Maybe a
Nothing
      let edge :: GAEdge
edge = GAEdge :: Maybe (DaVinciArc EdgeValue)
-> NodeId -> NodeId -> DGEdgeType -> EdgeValue -> GAEdge
GAEdge { udgEdge :: Maybe (DaVinciArc EdgeValue)
udgEdge = Maybe (DaVinciArc EdgeValue)
edge'
                        , gaeType :: DGEdgeType
gaeType = DGEdgeType
eType
                        , ganFrom :: NodeId
ganFrom = NodeId
nIdFrom
                        , ganTo :: NodeId
ganTo = NodeId
nIdTo
                        , gaeValue :: EdgeValue
gaeValue = EdgeValue
gaeV }
      AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g { edges :: Map EdgeId GAEdge
edges = EdgeId -> GAEdge -> Map EdgeId GAEdge -> Map EdgeId GAEdge
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert EdgeId
eId GAEdge
edge (Map EdgeId GAEdge -> Map EdgeId GAEdge)
-> Map EdgeId GAEdge -> Map EdgeId GAEdge
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map EdgeId GAEdge
edges AbstractionGraph
g }

-- | Gets uDrawGraph source and target node, edge type
getEdgeAux :: AbstractionGraph -- ^ The graph
           -> NodeId -- ^ ID of source node
           -> NodeId -- ^ ID of target node
           -> DGEdgeType -- ^ ID of the edgetype
           -> Maybe (DaVinciNode NodeValue, DaVinciNode NodeValue, GAEdgeType)
              -- ^ uDrawGraph source and target node, edge type
getEdgeAux :: AbstractionGraph
-> NodeId
-> NodeId
-> DGEdgeType
-> Maybe (DaVinciNode NodeValue, DaVinciNode NodeValue, GAEdgeType)
getEdgeAux g :: AbstractionGraph
g nIdFrom :: NodeId
nIdFrom nIdTo :: NodeId
nIdTo eType :: DGEdgeType
eType =
  let ns :: Map NodeId GANode
ns = AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g
      gaeT :: GAEdgeType
gaeT = DGEdgeType -> Map DGEdgeType GAEdgeType -> GAEdgeType
forall k a. (Show k, Ord k) => k -> Map k a -> a
get DGEdgeType
eType (Map DGEdgeType GAEdgeType -> GAEdgeType)
-> Map DGEdgeType GAEdgeType -> GAEdgeType
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map DGEdgeType GAEdgeType
edgeTypes AbstractionGraph
g
  in case (GANode -> Maybe (DaVinciNode NodeValue)
udgNode (GANode -> Maybe (DaVinciNode NodeValue))
-> GANode -> Maybe (DaVinciNode NodeValue)
forall a b. (a -> b) -> a -> b
$ NodeId -> Map NodeId GANode -> GANode
forall k a. (Show k, Ord k) => k -> Map k a -> a
get NodeId
nIdFrom Map NodeId GANode
ns, GANode -> Maybe (DaVinciNode NodeValue)
udgNode (GANode -> Maybe (DaVinciNode NodeValue))
-> GANode -> Maybe (DaVinciNode NodeValue)
forall a b. (a -> b) -> a -> b
$ NodeId -> Map NodeId GANode -> GANode
forall k a. (Show k, Ord k) => k -> Map k a -> a
get NodeId
nIdTo Map NodeId GANode
ns) of
    (Just nFrom :: DaVinciNode NodeValue
nFrom, Just nTo :: DaVinciNode NodeValue
nTo) | GAEdgeType -> NodeId -> NodeId -> Bool
f GAEdgeType
gaeT NodeId
nIdFrom NodeId
nIdTo -> (DaVinciNode NodeValue, DaVinciNode NodeValue, GAEdgeType)
-> Maybe (DaVinciNode NodeValue, DaVinciNode NodeValue, GAEdgeType)
forall a. a -> Maybe a
Just (DaVinciNode NodeValue
nFrom, DaVinciNode NodeValue
nTo, GAEdgeType
gaeT)
    _ -> Maybe (DaVinciNode NodeValue, DaVinciNode NodeValue, GAEdgeType)
forall a. Maybe a
Nothing
  where
    f :: GAEdgeType -> NodeId -> NodeId -> Bool
f et :: GAEdgeType
et nf :: NodeId
nf nt :: NodeId
nt = Bool -> Bool
not (GAEdgeType -> Bool
gaeHidden GAEdgeType
et Bool -> Bool -> Bool
|| AbstractionGraph -> NodeId -> Bool
isHiddenNode' AbstractionGraph
g NodeId
nf Bool -> Bool -> Bool
|| AbstractionGraph -> NodeId -> Bool
isHiddenNode' AbstractionGraph
g NodeId
nt)

-- | Deletes an edge
delEdge :: AbstractionGraph -- ^ The graph
        -> EdgeId -- ^ ID of the node
        -> IO AbstractionGraph
delEdge :: AbstractionGraph -> EdgeId -> IO AbstractionGraph
delEdge g :: AbstractionGraph
g eId :: EdgeId
eId = do
  case GAEdge -> Maybe (DaVinciArc EdgeValue)
udgEdge (GAEdge -> Maybe (DaVinciArc EdgeValue))
-> GAEdge -> Maybe (DaVinciArc EdgeValue)
forall a b. (a -> b) -> a -> b
$ EdgeId -> Map EdgeId GAEdge -> GAEdge
forall k a. (Show k, Ord k) => k -> Map k a -> a
get EdgeId
eId (Map EdgeId GAEdge -> GAEdge) -> Map EdgeId GAEdge -> GAEdge
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map EdgeId GAEdge
edges AbstractionGraph
g of
    Just edge :: DaVinciArc EdgeValue
edge -> 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
edge
    Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g { edges :: Map EdgeId GAEdge
edges = EdgeId -> Map EdgeId GAEdge -> Map EdgeId GAEdge
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete EdgeId
eId (Map EdgeId GAEdge -> Map EdgeId GAEdge)
-> Map EdgeId GAEdge -> Map EdgeId GAEdge
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map EdgeId GAEdge
edges AbstractionGraph
g }

-- | Adds an compressed edge
addCompressedEdge :: AbstractionGraph -- ^ The graph
                  -> (NodeId, NodeId, DGEdgeType, Bool) -- ^ Compressed edge id
                  -> IO AbstractionGraph
addCompressedEdge :: AbstractionGraph
-> (NodeId, NodeId, DGEdgeType, Bool) -> IO AbstractionGraph
addCompressedEdge g :: AbstractionGraph
g ce :: (NodeId, NodeId, DGEdgeType, Bool)
ce@(nIdFrom :: NodeId
nIdFrom, nIdTo :: NodeId
nIdTo, eType :: DGEdgeType
eType, orig :: Bool
orig) = do
  let gaeV :: (String, EdgeId, Maybe a)
gaeV = ("", NodeId -> EdgeId
EdgeId 0, Maybe a
forall a. Maybe a
Nothing)
  Maybe (DaVinciArc EdgeValue)
edge' <- case AbstractionGraph
-> NodeId
-> NodeId
-> DGEdgeType
-> Maybe (DaVinciNode NodeValue, DaVinciNode NodeValue, GAEdgeType)
getEdgeAux AbstractionGraph
g NodeId
nIdFrom NodeId
nIdTo DGEdgeType
eType of
    Just (nFrom :: DaVinciNode NodeValue
nFrom, nTo :: DaVinciNode NodeValue
nTo, gaeT :: GAEdgeType
gaeT) ->
      (DaVinciArc EdgeValue -> Maybe (DaVinciArc EdgeValue))
-> IO (DaVinciArc EdgeValue) -> IO (Maybe (DaVinciArc EdgeValue))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DaVinciArc EdgeValue -> Maybe (DaVinciArc EdgeValue)
forall a. a -> Maybe a
Just (IO (DaVinciArc EdgeValue) -> IO (Maybe (DaVinciArc EdgeValue)))
-> IO (DaVinciArc EdgeValue) -> IO (Maybe (DaVinciArc EdgeValue))
forall a b. (a -> b) -> a -> b
$ OurGraph
-> DaVinciArcType EdgeValue
-> EdgeValue
-> DaVinciNode NodeValue
-> DaVinciNode NodeValue
-> 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)
                         ((if Bool
orig then (DaVinciArcType EdgeValue, DaVinciArcType EdgeValue)
-> DaVinciArcType EdgeValue
forall a b. (a, b) -> a
fst else (DaVinciArcType EdgeValue, DaVinciArcType EdgeValue)
-> DaVinciArcType EdgeValue
forall a b. (a, b) -> b
snd) ((DaVinciArcType EdgeValue, DaVinciArcType EdgeValue)
 -> DaVinciArcType EdgeValue)
-> (DaVinciArcType EdgeValue, DaVinciArcType EdgeValue)
-> DaVinciArcType EdgeValue
forall a b. (a -> b) -> a -> b
$ GAEdgeType -> (DaVinciArcType EdgeValue, DaVinciArcType EdgeValue)
udgCompressed GAEdgeType
gaeT)
                         EdgeValue
forall a. (String, EdgeId, Maybe a)
gaeV DaVinciNode NodeValue
nFrom DaVinciNode NodeValue
nTo
    Nothing -> Maybe (DaVinciArc EdgeValue) -> IO (Maybe (DaVinciArc EdgeValue))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (DaVinciArc EdgeValue)
forall a. Maybe a
Nothing
  let edge :: GAEdge
edge = GAEdge :: Maybe (DaVinciArc EdgeValue)
-> NodeId -> NodeId -> DGEdgeType -> EdgeValue -> GAEdge
GAEdge { udgEdge :: Maybe (DaVinciArc EdgeValue)
udgEdge = Maybe (DaVinciArc EdgeValue)
edge'
                    , gaeType :: DGEdgeType
gaeType = DGEdgeType
eType
                    , ganFrom :: NodeId
ganFrom = NodeId
nIdFrom
                    , ganTo :: NodeId
ganTo = NodeId
nIdTo
                    , gaeValue :: EdgeValue
gaeValue = EdgeValue
forall a. (String, EdgeId, Maybe a)
gaeV }
  AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g { compressedEdges :: Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
compressedEdges = (NodeId, NodeId, DGEdgeType, Bool)
-> GAEdge
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (NodeId, NodeId, DGEdgeType, Bool)
ce GAEdge
edge (Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
 -> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge)
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
compressedEdges AbstractionGraph
g }

-- | Deletes an compressed edge
delCompressedEdge :: AbstractionGraph -- ^ The graph
                  -> (NodeId, NodeId, DGEdgeType, Bool) -- ^ Compressed edge id
                  -> IO AbstractionGraph
delCompressedEdge :: AbstractionGraph
-> (NodeId, NodeId, DGEdgeType, Bool) -> IO AbstractionGraph
delCompressedEdge g :: AbstractionGraph
g ce :: (NodeId, NodeId, DGEdgeType, Bool)
ce = do
  case GAEdge -> Maybe (DaVinciArc EdgeValue)
udgEdge (GAEdge -> Maybe (DaVinciArc EdgeValue))
-> GAEdge -> Maybe (DaVinciArc EdgeValue)
forall a b. (a -> b) -> a -> b
$ (NodeId, NodeId, DGEdgeType, Bool)
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge -> GAEdge
forall k a. (Show k, Ord k) => k -> Map k a -> a
get (NodeId, NodeId, DGEdgeType, Bool)
ce (Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge -> GAEdge)
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge -> GAEdge
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
compressedEdges AbstractionGraph
g of
    Just edge :: DaVinciArc EdgeValue
edge -> 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
edge
    Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g { compressedEdges :: Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
compressedEdges = (NodeId, NodeId, DGEdgeType, Bool)
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (NodeId, NodeId, DGEdgeType, Bool)
ce (Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
 -> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge)
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
compressedEdges AbstractionGraph
g }

-- | Hides an edge
hideEdge :: AbstractionGraph -- ^ The graph
         -> EdgeId -- ^ ID of the edge
         -> IO AbstractionGraph
hideEdge :: AbstractionGraph -> EdgeId -> IO AbstractionGraph
hideEdge g :: AbstractionGraph
g eId :: EdgeId
eId = do
  let edge :: GAEdge
edge = EdgeId -> Map EdgeId GAEdge -> GAEdge
forall k a. (Show k, Ord k) => k -> Map k a -> a
get EdgeId
eId (Map EdgeId GAEdge -> GAEdge) -> Map EdgeId GAEdge -> GAEdge
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map EdgeId GAEdge
edges AbstractionGraph
g
  case GAEdge -> Maybe (DaVinciArc EdgeValue)
udgEdge GAEdge
edge of
    Nothing -> AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g
    Just edge' :: DaVinciArc EdgeValue
edge' -> 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
edge'
      AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g { edges :: Map EdgeId GAEdge
edges = EdgeId -> GAEdge -> Map EdgeId GAEdge -> Map EdgeId GAEdge
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert EdgeId
eId GAEdge
edge { udgEdge :: Maybe (DaVinciArc EdgeValue)
udgEdge = Maybe (DaVinciArc EdgeValue)
forall a. Maybe a
Nothing } (Map EdgeId GAEdge -> Map EdgeId GAEdge)
-> Map EdgeId GAEdge -> Map EdgeId GAEdge
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map EdgeId GAEdge
edges AbstractionGraph
g }

-- | Hides a set of edgetypes (type ids)
hideSetOfEdgeTypes' :: AbstractionGraph -- ^ The graph
                    -> [DGEdgeType] -- ^ IDs of the edgetypes to hide
                    -> IO AbstractionGraph
hideSetOfEdgeTypes' :: AbstractionGraph -> [DGEdgeType] -> IO AbstractionGraph
hideSetOfEdgeTypes' g :: AbstractionGraph
g eTypes :: [DGEdgeType]
eTypes = do
  let (hEdges :: [EdgeId]
hEdges, sEdges :: [EdgeId]
sEdges) = (EdgeId -> GAEdge -> ([EdgeId], [EdgeId]) -> ([EdgeId], [EdgeId]))
-> ([EdgeId], [EdgeId])
-> Map EdgeId GAEdge
-> ([EdgeId], [EdgeId])
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\ eid :: EdgeId
eid e :: GAEdge
e (he :: [EdgeId]
he, se :: [EdgeId]
se) ->
         if DGEdgeType -> [DGEdgeType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (GAEdge -> DGEdgeType
gaeType GAEdge
e) [DGEdgeType]
eTypes then (EdgeId
eid EdgeId -> [EdgeId] -> [EdgeId]
forall a. a -> [a] -> [a]
: [EdgeId]
he, [EdgeId]
se) else ([EdgeId]
he, EdgeId
eid EdgeId -> [EdgeId] -> [EdgeId]
forall a. a -> [a] -> [a]
: [EdgeId]
se))
         ([], []) (Map EdgeId GAEdge -> ([EdgeId], [EdgeId]))
-> Map EdgeId GAEdge -> ([EdgeId], [EdgeId])
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map EdgeId GAEdge
edges AbstractionGraph
g'
      g' :: AbstractionGraph
g' = AbstractionGraph
g { edgeTypes :: Map DGEdgeType GAEdgeType
edgeTypes = (DGEdgeType -> GAEdgeType -> GAEdgeType)
-> Map DGEdgeType GAEdgeType -> Map DGEdgeType GAEdgeType
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
             (\ etId :: DGEdgeType
etId et :: GAEdgeType
et -> GAEdgeType
et { gaeHidden :: Bool
gaeHidden = DGEdgeType -> [DGEdgeType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem DGEdgeType
etId [DGEdgeType]
eTypes }) (Map DGEdgeType GAEdgeType -> Map DGEdgeType GAEdgeType)
-> Map DGEdgeType GAEdgeType -> Map DGEdgeType GAEdgeType
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map DGEdgeType GAEdgeType
edgeTypes AbstractionGraph
g }
  AbstractionGraph
g'' <- (AbstractionGraph -> EdgeId -> IO AbstractionGraph)
-> AbstractionGraph -> [EdgeId] -> IO AbstractionGraph
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM AbstractionGraph -> EdgeId -> IO AbstractionGraph
hideEdge AbstractionGraph
g' [EdgeId]
hEdges
  (AbstractionGraph -> EdgeId -> IO AbstractionGraph)
-> AbstractionGraph -> [EdgeId] -> IO AbstractionGraph
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM AbstractionGraph -> EdgeId -> IO AbstractionGraph
showEdge AbstractionGraph
g'' [EdgeId]
sEdges

-- | Hides a set of edgetypes (type ids)
hideSetOfEdgeTypes :: GraphInfo -- ^ The graph
                   -> [DGEdgeType] -- ^ IDs of the edgetypes to hide
                   -> IO ()
hideSetOfEdgeTypes :: GraphInfo -> [DGEdgeType] -> IO ()
hideSetOfEdgeTypes gi :: GraphInfo
gi eT :: [DGEdgeType]
eT = do
  (update :: String -> IO ()
update, exit :: IO ()
exit) <- String -> String -> IO (String -> IO (), IO ())
pulseBar "Updating graph" "hiding/showing edge types..."
  (AbstractionGraph -> IO AbstractionGraph) -> GraphInfo -> IO ()
wrapperWrite (AbstractionGraph -> [DGEdgeType] -> IO AbstractionGraph
`hideSetOfEdgeTypes'` [DGEdgeType]
eT) GraphInfo
gi
  String -> IO ()
update "finished"
  IO ()
exit

-- | Checks whether an edge is hidden or not
isHiddenEdge' :: AbstractionGraph -- ^ The graph
              -> EdgeId -- ^ ID of the edge
              -> Bool -- ^ Is edge hidden
isHiddenEdge' :: AbstractionGraph -> EdgeId -> Bool
isHiddenEdge' g :: AbstractionGraph
g eId :: EdgeId
eId = Maybe (DaVinciArc EdgeValue) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (DaVinciArc EdgeValue) -> Bool)
-> Maybe (DaVinciArc EdgeValue) -> Bool
forall a b. (a -> b) -> a -> b
$ GAEdge -> Maybe (DaVinciArc EdgeValue)
udgEdge (GAEdge -> Maybe (DaVinciArc EdgeValue))
-> GAEdge -> Maybe (DaVinciArc EdgeValue)
forall a b. (a -> b) -> a -> b
$ EdgeId -> Map EdgeId GAEdge -> GAEdge
forall k a. (Show k, Ord k) => k -> Map k a -> a
get EdgeId
eId (Map EdgeId GAEdge -> GAEdge) -> Map EdgeId GAEdge -> GAEdge
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map EdgeId GAEdge
edges AbstractionGraph
g

-- | Checks whether an edge is hidden or not
isHiddenEdge :: GraphInfo -- ^ The graph
             -> EdgeId -- ^ ID of the edge
             -> IO Bool -- ^ Is edge hidden
isHiddenEdge :: GraphInfo -> EdgeId -> IO Bool
isHiddenEdge gi :: GraphInfo
gi eId :: EdgeId
eId = (AbstractionGraph -> Bool) -> GraphInfo -> IO Bool
wrapperBool (AbstractionGraph -> EdgeId -> Bool
`isHiddenEdge'` EdgeId
eId) GraphInfo
gi

-- | Shows a hidden edge again
showEdge :: AbstractionGraph -- ^ The graph
         -> EdgeId -- ^ ID of the edge
         -> IO AbstractionGraph
showEdge :: AbstractionGraph -> EdgeId -> IO AbstractionGraph
showEdge g :: AbstractionGraph
g eId :: EdgeId
eId = do
  let es :: Map EdgeId GAEdge
es = AbstractionGraph -> Map EdgeId GAEdge
edges AbstractionGraph
g
      edge :: GAEdge
edge = EdgeId -> Map EdgeId GAEdge -> GAEdge
forall k a. (Show k, Ord k) => k -> Map k a -> a
get EdgeId
eId Map EdgeId GAEdge
es
  case GAEdge -> Maybe (DaVinciArc EdgeValue)
udgEdge GAEdge
edge of
    Just _ -> AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g
    Nothing -> case AbstractionGraph
-> NodeId
-> NodeId
-> DGEdgeType
-> Maybe (DaVinciNode NodeValue, DaVinciNode NodeValue, GAEdgeType)
getEdgeAux AbstractionGraph
g (GAEdge -> NodeId
ganFrom GAEdge
edge) (GAEdge -> NodeId
ganTo GAEdge
edge) (GAEdge -> DGEdgeType
gaeType GAEdge
edge) of
      Just (nFrom :: DaVinciNode NodeValue
nFrom, nTo :: DaVinciNode NodeValue
nTo, gaeT :: GAEdgeType
gaeT) -> do
        DaVinciArc EdgeValue
edge' <- OurGraph
-> DaVinciArcType EdgeValue
-> EdgeValue
-> DaVinciNode NodeValue
-> DaVinciNode NodeValue
-> 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) (GAEdgeType -> DaVinciArcType EdgeValue
udgEdgeType GAEdgeType
gaeT) (GAEdge -> EdgeValue
gaeValue GAEdge
edge) DaVinciNode NodeValue
nFrom
                        DaVinciNode NodeValue
nTo
        AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g { edges :: Map EdgeId GAEdge
edges = EdgeId -> GAEdge -> Map EdgeId GAEdge -> Map EdgeId GAEdge
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert EdgeId
eId GAEdge
edge { udgEdge :: Maybe (DaVinciArc EdgeValue)
udgEdge = DaVinciArc EdgeValue -> Maybe (DaVinciArc EdgeValue)
forall a. a -> Maybe a
Just DaVinciArc EdgeValue
edge' } Map EdgeId GAEdge
es }
      Nothing -> AbstractionGraph -> IO AbstractionGraph
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractionGraph
g

-- * Conversion and update of graph

-- | Apply changes to the uDrawGraph graph
applyChanges' :: AbstractionGraph -- ^ The graph
              -> [DGChange] -- ^ List of changes
              -> [NodeId] -- ^ IDs of the nodes to hide
              -> [EdgeId] -- ^ IDs of the edges to hide
              -> [(NodeId, NodeId, DGEdgeType, Bool)] -- ^ A list of new edges
              -> IO AbstractionGraph
applyChanges' :: AbstractionGraph
-> [DGChange]
-> [NodeId]
-> [EdgeId]
-> [(NodeId, NodeId, DGEdgeType, Bool)]
-> IO AbstractionGraph
applyChanges' g :: AbstractionGraph
g dgchanges :: [DGChange]
dgchanges hnIds :: [NodeId]
hnIds heIds' :: [EdgeId]
heIds' ce :: [(NodeId, NodeId, DGEdgeType, Bool)]
ce = do
  let
    -- split and convert changes
    (an' :: [GAChange]
an', dn :: [GAChange]
dn, cnt' :: [GAChange]
cnt', ae' :: [GAChange]
ae', de :: [GAChange]
de) = (DGChange
 -> ([GAChange], [GAChange], [GAChange], [GAChange], [GAChange])
 -> ([GAChange], [GAChange], [GAChange], [GAChange], [GAChange]))
-> ([GAChange], [GAChange], [GAChange], [GAChange], [GAChange])
-> [DGChange]
-> ([GAChange], [GAChange], [GAChange], [GAChange], [GAChange])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DGChange
-> ([GAChange], [GAChange], [GAChange], [GAChange], [GAChange])
-> ([GAChange], [GAChange], [GAChange], [GAChange], [GAChange])
splitChange ([], [], [], [], []) [DGChange]
dgchanges
    -- get Ids
    anIds :: [NodeId]
anIds = (GAChange -> NodeId) -> [GAChange] -> [NodeId]
forall a b. (a -> b) -> [a] -> [b]
map (\ ~(AddNode nId :: NodeId
nId _ _ _) -> NodeId
nId) [GAChange]
an'
    dnIds :: [NodeId]
dnIds = (GAChange -> NodeId) -> [GAChange] -> [NodeId]
forall a b. (a -> b) -> [a] -> [b]
map (\ ~(DelNode nId :: NodeId
nId) -> NodeId
nId) [GAChange]
dn
    aeIds :: [EdgeId]
aeIds = (GAChange -> EdgeId) -> [GAChange] -> [EdgeId]
forall a b. (a -> b) -> [a] -> [b]
map (\ ~(AddEdge eId :: EdgeId
eId _ _ _ _ _ _) -> EdgeId
eId) [GAChange]
ae'
    deIds :: [EdgeId]
deIds = (GAChange -> EdgeId) -> [GAChange] -> [EdgeId]
forall a b. (a -> b) -> [a] -> [b]
map (\ ~(DelEdge eId :: EdgeId
eId) -> EdgeId
eId) [GAChange]
de
    heIds :: [EdgeId]
heIds = [EdgeId]
heIds' [EdgeId] -> [EdgeId] -> [EdgeId]
forall a. [a] -> [a] -> [a]
++ ((EdgeId, GAEdge) -> EdgeId) -> [(EdgeId, GAEdge)] -> [EdgeId]
forall a b. (a -> b) -> [a] -> [b]
map (EdgeId, GAEdge) -> EdgeId
forall a b. (a, b) -> a
fst (((EdgeId, GAEdge) -> Bool)
-> [(EdgeId, GAEdge)] -> [(EdgeId, GAEdge)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (eId :: EdgeId
eId, e :: GAEdge
e) -> EdgeId -> [EdgeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem EdgeId
eId [EdgeId]
deIds Bool -> Bool -> Bool
&&
      EdgeId -> [EdgeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem EdgeId
eId [EdgeId]
heIds' Bool -> Bool -> Bool
&& (NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (GAEdge -> NodeId
ganTo GAEdge
e) [NodeId]
hnIds Bool -> Bool -> Bool
|| NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (GAEdge -> NodeId
ganFrom GAEdge
e) [NodeId]
hnIds))
      ([(EdgeId, GAEdge)] -> [(EdgeId, GAEdge)])
-> [(EdgeId, GAEdge)] -> [(EdgeId, GAEdge)]
forall a b. (a -> b) -> a -> b
$ Map EdgeId GAEdge -> [(EdgeId, GAEdge)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map EdgeId GAEdge -> [(EdgeId, GAEdge)])
-> Map EdgeId GAEdge -> [(EdgeId, GAEdge)]
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map EdgeId GAEdge
edges AbstractionGraph
g)
    -- filter multiple changes and changes for deleted and new nodes
    (cnt :: [GAChange]
cnt, new :: [GAChange]
new) = (GAChange -> Bool) -> [GAChange] -> ([GAChange], [GAChange])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\ ~(ChangeNodeType nId :: NodeId
nId _) -> NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem NodeId
nId [NodeId]
anIds)
      ([GAChange] -> ([GAChange], [GAChange]))
-> [GAChange] -> ([GAChange], [GAChange])
forall a b. (a -> b) -> a -> b
$ (GAChange -> Bool) -> [GAChange] -> [GAChange]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ ~(ChangeNodeType nId :: NodeId
nId _) -> NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem NodeId
nId [NodeId]
dnIds) ([GAChange] -> [GAChange]) -> [GAChange] -> [GAChange]
forall a b. (a -> b) -> a -> b
$ ([GAChange], [NodeId]) -> [GAChange]
forall a b. (a, b) -> a
fst
      (([GAChange], [NodeId]) -> [GAChange])
-> ([GAChange], [NodeId]) -> [GAChange]
forall a b. (a -> b) -> a -> b
$ (GAChange -> ([GAChange], [NodeId]) -> ([GAChange], [NodeId]))
-> ([GAChange], [NodeId]) -> [GAChange] -> ([GAChange], [NodeId])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ ~c :: GAChange
c@(ChangeNodeType nId :: NodeId
nId _) (cs :: [GAChange]
cs, nIds :: [NodeId]
nIds) -> if NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem NodeId
nId [NodeId]
nIds
                then ([GAChange]
cs, [NodeId]
nIds) else (GAChange
c GAChange -> [GAChange] -> [GAChange]
forall a. a -> [a] -> [a]
: [GAChange]
cs, NodeId
nId NodeId -> [NodeId] -> [NodeId]
forall a. a -> [a] -> [a]
: [NodeId]
nIds)) ([], []) [GAChange]
cnt'
    -- fuction for geting new nt if node type change is submitted for node
    nnT :: NodeId -> DGNodeType -> DGNodeType
nnT nId :: NodeId
nId nT :: DGNodeType
nT = (DGNodeType -> GAChange -> DGNodeType)
-> DGNodeType -> [GAChange] -> DGNodeType
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ nT' :: DGNodeType
nT' ~(ChangeNodeType nId' :: NodeId
nId' nT'' :: DGNodeType
nT'') ->
                              if NodeId
nId NodeId -> NodeId -> Bool
forall a. Eq a => a -> a -> Bool
== NodeId
nId' then DGNodeType
nT'' else DGNodeType
nT') DGNodeType
nT [GAChange]
new
    -- update node type and mark as hidden if they would be hidden afterwards
    an :: [GAChange]
an = (GAChange -> GAChange) -> [GAChange] -> [GAChange]
forall a b. (a -> b) -> [a] -> [b]
map (\ ~(AddNode nId :: NodeId
nId nT :: DGNodeType
nT nN :: String
nN _) -> NodeId -> DGNodeType -> String -> Bool -> GAChange
AddNode NodeId
nId (NodeId -> DGNodeType -> DGNodeType
nnT NodeId
nId DGNodeType
nT) String
nN
                                                (Bool -> GAChange) -> Bool -> GAChange
forall a b. (a -> b) -> a -> b
$ NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem NodeId
nId [NodeId]
hnIds) [GAChange]
an'
    -- old compressed edges
    oce :: [(NodeId, NodeId, DGEdgeType, Bool)]
oce = Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
-> [(NodeId, NodeId, DGEdgeType, Bool)]
forall k a. Map k a -> [k]
Map.keys (Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
 -> [(NodeId, NodeId, DGEdgeType, Bool)])
-> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
-> [(NodeId, NodeId, DGEdgeType, Bool)]
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map (NodeId, NodeId, DGEdgeType, Bool) GAEdge
compressedEdges AbstractionGraph
g
    -- delete compressed edges not needed anymore
    dce :: [GAChange]
dce = ([GAChange] -> (NodeId, NodeId, DGEdgeType, Bool) -> [GAChange])
-> [GAChange] -> [(NodeId, NodeId, DGEdgeType, Bool)] -> [GAChange]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ es :: [GAChange]
es e :: (NodeId, NodeId, DGEdgeType, Bool)
e -> if (NodeId, NodeId, DGEdgeType, Bool)
-> [(NodeId, NodeId, DGEdgeType, Bool)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (NodeId, NodeId, DGEdgeType, Bool)
e [(NodeId, NodeId, DGEdgeType, Bool)]
ce then [GAChange]
es else (NodeId, NodeId, DGEdgeType, Bool) -> GAChange
DelCompEdge (NodeId, NodeId, DGEdgeType, Bool)
e GAChange -> [GAChange] -> [GAChange]
forall a. a -> [a] -> [a]
: [GAChange]
es) [] [(NodeId, NodeId, DGEdgeType, Bool)]
oce
    -- get hidden nodes that are not hidden after update
    sn :: [GAChange]
sn = (NodeId -> GAChange) -> [NodeId] -> [GAChange]
forall a b. (a -> b) -> [a] -> [b]
map NodeId -> GAChange
ShowNode ([NodeId] -> [GAChange]) -> [NodeId] -> [GAChange]
forall a b. (a -> b) -> a -> b
$ (NodeId -> Bool) -> [NodeId] -> [NodeId]
forall a. (a -> Bool) -> [a] -> [a]
filter
             (\ n :: NodeId
n -> AbstractionGraph -> NodeId -> Bool
isHiddenNode' AbstractionGraph
g NodeId
n Bool -> Bool -> Bool
&& Bool -> Bool
not (NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem NodeId
n [NodeId]
hnIds Bool -> Bool -> Bool
|| NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem NodeId
n [NodeId]
dnIds))
             ([NodeId] -> [NodeId]) -> [NodeId] -> [NodeId]
forall a b. (a -> b) -> a -> b
$ Map NodeId GANode -> [NodeId]
forall k a. Map k a -> [k]
Map.keys (Map NodeId GANode -> [NodeId]) -> Map NodeId GANode -> [NodeId]
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map NodeId GANode
nodes AbstractionGraph
g
    -- edges to hide
    he :: [GAChange]
he = (EdgeId -> GAChange) -> [EdgeId] -> [GAChange]
forall a b. (a -> b) -> [a] -> [b]
map EdgeId -> GAChange
HideEdge ([EdgeId] -> [GAChange]) -> [EdgeId] -> [GAChange]
forall a b. (a -> b) -> a -> b
$ (EdgeId -> Bool) -> [EdgeId] -> [EdgeId]
forall a. (a -> Bool) -> [a] -> [a]
filter
             (\ eId :: EdgeId
eId -> EdgeId -> [EdgeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem EdgeId
eId [EdgeId]
aeIds Bool -> Bool -> Bool
&& Bool -> Bool
not (AbstractionGraph -> EdgeId -> Bool
isHiddenEdge' AbstractionGraph
g EdgeId
eId)) [EdgeId]
heIds
    -- mark as hidden if they would be hidden afterwards
    ae :: [GAChange]
ae = (GAChange -> GAChange) -> [GAChange] -> [GAChange]
forall a b. (a -> b) -> [a] -> [b]
map (\ ~(AddEdge eId :: EdgeId
eId eT :: DGEdgeType
eT nIdF :: NodeId
nIdF nIdT :: NodeId
nIdT eN :: String
eN eL :: Maybe (LEdge DGLinkLab)
eL _) ->
      EdgeId
-> DGEdgeType
-> NodeId
-> NodeId
-> String
-> Maybe (LEdge DGLinkLab)
-> Bool
-> GAChange
AddEdge EdgeId
eId DGEdgeType
eT NodeId
nIdF NodeId
nIdT String
eN Maybe (LEdge DGLinkLab)
eL (Bool -> GAChange) -> Bool -> GAChange
forall a b. (a -> b) -> a -> b
$ NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem NodeId
nIdF [NodeId]
hnIds Bool -> Bool -> Bool
|| NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem NodeId
nIdT [NodeId]
hnIds Bool -> Bool -> Bool
||
                                       EdgeId -> [EdgeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem EdgeId
eId [EdgeId]
heIds) [GAChange]
ae'
    -- nodes to hide
    hn :: [GAChange]
hn = (NodeId -> GAChange) -> [NodeId] -> [GAChange]
forall a b. (a -> b) -> [a] -> [b]
map NodeId -> GAChange
HideNode ([NodeId] -> [GAChange]) -> [NodeId] -> [GAChange]
forall a b. (a -> b) -> a -> b
$ (NodeId -> Bool) -> [NodeId] -> [NodeId]
forall a. (a -> Bool) -> [a] -> [a]
filter
             (\ nId :: NodeId
nId -> NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem NodeId
nId [NodeId]
anIds Bool -> Bool -> Bool
&& Bool -> Bool
not (AbstractionGraph -> NodeId -> Bool
isHiddenNode' AbstractionGraph
g NodeId
nId)) [NodeId]
hnIds
    -- edges to show
    se :: [GAChange]
se = (EdgeId -> GAChange) -> [EdgeId] -> [GAChange]
forall a b. (a -> b) -> [a] -> [b]
map EdgeId -> GAChange
ShowEdge
      ([EdgeId] -> [GAChange]) -> [EdgeId] -> [GAChange]
forall a b. (a -> b) -> a -> b
$ (EdgeId -> Bool) -> [EdgeId] -> [EdgeId]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ e :: EdgeId
e -> AbstractionGraph -> EdgeId -> Bool
isHiddenEdge' AbstractionGraph
g EdgeId
e Bool -> Bool -> Bool
&& EdgeId -> [EdgeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem EdgeId
e [EdgeId]
heIds Bool -> Bool -> Bool
&& EdgeId -> [EdgeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem EdgeId
e [EdgeId]
deIds)
      ([EdgeId] -> [EdgeId]) -> [EdgeId] -> [EdgeId]
forall a b. (a -> b) -> a -> b
$ Map EdgeId GAEdge -> [EdgeId]
forall k a. Map k a -> [k]
Map.keys (Map EdgeId GAEdge -> [EdgeId]) -> Map EdgeId GAEdge -> [EdgeId]
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> Map EdgeId GAEdge
edges AbstractionGraph
g
    -- get compressed edges to add
    ace :: [GAChange]
ace = ([GAChange] -> (NodeId, NodeId, DGEdgeType, Bool) -> [GAChange])
-> [GAChange] -> [(NodeId, NodeId, DGEdgeType, Bool)] -> [GAChange]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ es :: [GAChange]
es e :: (NodeId, NodeId, DGEdgeType, Bool)
e -> if (NodeId, NodeId, DGEdgeType, Bool)
-> [(NodeId, NodeId, DGEdgeType, Bool)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (NodeId, NodeId, DGEdgeType, Bool)
e [(NodeId, NodeId, DGEdgeType, Bool)]
oce then [GAChange]
es else (NodeId, NodeId, DGEdgeType, Bool) -> GAChange
AddCompEdge (NodeId, NodeId, DGEdgeType, Bool)
e GAChange -> [GAChange] -> [GAChange]
forall a. a -> [a] -> [a]
: [GAChange]
es) [] [(NodeId, NodeId, DGEdgeType, Bool)]
ce
    -- concat changes
    changes :: [GAChange]
changes = [GAChange]
de [GAChange] -> [GAChange] -> [GAChange]
forall a. [a] -> [a] -> [a]
++ [GAChange]
dce [GAChange] -> [GAChange] -> [GAChange]
forall a. [a] -> [a] -> [a]
++ [GAChange]
dn [GAChange] -> [GAChange] -> [GAChange]
forall a. [a] -> [a] -> [a]
++ [GAChange]
cnt [GAChange] -> [GAChange] -> [GAChange]
forall a. [a] -> [a] -> [a]
++ [GAChange]
sn [GAChange] -> [GAChange] -> [GAChange]
forall a. [a] -> [a] -> [a]
++ [GAChange]
an [GAChange] -> [GAChange] -> [GAChange]
forall a. [a] -> [a] -> [a]
++ [GAChange]
he [GAChange] -> [GAChange] -> [GAChange]
forall a. [a] -> [a] -> [a]
++ [GAChange]
hn [GAChange] -> [GAChange] -> [GAChange]
forall a. [a] -> [a] -> [a]
++ [GAChange]
se [GAChange] -> [GAChange] -> [GAChange]
forall a. [a] -> [a] -> [a]
++ [GAChange]
ae [GAChange] -> [GAChange] -> [GAChange]
forall a. [a] -> [a] -> [a]
++ [GAChange]
ace
  (AbstractionGraph -> GAChange -> IO AbstractionGraph)
-> AbstractionGraph -> [GAChange] -> IO AbstractionGraph
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM AbstractionGraph -> GAChange -> IO AbstractionGraph
applyChange AbstractionGraph
g [GAChange]
changes

-- | Apply changes to the uDrawGraph graph
applyChanges :: GraphInfo -- ^ The graph
             -> [DGChange] -- ^ List of changes
             -> [NodeId] -- ^ IDs of the nodes to hide
             -> [EdgeId] -- ^ IDs of the edges to hide
             -> [(NodeId, NodeId, DGEdgeType, Bool)] -- ^ A list of new edges
             -> IO ()
applyChanges :: GraphInfo
-> [DGChange]
-> [NodeId]
-> [EdgeId]
-> [(NodeId, NodeId, DGEdgeType, Bool)]
-> IO ()
applyChanges gi :: GraphInfo
gi changes :: [DGChange]
changes nIds :: [NodeId]
nIds eIds :: [EdgeId]
eIds compedges :: [(NodeId, NodeId, DGEdgeType, Bool)]
compedges =
  (AbstractionGraph -> IO AbstractionGraph) -> GraphInfo -> IO ()
wrapperWrite (\ g :: AbstractionGraph
g -> AbstractionGraph
-> [DGChange]
-> [NodeId]
-> [EdgeId]
-> [(NodeId, NodeId, DGEdgeType, Bool)]
-> IO AbstractionGraph
applyChanges' AbstractionGraph
g [DGChange]
changes [NodeId]
nIds [EdgeId]
eIds [(NodeId, NodeId, DGEdgeType, Bool)]
compedges) GraphInfo
gi

-- | Converts and splits DGChanges to GAChanges
splitChange :: DGChange -- ^ Development graph changes
               -> ([GAChange], [GAChange], [GAChange], [GAChange], [GAChange])
                  -- ^ Graph abstraction changes
               -> ([GAChange], [GAChange], [GAChange], [GAChange], [GAChange])
                  -- ^ Graph abstraction changes
splitChange :: DGChange
-> ([GAChange], [GAChange], [GAChange], [GAChange], [GAChange])
-> ([GAChange], [GAChange], [GAChange], [GAChange], [GAChange])
splitChange c :: DGChange
c (an :: [GAChange]
an, dn :: [GAChange]
dn, cnt :: [GAChange]
cnt, ae :: [GAChange]
ae, de :: [GAChange]
de) = case DGChange
c of
  InsertNode _ -> (GAChange
change GAChange -> [GAChange] -> [GAChange]
forall a. a -> [a] -> [a]
: [GAChange]
an, [GAChange]
dn, [GAChange]
cnt, [GAChange]
ae, [GAChange]
de)
  DeleteNode _ -> ([GAChange]
an, GAChange
change GAChange -> [GAChange] -> [GAChange]
forall a. a -> [a] -> [a]
: [GAChange]
dn, [GAChange]
cnt, [GAChange]
ae, [GAChange]
de)
  SetNodeLab _ _ -> ([GAChange]
an, [GAChange]
dn, GAChange
change GAChange -> [GAChange] -> [GAChange]
forall a. a -> [a] -> [a]
: [GAChange]
cnt, [GAChange]
ae, [GAChange]
de)
  InsertEdge _ -> ([GAChange]
an, [GAChange]
dn, [GAChange]
cnt, GAChange
change GAChange -> [GAChange] -> [GAChange]
forall a. a -> [a] -> [a]
: [GAChange]
ae, [GAChange]
de)
  DeleteEdge _ -> ([GAChange]
an, [GAChange]
dn, [GAChange]
cnt, [GAChange]
ae, GAChange
change GAChange -> [GAChange] -> [GAChange]
forall a. a -> [a] -> [a]
: [GAChange]
de)
  where
    change :: GAChange
change = DGChange -> GAChange
convertChange DGChange
c

-- | Converts a DGChange to a GAChange
convertChange :: DGChange -- ^ Development graph change
              -> GAChange -- ^ Graph abstraction change
convertChange :: DGChange -> GAChange
convertChange change :: DGChange
change = case DGChange
change of
  InsertNode (node :: NodeId
node, nodelab :: DGNodeLab
nodelab) ->
    NodeId -> DGNodeType -> String -> Bool -> GAChange
AddNode NodeId
node (DGNodeLab -> DGNodeType
getRealDGNodeType DGNodeLab
nodelab) (DGNodeLab -> String
getDGNodeName DGNodeLab
nodelab) Bool
False
  DeleteNode (node :: NodeId
node, _) ->
    NodeId -> GAChange
DelNode NodeId
node
  SetNodeLab _ (node :: NodeId
node, newLab :: DGNodeLab
newLab) ->
    NodeId -> DGNodeType -> GAChange
ChangeNodeType NodeId
node (DGNodeType -> GAChange) -> DGNodeType -> GAChange
forall a b. (a -> b) -> a -> b
$ DGNodeLab -> DGNodeType
getRealDGNodeType DGNodeLab
newLab
  InsertEdge e :: LEdge DGLinkLab
e@(src :: NodeId
src, tgt :: NodeId
tgt, lbl :: DGLinkLab
lbl) ->
    EdgeId
-> DGEdgeType
-> NodeId
-> NodeId
-> String
-> Maybe (LEdge DGLinkLab)
-> Bool
-> GAChange
AddEdge (DGLinkLab -> EdgeId
dgl_id DGLinkLab
lbl) (DGLinkLab -> DGEdgeType
getRealDGLinkType DGLinkLab
lbl) NodeId
src NodeId
tgt "" (LEdge DGLinkLab -> Maybe (LEdge DGLinkLab)
forall a. a -> Maybe a
Just LEdge DGLinkLab
e) Bool
False
  DeleteEdge (_, _, lbl :: DGLinkLab
lbl) ->
    EdgeId -> GAChange
DelEdge (EdgeId -> GAChange) -> EdgeId -> GAChange
forall a b. (a -> b) -> a -> b
$ DGLinkLab -> EdgeId
dgl_id DGLinkLab
lbl

-- | Applies a change to the graph
applyChange :: AbstractionGraph -- ^ The graph
            -> GAChange -- ^ Change to apply
            -> IO AbstractionGraph
applyChange :: AbstractionGraph -> GAChange -> IO AbstractionGraph
applyChange g :: AbstractionGraph
g change :: GAChange
change = case GAChange
change of
  AddNode nId :: NodeId
nId nT :: DGNodeType
nT nN :: String
nN nH :: Bool
nH -> AbstractionGraph
-> NodeId -> DGNodeType -> String -> Bool -> IO AbstractionGraph
addNode AbstractionGraph
g NodeId
nId DGNodeType
nT String
nN Bool
nH
  DelNode nId :: NodeId
nId -> AbstractionGraph -> NodeId -> IO AbstractionGraph
delNode AbstractionGraph
g NodeId
nId
  ChangeNodeType nId :: NodeId
nId nT :: DGNodeType
nT -> AbstractionGraph -> NodeId -> DGNodeType -> IO AbstractionGraph
changeNodeType AbstractionGraph
g NodeId
nId DGNodeType
nT
  ShowNode nId :: NodeId
nId -> AbstractionGraph -> NodeId -> IO AbstractionGraph
showNode AbstractionGraph
g NodeId
nId
  HideNode nId :: NodeId
nId -> AbstractionGraph -> NodeId -> IO AbstractionGraph
hideNode AbstractionGraph
g NodeId
nId
  AddEdge eId :: EdgeId
eId eT :: DGEdgeType
eT nIdF :: NodeId
nIdF nIdT :: NodeId
nIdT eN :: String
eN eL :: Maybe (LEdge DGLinkLab)
eL eH :: Bool
eH -> AbstractionGraph
-> EdgeId
-> DGEdgeType
-> NodeId
-> NodeId
-> String
-> Maybe (LEdge DGLinkLab)
-> Bool
-> IO AbstractionGraph
addEdge AbstractionGraph
g EdgeId
eId DGEdgeType
eT NodeId
nIdF NodeId
nIdT String
eN Maybe (LEdge DGLinkLab)
eL Bool
eH
  DelEdge eId :: EdgeId
eId -> AbstractionGraph -> EdgeId -> IO AbstractionGraph
delEdge AbstractionGraph
g EdgeId
eId
  ShowEdge eId :: EdgeId
eId -> AbstractionGraph -> EdgeId -> IO AbstractionGraph
showEdge AbstractionGraph
g EdgeId
eId
  HideEdge eId :: EdgeId
eId -> AbstractionGraph -> EdgeId -> IO AbstractionGraph
hideEdge AbstractionGraph
g EdgeId
eId
  AddCompEdge ceId :: (NodeId, NodeId, DGEdgeType, Bool)
ceId -> AbstractionGraph
-> (NodeId, NodeId, DGEdgeType, Bool) -> IO AbstractionGraph
addCompressedEdge AbstractionGraph
g (NodeId, NodeId, DGEdgeType, Bool)
ceId
  DelCompEdge ceId :: (NodeId, NodeId, DGEdgeType, Bool)
ceId -> AbstractionGraph
-> (NodeId, NodeId, DGEdgeType, Bool) -> IO AbstractionGraph
delCompressedEdge AbstractionGraph
g (NodeId, NodeId, DGEdgeType, Bool)
ceId

-- | Converts a DGraph to a list of changes
convert :: DGraph -- ^ The development graph
        -> [DGChange]  -- ^ List of changes
convert :: DGraph -> [DGChange]
convert dg :: DGraph
dg = (LNode DGNodeLab -> DGChange) -> [LNode DGNodeLab] -> [DGChange]
forall a b. (a -> b) -> [a] -> [b]
map LNode DGNodeLab -> DGChange
InsertNode (DGraph -> [LNode DGNodeLab]
labNodesDG DGraph
dg)
          [DGChange] -> [DGChange] -> [DGChange]
forall a. [a] -> [a] -> [a]
++ (LEdge DGLinkLab -> DGChange) -> [LEdge DGLinkLab] -> [DGChange]
forall a b. (a -> b) -> [a] -> [b]
map LEdge DGLinkLab -> DGChange
InsertEdge (DGraph -> [LEdge DGLinkLab]
labEdgesDG DGraph
dg)

-- * direct manipulation of uDrawGraph

-- | execute in the context of the given graph
doInGraphContext :: DVT.DaVinciCmd -- ^ uDrawGraph command
                 -> GraphInfo -- ^ The graph
                 -> IO ()
doInGraphContext :: DaVinciCmd -> GraphInfo -> IO ()
doInGraphContext cmd :: DaVinciCmd
cmd gi :: GraphInfo
gi = do
  AbstractionGraph
g <- GraphInfo -> IO AbstractionGraph
forall a. IORef a -> IO a
readIORef GraphInfo
gi
  let Graph dg :: DaVinciGraph
dg = AbstractionGraph -> OurGraph
theGraph AbstractionGraph
g
  BSem -> IO () -> IO ()
forall a b. Synchronized a => a -> IO b -> IO b
synchronize (DaVinciGraph -> BSem
pendingChangesLock DaVinciGraph
dg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DaVinciCmd -> Context -> IO ()
doInContext DaVinciCmd
cmd
    (Context -> IO ()) -> Context -> IO ()
forall a b. (a -> b) -> a -> b
$ DaVinciGraph -> Context
getDaVinciGraphContext DaVinciGraph
dg

-- | Improve the layout of a graph like calling \"Layout->Improve All\"
layoutImproveAll :: GraphInfo -- ^ The graph
                 -> IO ()
layoutImproveAll :: GraphInfo -> IO ()
layoutImproveAll = DaVinciCmd -> GraphInfo -> IO ()
doInGraphContext (MenuCmd -> DaVinciCmd
DVT.Menu (MenuCmd -> DaVinciCmd) -> MenuCmd -> DaVinciCmd
forall a b. (a -> b) -> a -> b
$ LayoutMenuCmd -> MenuCmd
DVT.Layout LayoutMenuCmd
DVT.ImproveAll)

-- | Display a message in a uDrawGraph window controlled by AbstractGraphView
showTemporaryMessage :: GraphInfo -- ^ The graph
                     -> String -- ^ message to be displayed
                     -> IO ()
showTemporaryMessage :: GraphInfo -> String -> IO ()
showTemporaryMessage gi :: GraphInfo
gi message :: String
message =
  DaVinciCmd -> GraphInfo -> IO ()
doInGraphContext (WindowCmd -> DaVinciCmd
DVT.Window (WindowCmd -> DaVinciCmd) -> WindowCmd -> DaVinciCmd
forall a b. (a -> b) -> a -> b
$ String -> WindowCmd
DVT.ShowMessage String
message) GraphInfo
gi

{- | Deactivate the input of all uDrawGraph windows;
Warning: every deactivate event must be paired an activate event -}
deactivateGraphWindow :: GraphInfo -- ^ The graph
                      -> IO ()
deactivateGraphWindow :: GraphInfo -> IO ()
deactivateGraphWindow = DaVinciCmd -> GraphInfo -> IO ()
doInGraphContext (WindowCmd -> DaVinciCmd
DVT.Window WindowCmd
DVT.Deactivate)

-- | Activate the input of a uDrawGraph display
activateGraphWindow :: GraphInfo -- ^ The graph
                    -> IO ()
activateGraphWindow :: GraphInfo -> IO ()
activateGraphWindow = DaVinciCmd -> GraphInfo -> IO ()
doInGraphContext (WindowCmd -> DaVinciCmd
DVT.Window WindowCmd
DVT.Activate)

-- | Closes the Window
closeGraphWindow :: GraphInfo -- ^ The graph
                 -> IO ()
closeGraphWindow :: GraphInfo -> IO ()
closeGraphWindow gi :: GraphInfo
gi = GraphInfo -> IO AbstractionGraph
forall a. IORef a -> IO a
readIORef GraphInfo
gi IO AbstractionGraph -> (AbstractionGraph -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= OurGraph -> IO ()
destroyGraph (OurGraph -> IO ())
-> (AbstractionGraph -> OurGraph) -> AbstractionGraph -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractionGraph -> OurGraph
theGraph

-- | destroy graph
destroyGraph :: OurGraph  -- ^ uDrawGraph graph
             -> IO ()
destroyGraph :: OurGraph -> IO ()
destroyGraph (Graph dg :: DaVinciGraph
dg) = Context -> IO ()
forall o. Destroyable o => o -> IO ()
destroy (Context -> IO ()) -> Context -> IO ()
forall a b. (a -> b) -> a -> b
$ DaVinciGraph -> Context
getDaVinciGraphContext DaVinciGraph
dg