{-# LANGUAGE FlexibleContexts #-}
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, unless, replicateM_)
import Data.Foldable
import Data.Functor
import Data.Traversable
import Prelude hiding (concat, concatMap, or, elem, foldr, any, mapM)


data GlobalVars n = GlobalVars
	{forall n. GlobalVars n -> Graph n
graph        ∷ Graph n,
	 forall n. GlobalVars n -> Bool
paused       ∷ Bool,
	 forall n. GlobalVars n -> Int
selectedRule ∷ Int,
	 forall n. GlobalVars n -> Set Node
highlighted  ∷ Set Node,
	 forall n. GlobalVars n -> Node -> Rewrite n ()
layoutStep   ∷ Node → Rewrite n (),
	 forall n. GlobalVars n -> Window
canvas       ∷ Window,
	 forall n. GlobalVars n -> Window
menu         ∷ Window,
	 forall n. GlobalVars n -> RuleTree n
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)

-- depth-first traversal
next ∷ LTLoc a → Maybe (LTLoc a)
next :: forall a. LTLoc a -> Maybe (LTLoc a)
next (Branch String
b (LabelledTree a
t:[LabelledTree a]
ts), LTZipper a
p) = (LabelledTree a, LTZipper a) -> Maybe (LabelledTree a, LTZipper a)
forall a. a -> Maybe a
Just (LabelledTree a
t, String
-> [LabelledTree a] -> LTZipper a -> [LabelledTree a] -> LTZipper a
forall a.
String
-> [LabelledTree a] -> LTZipper a -> [LabelledTree a] -> LTZipper a
Child String
b [] LTZipper a
p [LabelledTree a]
ts)
next (Leaf String
l a
x, LTZipper a
p) = (LabelledTree a, LTZipper a) -> Maybe (LabelledTree a, LTZipper a)
forall a. LTLoc a -> Maybe (LTLoc a)
right (String -> a -> LabelledTree a
forall a. String -> a -> LabelledTree a
Leaf String
l a
x, LTZipper a
p)
next (LabelledTree a, LTZipper a)
_ = Maybe (LabelledTree a, LTZipper a)
forall a. Maybe a
Nothing

nth ∷ Int → LTLoc a → Maybe (LTLoc a)
nth :: forall a. Int -> LTLoc a -> Maybe (LTLoc a)
nth Int
n LTLoc a
l = (Maybe (LTLoc a) -> Maybe (LTLoc a))
-> Maybe (LTLoc a) -> [Maybe (LTLoc a)]
forall a. (a -> a) -> a -> [a]
iterate (Maybe (LTLoc a) -> (LTLoc a -> Maybe (LTLoc a)) -> Maybe (LTLoc a)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LTLoc a -> Maybe (LTLoc a)
forall a. LTLoc a -> Maybe (LTLoc a)
next) (LTLoc a -> Maybe (LTLoc a)
forall a. a -> Maybe a
Just LTLoc a
l) [Maybe (LTLoc a)] -> Int -> Maybe (LTLoc a)
forall a. HasCallStack => [a] -> Int -> a
!! Int
n

right ∷ LTLoc a → Maybe (LTLoc a)
right :: forall a. LTLoc a -> Maybe (LTLoc a)
right (LabelledTree a
t, Child String
c [LabelledTree a]
ls LTZipper a
p (LabelledTree a
r:[LabelledTree a]
rs)) = (LabelledTree a, LTZipper a) -> Maybe (LabelledTree a, LTZipper a)
forall a. a -> Maybe a
Just (LabelledTree a
r, String
-> [LabelledTree a] -> LTZipper a -> [LabelledTree a] -> LTZipper a
forall a.
String
-> [LabelledTree a] -> LTZipper a -> [LabelledTree a] -> LTZipper a
Child String
c ([LabelledTree a]
ls [LabelledTree a] -> [LabelledTree a] -> [LabelledTree a]
forall α. [α] -> [α] -> [α]
⧺ [LabelledTree a
t]) LTZipper a
p [LabelledTree a]
rs)
right (LabelledTree a
t, Child String
c [LabelledTree a]
ls LTZipper a
p []) = (LabelledTree a, LTZipper a) -> Maybe (LabelledTree a, LTZipper a)
forall a. LTLoc a -> Maybe (LTLoc a)
up (LabelledTree a
t, String
-> [LabelledTree a] -> LTZipper a -> [LabelledTree a] -> LTZipper a
forall a.
String
-> [LabelledTree a] -> LTZipper a -> [LabelledTree a] -> LTZipper a
Child String
c [LabelledTree a]
ls LTZipper a
p []) Maybe (LabelledTree a, LTZipper a)
-> ((LabelledTree a, LTZipper a)
    -> Maybe (LabelledTree a, LTZipper a))
