{- |
Module      :  ./Taxonomy/MMiSSOntologyGraph.hs
Copyright   :  (c) Uni Bremen 2004-2006
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  luecke@informatik.uni-bremen.de
Stability   :  provisional
Portability :  non-portable(uni)

displays an ontology graph
-}

module Taxonomy.MMiSSOntologyGraph (displayClassGraph) where

import Data.List
import Control.Monad
import Data.IORef

import GUI.UDGUtils
import qualified GUI.HTkUtils as S
import Taxonomy.MMiSSOntology

import qualified Data.Map as Map
import Common.Lib.Graph
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.Query.DFS
import qualified Data.Foldable

import qualified Taxonomy.AbstractGraphView as A

displayClassGraph :: MMiSSOntology -> Maybe String -> IO A.OurGraph
displayClassGraph :: MMiSSOntology -> Maybe String -> IO OurGraph
displayClassGraph onto :: MMiSSOntology
onto startClass :: Maybe String
startClass = do
    [Config HTk] -> IO HTk
S.initHTk []
    GraphInfo
ginfo <- IO GraphInfo
A.initgraphs
    ClassGraph
classGraph <- case Maybe String
startClass of
        Nothing -> ClassGraph -> IO ClassGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassGraph -> IO ClassGraph) -> ClassGraph -> IO ClassGraph
forall a b. (a -> b) -> a -> b
$ ClassGraph -> ClassGraph
getPureClassGraph (ClassGraph -> ClassGraph) -> ClassGraph -> ClassGraph
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto
        Just className :: String
className -> case String
-> ClassGraph -> [Context (String, String, OntoObjectType) String]
gselName String
className (ClassGraph -> [Context (String, String, OntoObjectType) String])
-> ClassGraph -> [Context (String, String, OntoObjectType) String]
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto of
            [] -> ClassGraph -> IO ClassGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassGraph -> IO ClassGraph) -> ClassGraph -> IO ClassGraph
forall a b. (a -> b) -> a -> b
$ ClassGraph -> ClassGraph
getPureClassGraph (ClassGraph -> ClassGraph) -> ClassGraph -> ClassGraph
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto
            (_, v :: Node
v, l :: (String, String, OntoObjectType)
l, _) : _ -> ClassGraph -> IO ClassGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassGraph -> IO ClassGraph) -> ClassGraph -> IO ClassGraph
forall a b. (a -> b) -> a -> b
$ ([], Node
v, (String, String, OntoObjectType)
l, []) Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& ClassGraph
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty
    A.Result gid :: Node
gid _ <-
       String
-> Maybe (IO ())
-> Maybe (IO ())
-> Maybe (IO ())
-> [GlobalMenu]
-> [(String, DaVinciNodeTypeParms (String, Node, Node))]
-> [(String, DaVinciArcTypeParms EdgeValue)]
-> CompTable
-> GraphInfo
-> IO Result
A.makegraph (MMiSSOntology -> String
getOntologyName MMiSSOntology
onto) Maybe (IO ())
forall a. Maybe a
Nothing Maybe (IO ())
forall a. Maybe a
Nothing Maybe (IO ())
forall a. Maybe a
Nothing
           [MenuPrim (Maybe String) (IO ()) -> GlobalMenu
GlobalMenu (String -> IO () -> MenuPrim (Maybe String) (IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button "Button2" (String -> IO ()
putStrLn "Button2 was pressed"))]
           (((OntoObjectType, String)
 -> (String, DaVinciNodeTypeParms (String, Node, Node)))
-> [(OntoObjectType, String)]
-> [(String, DaVinciNodeTypeParms (String, Node, Node))]
forall a b. (a -> b) -> [a] -> [b]
map ( \ ( nam :: OntoObjectType
nam, col :: String
col) -> (OntoObjectType -> String
getTypeLabel OntoObjectType
nam, Shape (String, Node, Node)
forall value. Shape value
Box Shape (String, Node, Node)
-> DaVinciNodeTypeParms (String, Node, Node)
-> DaVinciNodeTypeParms (String, Node, Node)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$ String -> Color (String, Node, Node)
forall value. String -> Color value
Color String
col Color (String, Node, Node)
-> DaVinciNodeTypeParms (String, Node, Node)
-> DaVinciNodeTypeParms (String, Node, Node)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                 MMiSSOntology -> GraphInfo -> LocalMenu (String, Node, Node)
createLocalMenu MMiSSOntology
onto GraphInfo
ginfo
                 LocalMenu (String, Node, Node)
-> DaVinciNodeTypeParms (String, Node, Node)
-> DaVinciNodeTypeParms (String, Node, Node)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$ ((String, Node, Node) -> IO String)
-> ValueTitle (String, Node, Node)
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, Node, Node)
-> DaVinciNodeTypeParms (String, Node, Node)
-> DaVinciNodeTypeParms (String, Node, Node)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                 DaVinciNodeTypeParms (String, Node, Node)
forall (nodeTypeParms :: * -> *) value.
(NodeTypeParms nodeTypeParms, Typeable value) =>
nodeTypeParms value
emptyNodeTypeParms :: DaVinciNodeTypeParms (String, Int, Int)
                 )) [ (OntoObjectType
OntoClass, "#e0eeee")
                    , (OntoObjectType
OntoPredicate, "#ffd300")
                    , (OntoObjectType
OntoObject, "#ffffA0") ])
           (ClassGraph -> [(String, DaVinciArcTypeParms EdgeValue)]
createEdgeTypes (ClassGraph -> [(String, DaVinciArcTypeParms EdgeValue)])
-> ClassGraph -> [(String, DaVinciArcTypeParms EdgeValue)]
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto)
           []
           GraphInfo
ginfo
    ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph ClassGraph
classGraph Node
gid GraphInfo
ginfo
    Node -> GraphInfo -> MMiSSOntology -> IO ()
setEmptyRelationSpecs Node
gid GraphInfo
ginfo MMiSSOntology
onto
    A.Result gid' :: Node
gid' _ <- Node -> GraphInfo -> IO Result
A.redisplay Node
gid GraphInfo
ginfo
    Node -> GraphInfo -> IO OurGraph
A.getGraphid Node
gid' GraphInfo
ginfo

