graph-rewriting-gl-0.6.2: GraphRewriting/GL/Global.hs

module GraphRewriting.GL.Global where

import Graphics.UI.GLUT (addTimerCallback, Window, postRedisplay)
import GraphRewriting.Graph
import GraphRewriting.Graph.Read
import GraphRewriting.Rule
import GraphRewriting.Pattern
import Data.IORef
import GraphRewriting.Layout.RotPortSpec
import Data.Set as Set
import Data.List ((\\))
import Control.Monad

data GlobalVars n = GlobalVars
	{graph        ∷ Graph n,
	 paused       ∷ Bool,
	 selectedRule ∷ Rule n,
	 highlighted  ∷ Set Node,
	 layoutStep   ∷ Node → Rewrite n (),
	 canvas       ∷ Window}

redisplay ∷ Window → IO ()
redisplay = postRedisplay . Just

readGraph = liftM graph . readIORef
writeGraph g = modifyGraph (const g)

modifyGraph f globalVars = do
	modifyIORef globalVars $ \v → v {graph = f $ graph v}
	highlight globalVars

applyRule r globalVars = do
	layout ← liftM layoutStep $ readIORef globalVars
	g ← readGraph globalVars
	let ns = evalGraph readNodeList g
	-- we don't use the fist element of the tuple and compute newNodes ourselves due to a bug in the graph-rewriting package (It's completely out of my hands!!!!1)
	let (_, g') = runGraph (apply r) g
	let ns' = evalGraph readNodeList g'
	let newNodes = ns' Data.List.\\ ns
	writeGraph (execGraph (replicateM_ 15 $ mapM layout newNodes) g') globalVars

selectRule r globalVars = do
	modifyIORef globalVars $ \v → v {selectedRule = r}
	highlight globalVars

highlight globalVars = do
	gv@GlobalVars {graph = g, selectedRule = rule, highlighted = h, canvas = c} ← readIORef globalVars
	let h' = Set.fromList [head match | (match,rewrite) ← runPattern rule g]
	writeIORef globalVars $ gv {highlighted = h'}
	redisplay c

layoutLoop globalVars = do
	gv@GlobalVars {graph = g, paused = p, layoutStep = l, canvas = c} ← readIORef globalVars
	when (not p) $ do
		examine position (head $ nodes g) `seq` return ()
		writeIORef globalVars $ gv {graph = execGraph (mapM l =<< readNodeList) g}
		redisplay c
		addTimerCallback 40 $ layoutLoop globalVars

pause globalVars = modifyIORef globalVars $ \vs → vs {paused = True}

resume globalVars = do
	modifyIORef globalVars $ \vs → vs {paused = False}
	layoutLoop globalVars