-> Maybe (LabelledTree a, LTZipper a)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LabelledTree a, LTZipper a) -> Maybe (LabelledTree a, LTZipper a)
forall a. LTLoc a -> Maybe (LTLoc a)
right
right (LabelledTree a, LTZipper a)
_ = Maybe (LabelledTree a, LTZipper a)
forall a. Maybe a
Nothing

up ∷ LTLoc a → Maybe (LTLoc a)
up :: forall a. LTLoc a -> Maybe (LTLoc a)
up (LabelledTree a
t, Child String
c [LabelledTree a]
ls LTZipper a
p [LabelledTree a]
rs) = (LabelledTree a, LTZipper a) -> Maybe (LabelledTree a, LTZipper a)
forall a. a -> Maybe a
Just (String -> [LabelledTree a] -> LabelledTree a
forall a. String -> [LabelledTree a] -> LabelledTree a
Branch String
c ([LabelledTree a]
ls [LabelledTree a] -> [LabelledTree a] -> [LabelledTree a]
forall α. [α] -> [α] -> [α]
⧺ [LabelledTree a
t] [LabelledTree a] -> [LabelledTree a] -> [LabelledTree a]
forall α. [α] -> [α] -> [α]
⧺ [LabelledTree a]
rs), LTZipper a
p)
up (LabelledTree a, LTZipper a)
_ = Maybe (LabelledTree a, LTZipper a)
forall a. Maybe a
Nothing

put ∷ LTLoc a → LabelledTree a → LTLoc a
put :: forall a. LTLoc a -> LabelledTree a -> LTLoc a
put (LabelledTree a
_, LTZipper a
p) LabelledTree a
t = (LabelledTree a
t, LTZipper a
p)

top ∷ LTLoc a → LTLoc a
top :: forall a. LTLoc a -> LTLoc a
top (LabelledTree a
t, LTZipper a
Root) = (LabelledTree a
t, LTZipper a
forall a. LTZipper a
Root)
top (LabelledTree a
t, Child String
c [LabelledTree a]
ls LTZipper a
p [LabelledTree a]
rs) = (LabelledTree a, LTZipper a) -> (LabelledTree a, LTZipper a)
forall a. LTLoc a -> LTLoc a
top (String -> [LabelledTree a] -> LabelledTree a
forall a. String -> [LabelledTree a] -> LabelledTree a
Branch String
c ([LabelledTree a]
ls [LabelledTree a] -> [LabelledTree a] -> [LabelledTree a]
forall α. [α] -> [α] -> [α]
⧺ [LabelledTree a
t] [LabelledTree a] -> [LabelledTree a] -> [LabelledTree a]
forall α. [α] -> [α] -> [α]
⧺ [LabelledTree a]
rs), LTZipper a
p)

root ∷ LabelledTree a → LTLoc a
root :: forall a. LabelledTree a -> LTLoc a
root LabelledTree a
t = (LabelledTree a
t, LTZipper a
forall a. LTZipper a
Root)

instance Foldable LabelledTree where
	foldr :: forall a b. (a -> b -> b) -> b -> LabelledTree a -> b
foldr a -> b -> b
f b
y (Leaf String
l a
x) = a -> b -> b
f a
x b
y
	foldr a -> b -> b