setEmptyRelationSpecs :: A.Descr -> A.GraphInfo -> MMiSSOntology -> IO ()
setEmptyRelationSpecs :: Node -> GraphInfo -> MMiSSOntology -> IO ()
setEmptyRelationSpecs gid :: Node
gid gv :: GraphInfo
gv onto :: MMiSSOntology
onto = do
    (gs :: [(Node, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
    case Node -> [(Node, AbstractionGraph)] -> Maybe AbstractionGraph
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Node
gid [(Node, AbstractionGraph)]
gs of
      Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      _ -> do
          Node -> [RelationViewSpec] -> GraphInfo -> IO Result
A.writeRelViewSpecs Node
gid
               ((String -> RelationViewSpec) -> [String] -> [RelationViewSpec]
forall a b. (a -> b) -> [a] -> [b]
map ( \ relname :: String
relname -> String -> Bool -> Bool -> RelationViewSpec
A.RelViewSpec String
relname Bool
False Bool
False)
               ([String] -> [RelationViewSpec]) -> [String] -> [RelationViewSpec]
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> [String]
getRelationNames MMiSSOntology
onto) GraphInfo
gv
          () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

updateDaVinciGraph :: Gr (String, String, OntoObjectType) String -> A.Descr
                   -> A.GraphInfo -> IO ()
updateDaVinciGraph :: ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph nGraph :: ClassGraph
nGraph gid :: Node
gid gv :: GraphInfo
gv = do
    (gs :: [(Node, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
    case Node -> [(Node, AbstractionGraph)] -> Maybe AbstractionGraph
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Node
gid [(Node, AbstractionGraph)]
gs of
      Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just g :: AbstractionGraph
g -> do
           let oldGraph :: ClassGraph
oldGraph = AbstractionGraph -> ClassGraph
A.ontoGraph AbstractionGraph
g
               nMap :: NodeMapping
nMap = AbstractionGraph -> NodeMapping
A.nodeMap AbstractionGraph
g
           NodeMapping
nodeMap1 <- (NodeMapping
 -> LNode (String, String, OntoObjectType) -> IO NodeMapping)
-> NodeMapping
-> [LNode (String, String, OntoObjectType)]
-> IO NodeMapping
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Node
-> GraphInfo
-> ClassGraph
-> NodeMapping
-> LNode (String, String, OntoObjectType)
-> IO NodeMapping
createNode Node
gid GraphInfo
gv ClassGraph
oldGraph) NodeMapping
nMap
               ([LNode (String, String, OntoObjectType)] -> IO NodeMapping)
-> [LNode (String, String, OntoObjectType)] -> IO NodeMapping
forall a b. (a -> b) -> a -> b
$ ClassGraph -> [LNode (String, String, OntoObjectType)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes ClassGraph
nGraph
           NodeMapping
nodeMap2 <- (NodeMapping -> LEdge String -> IO NodeMapping)
-> NodeMapping -> [LEdge String] -> IO NodeMapping
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Node -> GraphInfo -> NodeMapping -> LEdge String -> IO NodeMapping
createLink Node
gid GraphInfo
gv) NodeMapping
nodeMap1 ([LEdge String] -> IO NodeMapping)
-> [LEdge String] -> IO NodeMapping
forall a b. (a -> b) -> a -> b
$ ClassGraph -> [LEdge String]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges ClassGraph
nGraph
           A.Result gid' :: Node
gid' err :: Maybe String
err <- Node -> ClassGraph -> GraphInfo -> IO Result
A.writeOntoGraph Node
gid ClassGraph
nGraph GraphInfo
gv
           Node -> NodeMapping -> GraphInfo -> IO Result
A.writeNodeMap Node
gid' NodeMapping
nodeMap2 GraphInfo
gv
           Maybe String -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Data.Foldable.forM_ Maybe String
err String -> IO ()
putStr

getTypeLabel :: OntoObjectType -> String
getTypeLabel :: OntoObjectType -> String
getTypeLabel t :: OntoObjectType
t = case OntoObjectType
t of
    OntoClass -> "class"
    OntoObject -> "object"
    OntoPredicate -> "predicate"

createNode :: Int -> A.GraphInfo -> ClassGraph -> A.NodeMapping
           -> LNode (String, String, OntoObjectType) -> IO A.NodeMapping
createNode :: Node
-> GraphInfo
-> ClassGraph
-> NodeMapping
-> LNode (String, String, OntoObjectType)
-> IO NodeMapping
createNode gid :: Node
gid ginfo :: GraphInfo
ginfo _ nMap :: NodeMapping
nMap (nodeID :: Node
nodeID, (name :: String
name, _, objectType :: OntoObjectType
objectType)) =
            case Node -> NodeMapping -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Node
nodeID NodeMapping
nMap of
              Just _ -> NodeMapping -> IO NodeMapping
forall (m :: * -> *) a. Monad m => a -> m a
return NodeMapping
nMap
              Nothing ->
                do A.Result nid :: Node
nid err :: Maybe String
err <-
                       Node -> String -> String -> GraphInfo -> IO Result
A.addnode Node
gid (OntoObjectType -> String
getTypeLabel OntoObjectType
objectType) String
name GraphInfo
ginfo
                   case Maybe String
err of
                     Nothing -> NodeMapping -> IO NodeMapping
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> Node -> NodeMapping -> NodeMapping
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Node
nodeID Node
nid NodeMapping
nMap)
                     Just str :: String
str -> do
                         String -> IO ()
putStr String
str
                         NodeMapping -> IO NodeMapping
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeMapping -> IO NodeMapping) -> NodeMapping -> IO NodeMapping
forall a b. (a -> b) -> a -> b
$ Node -> Node -> NodeMapping -> NodeMapping
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Node
nodeID Node
nid NodeMapping
nMap

createLink :: A.Descr -> A.GraphInfo -> A.NodeMapping -> LEdge String
           -> IO A.NodeMapping
createLink :: Node -> GraphInfo -> NodeMapping -> LEdge String -> IO NodeMapping
createLink gid :: Node
gid ginfo :: GraphInfo
ginfo nMap :: NodeMapping
nMap (node1 :: Node
node1, node2 :: Node
node2, edgeLabel_ :: String
edgeLabel_) = do
    Node
dNodeID_1 <- case Node -> NodeMapping -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Node
node1 NodeMapping
nMap of
                   Nothing -> Node -> IO Node
forall (m :: * -> *) a. Monad m => a -> m a
return (-1)
                   Just n :: Node
n -> Node -> IO Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
n
    Node
dNodeID_2 <- case Node -> NodeMapping -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Node
node2 NodeMapping
nMap of
                   Nothing -> Node -> IO Node
forall (m :: * -> *) a. Monad m => a -> m a
return (-1)
                   Just n :: Node
n -> Node -> IO Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
n
    if Node
dNodeID_1 Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
== -1 Bool -> Bool -> Bool
|| Node
dNodeID_2 Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
== -1 then NodeMapping -> IO NodeMapping
forall (m :: * -> *) a. Monad m => a -> m a
return NodeMapping
nMap else do
      A.Result _ err :: Maybe String
err <-
        if String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
edgeLabel_ ["isa", "instanceOf", "livesIn", "proves"]
        then Node
-> String
-> String
-> Maybe (LEdge DGLinkLab)
-> Node
-> Node
-> GraphInfo
-> IO Result
A.addlink Node
gid String
edgeLabel_ String
edgeLabel_ Maybe (LEdge DGLinkLab)
forall a. Maybe a
Nothing
             Node
dNodeID_2 Node
dNodeID_1 GraphInfo
ginfo
        else Node
-> String
-> String
-> Maybe (LEdge DGLinkLab)
-> Node
-> Node
-> GraphInfo
-> IO Result
A.addlink Node
gid String
edgeLabel_ String
edgeLabel_ Maybe (LEdge DGLinkLab)
forall a. Maybe a
Nothing
             Node
dNodeID_1 Node
dNodeID_2 GraphInfo
ginfo
      Maybe String -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Data.Foldable.forM_ Maybe String
err String -> IO ()
putStr
      NodeMapping -> IO NodeMapping
forall (m :: * -> *) a. Monad m => a -> m a
return NodeMapping
nMap

showRelationsForVisible :: MMiSSOntology -> A.GraphInfo -> (String, Int, Int)
                        -> IO ()
showRelationsForVisible :: MMiSSOntology -> GraphInfo -> (String, Node, Node) -> IO ()
showRelationsForVisible onto :: MMiSSOntology
onto gv :: GraphInfo
gv (_, _, gid :: Node
gid) =
  do (gs :: [(Node, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
     case Node -> [(Node, AbstractionGraph)] -> Maybe AbstractionGraph
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Node
gid [(Node, AbstractionGraph)]
gs of
       Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just g :: AbstractionGraph
g ->
         do let oldGraph :: ClassGraph
oldGraph = AbstractionGraph -> ClassGraph
A.ontoGraph AbstractionGraph
g
                nodesInOldGraph :: [Node]
nodesInOldGraph = (LNode (String, String, OntoObjectType) -> Node)
-> [LNode (String, String, OntoObjectType)] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map LNode (String, String, OntoObjectType) -> Node
forall a b. (a, b) -> a
fst ([LNode (String, String, OntoObjectType)] -> [Node])
-> [LNode (String, String, OntoObjectType)] -> [Node]
forall a b. (a -> b) -> a -> b
$ ClassGraph -> [LNode (String, String, OntoObjectType)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes ClassGraph
oldGraph
                newGr :: ClassGraph
newGr = (Node -> Bool) -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
(Node -> Bool) -> gr a b -> gr a b
restrict (Node -> [Node] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Node]
nodesInOldGraph) (ClassGraph -> ClassGraph) -> ClassGraph -> ClassGraph
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto
            Node -> GraphInfo -> IO Result
purgeGraph Node
gid GraphInfo
gv
            ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph ClassGraph
newGr Node
gid GraphInfo
gv
            Node -> GraphInfo -> IO Result
A.redisplay Node
gid GraphInfo
gv
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

showObjectsForVisible :: MMiSSOntology -> A.GraphInfo -> (String, Int, Int)
                      -> IO ()
showObjectsForVisible :: MMiSSOntology -> GraphInfo -> (String, Node, Node) -> IO ()
showObjectsForVisible onto :: MMiSSOntology
onto gv :: GraphInfo
gv (_, _, gid :: Node
gid) =
  do (gs :: [(Node, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
     case Node -> [(Node, AbstractionGraph)] -> Maybe AbstractionGraph
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Node
gid [(Node, AbstractionGraph)]
gs of
       Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just g :: AbstractionGraph
g ->
         do let oldGraph :: ClassGraph
oldGraph = AbstractionGraph -> ClassGraph
A.ontoGraph AbstractionGraph
g
                classesInOldGraph :: [String]
classesInOldGraph =
                    (Context (String, String, OntoObjectType) String -> String)
-> [Context (String, String, OntoObjectType) String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ( \ (_, _, (className :: String
className, _, _), _) -> String
className)
                    ([Context (String, String, OntoObjectType) String] -> [String])
-> [Context (String, String, OntoObjectType) String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Context (String, String, OntoObjectType) String -> Bool)
-> [Context (String, String, OntoObjectType) String]
-> [Context (String, String, OntoObjectType) String]
forall a. (a -> Bool) -> [a] -> [a]
filter ( \ (_, _, (_, _, objectType :: OntoObjectType
objectType), _)
                                   -> OntoObjectType
objectType OntoObjectType -> OntoObjectType -> Bool
forall a. Eq a => a -> a -> Bool
== OntoObjectType
OntoClass)
                    ([Context (String, String, OntoObjectType) String]
 -> [Context (String, String, OntoObjectType) String])
-> [Context (String, String, OntoObjectType) String]
-> [Context (String, String, OntoObjectType) String]
forall a b. (a -> b) -> a -> b
$ (Node -> Context (String, String, OntoObjectType) String)
-> [Node] -> [Context (String, String, OntoObjectType) String]
forall a b. (a -> b) -> [a] -> [b]
map (ClassGraph
-> Node -> Context (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Context a b
context ClassGraph
oldGraph) ([Node] -> [Context (String, String, OntoObjectType) String])
-> [Node] -> [Context (String, String, OntoObjectType) String]
forall a b. (a -> b) -> a -> b
$ ClassGraph -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
nodes ClassGraph
oldGraph

                findObjectsOfClass :: t a -> (a, (a, a, c)) -> Bool
findObjectsOfClass classList :: t a
classList (_, (_, className :: a
className, _)) =
                    a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
className t a
classList
                objectList :: [Node]
objectList =
                    (LNode (String, String, OntoObjectType) -> Node)
-> [LNode (String, String, OntoObjectType)] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map LNode (String, String, OntoObjectType) -> Node
forall a b. (a, b) -> a
fst ([LNode (String, String, OntoObjectType)] -> [Node])
-> [LNode (String, String, OntoObjectType)] -> [Node]
forall a b. (a -> b) -> a -> b
$ (LNode (String, String, OntoObjectType) -> Bool)
-> [LNode (String, String, OntoObjectType)]
-> [LNode (String, String, OntoObjectType)]
forall a. (a -> Bool) -> [a] -> [a]
filter ([String] -> LNode (String, String, OntoObjectType) -> Bool
forall (t :: * -> *) a a a c.
(Foldable t, Eq a) =>
t a -> (a, (a, a, c)) -> Bool
findObjectsOfClass [String]
classesInOldGraph)
                    ([LNode (String, String, OntoObjectType)]
 -> [LNode (String, String, OntoObjectType)])
-> [LNode (String, String, OntoObjectType)]
-> [LNode (String, String, OntoObjectType)]
forall a b. (a -> b) -> a -> b
$ [OntoObjectType]
-> ClassGraph -> [LNode (String, String, OntoObjectType)]
getTypedNodes [OntoObjectType
OntoObject] (ClassGraph -> [LNode (String, String, OntoObjectType)])
-> ClassGraph -> [LNode (String, String, OntoObjectType)]
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto
                objectGr :: ClassGraph
objectGr = (Node -> Bool) -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
(Node -> Bool) -> gr a b -> gr a b
restrict (Node -> [Node] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Node]
objectList) (MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto)
            ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph (ClassGraph -> ClassGraph -> ClassGraph -> ClassGraph
makeObjectGraph ClassGraph
oldGraph
                                (ClassGraph -> ClassGraph
getPureClassGraph (MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto))
                                ClassGraph
objectGr) Node
gid GraphInfo
gv
            Node -> GraphInfo -> IO Result
A.redisplay Node
gid GraphInfo
gv
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

showWholeObjectGraph :: MMiSSOntology -> A.GraphInfo -> (String, Int, Int)
                     -> IO ()
showWholeObjectGraph :: MMiSSOntology -> GraphInfo -> (String, Node, Node) -> IO ()
showWholeObjectGraph onto :: MMiSSOntology
onto gv :: GraphInfo
gv (_, _, gid :: Node
gid) =
  do ([(Node, AbstractionGraph)], Node)
oldGv <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
     A.Result _ err :: Maybe String
err <- Node -> GraphInfo -> IO Result
purgeGraph Node
gid GraphInfo
gv
     let objectList :: [Node]
objectList = (LNode (String, String, OntoObjectType) -> Node)
-> [LNode (String, String, OntoObjectType)] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map LNode (String, String, OntoObjectType) -> Node
forall a b. (a, b) -> a
fst ([LNode (String, String, OntoObjectType)] -> [Node])
-> [LNode (String, String, OntoObjectType)] -> [Node]
forall a b. (a -> b) -> a -> b
$ [OntoObjectType]
-> ClassGraph -> [LNode (String, String, OntoObjectType)]
getTypedNodes [OntoObjectType
OntoObject] (ClassGraph -> [LNode (String, String, OntoObjectType)])
-> ClassGraph -> [LNode (String, String, OntoObjectType)]
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto
         objectGraph :: ClassGraph
objectGraph = (Node -> Bool) -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
(Node -> Bool) -> gr a b -> gr a b
restrict (Node -> [Node] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Node]
objectList) (ClassGraph -> ClassGraph) -> ClassGraph -> ClassGraph
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto
     ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph (ClassGraph -> ClassGraph -> ClassGraph -> ClassGraph
makeObjectGraph ClassGraph
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty
                         (MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto) ClassGraph
objectGraph) Node
gid GraphInfo
gv
     case Maybe String
err of
       Just _ -> GraphInfo -> ([(Node, AbstractionGraph)], Node) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gv ([(Node, AbstractionGraph)], Node)
oldGv
       Nothing -> do
           Node -> GraphInfo -> IO Result
A.redisplay Node
gid GraphInfo
gv
           () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

makeObjectGraph :: ClassGraph -> ClassGraph -> ClassGraph -> ClassGraph
makeObjectGraph :: ClassGraph -> ClassGraph -> ClassGraph -> ClassGraph
makeObjectGraph oldGr :: ClassGraph
oldGr classGr :: ClassGraph
classGr objectGr :: ClassGraph
objectGr =
  let newGr :: ClassGraph
newGr = [LNode (String, String, OntoObjectType)]
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
[LNode a] -> gr a b -> gr a b
insNodes (ClassGraph -> [LNode (String, String, OntoObjectType)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes ClassGraph
objectGr) ClassGraph
oldGr
      newGr2 :: ClassGraph
newGr2 = (ClassGraph -> LEdge String -> ClassGraph)
-> ClassGraph -> [LEdge String] -> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ClassGraph -> LEdge String -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
gr a b -> (Node, Node, b) -> gr a b
insEdgeSecurely ClassGraph
newGr (ClassGraph -> [LEdge String]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges ClassGraph
objectGr)
      newGr3 :: ClassGraph
newGr3 = (ClassGraph
 -> LNode (String, String, OntoObjectType) -> ClassGraph)
-> ClassGraph
-> [LNode (String, String, OntoObjectType)]
-> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ClassGraph -> LNode (String, String, OntoObjectType) -> ClassGraph
forall a c. ClassGraph -> (a, (String, String, c)) -> ClassGraph
insInstanceOfEdge ClassGraph
newGr2 (ClassGraph -> [LNode (String, String, OntoObjectType)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes ClassGraph
objectGr)
  in ClassGraph
newGr3
  where
    insEdgeSecurely :: gr a b -> (Node, Node, b) -> gr a b
insEdgeSecurely gr :: gr a b
gr (node1 :: Node
node1, node2 :: Node
node2, label :: b
label) = case Node -> gr a b -> Decomp gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
node1 gr a b
gr of
        (Nothing, _) -> gr a b
gr
        _ -> case Node -> gr a b -> Decomp gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
node2 gr a b
gr of
            (Nothing, _) -> gr a b
gr
            _ -> (Node, Node, b) -> gr a b -> gr a b
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
LEdge b -> gr a b -> gr a b
insEdge (Node
node1, Node
node2, b
label) gr a b
gr
    insInstanceOfEdge :: ClassGraph -> (a, (String, String, c)) -> ClassGraph
insInstanceOfEdge gr :: ClassGraph
gr (_, (objectName :: String
objectName, className :: String
className, _)) =
      case ClassGraph -> String -> Maybe Node
findLNode ClassGraph
gr String
className of
        Nothing -> case ClassGraph -> String -> Maybe Node
findLNode ClassGraph
classGr String
className of
          Nothing -> ClassGraph
gr
          Just classNodeID :: Node
classNodeID -> ClassGraph -> Node -> String -> ClassGraph
insInstanceOfEdge1
              (LNode (String, String, OntoObjectType) -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
insNode (Node
classNodeID, (String
className, "", OntoObjectType
OntoClass)) ClassGraph
gr)
                                            Node
classNodeID String
objectName
        Just classNodeID :: Node
classNodeID -> ClassGraph -> Node -> String -> ClassGraph
insInstanceOfEdge1 ClassGraph
gr Node
classNodeID String
objectName
    insInstanceOfEdge1 :: ClassGraph -> Node -> String -> ClassGraph
insInstanceOfEdge1 gr :: ClassGraph
gr classNodeID :: Node
classNodeID objectName :: String
objectName =
      case ClassGraph -> String -> Maybe Node
findLNode ClassGraph
gr String
objectName of
        Nothing -> ClassGraph
gr
        Just objectNodeID :: Node
objectNodeID -> LEdge String -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
LEdge b -> gr a b -> gr a b
insEdge
             (Node
objectNodeID, Node
classNodeID, "instanceOf") ClassGraph
gr

showWholeClassGraph :: MMiSSOntology -> A.GraphInfo -> (String, Int, Int)
                    -> IO ()
showWholeClassGraph :: MMiSSOntology -> GraphInfo -> (String, Node, Node) -> IO ()
showWholeClassGraph onto :: MMiSSOntology
onto gv :: GraphInfo
gv (_, _, gid :: Node
gid) =
  do ([(Node, AbstractionGraph)], Node)
oldGv <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
     A.Result _ err :: Maybe String
err <- Node -> GraphInfo -> IO Result
purgeGraph Node
gid GraphInfo
gv
     ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph (ClassGraph -> ClassGraph
getPureClassGraph (MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto)) Node
gid GraphInfo
gv
     case Maybe String
err of
       Just _ -> GraphInfo -> ([(Node, AbstractionGraph)], Node) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gv ([(Node, AbstractionGraph)], Node)
oldGv
       Nothing -> do
         Node -> GraphInfo -> IO Result
A.redisplay Node
gid GraphInfo
gv
         () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

showRelationsToNeighbors :: MMiSSOntology -> A.GraphInfo -> [String]
                         -> (String, Int, Int) -> IO ()
showRelationsToNeighbors :: MMiSSOntology
-> GraphInfo -> [String] -> (String, Node, Node) -> IO ()
showRelationsToNeighbors onto :: MMiSSOntology
onto gv :: GraphInfo
gv rels :: [String]
rels (name :: String
name, _, gid :: Node
gid) =
  do ([(Node, AbstractionGraph)], Node)
oldGv <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
     ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph (ClassGraph -> String -> [String] -> ClassGraph
reduceToNeighbors (MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto)
                         String
name [String]
rels) Node
gid GraphInfo
gv
     GraphInfo -> ([(Node, AbstractionGraph)], Node) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gv ([(Node, AbstractionGraph)], Node)
oldGv

reduceToNeighbors :: ClassGraph -> String -> [String] -> ClassGraph
reduceToNeighbors :: ClassGraph -> String -> [String] -> ClassGraph
reduceToNeighbors g :: ClassGraph
g name :: String
name forbiddenRels :: [String]
forbiddenRels =
  case ClassGraph -> String -> Maybe Node
findLNode ClassGraph
g String
name of
    Nothing -> ClassGraph
g
    Just node :: Node
node ->
      let (p :: Adj String
p, v :: Node
v, l :: (String, String, OntoObjectType)
l, s :: Adj String
s) = ClassGraph
-> Node -> Context (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Context a b
context ClassGraph
g Node
node
          noForbidden :: (String, b) -> Bool
noForbidden = Bool -> Bool
not (Bool -> Bool) -> ((String, b) -> Bool) -> (String, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
forbiddenRels) (String -> Bool) -> ((String, b) -> String) -> (String, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, b) -> String
forall a b. (a, b) -> a
fst
          p' :: Adj String
p' = ((String, Node) -> Bool) -> Adj String -> Adj String
forall a. (a -> Bool) -> [a] -> [a]
filter (String, Node) -> Bool
forall b. (String, b) -> Bool
noForbidden Adj String
p
          s' :: Adj String
s' = ((String, Node) -> Bool) -> Adj String -> Adj String
forall a. (a -> Bool) -> [a] -> [a]
filter (String, Node) -> Bool
forall b. (String, b) -> Bool
noForbidden Adj String
s
          ns :: [Node]
ns = ((String, Node) -> Node) -> Adj String -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (String, Node) -> Node
forall a b. (a, b) -> b
snd Adj String
p' [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ ((String, Node) -> Node) -> Adj String -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (String, Node) -> Node
forall a b. (a, b) -> b
snd Adj String
s'
          myInsNode :: gr a b -> gr a b -> Node -> gr a b
myInsNode gr :: gr a b
gr newGr :: gr a b
newGr nodeID :: Node
nodeID = case Node -> gr a b -> Decomp gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
nodeID gr a b
newGr of
              (Nothing, _) ->
                  ([], Node
nodeID, Context a b -> a
forall a b. Context a b -> a
lab' (gr a b -> Node -> Context a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Context a b
context gr a b
gr Node
nodeID), []) Context a b -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& gr a b
newGr
              _ -> gr a b
newGr
      in (Adj String
p', Node
v, (String, String, OntoObjectType)
l, Adj String
s') Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& (ClassGraph -> Node -> ClassGraph)
-> ClassGraph -> [Node] -> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (ClassGraph -> ClassGraph -> Node -> ClassGraph
forall (gr :: * -> * -> *) (gr :: * -> * -> *) a b b.
(DynGraph gr, Graph gr) =>
gr a b -> gr a b -> Node -> gr a b
myInsNode ClassGraph
g) ClassGraph
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty [Node]
ns

showAllRelations :: MMiSSOntology -> A.GraphInfo -> Bool -> [String]
                 -> (String, Int, Int) -> IO ()
showAllRelations :: MMiSSOntology
-> GraphInfo -> Bool -> [String] -> (String, Node, Node) -> IO ()
showAllRelations onto :: MMiSSOntology
onto gv :: GraphInfo
gv withIncoming :: Bool
withIncoming rels :: [String]
rels (name :: String
name, _, gid :: Node
gid) =
  do ([(Node, AbstractionGraph)], Node)
oldGv <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
     let newGr :: ClassGraph
newGr = ClassGraph
-> ClassGraph -> Bool -> [String] -> String -> ClassGraph
reduceToRelations (MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto)
                  ClassGraph
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty Bool
withIncoming [String]
rels String
name
     ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph ClassGraph
newGr Node
gid GraphInfo
gv
     GraphInfo -> ([(Node, AbstractionGraph)], Node) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef GraphInfo
gv ([(Node, AbstractionGraph)], Node)
oldGv

reduceToRelations :: ClassGraph -> ClassGraph -> Bool -> [String] -> String
                  -> ClassGraph
reduceToRelations :: ClassGraph
-> ClassGraph -> Bool -> [String] -> String -> ClassGraph
reduceToRelations wholeGraph :: ClassGraph
wholeGraph g :: ClassGraph
g withIncoming :: Bool
withIncoming forbiddenRels :: [String]
forbiddenRels name :: String
name =
  let g1 :: ClassGraph
g1 = (String -> Bool) -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
(b -> Bool) -> gr a b -> gr a b
elfilter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
forbiddenRels)) ClassGraph
wholeGraph
  in case ClassGraph -> String -> Maybe Node
findLNode ClassGraph
g1 String
name of
       Nothing -> ClassGraph
g
       Just selectedNode :: Node
selectedNode ->
          let nodeList :: [Node]
nodeList = if Bool
withIncoming
                           then [Node] -> ClassGraph -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Node] -> gr a b -> [Node]
udfs [Node
selectedNode] ClassGraph
g1
                           else [Node] -> ClassGraph -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Node] -> gr a b -> [Node]
dfs [Node
selectedNode] ClassGraph
g1
              toDelete :: [Node]
toDelete = ClassGraph -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
nodes ClassGraph
g1 [Node] -> [Node] -> [Node]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Node]
nodeList
              g1' :: ClassGraph
g1' = [Node] -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Node] -> gr a b -> gr a b
delNodes [Node]
toDelete ClassGraph
g1
              g2 :: ClassGraph
g2 = ClassGraph -> ClassGraph -> ClassGraph
mergeGraphs ClassGraph
g1' ClassGraph
g
              newNodesList :: [Node]
newNodesList = [Node]
nodeList [Node] -> [Node] -> [Node]
forall a. Eq a => [a] -> [a] -> [a]
\\ ClassGraph -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
nodes ClassGraph
g
          in if [Node] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node]
newNodesList
               then ClassGraph
g2
               else (ClassGraph -> Node -> ClassGraph)
-> ClassGraph -> [Node] -> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (ClassGraph -> Bool -> [String] -> ClassGraph -> Node -> ClassGraph
followRelationOverSubClasses ClassGraph
wholeGraph
                           Bool
withIncoming [String]
forbiddenRels) ClassGraph
g2 [Node]
newNodesList

followRelationOverSubClasses :: ClassGraph -> Bool -> [String] -> ClassGraph
                             -> Node -> ClassGraph
followRelationOverSubClasses :: ClassGraph -> Bool -> [String] -> ClassGraph -> Node -> ClassGraph
followRelationOverSubClasses wholeGraph :: ClassGraph
wholeGraph withIncoming :: Bool
withIncoming forbiddenRels :: [String]
forbiddenRels g :: ClassGraph
g node :: Node
node =
 let g1 :: ClassGraph
g1 = (String -> Bool) -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
(b -> Bool) -> gr a b -> gr a b
elfilter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "isa") ClassGraph
wholeGraph
 in case Node
-> ClassGraph -> Decomp Gr (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
node ClassGraph
g1 of
      (Nothing, _) -> ClassGraph
g
      _ ->
         let subclasses :: [Node]
subclasses = [Node] -> ClassGraph -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Node] -> gr a b -> [Node]
rdfs [Node
node] ClassGraph
g1
             newNs :: [Node]
newNs = [Node]
subclasses [Node] -> [Node] -> [Node]
forall a. Eq a => [a] -> [a] -> [a]
\\ ClassGraph -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
nodes ClassGraph
g
         in if [Node] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node]
newNs
              then ClassGraph
g
              else
                let
                  toDelete :: [Node]
toDelete = ClassGraph -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
nodes ClassGraph
g1 [Node] -> [Node] -> [Node]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Node]
subclasses
                  g2 :: ClassGraph
g2 = ClassGraph -> ClassGraph -> ClassGraph
mergeGraphs ([Node] -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Node] -> gr a b -> gr a b
delNodes [Node]
toDelete ClassGraph
g1) ClassGraph
g
                in (ClassGraph -> Node -> ClassGraph)
-> ClassGraph -> [Node] -> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ClassGraph -> Node -> ClassGraph
transClosureForNode ClassGraph
g2 [Node]
newNs
 where
   transClosureForNode :: ClassGraph -> Node -> ClassGraph
transClosureForNode g' :: ClassGraph
g' n :: Node
n =
     let (name :: String
name, _, _) = Context (String, String, OntoObjectType) String
-> (String, String, OntoObjectType)
forall a b. Context a b -> a
lab' (Context (String, String, OntoObjectType) String
 -> (String, String, OntoObjectType))
-> Context (String, String, OntoObjectType) String
-> (String, String, OntoObjectType)
forall a b. (a -> b) -> a -> b
$ ClassGraph
-> Node -> Context (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Context a b
context ClassGraph
wholeGraph Node
n
     in ClassGraph
-> ClassGraph -> Bool -> [String] -> String -> ClassGraph
reduceToRelations ClassGraph
wholeGraph ClassGraph
g' Bool
withIncoming [String]
forbiddenRels String
name

mergeGraphs :: ClassGraph -> ClassGraph -> ClassGraph
mergeGraphs :: ClassGraph -> ClassGraph -> ClassGraph
mergeGraphs g1 :: ClassGraph
g1 g2 :: ClassGraph
g2 =
  [LEdge String] -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges (ClassGraph -> [LEdge String]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges ClassGraph
g2) (ClassGraph -> ClassGraph) -> ClassGraph -> ClassGraph
forall a b. (a -> b) -> a -> b
$ [LNode (String, String, OntoObjectType)]
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
[LNode a] -> gr a b -> gr a b
insNodes (ClassGraph -> [LNode (String, String, OntoObjectType)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes ClassGraph
g2 [LNode (String, String, OntoObjectType)]
-> [LNode (String, String, OntoObjectType)]
-> [LNode (String, String, OntoObjectType)]
forall a. Eq a => [a] -> [a] -> [a]
\\ ClassGraph -> [LNode (String, String, OntoObjectType)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes ClassGraph
g1) ClassGraph
g1

showSuperSubClassesForVisible :: MMiSSOntology -> A.GraphInfo -> Bool -> Bool
                              -> (String, Int, Int) -> IO ()
showSuperSubClassesForVisible :: MMiSSOntology
-> GraphInfo -> Bool -> Bool -> (String, Node, Node) -> IO ()
showSuperSubClassesForVisible onto :: MMiSSOntology
onto gv :: GraphInfo
gv showSuper :: Bool
showSuper transitive :: Bool
transitive (_, _, gid :: Node
gid) =
  do [String]
nodeList <- Node -> GraphInfo -> IO [String]
myGetNodes Node
gid GraphInfo
gv
     if Bool
transitive
       then ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph
                 ((ClassGraph -> String -> ClassGraph)
-> ClassGraph -> [String] -> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (ClassGraph -> Bool -> ClassGraph -> String -> ClassGraph
getSubSuperClosure (MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto) Bool
showSuper)
                        ClassGraph
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty [String]
nodeList) Node
gid GraphInfo
gv
       else ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph
                 ((ClassGraph -> String -> ClassGraph)
-> ClassGraph -> [String] -> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (ClassGraph -> Bool -> ClassGraph -> String -> ClassGraph
getSubSuperSingle (MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto) Bool
showSuper)
                        ClassGraph
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty [String]
nodeList) Node
gid GraphInfo
gv
     Node -> GraphInfo -> IO Result
A.redisplay Node
gid GraphInfo
gv
     () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

reduceToThisNode :: MMiSSOntology -> A.GraphInfo -> (String, Int, Int) -> IO ()
reduceToThisNode :: MMiSSOntology -> GraphInfo -> (String, Node, Node) -> IO ()
reduceToThisNode onto :: MMiSSOntology
onto gv :: GraphInfo
gv (name :: String
name, _, gid :: Node
gid) = do
     Node -> GraphInfo -> IO Result
purgeGraph Node
gid GraphInfo
gv
     case String
-> ClassGraph -> [Context (String, String, OntoObjectType) String]
gselName String
name (ClassGraph -> [Context (String, String, OntoObjectType) String])
-> ClassGraph -> [Context (String, String, OntoObjectType) String]
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto of
       [] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       (_, v :: Node
v, l :: (String, String, OntoObjectType)
l, _) : _ -> do
           ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph (([], Node
v, (String, String, OntoObjectType)
l, []) Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& ClassGraph
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty) Node
gid GraphInfo
gv
           Node -> GraphInfo -> IO Result
A.redisplay Node
gid GraphInfo
gv
           () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

purgeThisNode :: A.GraphInfo -> (String, Int, Int) -> IO ()
purgeThisNode :: GraphInfo -> (String, Node, Node) -> IO ()
purgeThisNode gv :: GraphInfo
gv (name :: String
name, _, gid :: Node
gid) =
  do (gs :: [(Node, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
     case Node -> [(Node, AbstractionGraph)] -> Maybe AbstractionGraph
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Node
gid [(Node, AbstractionGraph)]
gs of
       Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just g :: AbstractionGraph
g ->
        do let oldGraph :: ClassGraph
oldGraph = AbstractionGraph -> ClassGraph
A.ontoGraph AbstractionGraph
g
               nMap :: NodeMapping
nMap = AbstractionGraph -> NodeMapping
A.nodeMap AbstractionGraph
g
           (_, mayNodeID :: Maybe Node
mayNodeID) <-
              case ClassGraph -> String -> Maybe Node
findLNode ClassGraph
oldGraph String
name of
                Nothing -> (ClassGraph, Maybe Node) -> IO (ClassGraph, Maybe Node)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassGraph
oldGraph, Maybe Node
forall a. Maybe a
Nothing)
                Just nodeID :: Node
nodeID -> (ClassGraph, Maybe Node) -> IO (ClassGraph, Maybe Node)
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> gr a b
delNode Node
nodeID ClassGraph
oldGraph, Node -> Maybe Node
forall a. a -> Maybe a
Just Node
nodeID)
           case Maybe Node
mayNodeID of
             Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             Just nodeID :: Node
nodeID ->
               case Node -> NodeMapping -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Node
nodeID NodeMapping
nMap of
                 Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 Just node :: Node
node -> do
                     Node -> Node -> GraphInfo -> IO Result
A.delnode Node
gid Node
node GraphInfo
gv
                     Node -> GraphInfo -> IO Result
A.redisplay Node
gid GraphInfo
gv
                     () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

showSuperSubClasses :: MMiSSOntology -> A.GraphInfo -> Bool -> Bool
                    -> (String, Int, Int) -> IO ()
showSuperSubClasses :: MMiSSOntology
-> GraphInfo -> Bool -> Bool -> (String, Node, Node) -> IO ()
showSuperSubClasses onto :: MMiSSOntology
onto gv :: GraphInfo
gv showSuper :: Bool
showSuper transitive :: Bool
transitive (name :: String
name, _, gid :: Node
gid) =
  do if Bool
transitive
       then ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph
              (ClassGraph -> Bool -> ClassGraph -> String -> ClassGraph
getSubSuperClosure (MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto) Bool
showSuper ClassGraph
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty String
name)
              Node
gid GraphInfo
gv
       else ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph (ClassGraph -> Bool -> ClassGraph -> String -> ClassGraph
getSubSuperSingle (MMiSSOntology -> ClassGraph
getClassGraph MMiSSOntology
onto)
                                Bool
showSuper ClassGraph
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty String
name) Node
gid GraphInfo
gv
     Node -> GraphInfo -> IO Result
A.redisplay Node
gid GraphInfo
gv
     () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

getSubSuperSingle :: ClassGraph -> Bool -> ClassGraph -> String -> ClassGraph
getSubSuperSingle :: ClassGraph -> Bool -> ClassGraph -> String -> ClassGraph
getSubSuperSingle g :: ClassGraph
g showSuper :: Bool
showSuper newGr :: ClassGraph
newGr name :: String
name =
  case ClassGraph -> String -> Maybe Node
findLNode ClassGraph
g String
name of
    Nothing -> ClassGraph
g
    Just nodeID :: Node
nodeID ->
      let isaPred :: (a, b, String) -> Bool
isaPred (_, _, a :: String
a) = String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "isa"
          subClassEdges :: [LEdge String]
subClassEdges = (LEdge String -> Bool) -> [LEdge String] -> [LEdge String]
forall a. (a -> Bool) -> [a] -> [a]
filter LEdge String -> Bool
forall a b. (a, b, String) -> Bool
isaPred ([LEdge String] -> [LEdge String])
-> [LEdge String] -> [LEdge String]
forall a b. (a -> b) -> a -> b
$ ClassGraph -> Node -> [LEdge String]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [LEdge b]
inn ClassGraph
g Node
nodeID
          ng :: ClassGraph
ng = (ClassGraph -> LEdge String -> ClassGraph)
-> ClassGraph -> [LEdge String] -> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (ClassGraph -> ClassGraph -> LEdge String -> ClassGraph
insPredecessorAndEdge ClassGraph
g)
               (Node -> ClassGraph -> ClassGraph
insertInitialNode Node
nodeID ClassGraph
newGr) [LEdge String]
subClassEdges
      in if Bool
showSuper
           then let superClassEdges :: [LEdge String]
superClassEdges = (LEdge String -> Bool) -> [LEdge String] -> [LEdge String]
forall a. (a -> Bool) -> [a] -> [a]
filter LEdge String -> Bool
forall a b. (a, b, String) -> Bool
isaPred ([LEdge String] -> [LEdge String])
-> [LEdge String] -> [LEdge String]
forall a b. (a -> b) -> a -> b
$ ClassGraph -> Node -> [LEdge String]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [LEdge b]
out ClassGraph
g Node
nodeID
                in (ClassGraph -> LEdge String -> ClassGraph)
-> ClassGraph -> [LEdge String] -> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (ClassGraph -> ClassGraph -> LEdge String -> ClassGraph
insSuccessorAndEdge ClassGraph
g) ClassGraph
ng [LEdge String]
superClassEdges
           else ClassGraph
ng
  where
    insertInitialNode :: Node -> ClassGraph -> ClassGraph
    insertInitialNode :: Node -> ClassGraph -> ClassGraph
insertInitialNode nodeID :: Node
nodeID gr :: ClassGraph
gr =
      case Node
-> ClassGraph -> Decomp Gr (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
nodeID ClassGraph
gr of
        (Nothing, _) -> ([], Node
nodeID, (String
name, "", OntoObjectType
OntoClass), []) Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& ClassGraph
gr
        _ -> ClassGraph
gr
    insPredecessorAndEdge :: ClassGraph -> ClassGraph -> LEdge String
                          -> ClassGraph
    insPredecessorAndEdge :: ClassGraph -> ClassGraph -> LEdge String -> ClassGraph
insPredecessorAndEdge oldGr :: ClassGraph
oldGr newGr' :: ClassGraph
newGr' (fromNode :: Node
fromNode, toNode :: Node
toNode, edgeLabel_ :: String
edgeLabel_) =
      case Decomp Gr (String, String, OntoObjectType) String
-> MContext (String, String, OntoObjectType) String
forall a b. (a, b) -> a
fst (Decomp Gr (String, String, OntoObjectType) String
 -> MContext (String, String, OntoObjectType) String)
-> Decomp Gr (String, String, OntoObjectType) String
-> MContext (String, String, OntoObjectType) String
forall a b. (a -> b) -> a -> b
$ Node
-> ClassGraph -> Decomp Gr (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
fromNode ClassGraph
oldGr of
        Nothing -> ClassGraph
newGr'
        Just (_, _, nodeLabel1 :: (String, String, OntoObjectType)
nodeLabel1, _) ->
           case Node
-> ClassGraph -> Decomp Gr (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
fromNode ClassGraph
newGr' of
             (Nothing, _) ->
                 ([], Node
fromNode, (String, String, OntoObjectType)
nodeLabel1, [(String
edgeLabel_, Node
toNode)]) Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& ClassGraph
newGr'
             (Just (p :: Adj String
p, fromNodeID :: Node
fromNodeID, nodeLabel2 :: (String, String, OntoObjectType)
nodeLabel2, s :: Adj String
s), newGr2 :: ClassGraph
newGr2) ->
                 (Adj String
p, Node
fromNodeID, (String, String, OntoObjectType)
nodeLabel2, (String
edgeLabel_, Node
toNode) (String, Node) -> Adj String -> Adj String
forall a. a -> [a] -> [a]
: Adj String
s) Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& ClassGraph
newGr2
    insSuccessorAndEdge :: ClassGraph -> ClassGraph -> LEdge String
                        -> ClassGraph
    insSuccessorAndEdge :: ClassGraph -> ClassGraph -> LEdge String -> ClassGraph
insSuccessorAndEdge oldGr :: ClassGraph
oldGr newGr' :: ClassGraph
newGr' (fromNode :: Node
fromNode, toNode :: Node
toNode, edgeLabel_ :: String
edgeLabel_) =
      case Decomp Gr (String, String, OntoObjectType) String
-> MContext (String, String, OntoObjectType) String
forall a b. (a, b) -> a
fst (Decomp Gr (String, String, OntoObjectType) String
 -> MContext (String, String, OntoObjectType) String)
-> Decomp Gr (String, String, OntoObjectType) String
-> MContext (String, String, OntoObjectType) String
forall a b. (a -> b) -> a -> b
$ Node
-> ClassGraph -> Decomp Gr (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
toNode ClassGraph
oldGr of
        Nothing -> ClassGraph
newGr'
        Just (_, _, (nodeLabel1 :: String
nodeLabel1, _, _), _) ->
           case Node
-> ClassGraph -> Decomp Gr (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
toNode ClassGraph
newGr' of
             (Nothing, _) ->
              ([(String
edgeLabel_, Node
fromNode)], Node
toNode, (String
nodeLabel1, "", OntoObjectType
OntoClass), [])
              Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& ClassGraph
newGr'
             (Just (p :: Adj String
p, toNodeID :: Node
toNodeID, nodeLabel2 :: (String, String, OntoObjectType)
nodeLabel2, s :: Adj String
s), newGr2 :: ClassGraph
newGr2) ->
                 ((String
edgeLabel_, Node
fromNode) (String, Node) -> Adj String -> Adj String
forall a. a -> [a] -> [a]
: Adj String
p, Node
toNodeID, (String, String, OntoObjectType)
nodeLabel2, Adj String
s) Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& ClassGraph
newGr2

getSubSuperClosure :: ClassGraph -> Bool -> ClassGraph -> String -> ClassGraph
getSubSuperClosure :: ClassGraph -> Bool -> ClassGraph -> String -> ClassGraph
getSubSuperClosure g :: ClassGraph
g showSuper :: Bool
showSuper newGr :: ClassGraph
newGr name :: String
name =
  case ClassGraph -> String -> Maybe Node
findLNode ClassGraph
g String
name of
    Nothing -> ClassGraph
g
    Just nodeID :: Node
nodeID ->
      let ng :: ClassGraph
ng = (ClassGraph -> Node -> ClassGraph)
-> ClassGraph -> [Node] -> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ClassGraph -> Node -> ClassGraph
subClassClosure ClassGraph
newGr [Node
nodeID]
      in if Bool
showSuper
           then (ClassGraph -> Node -> ClassGraph)
-> ClassGraph -> [Node] -> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Node -> ClassGraph -> Node -> ClassGraph
superClassClosure Node
nodeID) ClassGraph
ng [Node
nodeID]
           else ClassGraph
ng
  where
    superClassClosure :: Node -> ClassGraph -> Node -> ClassGraph
    superClassClosure :: Node -> ClassGraph -> Node -> ClassGraph
superClassClosure specialNodeID :: Node
specialNodeID ng :: ClassGraph
ng nodeID :: Node
nodeID =
      case Decomp Gr (String, String, OntoObjectType) String
-> MContext (String, String, OntoObjectType) String
forall a b. (a, b) -> a
fst (Decomp Gr (String, String, OntoObjectType) String
 -> MContext (String, String, OntoObjectType) String)
-> Decomp Gr (String, String, OntoObjectType) String
-> MContext (String, String, OntoObjectType) String
forall a b. (a -> b) -> a -> b
$ Node
-> ClassGraph -> Decomp Gr (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
nodeID ClassGraph
g of
        Nothing -> ClassGraph
ng
        Just (_, _, (label :: String
label, _, _), outAdj :: Adj String
outAdj) ->
          let isaAdj :: Adj String
isaAdj = ((String, Node) -> Bool) -> Adj String -> Adj String
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "isa") (String -> Bool)
-> ((String, Node) -> String) -> (String, Node) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Node) -> String
forall a b. (a, b) -> a
fst) Adj String
outAdj
              ng1 :: ClassGraph
ng1 = (ClassGraph -> Node -> ClassGraph)
-> ClassGraph -> [Node] -> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Node -> ClassGraph -> Node -> ClassGraph
superClassClosure Node
specialNodeID) ClassGraph
ng
                    ([Node] -> ClassGraph) -> [Node] -> ClassGraph
forall a b. (a -> b) -> a -> b
$ ((String, Node) -> Node) -> Adj String -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (String, Node) -> Node
forall a b. (a, b) -> b
snd Adj String
isaAdj
          in if Node
nodeID Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
== Node
specialNodeID
          then case Node
-> ClassGraph -> Decomp Gr (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
specialNodeID ClassGraph
ng1 of
     -- This should never be the case, but we somehow have to deal with it
              (Nothing, _) -> (Adj String
isaAdj, Node
nodeID, (String
label, "", OntoObjectType
OntoClass), [])
                              Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& ClassGraph
ng1
              (Just (inAdj :: Adj String
inAdj, _, _, _), ng2 :: ClassGraph
ng2) ->
                  (Adj String
inAdj, Node
nodeID, (String
label, "", OntoObjectType
OntoClass), Adj String
isaAdj) Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& ClassGraph
ng2
          else case Node
-> ClassGraph -> Decomp Gr (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
nodeID ClassGraph
ng1 of
              (Nothing, _) -> ([], Node
nodeID, (String
label, "", OntoObjectType
OntoClass), Adj String
isaAdj)
                              Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& ClassGraph
ng1
              (Just (inAdj :: Adj String
inAdj, _, _, outAdj2 :: Adj String
outAdj2), ng2 :: ClassGraph
ng2) ->
                  (Adj String
inAdj Adj String -> Adj String -> Adj String
forall a. [a] -> [a] -> [a]
++ Adj String
isaAdj, Node
nodeID, (String
label, "", OntoObjectType
OntoClass), Adj String
outAdj2)
                  Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& ClassGraph
ng2
{- - subClassClosure hunts transitively all isa-Ajacencies that goes
    into the given node (nodeID).  For all nodes collected, their
    outgoing adjacencies are ignored because we only want to show the
    isa-Relation to the superclass. The given specialNodeID is the ID
    of the node from which the search for subclasses startet. Because
    this node is already in the graph, we have to delete and reinsert
    it with its outgoing adjacencies (which consists of the
    isa-relations to it's superclasses, build by superClassClosure
    beforehand).  - -}
    subClassClosure :: ClassGraph -> Node -> ClassGraph
    subClassClosure :: ClassGraph -> Node -> ClassGraph
subClassClosure ng :: ClassGraph
ng nodeID :: Node
nodeID =
      case Decomp Gr (String, String, OntoObjectType) String
-> MContext (String, String, OntoObjectType) String
forall a b. (a, b) -> a
fst (Decomp Gr (String, String, OntoObjectType) String
 -> MContext (String, String, OntoObjectType) String)
-> Decomp Gr (String, String, OntoObjectType) String
-> MContext (String, String, OntoObjectType) String
forall a b. (a -> b) -> a -> b
$ Node
-> ClassGraph -> Decomp Gr (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
nodeID ClassGraph
g of
        Nothing -> ClassGraph
ng
        Just (inAdj :: Adj String
inAdj, _, (label :: String
label, _, _), _) ->
          let isaAdj :: Adj String
isaAdj = ((String, Node) -> Bool) -> Adj String -> Adj String
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "isa") (String -> Bool)
-> ((String, Node) -> String) -> (String, Node) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Node) -> String
forall a b. (a, b) -> a
fst) Adj String
inAdj
              ng1 :: ClassGraph
ng1 = (ClassGraph -> Node -> ClassGraph)
-> ClassGraph -> [Node] -> ClassGraph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ClassGraph -> Node -> ClassGraph
subClassClosure ClassGraph
ng ([Node] -> ClassGraph) -> [Node] -> ClassGraph
forall a b. (a -> b) -> a -> b
$ ((String, Node) -> Node) -> Adj String -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (String, Node) -> Node
forall a b. (a, b) -> b
snd Adj String
isaAdj
          in case Decomp Gr (String, String, OntoObjectType) String
-> MContext (String, String, OntoObjectType) String
forall a b. (a, b) -> a
fst (Decomp Gr (String, String, OntoObjectType) String
 -> MContext (String, String, OntoObjectType) String)
-> Decomp Gr (String, String, OntoObjectType) String
-> MContext (String, String, OntoObjectType) String
forall a b. (a -> b) -> a -> b
$ Node
-> ClassGraph -> Decomp Gr (String, String, OntoObjectType) String
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
nodeID ClassGraph
ng1 of
               Nothing -> (Adj String
isaAdj, Node
nodeID, (String
label, "", OntoObjectType
OntoClass), []) Context (String, String, OntoObjectType) String
-> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& ClassGraph
ng1
               _ -> ClassGraph
ng1

hideObjectsForVisible :: A.GraphInfo -> (String, Int, Int) -> IO ()
hideObjectsForVisible :: GraphInfo -> (String, Node, Node) -> IO ()
hideObjectsForVisible gv :: GraphInfo
gv (_, _, gid :: Node
gid) =
  do (gs :: [(Node, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
     case Node -> [(Node, AbstractionGraph)] -> Maybe AbstractionGraph
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Node
gid [(Node, AbstractionGraph)]
gs of
       Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just g :: AbstractionGraph
g ->
         do let oldGraph :: ClassGraph
oldGraph = AbstractionGraph -> ClassGraph
A.ontoGraph AbstractionGraph
g
                objectNodeIDs :: [Node]
objectNodeIDs = (Context (String, String, OntoObjectType) String -> Node)
-> [Context (String, String, OntoObjectType) String] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map ( \ (_, v :: Node
v, _, _) -> Node
v) ([Context (String, String, OntoObjectType) String] -> [Node])
-> [Context (String, String, OntoObjectType) String] -> [Node]
forall a b. (a -> b) -> a -> b
$
                                (OntoObjectType -> Bool)
-> ClassGraph -> [Context (String, String, OntoObjectType) String]
gselType (OntoObjectType -> OntoObjectType -> Bool
forall a. Eq a => a -> a -> Bool
== OntoObjectType
OntoObject) ClassGraph
oldGraph
            Node -> GraphInfo -> IO Result
purgeGraph Node
gid GraphInfo
gv
            ClassGraph -> Node -> GraphInfo -> IO ()
updateDaVinciGraph ((Node -> Bool) -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
(Node -> Bool) -> gr a b -> gr a b
restrict (Node -> [Node] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Node]
objectNodeIDs) ClassGraph
oldGraph)
                               Node
gid GraphInfo
gv
            Node -> GraphInfo -> IO Result
A.redisplay Node
gid GraphInfo
gv
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

createEdgeTypes :: ClassGraph -> [(String, DaVinciArcTypeParms A.EdgeValue)]
createEdgeTypes :: ClassGraph -> [(String, DaVinciArcTypeParms EdgeValue)]
createEdgeTypes g :: ClassGraph
g = (String -> (String, DaVinciArcTypeParms EdgeValue))
-> [String] -> [(String, DaVinciArcTypeParms EdgeValue)]
forall a b. (a -> b) -> [a] -> [b]
map String -> (String, DaVinciArcTypeParms EdgeValue)
createEdgeType
   ([String] -> [(String, DaVinciArcTypeParms EdgeValue)])
-> [String] -> [(String, DaVinciArcTypeParms EdgeValue)]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ((LEdge String -> String) -> [LEdge String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ( \ (_, _, l :: String
l) -> String
l) ([LEdge String] -> [String]) -> [LEdge String] -> [String]
forall a b. (a -> b) -> a -> b
$ ClassGraph -> [LEdge String]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges ClassGraph
g) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["instanceOf"]
  where
    createEdgeType :: String -> (String, DaVinciArcTypeParms EdgeValue)
createEdgeType str :: String
str =
      case String
str of
        "isa" ->
             ("isa",
               EdgePattern EdgeValue
forall value. EdgePattern value
Thick
               EdgePattern EdgeValue
-> DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$ String -> Head EdgeValue
forall value. String -> Head value
Head "oarrow"
               Head EdgeValue
-> DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$ String -> EdgeDir EdgeValue
forall value. String -> EdgeDir value
Dir "first"
               EdgeDir EdgeValue
-> DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$ DaVinciArcTypeParms EdgeValue
forall (arcTypeParms :: * -> *) value.
(ArcTypeParms arcTypeParms, Typeable value) =>
arcTypeParms value
emptyArcTypeParms :: DaVinciArcTypeParms A.EdgeValue)
        "instanceOf" ->
             ("instanceOf",
               EdgePattern EdgeValue
forall value. EdgePattern value
Dotted
               EdgePattern EdgeValue
-> DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$ String -> EdgeDir EdgeValue
forall value. String -> EdgeDir value
Dir "first"
               EdgeDir EdgeValue
-> DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$ DaVinciArcTypeParms EdgeValue
forall (arcTypeParms :: * -> *) value.
(ArcTypeParms arcTypeParms, Typeable value) =>
arcTypeParms value
emptyArcTypeParms :: DaVinciArcTypeParms A.EdgeValue)
        _ -> -- "contains"
             (String
str,
              EdgePattern EdgeValue
forall value. EdgePattern value
Solid
              EdgePattern EdgeValue
-> DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$ String -> Head EdgeValue
forall value. String -> Head value
Head "arrow"
              Head EdgeValue
-> DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$ (EdgeValue -> IO String) -> ValueTitle EdgeValue
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 EdgeValue
-> DaVinciArcTypeParms EdgeValue -> DaVinciArcTypeParms EdgeValue
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$ DaVinciArcTypeParms EdgeValue
forall (arcTypeParms :: * -> *) value.
(ArcTypeParms arcTypeParms, Typeable value) =>
arcTypeParms value
emptyArcTypeParms :: DaVinciArcTypeParms A.EdgeValue)

createLocalMenu :: MMiSSOntology -> A.GraphInfo -> LocalMenu (String, Int, Int)
createLocalMenu :: MMiSSOntology -> GraphInfo -> LocalMenu (String, Node, Node)
createLocalMenu onto :: MMiSSOntology
onto ginfo :: GraphInfo
ginfo =
    let relMenus :: Bool -> [MenuPrim a ((String, Node, Node) -> IO ())]
relMenus b :: Bool
b =
            Bool
-> [String]
-> MMiSSOntology
-> GraphInfo
-> [MenuPrim a ((String, Node, Node) -> IO ())]
forall a.
Bool
-> [String]
-> MMiSSOntology
-> GraphInfo
-> [MenuPrim a ((String, Node, Node) -> IO ())]
createRelationMenuButtons Bool
b (MMiSSOntology -> [String]
getRelationNames MMiSSOntology
onto) MMiSSOntology
onto GraphInfo
ginfo
        allRels :: (MMiSSOntology
 -> GraphInfo -> Bool -> [String] -> (String, Node, Node) -> IO ())
-> Bool -> [MenuPrim subMenuValue ((String, Node, Node) -> IO ())]
allRels f :: MMiSSOntology
-> GraphInfo -> Bool -> [String] -> (String, Node, Node) -> IO ()
f b :: Bool
b = [ String
-> ((String, Node, Node) -> IO ())
-> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button "All relations" (((String, Node, Node) -> IO ())
 -> MenuPrim subMenuValue ((String, Node, Node) -> IO ()))
-> ((String, Node, Node) -> IO ())
-> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
forall a b. (a -> b) -> a -> b
$ MMiSSOntology
-> GraphInfo -> Bool -> [String] -> (String, Node, Node) -> IO ()
f MMiSSOntology
onto GraphInfo
ginfo Bool
b ["isa"]
                      , MenuPrim subMenuValue ((String, Node, Node) -> IO ())
forall subMenuValue value. MenuPrim subMenuValue value
Blank ] [MenuPrim subMenuValue ((String, Node, Node) -> IO ())]
-> [MenuPrim subMenuValue ((String, Node, Node) -> IO ())]
-> [MenuPrim subMenuValue ((String, Node, Node) -> IO ())]
forall a. [a] -> [a] -> [a]
++ Bool -> [MenuPrim subMenuValue ((String, Node, Node) -> IO ())]
forall a. Bool -> [MenuPrim a ((String, Node, Node) -> IO ())]
relMenus Bool
b
        superSub' :: (MMiSSOntology -> GraphInfo -> Bool -> a -> value)
-> Bool -> a -> MenuPrim subMenuValue value
superSub' f :: MMiSSOntology -> GraphInfo -> Bool -> a -> value
f b1 :: Bool
b1 = String -> value -> MenuPrim subMenuValue value
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button
            (if Bool
b1 then "Sub/Superclasses" else "Subclasses")
            (value -> MenuPrim subMenuValue value)
-> (a -> value) -> a -> MenuPrim subMenuValue value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MMiSSOntology -> GraphInfo -> Bool -> a -> value
f MMiSSOntology
onto GraphInfo
ginfo Bool
b1
        superSub :: Bool
-> Bool -> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
superSub = (MMiSSOntology
 -> GraphInfo -> Bool -> Bool -> (String, Node, Node) -> IO ())
-> Bool
-> Bool
-> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
forall a value subMenuValue.
(MMiSSOntology -> GraphInfo -> Bool -> a -> value)
-> Bool -> a -> MenuPrim subMenuValue value
superSub' MMiSSOntology
-> GraphInfo -> Bool -> Bool -> (String, Node, Node) -> IO ()
showSuperSubClasses
        superSubForVis :: Bool
-> Bool -> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
superSubForVis = (MMiSSOntology
 -> GraphInfo -> Bool -> Bool -> (String, Node, Node) -> IO ())
-> Bool
-> Bool
-> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
forall a value subMenuValue.
(MMiSSOntology -> GraphInfo -> Bool -> a -> value)
-> Bool -> a -> MenuPrim subMenuValue value
superSub' MMiSSOntology
-> GraphInfo -> Bool -> Bool -> (String, Node, Node) -> IO ()
showSuperSubClassesForVisible
        relMen :: (Bool -> [MenuPrim (Maybe String) value])
-> MenuPrim (Maybe String) value
relMen f :: Bool -> [MenuPrim (Maybe String) value]
f = Maybe String
-> [MenuPrim (Maybe String) value] -> MenuPrim (Maybe String) value
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
Menu (String -> Maybe String
forall a. a -> Maybe a
Just "Show relations")
                   [ Maybe String
-> [MenuPrim (Maybe String) value] -> MenuPrim (Maybe String) value
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
Menu (String -> Maybe String
forall a. a -> Maybe a
Just "Outgoing") ([MenuPrim (Maybe String) value] -> MenuPrim (Maybe String) value)
-> [MenuPrim (Maybe String) value] -> MenuPrim (Maybe String) value
forall a b. (a -> b) -> a -> b
$ Bool -> [MenuPrim (Maybe String) value]
f Bool
False
                   , Maybe String
-> [MenuPrim (Maybe String) value] -> MenuPrim (Maybe String) value
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
Menu (String -> Maybe String
forall a. a -> Maybe a
Just "Out + In") ([MenuPrim (Maybe String) value] -> MenuPrim (Maybe String) value)
-> [MenuPrim (Maybe String) value] -> MenuPrim (Maybe String) value
forall a b. (a -> b) -> a -> b
$ Bool -> [MenuPrim (Maybe String) value]
f Bool
True ]
        nodeMen :: (Bool -> Bool -> MenuPrim (Maybe String) value)
-> Bool
-> [MenuPrim (Maybe String) value]
-> MenuPrim (Maybe String) value
nodeMen f :: Bool -> Bool -> MenuPrim (Maybe String) value
f b :: Bool
b = Maybe String
-> [MenuPrim (Maybe String) value] -> MenuPrim (Maybe String) value
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
Menu (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ "Show "
                              String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
b then "transitively" else "adjacent")
                        ([MenuPrim (Maybe String) value] -> MenuPrim (Maybe String) value)
-> ([MenuPrim (Maybe String) value]
    -> [MenuPrim (Maybe String) value])
-> [MenuPrim (Maybe String) value]
-> MenuPrim (Maybe String) value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ Bool -> Bool -> MenuPrim (Maybe String) value
f Bool
False Bool
b, Bool -> Bool -> MenuPrim (Maybe String) value
f Bool
True Bool
b ] [MenuPrim (Maybe String) value]
-> [MenuPrim (Maybe String) value]
-> [MenuPrim (Maybe String) value]
forall a. [a] -> [a] -> [a]
++)
    in MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
-> LocalMenu (String, Node, Node)
forall value.
MenuPrim (Maybe String) (value -> IO ()) -> LocalMenu value
LocalMenu (MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
 -> LocalMenu (String, Node, Node))
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
-> LocalMenu (String, Node, Node)
forall a b. (a -> b) -> a -> b
$ Maybe String
-> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())]
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
Menu Maybe String
forall a. Maybe a
Nothing
    [ Maybe String
-> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())]
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
Menu (String -> Maybe String
forall a. a -> Maybe a
Just "For this node")
      [ (Bool
 -> Bool -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> Bool
-> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())]
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall value.
(Bool -> Bool -> MenuPrim (Maybe String) value)
-> Bool
-> [MenuPrim (Maybe String) value]
-> MenuPrim (Maybe String) value
nodeMen Bool
-> Bool -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue.
Bool
-> Bool -> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
superSub Bool
True [(Bool -> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())])
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall value.
(Bool -> [MenuPrim (Maybe String) value])
-> MenuPrim (Maybe String) value
relMen ((Bool
  -> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())])
 -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> (Bool
    -> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())])
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall a b. (a -> b) -> a -> b
$ (MMiSSOntology
 -> GraphInfo -> Bool -> [String] -> (String, Node, Node) -> IO ())
