module GraphRewriting.GL.Global where
import Prelude.Unicode
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 qualified Data.Set as Set
import Data.Set (Set)
import Data.List ((\\))
import Control.Monad (when, replicateM_)
import Data.Foldable
import Data.Functor
import Data.Traversable
import Prelude hiding (concat, concatMap, or, elem, foldr, any, mapM)
data GlobalVars n = GlobalVars
{graph ∷ Graph n,
paused ∷ Bool,
selectedRule ∷ Int,
highlighted ∷ Set Node,
layoutStep ∷ Node → Rewrite n (),
canvas ∷ Window,
menu ∷ Window,
getRules ∷ RuleTree n}
data LabelledTree a = Branch String [LabelledTree a] | Leaf String a
data LTZipper a = Root | Child String [LabelledTree a] (LTZipper a) [LabelledTree a]
type LTLoc a = (LabelledTree a, LTZipper a)
next ∷ LTLoc a → Maybe (LTLoc a)
next (Branch b (t:ts), p) = Just (t, Child b [] p ts)
next (Leaf l x, p) = right (Leaf l x, p)
next _ = Nothing
nth ∷ Int → LTLoc a → Maybe (LTLoc a)
nth n l = iterate (>>= next) (Just l) !! n
right ∷ LTLoc a → Maybe (LTLoc a)
right (t, Child c ls p (r:rs)) = Just (r, Child c (ls ⧺ [t]) p rs)
right (t, Child c ls p []) = up (t, Child c ls p []) >>= right
right _ = Nothing
up ∷ LTLoc a → Maybe (LTLoc a)
up (t, Child c ls p rs) = Just (Branch c (ls ⧺ [t] ⧺ rs), p)
up _ = Nothing
put ∷ LTLoc a → LabelledTree a → LTLoc a
put (_, p) t = (t, p)
top ∷ LTLoc a → LTLoc a
top (t, Root) = (t, Root)
top (t, Child c ls p rs) = top (Branch c (ls ⧺ [t] ⧺ rs), p)
root ∷ LabelledTree a → LTLoc a
root t = (t, Root)
instance Foldable LabelledTree where
foldr f y (Leaf l x) = f x y
foldr f y (Branch l ts) = foldr (flip $ foldr f) y ts
instance Functor LabelledTree where
fmap f (Leaf l x) = Leaf l (f x)
fmap f (Branch l ts) = Branch l $ fmap f <$> ts
instance Traversable LabelledTree where
traverse f (Leaf l x) = Leaf l <$> f x
traverse f (Branch l ts) = Branch l <$> traverse (traverse f) ts
showRuleTree ∷ RuleTree n → String
showRuleTree = showLabelledTree 2 0 (+) . fmap fst
showLabelledTree ∷ Show a ⇒ Int → a → (a → a → a) → LabelledTree a → String
showLabelledTree indentation init combine = snd . rec where
rec (Leaf l x) = (x, l ⧺ " " ⧺ show x)
rec (Branch l ts) = (x, l ⧺ " " ⧺ show x ⧺ "\n" ⧺ indent (unlines ls)) where
x = foldr combine init xs
(xs, ls) = unzip $ map rec ts
indent str = unlines $ map (replicate indentation ' ' ⧺) (lines str)
unlines [] = ""
unlines [x] = x
unlines xs = head xs ⧺ "\n" ⧺ unlines (tail xs)
instance Show a ⇒ Show (LabelledTree a) where
show (Leaf l x) = l ⧺ " " ⧺ show x
show (Branch l s) = l ⧺ "\n" ⧺ indent (unlines $ map show s) where
indent str = unlines $ map (replicate 2 ' ' ⧺) (lines str)
unlines [] = ""
unlines [x] = x
unlines xs = head xs ⧺ "\n" ⧺ unlines (tail xs)
redisplay ∷ Window → IO ()
redisplay = postRedisplay . Just
readGraph = fmap graph . readIORef
writeGraph g = modifyGraph (const g)
modifyGraph f globalVars = do
modifyIORef globalVars $ \v → v {graph = f $ graph v}
applyRule ∷ Rule n → IORef (GlobalVars n) → IO ()
applyRule r globalVars = do
layout ← layoutStep <$> readIORef globalVars
g ← readGraph globalVars
let ns = evalGraph readNodeList g
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
highlight globalVars
selectRule i globalVars = do
ruleListLength ← numNodes <$> getRules <$> readIORef globalVars
if 0 ≤ i ∧ i < ruleListLength
then do
modifyIORef globalVars $ \v → v {selectedRule = i}
highlight globalVars
else return ()
highlight globalVars = do
gv@GlobalVars {graph = g, getRules = rs, selectedRule = r, highlighted = h, canvas = c} ← readIORef globalVars
let rule = fold $ fmap snd (subtrees rs !! r)
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
subtrees ∷ LabelledTree a → [LabelledTree a]
subtrees t = t : case t of
Leaf _ _ → []
Branch l ts → concatMap subtrees ts
numNodes ∷ LabelledTree a → Int
numNodes = length . subtrees
type RuleTree n = LabelledTree (Int, Rule n)
applyLeafRules ∷ (Rule n → Rule n) → Int → IORef (GlobalVars n) → IO ()
applyLeafRules restriction idx gvs = do
g ← readGraph gvs
comptree ← getRules <$> readIORef gvs
let pos = nth idx (root comptree)
case pos of
Nothing → return ()
Just (tree,p) → do
let ns = evalGraph readNodeList g
let rule = restriction $ fold $ fmap snd tree
let ms = head $ evalPattern (matches rule) g
let ((_, g'), tree') = mapAccumL applyLeafRules' (ms, g) tree
let ns' = evalGraph readNodeList g'
let newNodes = ns' Data.List.\\ ns
layout ← layoutStep <$> readIORef gvs
writeGraph (execGraph (replicateM_ 15 (mapM layout newNodes)) g') gvs
modifyIORef gvs $ \x → x {getRules = fst $ top (tree',p)}
where
applyLeafRules' (matches, g) (n, r) = let
ms = runPattern r' g
r' = restrictOverlap (\past future → future `elem` matches) (restriction r)
in if null ms
then ((matches, g), (n, r))
else let
(match, rewrite) = head ms
g' = execGraph rewrite g
in applyLeafRules' (filter (\m → not $ any (`elem` match) m) matches, g') (n + 1, r)