content: {- |
  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
               { flagHideNodes :: Bool
               , flagHideEdges :: Bool
               , flagHideNames :: Bool
               }
  
  -- | Global datatype for all GUI functions
  data GInfo = GInfo
               { -- Global
                 intState :: IORef IntState
               , hetcatsOpts :: HetcatsOpts
               , windowCount :: MVar Int
               , exitMVar :: MVar ()
               , globalLock :: MVar ()
               , functionLock :: MVar ()
               , libGraphLock :: MVar ()
               , openGraphs :: IORef (Map.Map LibName GInfo)
                 -- Local
               , libName :: LibName
               , graphInfo :: GraphInfo
               , internalNames :: IORef [(String, (String -> String) -> IO ())]
               , options :: IORef Flags
               }
  
  updateWindowCount :: GInfo -> (Int -> Int) -> IO ()
  updateWindowCount gi f = do
    c <- modifyMVar (windowCount gi) (\ a -> let b = f a in return (b, b))
    when (c <= 0) $ exitGInfo gi
  
  -- | Returns the exit-function
  exitGInfo :: GInfo -> IO ()
  exitGInfo gi = putMVar (exitMVar 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 (Eq, Ord, Show)
  
  -- | Creates an empty GInfo
  emptyGInfo :: IO GInfo
  emptyGInfo = do
    intSt <- newIORef emptyIntState
    gi <- initGraph
    oGraphs <- newIORef Map.empty
    iorIN <- newIORef []
    flags <- newIORef Flags { flagHideNodes = True
                            , flagHideEdges = True
                            , flagHideNames = True }
    gl <- newEmptyMVar
    fl <- newEmptyMVar
    exit <- newEmptyMVar
    lgl <- newEmptyMVar
    wc <- newMVar 0
    return GInfo { -- Global
                   intState = intSt
                 , hetcatsOpts = defaultHetcatsOpts
                 , windowCount = wc
                 , exitMVar = exit
                 , globalLock = gl
                 , functionLock = fl
                 , libGraphLock = lgl
                 , openGraphs = oGraphs
                   -- Local
                 , libName = iriLibName nullIRI
                 , graphInfo = gi
                 , internalNames = iorIN
                 , options = flags
                 }
  
  -- | Creates an empty GInfo
  copyGInfo :: GInfo -> LibName -> IO GInfo
  copyGInfo gInfo ln = do
    gi <- initGraph
    iorIN <- newIORef []
    flags <- newIORef Flags { flagHideNodes = True
                            , flagHideEdges = True
                            , flagHideNames = True }
    -- Change local parts
    let gInfo' = gInfo { libName = ln
                       , graphInfo = gi
                       , internalNames = iorIN
                       , options = flags
                       }
        ogs = openGraphs gInfo
    oGraphs <- readIORef ogs
    writeIORef ogs $ Map.insert ln gInfo' oGraphs
    return gInfo'
  
  {- | Acquire the global lock. If already locked it waits till it is unlocked
       again. -}
  lockGlobal :: GInfo -> IO ()
  lockGlobal gi = putMVar (globalLock gi) ()
  
  -- | Releases the global lock.
  unlockGlobal :: GInfo -> IO ()
  unlockGlobal gi =
    tryTakeMVar (globalLock gi) >> return ()
  
  -- | Generates the colortable
  colors :: Map.Map (Colors, Bool, Bool) (String, String)
  colors = Map.fromList
    [ ((Black, False, False), ("gray0", "gray0" ))
    , ((Black, False, True ), ("gray30", "gray5" ))
    , ((Blue, False, False), ("RoyalBlue3", "gray20"))
    , ((Blue, False, True ), ("RoyalBlue1", "gray23"))
    , ((Blue, True, False), ("SteelBlue3", "gray27"))
    , ((Blue, True, True ), ("SteelBlue1", "gray30"))
    , ((Coral, False, False), ("coral3", "gray40"))
    , ((Coral, False, True ), ("coral1", "gray43"))
    , ((Coral, True, False), ("LightSalmon2", "gray47"))
    , ((Coral, True, True ), ("LightSalmon", "gray50"))
    , ((Green, False, False), ("MediumSeaGreen", "gray60"))
    , ((Green, False, True ), ("PaleGreen3", "gray63"))
    , ((Green, True, False), ("PaleGreen2", "gray67"))
    , ((Green, True, True ), ("LightGreen", "gray70"))
    , ((Purple, False, False), ("purple2", "gray74"))
    , ((Yellow, False, False), ("gold", "gray78"))
    , ((Yellow, False, True ), ("yellow", "gray81"))
    , ((Yellow, True, False), ("LightGoldenrod3", "gray85"))
    , ((Yellow, True, True ), ("LightGoldenrod", "gray88"))
    ]
  
  -- | Converts colors to grayscale if needed
  getColor :: HetcatsOpts
           -> Colors -- ^ Colorname
           -> Bool -- ^ Colorvariant
           -> Bool -- ^ Lightvariant
           -> String
  getColor opts c v l = case Map.lookup (c, v, l) colors of
    Just (cname, gname) -> if uncolored opts then gname else cname
    Nothing -> error $ "Color not defined: "
                    ++ (if v then "alternative " else "")
                    ++ (if l then "light " else "")
                    ++ show c
  