-> Bool
-> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())]
forall subMenuValue.
(MMiSSOntology
 -> GraphInfo -> Bool -> [String] -> (String, Node, Node) -> IO ())
-> Bool -> [MenuPrim subMenuValue ((String, Node, Node) -> IO ())]
allRels MMiSSOntology
-> GraphInfo -> Bool -> [String] -> (String, Node, Node) -> IO ()
showAllRelations]
      , (Bool
 -> Bool -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> Bool
-> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())]
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall value.
(Bool -> Bool -> MenuPrim (Maybe String) value)
-> Bool
-> [MenuPrim (Maybe String) value]
-> MenuPrim (Maybe String) value
nodeMen Bool
-> Bool -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue.
Bool
-> Bool -> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
superSub Bool
False
        [(Bool -> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())])
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall value.
(Bool -> [MenuPrim (Maybe String) value])
-> MenuPrim (Maybe String) value
relMen ((Bool
  -> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())])
 -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> (Bool
    -> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())])
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall a b. (a -> b) -> a -> b
$ (MMiSSOntology
 -> GraphInfo -> Bool -> [String] -> (String, Node, Node) -> IO ())
-> Bool
-> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())]
forall subMenuValue.
(MMiSSOntology
 -> GraphInfo -> Bool -> [String] -> (String, Node, Node) -> IO ())