f b
y (Branch String
l [LabelledTree a]
ts) = (LabelledTree a -> b -> b) -> b -> [LabelledTree a] -> b
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((b -> LabelledTree a -> b) -> LabelledTree a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((b -> LabelledTree a -> b) -> LabelledTree a -> b -> b)
-> (b -> LabelledTree a -> b) -> LabelledTree a -> b -> b
forall a b. (a -> b) -> a -> b
$ (a -> b -> b) -> b -> LabelledTree a -> b
forall a b. (a -> b -> b) -> b -> LabelledTree a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
f) b
y [LabelledTree a]
ts

instance Functor LabelledTree where
	fmap :: forall a b. (a -> b) -> LabelledTree a -> LabelledTree b
fmap a -> b
f (Leaf String
l a
x) = String -> b -> LabelledTree b
forall a. String -> a -> LabelledTree a
Leaf String
l (a -> b
f a
x)
	fmap a -> b
f (Branch String
l [LabelledTree a]
ts) = String -> [LabelledTree b] -> LabelledTree b
forall a. String -> [LabelledTree a] -> LabelledTree a
Branch String
l ([LabelledTree b] -> LabelledTree b)
-> [LabelledTree b] -> LabelledTree b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> LabelledTree a -> LabelledTree b
forall a b. (a -> b) -> LabelledTree a -> LabelledTree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (LabelledTree a -> LabelledTree b)
-> [LabelledTree a] -> [LabelledTree b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LabelledTree a]
ts

instance Traversable LabelledTree where
	traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LabelledTree a -> f (LabelledTree b)
traverse a -> f b
f (Leaf String
l a
x) = String -> b -> LabelledTree b
forall a. String -> a -> LabelledTree a
Leaf String
l (b -> LabelledTree b) -> f b -> f (LabelledTree b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
	traverse a -> f b
f (Branch String
l [LabelledTree a]
ts) = String -> [LabelledTree b] -> LabelledTree b
forall a. String -> [LabelledTree a] -> LabelledTree a
Branch String
l ([LabelledTree b] -> LabelledTree b)
-> f [LabelledTree b] -> f (LabelledTree b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LabelledTree a -> f (LabelledTree b))
-> [LabelledTree a] -> f [LabelledTree b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((a -> f b) -> LabelledTree a -> f (LabelledTree b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LabelledTree a -> f (LabelledTree b)
traverse a -> f b
f) [LabelledTree a]
ts

showRuleTree ∷ RuleTree n → String
showRuleTree :: forall n. RuleTree n -> String
showRuleTree = Int -> Int -> (Int -> Int -> Int) -> LabelledTree Int -> String
forall a.
Show a =>
Int -> a -> (a -> a -> a) -> LabelledTree a -> String
showLabelledTree Int
2 Int
0 Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (LabelledTree Int -> String)
-> (RuleTree n -> LabelledTree Int) -> RuleTree n -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Rule n) -> Int) -> RuleTree n -> LabelledTree Int
forall a b. (a -> b) -> LabelledTree a -> LabelledTree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Rule n) -> Int
forall a b. (a, b) -> a
fst

showLabelledTree ∷ Show a ⇒ Int → a → (a → a → a) → LabelledTree a → String
showLabelledTree :: forall a.
Show a =>
Int -> a -> (a -> a -> a) -> LabelledTree a -> String
showLabelledTree Int
indentation a
init a -> a -> a
combine = (a, String) -> String
forall a b. (a, b) -> b
snd ((a, String) -> String)
-> (LabelledTree a -> (a, String)) -> LabelledTree a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelledTree a -> (a, String)
rec where

	rec :: LabelledTree a -> (a, String)
rec (Leaf String
l a
x) = (a
x, String
l String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ String
" " String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ a -> String
forall a. Show a => a -> String
show a
x)
	rec (Branch String
l [LabelledTree a]
ts) = (a
x, String
l String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ String
" " String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ String
"\n" String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ String -> String
indent ([String] -> String
unlines [String]
ls)) where
		x :: a
x = (a -> a -> a) -> a -> [a] -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> a -> a
combine a
init [a]
xs
		([a]
xs, [String]
ls) = [(a, String)] -> ([a], [String])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(a, String)] -> ([a], [String]))
-> [(a, String)] -> ([a], [String])
forall a b. (a -> b) -> a -> b
$ (LabelledTree a -> (a, String))
-> [LabelledTree a] -> [(a, String)]
forall a b. (a -> b) -> [a] -> [b]
map LabelledTree a -> (a, String)
rec [LabelledTree a]
ts

	indent :: String -> String
