{- |
Module      :  ./GUI/GraphTypes.hs
Description :  Types for the Central GUI of Hets
Copyright   :  (c) Jorina Freya Gerken, Till Mossakowski, Uni Bremen 2002-2006
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  till@informatik.uni-bremen.de
Stability   :  provisional
Portability :  non-portable (imports Logic)
-}

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
             }

-- | Global datatype for all GUI functions
data GInfo = GInfo
             { -- Global
               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)
               -- Local
             , 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

-- | Returns the exit-function
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 of the convertGraph function. Used as type of a parameter of some
     functions in GraphMenu and GraphLogic. -}
type ConvFunc = GInfo -> String -> LibFunc -> IO ()

type LibFunc = GInfo -> IO ()

type DaVinciGraphTypeSyn =
     Graph DaVinciGraph
           DaVinciGraphParms
           DaVinciNode
           DaVinciNodeType
           DaVinciNodeTypeParms
           DaVinciArc
           DaVinciArcType
           DaVinciArcTypeParms

-- | Colors to use.
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)

-- | Creates an empty GInfo
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 { -- Global
                 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
                 -- Local
               , 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
               }

-- | Creates an empty GInfo
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 }
  -- Change local parts
  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'

{- | Acquire the global lock. If already locked it waits till it is unlocked
     again. -}
lockGlobal :: GInfo -> IO ()
lockGlobal :: GInfo -> IO ()
lockGlobal gi :: GInfo
gi = MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (GInfo -> MVar ()
globalLock GInfo
gi) ()

-- | Releases the global lock.
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 ()

-- | Generates the colortable
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"))
  ]

-- | Converts colors to grayscale if needed
getColor :: HetcatsOpts
         -> Colors -- ^ Colorname
         -> Bool -- ^ Colorvariant
         -> Bool -- ^ Lightvariant
         -> 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