-> Bool -> [MenuPrim subMenuValue ((String, Node, Node) -> IO ())]
allRels ( \ o :: MMiSSOntology
o g :: GraphInfo
g _ -> MMiSSOntology
-> GraphInfo -> [String] -> (String, Node, Node) -> IO ()
showRelationsToNeighbors MMiSSOntology
o GraphInfo
g)]
      ]
    , Maybe String
-> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())]
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
Menu (String -> Maybe String
forall a. a -> Maybe a
Just "For visible nodes")
      [ (Bool
 -> Bool -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> Bool
-> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())]
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall value.
(Bool -> Bool -> MenuPrim (Maybe String) value)
-> Bool
-> [MenuPrim (Maybe String) value]
-> MenuPrim (Maybe String) value
nodeMen Bool
-> Bool -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue.
Bool
-> Bool -> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
superSubForVis Bool
True []
      , (Bool
 -> Bool -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> Bool
-> [MenuPrim (Maybe String) ((String, Node, Node) -> IO ())]
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall value.
(Bool -> Bool -> MenuPrim (Maybe String) value)
-> Bool
-> [MenuPrim (Maybe String) value]
-> MenuPrim (Maybe String) value
nodeMen Bool
-> Bool -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue.
Bool
-> Bool -> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
superSubForVis Bool
False []
      , MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value. MenuPrim subMenuValue value
Blank
      , String
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button "Show relations" (((String, Node, Node) -> IO ())
 -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> GraphInfo -> (String, Node, Node) -> IO ()
showRelationsForVisible MMiSSOntology
onto GraphInfo
ginfo
      , MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value. MenuPrim subMenuValue value
Blank
      , String
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button "Show objects" (((String, Node, Node) -> IO ())
 -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> GraphInfo -> (String, Node, Node) -> IO ()
showObjectsForVisible MMiSSOntology
onto GraphInfo
ginfo
      , String
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button "Hide objects" (((String, Node, Node) -> IO ())
 -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall a b. (a -> b) -> a -> b
$ GraphInfo -> (String, Node, Node) -> IO ()
hideObjectsForVisible GraphInfo
ginfo
      ]
    , String
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button "Show whole class graph" (((String, Node, Node) -> IO ())
 -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> GraphInfo -> (String, Node, Node) -> IO ()
showWholeClassGraph MMiSSOntology
onto GraphInfo
ginfo
    , String
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button "Show whole object graph" (((String, Node, Node) -> IO ())
 -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> GraphInfo -> (String, Node, Node) -> IO ()
showWholeObjectGraph MMiSSOntology
onto GraphInfo
ginfo
    , String
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button "Show relations" (((String, Node, Node) -> IO ())
 -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall a b. (a -> b) -> a -> b
$ GraphInfo -> (String, Node, Node) -> IO ()
showRelationDialog GraphInfo
ginfo
    , String
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button "Reduce to this node" (((String, Node, Node) -> IO ())
 -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall a b. (a -> b) -> a -> b
$ MMiSSOntology -> GraphInfo -> (String, Node, Node) -> IO ()
reduceToThisNode MMiSSOntology
onto GraphInfo
ginfo
    , String
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button "Delete this node" (((String, Node, Node) -> IO ())
 -> MenuPrim (Maybe String) ((String, Node, Node) -> IO ()))
-> ((String, Node, Node) -> IO ())
-> MenuPrim (Maybe String) ((String, Node, Node) -> IO ())
forall a b. (a -> b) -> a -> b
$ GraphInfo -> (String, Node, Node) -> IO ()
purgeThisNode GraphInfo
ginfo
    ]

createRelationMenuButtons :: Bool -> [String] -> MMiSSOntology -> A.GraphInfo
                          -> [MenuPrim a ((String, Int, Int) -> IO ())]
createRelationMenuButtons :: Bool
-> [String]
-> MMiSSOntology
-> GraphInfo
-> [MenuPrim a ((String, Node, Node) -> IO ())]
createRelationMenuButtons withIncomingRels :: Bool
withIncomingRels relNames :: [String]
relNames onto :: MMiSSOntology
onto ginfo :: GraphInfo
ginfo =
    (String -> MenuPrim a ((String, Node, Node) -> IO ()))
-> [String] -> [MenuPrim a ((String, Node, Node) -> IO ())]
forall a b. (a -> b) -> [a] -> [b]
map String -> MenuPrim a ((String, Node, Node) -> IO ())
forall subMenuValue.
String -> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
createButton [String]
relNames
  where
    createButton :: String -> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
createButton name :: String
name = String
-> ((String, Node, Node) -> IO ())
-> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button String
name
        (((String, Node, Node) -> IO ())
 -> MenuPrim subMenuValue ((String, Node, Node) -> IO ()))
-> ((String, Node, Node) -> IO ())
-> MenuPrim subMenuValue ((String, Node, Node) -> IO ())
forall a b. (a -> b) -> a -> b
$ MMiSSOntology
-> GraphInfo -> Bool -> [String] -> (String, Node, Node) -> IO ()
showAllRelations MMiSSOntology
onto GraphInfo
ginfo Bool
withIncomingRels
              ([String] -> (String, Node, Node) -> IO ())
-> [String] -> (String, Node, Node) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
delete String
name ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
relNames [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["isa"]

myDeleteNode :: A.Descr -> A.GraphInfo -> A.Result
             -> (Int, (String, DaVinciNode (String, Int, Int)))
             -> IO A.Result
myDeleteNode :: Node
-> GraphInfo
-> Result
-> (Node, (String, DaVinciNode (String, Node, Node)))
-> IO Result
myDeleteNode gid :: Node
gid gv :: GraphInfo
gv _ node :: (Node, (String, DaVinciNode (String, Node, Node)))
node = Node -> Node -> GraphInfo -> IO Result
A.delnode Node
gid ((Node, (String, DaVinciNode (String, Node, Node))) -> Node
forall a b. (a, b) -> a
fst (Node, (String, DaVinciNode (String, Node, Node)))
node) GraphInfo
gv

purgeGraph :: Int -> A.GraphInfo -> IO A.Result
purgeGraph :: Node -> GraphInfo -> IO Result
purgeGraph gid :: Node
gid gv :: GraphInfo
gv =
  do (gs :: [(Node, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
     case Node -> [(Node, AbstractionGraph)] -> Maybe AbstractionGraph
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Node
gid [(Node, AbstractionGraph)]
gs of
       Just g :: AbstractionGraph
g -> do
         Node -> ClassGraph -> GraphInfo -> IO Result
A.writeOntoGraph Node
gid ClassGraph
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty GraphInfo
gv
         Node -> NodeMapping -> GraphInfo -> IO Result
A.writeNodeMap Node
gid NodeMapping
forall k a. Map k a
Map.empty GraphInfo
gv
         (Result
 -> (Node, (String, DaVinciNode (String, Node, Node))) -> IO Result)
-> Result
-> [(Node, (String, DaVinciNode (String, Node, Node)))]
-> IO Result
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Node
-> GraphInfo
-> Result
-> (Node, (String, DaVinciNode (String, Node, Node)))
-> IO Result
myDeleteNode Node
gid GraphInfo
gv) (Node -> Maybe String -> Result
A.Result 0 Maybe String
forall a. Maybe a
Nothing)
               ([(Node, (String, DaVinciNode (String, Node, Node)))] -> IO Result)
-> [(Node, (String, DaVinciNode (String, Node, Node)))]
-> IO Result
forall a b. (a -> b) -> a -> b
$ Map Node (String, DaVinciNode (String, Node, Node))
-> [(Node, (String, DaVinciNode (String, Node, Node)))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Node (String, DaVinciNode (String, Node, Node))
 -> [(Node, (String, DaVinciNode (String, Node, Node)))])
-> Map Node (String, DaVinciNode (String, Node, Node))
-> [(Node, (String, DaVinciNode (String, Node, Node)))]
forall a b. (a -> b) -> a -> b
$ AbstractionGraph
-> Map Node (String, DaVinciNode (String, Node, Node))
A.nodes AbstractionGraph
g
       Nothing -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ Node -> Maybe String -> Result
A.Result 0 (Maybe String -> Result) -> Maybe String -> Result
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
                  "Graph id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
forall a. Show a => a -> String
show Node
gid String -> String -> String
forall a. [a] -> [a] -> [a]
++ " not found"

myGetNodes :: Int -> A.GraphInfo -> IO [String]
myGetNodes :: Node -> GraphInfo -> IO [String]
myGetNodes gid :: Node
gid gv :: GraphInfo
gv =
  do (gs :: [(Node, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
     case Node -> [(Node, AbstractionGraph)] -> Maybe AbstractionGraph
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Node
gid [(Node, AbstractionGraph)]
gs of
       Just g :: AbstractionGraph
g -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (LNode (String, String, OntoObjectType) -> String)
-> [LNode (String, String, OntoObjectType)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ( \ (_, (name :: String
name, _, _)) -> String
name)
                 ([LNode (String, String, OntoObjectType)] -> [String])
-> [LNode (String, String, OntoObjectType)] -> [String]
forall a b. (a -> b) -> a -> b
$ ClassGraph -> [LNode (String, String, OntoObjectType)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes (ClassGraph -> [LNode (String, String, OntoObjectType)])
-> ClassGraph -> [LNode (String, String, OntoObjectType)]
forall a b. (a -> b) -> a -> b
$ AbstractionGraph -> ClassGraph
A.ontoGraph AbstractionGraph
g
       Nothing -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []


getPureClassGraph :: ClassGraph -> ClassGraph
getPureClassGraph :: ClassGraph -> ClassGraph
getPureClassGraph g :: ClassGraph
g =
    let classNodeList :: [Node]
classNodeList = (LNode (String, String, OntoObjectType) -> Node)
-> [LNode (String, String, OntoObjectType)] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map LNode (String, String, OntoObjectType) -> Node
forall a b. (a, b) -> a
fst
          ([LNode (String, String, OntoObjectType)] -> [Node])
-> [LNode (String, String, OntoObjectType)] -> [Node]
forall a b. (a -> b) -> a -> b
$ [OntoObjectType]
-> ClassGraph -> [LNode (String, String, OntoObjectType)]
getTypedNodes [OntoObjectType
OntoClass, OntoObjectType
OntoPredicate] ClassGraph
g
    in (Node -> Bool) -> ClassGraph -> ClassGraph
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
(Node -> Bool) -> gr a b -> gr a b
restrict (Node -> [Node] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Node]
classNodeList) ClassGraph
g


restrict :: DynGraph gr => (Node -> Bool) -> gr a b -> gr a b
restrict :: (Node -> Bool) -> gr a b -> gr a b
restrict f :: Node -> Bool
f = (Context a b -> gr a b -> gr a b) -> gr a b -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b c.
Graph gr =>
(Context a b -> c -> c) -> c -> gr a b -> c
ufold Context a b -> gr a b -> gr a b
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
([(b, Node)], Node, a, [(b, Node)]) -> gr a b -> gr a b
cfilter gr a b
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty
            where cfilter :: ([(b, Node)], Node, a, [(b, Node)]) -> gr a b -> gr a b
cfilter (p :: [(b, Node)]
p, v :: Node
v, l :: a
l, s :: [(b, Node)]
s) g :: gr a b
g =
                      if Node -> Bool
f Node
v then ([(b, Node)]
p', Node
v, a
l, [(b, Node)]
s') ([(b, Node)], Node, a, [(b, Node)]) -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& gr a b
g else gr a b
g
                   where p' :: [(b, Node)]
p' = ((b, Node) -> Bool) -> [(b, Node)] -> [(b, Node)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Node -> Bool
f (Node -> Bool) -> ((b, Node) -> Node) -> (b, Node) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, Node) -> Node
forall a b. (a, b) -> b
snd) [(b, Node)]
p
                         s' :: [(b, Node)]
s' = ((b, Node) -> Bool) -> [(b, Node)] -> [(b, Node)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Node -> Bool
f (Node -> Bool) -> ((b, Node) -> Node) -> (b, Node) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, Node) -> Node
forall a b. (a, b) -> b
snd) [(b, Node)]
s


getTypedNodes :: [OntoObjectType] -> ClassGraph
              -> [LNode (String, String, OntoObjectType)]
getTypedNodes :: [OntoObjectType]
-> ClassGraph -> [LNode (String, String, OntoObjectType)]
getTypedNodes ts :: [OntoObjectType]
ts = (Context (String, String, OntoObjectType) String
 -> LNode (String, String, OntoObjectType))
-> [Context (String, String, OntoObjectType) String]
-> [LNode (String, String, OntoObjectType)]
forall a b. (a -> b) -> [a] -> [b]
map Context (String, String, OntoObjectType) String
-> LNode (String, String, OntoObjectType)
forall a b. Context a b -> LNode a
labNode' ([Context (String, String, OntoObjectType) String]
 -> [LNode (String, String, OntoObjectType)])
-> (ClassGraph
    -> [Context (String, String, OntoObjectType) String])
-> ClassGraph
-> [LNode (String, String, OntoObjectType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OntoObjectType -> Bool)
-> ClassGraph -> [Context (String, String, OntoObjectType) String]
gselType (OntoObjectType -> [OntoObjectType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OntoObjectType]
ts)

showRelationDialog :: A.GraphInfo -> (String, Int, Int) -> IO ()
showRelationDialog :: GraphInfo -> (String, Node, Node) -> IO ()
showRelationDialog gv :: GraphInfo
gv (_ , _, gid :: Node
gid) =
  do (gs :: [(Node, AbstractionGraph)]
gs, _) <- GraphInfo -> IO ([(Node, AbstractionGraph)], Node)
forall a. IORef a -> IO a
readIORef GraphInfo
gv
     case Node -> [(Node, AbstractionGraph)] -> Maybe AbstractionGraph
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Node
gid [(Node, AbstractionGraph)]
gs of
       Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just g :: AbstractionGraph
g ->
         do let rvs :: [RelationViewSpec]
rvs = AbstractionGraph -> [RelationViewSpec]
A.relViewSpecs AbstractionGraph
g
                specEntries :: Form [((), (Bool, Bool))]
specEntries = [Form ((), (Bool, Bool))] -> Form [((), (Bool, Bool))]
forall value. [Form value] -> Form [value]
S.row ([Form ((), (Bool, Bool))] -> Form [((), (Bool, Bool))])
-> [Form ((), (Bool, Bool))] -> Form [((), (Bool, Bool))]
forall a b. (a -> b) -> a -> b
$ (RelationViewSpec -> Form ((), (Bool, Bool)))
-> [RelationViewSpec] -> [Form ((), (Bool, Bool))]
forall a b. (a -> b) -> [a] -> [b]
map RelationViewSpec -> Form ((), (Bool, Bool))
relSpecToFormEntry [RelationViewSpec]
rvs
                form :: Form (((), ((), ())), [((), (Bool, Bool))])
form = Form ((), ((), ()))
firstRow Form ((), ((), ()))
-> Form [((), (Bool, Bool))]
-> Form (((), ((), ())), [((), (Bool, Bool))])
forall value1 value2.
Form value1 -> Form value2 -> Form (value1, value2)
S.// Form [((), (Bool, Bool))]
specEntries
            String
-> Form (((), ((), ())), [((), (Bool, Bool))])
-> IO (Maybe (((), ((), ())), [((), (Bool, Bool))]))
forall value. String -> Form value -> IO (Maybe value)
S.doForm "Show relations" Form (((), ((), ())), [((), (Bool, Bool))])
form
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    firstRow :: Form ((), ((), ()))
firstRow = String -> () -> Form ()
forall label value.
(FormLabel label, FormValue value) =>
label -> value -> Form value
S.newFormEntry "" () Form () -> Form ((), ()) -> Form ((), ((), ()))
forall value1 value2.
Form value1 -> Form value2 -> Form (value1, value2)
S.\\ String -> () -> Form ()
forall label value.
(FormLabel label, FormValue value) =>
label -> value -> Form value
S.newFormEntry "Show" ()
       Form () -> Form () -> Form ((), ())
forall value1 value2.
Form value1 -> Form value2 -> Form (value1, value2)
S.\\ String -> () -> Form ()
forall label value.
(FormLabel label, FormValue value) =>
label -> value -> Form value
S.newFormEntry "Transitive" ()
    relSpecToFormEntry :: RelationViewSpec -> Form ((), (Bool, Bool))
relSpecToFormEntry (A.RelViewSpec relname :: String
relname b1 :: Bool
b1 b2 :: Bool
b2) =
      String -> () -> Form ()
forall label value.
(FormLabel label, FormValue value) =>
label -> value -> Form value
S.newFormEntry String
relname () Form () -> Form (Bool, Bool) -> Form ((), (Bool, Bool))
forall value1 value2.
Form value1 -> Form value2 -> Form (value1, value2)
S.\\ String -> Bool -> Form Bool
forall label value.
(FormLabel label, FormValue value) =>
label -> value -> Form value
S.newFormEntry "" Bool
b1
       Form Bool -> Form Bool -> Form (Bool, Bool)
forall value1 value2.
Form value1 -> Form value2 -> Form (value1, value2)
S.\\ String -> Bool -> Form Bool
forall label value.
(FormLabel label, FormValue value) =>
label -> value -> Form value
S.newFormEntry "" Bool
b2