indent String
str = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
indentation Char
' ' String -> String -> String
forall α. [α] -> [α] -> [α]
⧺) (String -> [String]
lines String
str)

	unlines :: [String] -> String
unlines [] = String
""
	unlines [String
x] = String
x
	unlines [String]
xs = [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
xs String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ String
"\n" String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ [String] -> String
unlines ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail [String]
xs)

instance Show a ⇒ Show (LabelledTree a) where
	show :: LabelledTree a -> String
show (Leaf   String
l a
x) = String
l String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ String
" " String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ a -> String
forall a. Show a => a -> String
show a
x
	show (Branch String
l [LabelledTree a]
s) = String
l String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ String
"\n" String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ String -> String
indent ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (LabelledTree a -> String) -> [LabelledTree a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map LabelledTree a -> String
forall a. Show a => a -> String
show [LabelledTree a]
s) where
			indent :: String -> String
indent String
str = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
2 Char
' ' String -> String -> String
forall α. [α] -> [α] -> [α]
⧺) (String -> [String]
lines String
str)
			unlines :: [String] -> String
unlines [] = String
""
			unlines [String
x] = String
x
			unlines [String]
xs = [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
xs String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ String
"\n" String -> String -> String
forall α. [α] -> [α] -> [α]
⧺ [String] -> String
unlines ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail [String]
xs)

redisplay ∷ Window → IO ()
redisplay :: Window -> IO ()
redisplay = Maybe Window -> IO ()
forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
postRedisplay (Maybe Window -> IO ())
-> (Window -> Maybe Window) -> Window -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> Maybe Window
forall a. a -> Maybe a
Just

