GraphTypes.hs revision c745add71930134bc085a544783213179bd3e734
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterModule : $Header$
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterDescription : Types for the Central GUI of Hets
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterCopyright : (c) Jorina Freya Gerken, Till Mossakowski, Uni Bremen 2002-2006
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterMaintainer : till@informatik.uni-bremen.de
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterStability : provisional
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterPortability : non-portable (imports Logic)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , InternalNames(..)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , DaVinciGraphTypeSyn
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , Colors(..)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , emptyGInfo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , lockGlobal
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , tryLockGlobal
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , unlockGlobal
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , mergeHistoryLast2Entries
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterimport GUI.GraphAbstraction(GraphInfo, initgraphs)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- import GUI.History(CommandHistory, emptyCommandHistory)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterimport Common.Id(nullRange)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterimport Driver.Options(HetcatsOpts(uncolored), defaultHetcatsOpts)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterimport qualified Data.Map as Map
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterdata InternalNames = InternalNames
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster { showNames :: Bool
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , updater :: [(String,(String -> String) -> IO ())]
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- | Global datatype for all GUI functions
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterdata GInfo = GInfo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster intState :: IORef IntState
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , gi_hetcatsOpts :: HetcatsOpts
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , windowCount :: MVar Integer
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , exitMVar :: MVar ()
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , globalLock :: MVar ()
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , functionLock :: MVar ()
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , libGraphLock :: MVar ()
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , openGraphs :: IORef (Map.Map LIB_NAME GInfo)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , gi_GraphInfo :: GraphInfo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , internalNamesIORef :: IORef InternalNames
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , proofGUIMVar :: GUIMVar
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster{- | Type of the convertGraph function. Used as type of a parameter of some
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster functions in GraphMenu and GraphLogic. -}
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fostertype ConvFunc = GInfo -> String -> LibFunc -> IO ()
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fostertype LibFunc = GInfo -> IO ()
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fostertype DaVinciGraphTypeSyn =
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster Graph DaVinciGraph
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster DaVinciGraphParms
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster DaVinciNodeType
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster DaVinciNodeTypeParms
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster DaVinciArcType
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster DaVinciArcTypeParms
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- | Colors to use.
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterdata Colors = Black
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster deriving (Eq, Ord, Show)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- | Creates an empty GInfo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosteremptyGInfo :: IO GInfo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosteremptyGInfo = do
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster let ihist = IntHistory {
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster undoList = [],
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster redoList = [] }
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster istate = emptyIntIState emptyLibEnv $ Lib_id $ Indirect_link
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster "" nullRange "" noTime
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster st = IntState {
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster i_state = Just istate,
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster i_hist = ihist,
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster filename = []}
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster intSt <- newIORef st
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster graphInfo <- initgraphs
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster oGraphs <- newIORef Map.empty
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster iorIN <- newIORef $ InternalNames False []
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster guiMVar <- newEmptyMVar
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster gl <- newEmptyMVar
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster fl <- newEmptyMVar
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster exit <- newEmptyMVar
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster lgl <- newEmptyMVar
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster wc <- newMVar 0
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster return $ GInfo { intState = intSt
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , gi_GraphInfo = graphInfo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , internalNamesIORef = iorIN
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , gi_hetcatsOpts = defaultHetcatsOpts
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , proofGUIMVar = guiMVar
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , windowCount = wc
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , exitMVar = exit
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , globalLock = gl
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , functionLock = fl
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , libGraphLock = lgl
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , openGraphs = oGraphs
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- | Creates an empty GInfo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostercopyGInfo :: GInfo -> LIB_NAME -> IO GInfo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostercopyGInfo gInfo newLN = do
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster graphInfo <- initgraphs
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster iorIN <- newIORef $ InternalNames False []
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster guiMVar <- newEmptyMVar
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster intSt <- readIORef $ intState gInfo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster let intSt' = intSt {
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster i_state = case i_state intSt of
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster Nothing -> Nothing
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster Just st -> Just $ st {
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster i_ln = newLN}
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster writeIORef (intState gInfo) $ intSt'
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster let gInfo' = gInfo { gi_GraphInfo = graphInfo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , internalNamesIORef = iorIN
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , proofGUIMVar = guiMVar
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster oGraphs <- readIORef $ openGraphs gInfo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster writeIORef (openGraphs gInfo) $ Map.insert newLN gInfo' oGraphs
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster return gInfo'
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster{- | Acquire the global lock. If already locked it waits till it is unlocked
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterlockGlobal :: GInfo -> IO ()
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterlockGlobal (GInfo { globalLock = lock }) = putMVar lock ()
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- | Tries to acquire the global lock. Return False if already acquired.
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostertryLockGlobal :: GInfo -> IO Bool
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostertryLockGlobal (GInfo { globalLock = lock }) = tryPutMVar lock ()
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- | Releases the global lock.
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterunlockGlobal :: GInfo -> IO ()
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterunlockGlobal (GInfo { globalLock = lock }) = do
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster unlocked <- tryTakeMVar lock
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster case unlocked of
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster Just () -> return ()
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster Nothing -> error "Global lock wasn't locked."
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- | Generates the colortable
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fostercolors :: Map.Map (Colors, Bool, Bool) (String, String)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster [ ((Black, False, False), ("gray0", "gray0" ))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Black, False, True ), ("gray30", "gray5" ))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Blue, False, False), ("RoyalBlue3", "gray20"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Blue, False, True ), ("RoyalBlue1", "gray23"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Blue, True, False), ("SteelBlue3", "gray27"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Blue, True, True ), ("SteelBlue1", "gray30"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Coral, False, False), ("coral3", "gray40"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Coral, False, True ), ("coral1", "gray43"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Coral, True, False), ("LightSalmon2", "gray47"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Coral, True, True ), ("LightSalmon", "gray50"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Green, False, False), ("MediumSeaGreen", "gray60"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Green, False, True ), ("PaleGreen3", "gray63"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Green, True, False), ("PaleGreen2", "gray67"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Green, True, True ), ("LightGreen", "gray70"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Yellow, False, False), ("gold2", "gray78"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Yellow, False, True ), ("gold", "gray81"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Khaki, False, False), ("LightGoldenrod3", "gray85"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , ((Khaki, False, True ), ("LightGoldenrod", "gray88"))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- | Converts colors to grayscale if needed
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostergetColor :: HetcatsOpts
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster -> Colors -- ^ Colorname
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster -> Bool -- ^ Colorvariant
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster -> Bool -- ^ Lightvariant
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostergetColor opts c v l = case Map.lookup (c, v, l) colors of
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster Just (cname, gname) -> if uncolored opts then gname else cname
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster Nothing -> error $ "Color not defined: "
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster ++ (if v then "alternative " else "")
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster ++ (if l then "light " else "")
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- combine last two history entries into one entry (both steps are undone
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- in one call
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostermergeHistoryLast2Entries :: GInfo -> IO ()
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostermergeHistoryLast2Entries gInfo = do
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster ost <- readIORef $ intState gInfo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster let ulst = undoList $ i_hist ost
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster case ulst of
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster let z = Int_CmdHistoryDescription {
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster cmdName = (cmdName x) ++ "\n"++ (cmdName y),
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster cmdDescription = (cmdDescription x) ++
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster (cmdDescription y) }
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster i_hist = (i_hist ost) {
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster undoList = z:m
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster writeIORef (intState gInfo) nwst
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster _ -> return ()