{- |

Module : $Header$

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(..)

, closeGInfo

, exitGInfo

, ConvFunc

, LibFunc

, DaVinciGraphTypeSyn

, Colors(..)

, Flags(..)

, getColor

, emptyGInfo

, copyGInfo

, lockGlobal

, tryLockGlobal

, unlockGlobal

) where

import GUI.GraphAbstraction(GraphInfo, initGraph)

import GUI.UDGUtils

import Common.LibName

import Driver.Options(HetcatsOpts(uncolored), defaultHetcatsOpts)

import Data.IORef

import qualified Data.Map as Map

import Control.Concurrent.MVar

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 Integer

, 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

}

closeGInfo :: GInfo -> IO Bool

closeGInfo GInfo

{ exitMVar = exit'

, windowCount = wc

, libGraphLock = lock

} = do

count <- takeMVar wc

if count <= 1

then putMVar exit' ()

else do

putMVar wc $ count - 1

takeMVar lock

return True

exitGInfo :: GInfo -> IO ()

exitGInfo GInfo {exitMVar = exit'} = putMVar exit' ()

{- | 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 = emptyLibName ""

, 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

}

oGraphs <- readIORef $ openGraphs gInfo

writeIORef (openGraphs gInfo) $ 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 (GInfo { globalLock = lock }) = putMVar lock ()

-- | Tries to acquire the global lock. Return False if already acquired.

tryLockGlobal :: GInfo -> IO Bool

tryLockGlobal (GInfo { globalLock = lock }) = tryPutMVar lock ()

-- | Releases the global lock.

unlockGlobal :: GInfo -> IO ()

unlockGlobal (GInfo { globalLock = lock }) = do

unlocked <- tryTakeMVar lock

case unlocked of

Just () -> return ()

Nothing -> error "Global lock wasn't locked."

-- | 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