readGraph :: IORef (GlobalVars n) -> IO (Graph n)
readGraph = (GlobalVars n -> Graph n) -> IO (GlobalVars n) -> IO (Graph n)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GlobalVars n -> Graph n
forall n. GlobalVars n -> Graph n
graph (IO (GlobalVars n) -> IO (Graph n))
-> (IORef (GlobalVars n) -> IO (GlobalVars n))
-> IORef (GlobalVars n)
-> IO (Graph n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef
writeGraph :: Graph n -> IORef (GlobalVars n) -> IO ()
writeGraph Graph n
g = (Graph n -> Graph n) -> IORef (GlobalVars n) -> IO ()
forall {n}. (Graph n -> Graph n) -> IORef (GlobalVars n) -> IO ()
modifyGraph (Graph n -> Graph n -> Graph n
forall a b. a -> b -> a
const Graph n
g)

modifyGraph :: (Graph n -> Graph n) -> IORef (GlobalVars n) -> IO ()
modifyGraph Graph n -> Graph n
f IORef (GlobalVars n)
globalVars = do
	IORef (GlobalVars n) -> (GlobalVars n -> GlobalVars n) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (GlobalVars n)
globalVars ((GlobalVars n -> GlobalVars n) -> IO ())
-> (GlobalVars n -> GlobalVars n) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GlobalVars n
v → GlobalVars n
v {graph = f $ graph v}

applyRule ∷ Rule n → IORef (GlobalVars n) → IO ()
applyRule :: forall n. Rule n -> IORef (GlobalVars n) -> IO ()
applyRule Rule n
r IORef (GlobalVars n)
globalVars = do
	Node -> Rewrite n ()
layout ← GlobalVars n -> Node -> Rewrite n ()
forall n. GlobalVars n -> Node -> Rewrite n ()
layoutStep (GlobalVars n -> Node -> Rewrite n ())
-> IO (GlobalVars n) -> IO (Node -> Rewrite n ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
	Graph n
g ← IORef (GlobalVars n) -> IO (Graph n)
forall {n}. IORef (GlobalVars n) -> IO (Graph n)
readGraph IORef (GlobalVars n)
globalVars
	let ns :: [Node]
ns = Rewrite n [Node] -> Graph n -> [Node]
forall n a. Rewrite n a -> Graph n -> a
evalGraph Rewrite n [Node]
forall n (m :: * -> *). MonadReader (Graph n) m => m [Node]
readNodeList Graph n
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 (()
_, Graph n
g') = Rewrite n () -> Graph n -> ((), Graph n)
forall n a. Rewrite n a -> Graph n -> (a, Graph n)
runGraph (Rule n -> Rewrite n ()
forall n. Rule n -> Rewrite n ()
apply Rule n
r) Graph n
g
	let ns' :: [Node]
ns' = Rewrite n [Node] -> Graph n -> [Node]
forall n a. Rewrite n a -> Graph n -> a
evalGraph Rewrite n [Node]
forall n (m :: * -> *). MonadReader (Graph n) m => m [Node]
readNodeList Graph n
g'
	let newNodes :: [Node]
newNodes = [Node]
ns' [Node] -> [Node] -> [Node]
forall a. Eq a => [a] -> [a] -> [a]
Data.List.\\ [Node]
ns
	Graph n -> IORef (GlobalVars n) -> IO ()
forall {n}. Graph n -> IORef (GlobalVars n) -> IO ()
writeGraph (Rewrite n () -> Graph n -> Graph n
forall n a. Rewrite n a -> Graph n -> Graph n
execGraph (Int -> Rewrite n [()] -> Rewrite n ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
15 (Rewrite n [()] -> Rewrite n ()) -> Rewrite n [()] -> Rewrite n ()
forall a b. (a -> b) -> a -> b
$ (Node -> Rewrite n ()) -> [Node] -> Rewrite n [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Node -> Rewrite n ()
layout [Node]
newNodes) Graph n
g') IORef (GlobalVars n)
globalVars
	IORef (GlobalVars n) -> IO ()
forall {n}. IORef (GlobalVars n) -> IO ()
highlight IORef (GlobalVars n)
globalVars

selectRule :: Int -> IORef (GlobalVars n) -> IO ()
selectRule Int
i IORef (GlobalVars n)
globalVars = do
	Int
ruleListLength ← LabelledTree (Int, Rule n) -> Int
forall a. LabelledTree a -> Int
numNodes (LabelledTree (Int, Rule n) -> Int)
-> (GlobalVars n -> LabelledTree (Int, Rule n))
-> GlobalVars n
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalVars n -> LabelledTree (Int, Rule n)
forall n. GlobalVars n -> RuleTree n
getRules (GlobalVars n -> Int) -> IO (GlobalVars n) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
	Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
0 Int -> Int -> Bool
forall α. Ord α => α -> α -> Bool
≤ Int
i Bool -> Bool -> Bool
∧ Int
i Int -> Int -> Bool
forall α. Ord α => α -> α -> Bool
< Int
ruleListLength) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
		IORef (GlobalVars n) -> (GlobalVars n -> GlobalVars n) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (GlobalVars n)
globalVars ((GlobalVars n -> GlobalVars n) -> IO ())
-> (GlobalVars n -> GlobalVars n) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GlobalVars n
v → GlobalVars n
v {selectedRule = i}
		IORef (GlobalVars n) -> IO ()
forall {n}. IORef (GlobalVars n) -> IO ()
highlight IORef (GlobalVars n)
globalVars

highlight :: IORef (GlobalVars n) -> IO ()
highlight IORef (GlobalVars n)
globalVars = do
	gv :: GlobalVars n
gv@GlobalVars {graph :: forall n. GlobalVars n -> Graph n
graph = Graph n
g, getRules :: forall n. GlobalVars n -> RuleTree n
getRules = RuleTree n
rs, selectedRule :: forall n. GlobalVars n -> Int
selectedRule = Int
r, highlighted :: forall n. GlobalVars n -> Set Node
highlighted = Set Node
h, canvas :: forall n. GlobalVars n -> Window
canvas = Window
c} ← IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
	let rule :: Rule n
rule = ((Int, Rule n) -> Rule n) -> RuleTree n -> Rule n
forall m a. Monoid m => (a -> m) -> LabelledTree a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int, Rule n) -> Rule n
forall a b. (a, b) -> b
snd (RuleTree n -> [RuleTree n]
forall a. LabelledTree a -> [LabelledTree a]
subtrees RuleTree n
rs [RuleTree n] -> Int -> RuleTree n
forall a. HasCallStack => [a] -> Int -> a
!! Int
r)
	let h' :: Set Node
h' = [Node] -> Set Node
forall a. Ord a => [a] -> Set a
Set.fromList [[Node] -> Node
forall a. HasCallStack => [a] -> a
head [Node]
match | ([Node]
match,Rewrite n ()
rewrite) ← Rule n -> Graph n -> [([Node], Rewrite n ())]
forall n a. Pattern n a -> Graph n -> [([Node], a)]
runPattern Rule n
rule Graph n
g]
	IORef (GlobalVars n) -> GlobalVars n -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (GlobalVars n)
globalVars (GlobalVars n -> IO ()) -> GlobalVars n -> IO ()
forall a b. (a -> b) -> a -> b
$ GlobalVars n
gv {highlighted = h'}
	Window -> IO ()
redisplay Window
c

layoutLoop :: IORef (GlobalVars n) -> IO ()
layoutLoop IORef (GlobalVars n)
globalVars = do
	gv :: GlobalVars n
gv@GlobalVars {graph :: forall n. GlobalVars n -> Graph n
graph = Graph n
g, paused :: forall n. GlobalVars n -> Bool
paused = Bool
p, layoutStep :: forall n. GlobalVars n -> Node -> Rewrite n ()
layoutStep = Node -> Rewrite n ()
l, canvas :: forall n. GlobalVars n -> Window
canvas = Window
c} ← IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
	Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
p (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
		(Position -> Vector2) -> n -> Vector2
forall v n field. View v n => (v -> field) -> n -> field
examine Position -> Vector2
position ([n] -> n
forall a. HasCallStack => [a] -> a
head ([n] -> n) -> [n] -> n
forall a b. (a -> b) -> a -> b
$ Graph n -> [n]
forall n. Graph n -> [n]
nodes Graph n
g) Vector2 -> IO () -> IO ()
forall a b. a -> b -> b
`seq` () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
		IORef (GlobalVars n) -> GlobalVars n -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (GlobalVars n)
globalVars (GlobalVars n -> IO ()) -> GlobalVars n -> IO ()
forall a b. (a -> b) -> a -> b
$ GlobalVars n
gv {graph = execGraph (mapM l =<< readNodeList) g} -- TODO: relayout all nodes at once
		Window -> IO ()
redisplay Window
c
		Int -> IO () -> IO ()
addTimerCallback Int
40 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (GlobalVars n) -> IO ()
layoutLoop IORef (GlobalVars n)
globalVars

pause :: IORef (GlobalVars n) -> IO ()
pause IORef (GlobalVars n)
globalVars = IORef (GlobalVars n) -> (GlobalVars n -> GlobalVars n) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (GlobalVars n)
globalVars ((GlobalVars n -> GlobalVars n) -> IO ())
-> (GlobalVars n -> GlobalVars n) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GlobalVars n
vs → GlobalVars n
vs {paused = True}

resume :: IORef (GlobalVars n) -> IO ()
resume IORef (GlobalVars n)
globalVars = do
	IORef (GlobalVars n) -> (GlobalVars n -> GlobalVars n) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (GlobalVars n)
globalVars ((GlobalVars n -> GlobalVars n) -> IO ())
-> (GlobalVars n -> GlobalVars n) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GlobalVars n
vs → GlobalVars n
vs {paused = False}
	IORef (GlobalVars n) -> IO ()
forall {n}. View Position n => IORef (GlobalVars n) -> IO ()
layoutLoop IORef (GlobalVars n)
globalVars

subtrees ∷ LabelledTree a → [LabelledTree a]
subtrees :: forall a. LabelledTree a -> [LabelledTree a]
subtrees LabelledTree a
t = LabelledTree a
t LabelledTree a -> [LabelledTree a] -> [LabelledTree a]
forall a. a -> [a] -> [a]
: case LabelledTree a
t of
	Leaf String
_ a
_ → []
	Branch String
l [LabelledTree a]
ts → (LabelledTree a -> [LabelledTree a])
-> [LabelledTree a] -> [LabelledTree a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LabelledTree a -> [LabelledTree a]
forall a. LabelledTree a -> [LabelledTree a]
subtrees [LabelledTree a]
ts

numNodes ∷ LabelledTree a → Int
numNodes :: forall a. LabelledTree a -> Int
numNodes = [LabelledTree a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([LabelledTree a] -> Int)
-> (LabelledTree a -> [LabelledTree a]) -> LabelledTree a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelledTree a -> [LabelledTree a]
forall a. LabelledTree a -> [LabelledTree a]
subtrees

type RuleTree n = LabelledTree (Int, Rule n)

-- | Traverses the rule tree depth-first and executes all leaf rules it encounters. Rules are
-- executed everywhere they match, except if they overlap one of them is chosen at random.
-- So this corresponds to a complete development.
applyLeafRules ∷ (Rule n → Rule n) → Int → IORef (GlobalVars n) → IO ()
applyLeafRules :: forall n.
(Rule n -> Rule n) -> Int -> IORef (GlobalVars n) -> IO ()
applyLeafRules Rule n -> Rule n
restriction Int
idx IORef (GlobalVars n)
gvs = do
	Graph n
g ← IORef (GlobalVars n) -> IO (Graph n)
forall {n}. IORef (GlobalVars n) -> IO (Graph n)
readGraph IORef (GlobalVars n)
gvs
	RuleTree n
comptree ← GlobalVars n -> RuleTree n
forall n. GlobalVars n -> RuleTree n
getRules (GlobalVars n -> RuleTree n)
-> IO (GlobalVars n) -> IO (RuleTree n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
gvs
	let pos :: Maybe (LTLoc (Int, Rule n))
pos = Int -> LTLoc (Int, Rule n) -> Maybe (LTLoc (Int, Rule n))
forall a. Int -> LTLoc a -> Maybe (LTLoc a)
nth Int
idx (RuleTree n -> LTLoc (Int, Rule n)
forall a. LabelledTree a -> LTLoc a
root RuleTree n
comptree)
	case Maybe (LTLoc (Int, Rule n))
pos of
		Maybe (LTLoc (Int, Rule n))
Nothing → () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
		Just (RuleTree n
tree,LTZipper (Int, Rule n)
p) → do
			let ns :: [Node]
ns = Rewrite n [Node] -> Graph n -> [Node]
forall n a. Rewrite n a -> Graph n -> a
evalGraph Rewrite n [Node]
forall n (m :: * -> *). MonadReader (Graph n) m => m [Node]
readNodeList Graph n
g
			-- first we mark all redexes
			let rule :: Rule n
rule = Rule n -> Rule n
restriction (Rule n -> Rule n) -> Rule n -> Rule n
forall a b. (a -> b) -> a -> b
$ ((Int, Rule n) -> Rule n) -> RuleTree n -> Rule n
forall m a. Monoid m => (a -> m) -> LabelledTree a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int, Rule n) -> Rule n
forall a b. (a, b) -> b
snd RuleTree n
tree
			-- then we find a non-overlapping subset
			let ms :: [[Node]]
ms = [[[Node]]] -> [[Node]]
forall a. HasCallStack => [a] -> a
head ([[[Node]]] -> [[Node]]) -> [[[Node]]] -> [[Node]]
forall a b. (a -> b) -> a -> b
$ Pattern n [[Node]] -> Graph n -> [[[Node]]]
forall n a. Pattern n a -> Graph n -> [a]
evalPattern (Rule n -> Pattern n [[Node]]
forall (m :: * -> *) n a.
Monad m =>
PatternT n m a -> PatternT n m [[Node]]
matches Rule n
rule) Graph n
g
			-- then we apply the rules in the leafs while restricting them to that subset
			let (([[Node]]
_, Graph n
g'), RuleTree n
tree') = (([[Node]], Graph n)
 -> (Int, Rule n) -> (([[Node]], Graph n), (Int, Rule n)))
-> ([[Node]], Graph n)
-> RuleTree n
-> (([[Node]], Graph n), RuleTree n)
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL ([[Node]], Graph n)
-> (Int, Rule n) -> (([[Node]], Graph n), (Int, Rule n))
forall {a}.
Num a =>
([[Node]], Graph n)
-> (a, Rule n) -> (([[Node]], Graph n), (a, Rule n))
applyLeafRules' ([[Node]]
ms, Graph n
g) RuleTree n
tree
			let ns' :: [Node]
ns' = Rewrite n [Node] -> Graph n -> [Node]
forall n a. Rewrite n a -> Graph n -> a
evalGraph Rewrite n [Node]
forall n (m :: * -> *). MonadReader (Graph n) m => m [Node]
readNodeList Graph n
g'
			let newNodes :: [Node]
newNodes = [Node]
ns' [Node] -> [Node] -> [Node]
forall a. Eq a => [a] -> [a] -> [a]
Data.List.\\ [Node]
ns
			Node -> Rewrite n ()
layout ← GlobalVars n -> Node -> Rewrite n ()
forall n. GlobalVars n -> Node -> Rewrite n ()
layoutStep (GlobalVars n -> Node -> Rewrite n ())
-> IO (GlobalVars n) -> IO (Node -> Rewrite n ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
gvs
			Graph n -> IORef (GlobalVars n) -> IO ()
forall {n}. Graph n -> IORef (GlobalVars n) -> IO ()
writeGraph (Rewrite n () -> Graph n -> Graph n
forall n a. Rewrite n a -> Graph n -> Graph n
execGraph (Int -> Rewrite n [()] -> Rewrite n ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
15 ((Node -> Rewrite n ()) -> [Node] -> Rewrite n [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Node -> Rewrite n ()
layout [Node]
newNodes)) Graph n
g') IORef (GlobalVars n)
gvs
			IORef (GlobalVars n) -> (GlobalVars n -> GlobalVars n) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (GlobalVars n)
gvs ((GlobalVars n -> GlobalVars n) -> IO ())
-> (GlobalVars n -> GlobalVars n) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GlobalVars n
x → GlobalVars n
x {getRules = fst $ top (tree',p)}

	where

	-- At every leaf apply the rule restricted to the set of predetermined matches, every time removing the
	-- the match from the set updating the graph and the counter.
--	applyLeafRules' ∷ ([Match], Graph n) → (Int, Rule n) → (([Match], Graph n), (Int, Rule n))
	applyLeafRules' :: ([[Node]], Graph n)
-> (a, Rule n) -> (([[Node]], Graph n), (a, Rule n))
applyLeafRules' ([[Node]]
matches, Graph n
g) (a
n, Rule n
r) = let
			ms :: [([Node], Rewrite n ())]
ms = Rule n -> Graph n -> [([Node], Rewrite n ())]
forall n a. Pattern n a -> Graph n -> [([Node], a)]
runPattern Rule n
r' Graph n
g
			r' :: Rule n
r' = ([Node] -> [Node] -> Bool) -> Rule n -> Rule n
forall (m :: * -> *) n a.
Monad m =>
([Node] -> [Node] -> Bool) -> PatternT n m a -> PatternT n m a
restrictOverlap (\[Node]
past [Node]
future → [Node]
future [Node] -> [[Node]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Node]]
matches) (Rule n -> Rule n
restriction Rule n
r)
		in if [([Node], Rewrite n ())] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Node], Rewrite n ())]
ms
			then (([[Node]]
matches, Graph n
g), (a
n, Rule n
r))
			else let
					([Node]
match, Rewrite n ()
rewrite) = [([Node], Rewrite n ())] -> ([Node], Rewrite n ())
forall a. HasCallStack => [a] -> a
head [([Node], Rewrite n ())]
ms
					g' :: Graph n
g' = Rewrite n () -> Graph n -> Graph n
forall n a. Rewrite n a -> Graph n -> Graph n
execGraph Rewrite n ()
rewrite Graph n
g
				in ([[Node]], Graph n)
-> (a, Rule n) -> (([[Node]], Graph n), (a, Rule n))
applyLeafRules' (([Node] -> Bool) -> [[Node]] -> [[Node]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Node] -> Bool) -> [Node] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> Bool) -> [Node] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Node -> [Node] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Node]
match)) [[Node]]
matches, Graph n
g') (a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, Rule n
r)