module GUI.GraphTypes
( GInfo (..)
, updateWindowCount
, exitGInfo
, ConvFunc
, LibFunc
, DaVinciGraphTypeSyn
, Colors (..)
, Flags (..)
, getColor
, emptyGInfo
, copyGInfo
, lockGlobal
, unlockGlobal
) where
import GUI.GraphAbstraction (GraphInfo, initGraph)
import GUI.UDGUtils
import Common.LibName
import Common.IRI
import Driver.Options (HetcatsOpts (uncolored), defaultHetcatsOpts)
import Data.IORef
import qualified Data.Map as Map
import Control.Concurrent.MVar
import Control.Monad (when)
import Interfaces.DataTypes
import Interfaces.Utils
data Flags = Flags
{ Flags -> Bool
flagHideNodes :: Bool
, Flags -> Bool
flagHideEdges :: Bool
, Flags -> Bool
flagHideNames :: Bool
}
data GInfo = GInfo
{
GInfo -> IORef IntState
intState :: IORef IntState
, GInfo -> HetcatsOpts
hetcatsOpts :: HetcatsOpts
, GInfo -> MVar Int
windowCount :: MVar Int
, GInfo -> MVar ()
exitMVar :: MVar ()
, GInfo -> MVar ()
globalLock :: MVar ()
, GInfo -> MVar ()
functionLock :: MVar ()
, GInfo -> MVar ()
libGraphLock :: MVar ()
, GInfo -> IORef (Map LibName GInfo)
openGraphs :: IORef (Map.Map LibName GInfo)
, GInfo -> LibName
libName :: LibName
, GInfo -> GraphInfo
graphInfo :: GraphInfo
, GInfo -> IORef [(String, (String -> String) -> IO ())]
internalNames :: IORef [(String, (String -> String) -> IO ())]
, GInfo -> IORef Flags
options :: IORef Flags
}
updateWindowCount :: GInfo -> (Int -> Int) -> IO ()
updateWindowCount :: GInfo -> (Int -> Int) -> IO ()
updateWindowCount gi :: GInfo
gi f :: Int -> Int
f = do
Int
c <- MVar Int -> (Int -> IO (Int, Int)) -> IO Int
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (GInfo -> MVar Int
windowCount GInfo
gi) (\ a :: Int
a -> let b :: Int
b = Int -> Int
f Int
a in (Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
b, Int
b))
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GInfo -> IO ()
exitGInfo GInfo
gi
exitGInfo :: GInfo -> IO ()
exitGInfo :: GInfo -> IO ()
exitGInfo gi :: GInfo
gi = MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (GInfo -> MVar ()
exitMVar GInfo
gi) ()
type ConvFunc = GInfo -> String -> LibFunc -> IO ()
type LibFunc = GInfo -> IO ()
type DaVinciGraphTypeSyn =
Graph DaVinciGraph
DaVinciGraphParms
DaVinciNode
DaVinciNodeType
DaVinciNodeTypeParms
DaVinciArc
DaVinciArcType
DaVinciArcTypeParms
data Colors = Black
| Blue
| Coral
| Green
| Yellow
| Purple
deriving (Colors -> Colors -> Bool
(Colors -> Colors -> Bool)
-> (Colors -> Colors -> Bool) -> Eq Colors
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Colors -> Colors -> Bool
$c/= :: Colors -> Colors -> Bool
== :: Colors -> Colors -> Bool
$c== :: Colors -> Colors -> Bool
Eq, Eq Colors
Eq Colors =>
(Colors -> Colors -> Ordering)
-> (Colors -> Colors -> Bool)
-> (Colors -> Colors -> Bool)
-> (Colors -> Colors -> Bool)
-> (Colors -> Colors -> Bool)
-> (Colors -> Colors -> Colors)
-> (Colors -> Colors -> Colors)
-> Ord Colors
Colors -> Colors -> Bool
Colors -> Colors -> Ordering
Colors -> Colors -> Colors
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Colors -> Colors -> Colors
$cmin :: Colors -> Colors -> Colors
max :: Colors -> Colors -> Colors
$cmax :: Colors -> Colors -> Colors
>= :: Colors -> Colors -> Bool
$c>= :: Colors -> Colors -> Bool
> :: Colors -> Colors -> Bool
$c> :: Colors -> Colors -> Bool
<= :: Colors -> Colors -> Bool
$c<= :: Colors -> Colors -> Bool
< :: Colors -> Colors -> Bool
$c< :: Colors -> Colors -> Bool
compare :: Colors -> Colors -> Ordering
$ccompare :: Colors -> Colors -> Ordering
$cp1Ord :: Eq Colors
Ord, Int -> Colors -> String -> String
[Colors] -> String -> String
Colors -> String
(Int -> Colors -> String -> String)
-> (Colors -> String)
-> ([Colors] -> String -> String)
-> Show Colors
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Colors] -> String -> String
$cshowList :: [Colors] -> String -> String
show :: Colors -> String
$cshow :: Colors -> String
showsPrec :: Int -> Colors -> String -> String
$cshowsPrec :: Int -> Colors -> String -> String
Show)
emptyGInfo :: IO GInfo
emptyGInfo :: IO GInfo
emptyGInfo = do
IORef IntState
intSt <- IntState -> IO (IORef IntState)
forall a. a -> IO (IORef a)
newIORef IntState
emptyIntState
GraphInfo
gi <- IO GraphInfo
initGraph
IORef (Map LibName GInfo)
oGraphs <- Map LibName GInfo -> IO (IORef (Map LibName GInfo))
forall a. a -> IO (IORef a)
newIORef Map LibName GInfo
forall k a. Map k a
Map.empty
IORef [(String, (String -> String) -> IO ())]
iorIN <- [(String, (String -> String) -> IO ())]
-> IO (IORef [(String, (String -> String) -> IO ())])
forall a. a -> IO (IORef a)
newIORef []
IORef Flags
flags <- Flags -> IO (IORef Flags)
forall a. a -> IO (IORef a)
newIORef Flags :: Bool -> Bool -> Bool -> Flags
Flags { flagHideNodes :: Bool
flagHideNodes = Bool
True
, flagHideEdges :: Bool
flagHideEdges = Bool
True
, flagHideNames :: Bool
flagHideNames = Bool
True }
MVar ()
gl <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
MVar ()
fl <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
MVar ()
exit <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
MVar ()
lgl <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
MVar Int
wc <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar 0
GInfo -> IO GInfo
forall (m :: * -> *) a. Monad m => a -> m a
return GInfo :: IORef IntState
-> HetcatsOpts
-> MVar Int
-> MVar ()
-> MVar ()
-> MVar ()
-> MVar ()
-> IORef (Map LibName GInfo)
-> LibName
-> GraphInfo
-> IORef [(String, (String -> String) -> IO ())]
-> IORef Flags
-> GInfo
GInfo {
intState :: IORef IntState
intState = IORef IntState
intSt
, hetcatsOpts :: HetcatsOpts
hetcatsOpts = HetcatsOpts
defaultHetcatsOpts
, windowCount :: MVar Int
windowCount = MVar Int
wc
, exitMVar :: MVar ()
exitMVar = MVar ()
exit
, globalLock :: MVar ()
globalLock = MVar ()
gl
, functionLock :: MVar ()
functionLock = MVar ()
fl
, libGraphLock :: MVar ()
libGraphLock = MVar ()
lgl
, openGraphs :: IORef (Map LibName GInfo)
openGraphs = IORef (Map LibName GInfo)
oGraphs
, libName :: LibName
libName = IRI -> LibName
iriLibName IRI
nullIRI
, graphInfo :: GraphInfo
graphInfo = GraphInfo
gi
, internalNames :: IORef [(String, (String -> String) -> IO ())]
internalNames = IORef [(String, (String -> String) -> IO ())]
iorIN
, options :: IORef Flags
options = IORef Flags
flags
}
copyGInfo :: GInfo -> LibName -> IO GInfo
copyGInfo :: GInfo -> LibName -> IO GInfo
copyGInfo gInfo :: GInfo
gInfo ln :: LibName
ln = do
GraphInfo
gi <- IO GraphInfo
initGraph
IORef [(String, (String -> String) -> IO ())]
iorIN <- [(String, (String -> String) -> IO ())]
-> IO (IORef [(String, (String -> String) -> IO ())])
forall a. a -> IO (IORef a)
newIORef []
IORef Flags
flags <- Flags -> IO (IORef Flags)
forall a. a -> IO (IORef a)
newIORef Flags :: Bool -> Bool -> Bool -> Flags
Flags { flagHideNodes :: Bool
flagHideNodes = Bool
True
, flagHideEdges :: Bool
flagHideEdges = Bool
True
, flagHideNames :: Bool
flagHideNames = Bool
True }
let gInfo' :: GInfo
gInfo' = GInfo
gInfo { libName :: LibName
libName = LibName
ln
, graphInfo :: GraphInfo
graphInfo = GraphInfo
gi
, internalNames :: IORef [(String, (String -> String) -> IO ())]
internalNames = IORef [(String, (String -> String) -> IO ())]
iorIN
, options :: IORef Flags
options = IORef Flags
flags
}
ogs :: IORef (Map LibName GInfo)
ogs = GInfo -> IORef (Map LibName GInfo)
openGraphs GInfo
gInfo
Map LibName GInfo
oGraphs <- IORef (Map LibName GInfo) -> IO (Map LibName GInfo)
forall a. IORef a -> IO a
readIORef IORef (Map LibName GInfo)
ogs
IORef (Map LibName GInfo) -> Map LibName GInfo -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Map LibName GInfo)
ogs (Map LibName GInfo -> IO ()) -> Map LibName GInfo -> IO ()
forall a b. (a -> b) -> a -> b
$ LibName -> GInfo -> Map LibName GInfo -> Map LibName GInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert LibName
ln GInfo
gInfo' Map LibName GInfo
oGraphs
GInfo -> IO GInfo
forall (m :: * -> *) a. Monad m => a -> m a
return GInfo
gInfo'
lockGlobal :: GInfo -> IO ()
lockGlobal :: GInfo -> IO ()
lockGlobal gi :: GInfo
gi = MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (GInfo -> MVar ()
globalLock GInfo
gi) ()
unlockGlobal :: GInfo -> IO ()
unlockGlobal :: GInfo -> IO ()
unlockGlobal gi :: GInfo
gi =
MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar (GInfo -> MVar ()
globalLock GInfo
gi) IO (Maybe ()) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
colors :: Map.Map (Colors, Bool, Bool) (String, String)
colors :: Map (Colors, Bool, Bool) (String, String)
colors = [((Colors, Bool, Bool), (String, String))]
-> Map (Colors, Bool, Bool) (String, String)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ ((Colors
Black, Bool
False, Bool
False), ("gray0", "gray0" ))
, ((Colors
Black, Bool
False, Bool
True ), ("gray30", "gray5" ))
, ((Colors
Blue, Bool
False, Bool
False), ("RoyalBlue3", "gray20"))
, ((Colors
Blue, Bool
False, Bool
True ), ("RoyalBlue1", "gray23"))
, ((Colors
Blue, Bool
True, Bool
False), ("SteelBlue3", "gray27"))
, ((Colors
Blue, Bool
True, Bool
True ), ("SteelBlue1", "gray30"))
, ((Colors
Coral, Bool
False, Bool
False), ("coral3", "gray40"))
, ((Colors
Coral, Bool
False, Bool
True ), ("coral1", "gray43"))
, ((Colors
Coral, Bool
True, Bool
False), ("LightSalmon2", "gray47"))
, ((Colors
Coral, Bool
True, Bool
True ), ("LightSalmon", "gray50"))
, ((Colors
Green, Bool
False, Bool
False), ("MediumSeaGreen", "gray60"))
, ((Colors
Green, Bool
False, Bool
True ), ("PaleGreen3", "gray63"))
, ((Colors
Green, Bool
True, Bool
False), ("PaleGreen2", "gray67"))
, ((Colors
Green, Bool
True, Bool
True ), ("LightGreen", "gray70"))
, ((Colors
Purple, Bool
False, Bool
False), ("purple2", "gray74"))
, ((Colors
Yellow, Bool
False, Bool
False), ("gold", "gray78"))
, ((Colors
Yellow, Bool
False, Bool
True ), ("yellow", "gray81"))
, ((Colors
Yellow, Bool
True, Bool
False), ("LightGoldenrod3", "gray85"))
, ((Colors
Yellow, Bool
True, Bool
True ), ("LightGoldenrod", "gray88"))
]
getColor :: HetcatsOpts
-> Colors
-> Bool
-> Bool
-> String
getColor :: HetcatsOpts -> Colors -> Bool -> Bool -> String
getColor opts :: HetcatsOpts
opts c :: Colors
c v :: Bool
v l :: Bool
l = case (Colors, Bool, Bool)
-> Map (Colors, Bool, Bool) (String, String)
-> Maybe (String, String)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Colors
c, Bool
v, Bool
l) Map (Colors, Bool, Bool) (String, String)
colors of
Just (cname :: String
cname, gname :: String
gname) -> if HetcatsOpts -> Bool
uncolored HetcatsOpts
opts then String
gname else String
cname
Nothing -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "Color not defined: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
v then "alternative " else "")
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
l then "light " else "")
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Colors -> String
forall a. Show a => a -> String
show Colors
c