{-# LANGUAGE UnicodeSyntax #-}
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 ((\\), foldl')
import Control.Monad (when, replicateM, replicateM_)
import Data.Monoid
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 ∷ Rule n,
	 highlighted  ∷ Set Node,
	 layoutStep   ∷ Node → Rewrite n (),
	 canvas       ∷ Window,
	 menu         ∷ Window,
	 getRules     ∷ RuleTree n,
	 selectedIndex ∷ Int}

data LabelledTree a = Branch String [LabelledTree a] | Leaf String a

--data LTZipper a = Root (LabelledTree a) | Child String [LabelledTree a] (LabelledTree a) [LabelledTree a]

--forward ∷ LTZipper a → Maybe (LTZipper a)
--forward (Root l) = 
--forward (Child label ls child rs) = case child of
--	Leaf {} → forwardHere
--	Branch label' [    ] → forwardHere
--	Branch label' (t:ts) → 
--	where
--	forwardHere = case rs of
--		[  ] → Nothing
--		r:rs → Just $ Child label (ls ⧺ [child]) r rs
--		[  ] → Nothing
--		r:rs → Just $ Child label (ls ⧺ [child]) r rs
--forward (Child label ls child@(Leaf {}) (r:rs)) = Just $ Child label (ls ⧺ [child]) r rs

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 t = show $ fmap (\(n,r) → n) t
--	indentation = 2
--	srt t = case t of
--		Leaf l x    → (x, l ⧺ " " ⧺ show x)
--		Branch l ts → (x, l ⧺ " " ⧺ show x ⧺ concatMap indent lines) where
--			(xs, lines) = unzip $ map srt ts
--			x = mconcat xs
--			indent line = "\n" ⧺ replicate indentation ' ' ⧺ line

instance Show a ⇒ Show (LabelledTree a) where
	show (Leaf   l x) = l ⧺ " " ⧺ show x
	show (Branch l s) = l ⧺ " " ⧺ unlines (map (indent . show) s)
		where indent str = replicate 2 ' ' ⧺ str

-- two labeled trees are equal iff their labels and counters are equal
--instance Eq (LabelledTree (Rule n)) where
--	Leaf l1 r1 c1 == Leaf l2 r2 c2 = l1 == l2 && c1 == c2
--	Branch l1 c1 rs1 == Branch l2 c2 rs2 = l1 == l2 && c1 == c2 && and (zipWith (==) rs1 rs2)
--	_ == _ = False

-- (Pattern n a, [(String, Pattern n a)]) -→ ruleList ∷ [Pattern n a]
--flattenLT ∷ String → ([a] → a) → LabelledTree a → (a,[(String, a)])
--flattenLT indent combine tree = case tree of
--	Leaf l x c → (x,[(l,x)])
--	Branch b c cs → (x, (b,x) : zip (Prelude.map (indent ⧺) strs) ys) where
--		x = combine xs
--		(xs,css) = unzip $ Prelude.map (flattenLT indent combine) cs
--		(strs,ys) = unzip $ concat css

flattenLT ∷ String → ([a] → a) → LabelledTree a → (a,[(String, a)])
flattenLT indent combine tree = case tree of
	Leaf l x → (x,[(l,x)])
	Branch b cs → (x, (b,x) : zip (map (indent ⧺) strs) ys) where
		x = combine xs
		(xs,css) = unzip $ map (flattenLT indent combine) cs
		(strs,ys) = unzip $ concat css


-- | Useful for benchmarking. Print the flattened counters of the rule tree, separated
-- by tabs, so that the numbers can be pasted directly into several cells of a spreadsheet.
showFlatTabs ∷ Show a ⇒ LabelledTree a → String
showFlatTabs (Leaf l x)   = show l ⧺ "\t"
showFlatTabs (Branch l s) = show l ⧺ "\t" ⧺ concatMap showFlatTabs s

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}
--	highlight globalVars	-- this doesn't work with the command line benchmarking

applyRule ∷ Rule n → IORef (GlobalVars n) → IO ()
applyRule r globalVars = do
	layout ← 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
	highlight 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

-- | Increases the counter of a Leaf or Branch at the given index by nn
increaseCounter ∷ Int → Int → Int → LabelledTree (a,Int) → LabelledTree (a,Int)
increaseCounter = undefined
--increaseCounter i idx nn (Leaf n r c) | i == idx  = Leaf n r (c+nn)
--									  | otherwise = Leaf n r c
--increaseCounter i idx nn (Branch n c rs) | i == idx  = Branch n (c+nn) rs
--									     | otherwise = Branch n c $ increaseCounter' (i+1) idx nn rs
--
--increaseCounter' ∷ Int → Int → Int → [LabelledTree a] → [LabelledTree a]
--increaseCounter' i idx nn [] = []
--increaseCounter' i idx nn (Leaf n r c:rs) | i == idx  = Leaf n r (c+nn) : rs
--									      | otherwise = Leaf n r c : increaseCounter' (i+1) idx nn rs
--increaseCounter' i idx nn (b@(Branch n c rss):rs) | i == idx  = Branch n (c+nn) rss : rs
--											      | otherwise = Branch n c (increaseCounter' (i+1) idx nn rss)
--															  : increaseCounter' (i + nrnodes) idx nn rs
--						where nrnodes = length (flattenedLT b)

subtrees ∷ LabelledTree a → [LabelledTree a]
subtrees t = t : case t of
	Leaf _ _ → []
	Branch l ts → concatMap subtrees ts

--subtree' i (Branch l s) = 
--subtree' i (l@(Leaf n r c):rs) | i == idx  = Right l
--								   | otherwise = subtree' (i+1) idx rs
--subtree' i idx (b@(Branch n c rss):rs) | i == idx  = Right b
--									   | otherwise = case subtree' (i+1) idx rss of
--											Left i  → subtree' i idx rs -- we already increased i earlier here
--											Right t → Right t

-- | Given a list of matches (i.e. [[Node]]) it will pick all matches if none of
-- its nodes has been picked before
filterOverlaps ∷ [Match] → Set Match
filterOverlaps = Set.fromList . snd . foldr add (Set.empty, []) where
	add m (ns, ms) = if any (`Set.member` ns) m then (ns, ms) else (foldr Set.insert ns m, m:ms)

--applyLeafRule ∷ Int → [Match] → IORef (GlobalVars n) → LabelledTree (Rule n) → IO ()
--applyLeafRule idx ms gvs (Leaf n r c) = do
--	gv ← readIORef gvs
--	layout ← liftM layoutStep $ readIORef gvs
--	g ← readGraph gvs
--	let ns = evalGraph readNodeList g
--	let redexes = head $ evalPattern (amnesia $ matches r) (graph gv)
--	    nonOverlappingMatches = [m | m ← filterOverlaps redexes, m `elem` ms]
--	    nrMatched = length nonOverlappingMatches
--	    newRuleTree = branchSums $ increaseCounter 0 idx nrMatched (getRules gv)
--	    g' = execGraph (apply $ exhaustive $ restrictOverlap (\past future → future `elem` nonOverlappingMatches) r) g
--	modifyIORef gvs $ \x → x {getRules = newRuleTree}
--	let ns' = evalGraph readNodeList g'
--	let newNodes = ns' Data.List.\\ ns
--	writeGraph (execGraph (replicateM_ 15 $ mapM layout newNodes) g') gvs
--applyLeafRule idx ms gvs (Branch n c rs) = return ()

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 ∷ Int → IORef (GlobalVars n) → IO ()
applyLeafRules idx gvs = do
	g ← readGraph gvs
	comptree ← getRules <$> readIORef gvs
	let trees = subtrees comptree
	if not $ 0 ≤ idx ∧ idx < length trees
		then return ()
		else do
			let tree = trees !! idx
			let ns = evalGraph readNodeList g
			let rule = fold $ fmap snd tree
			let nonOverlappingMatches = filterOverlaps $ head $ evalPattern (matches rule) g
			let ((_, g'), tree') = mapAccumR applyLeafRules' (nonOverlappingMatches, 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 = insertTree idx tree tree'}

insertTree ∷ Int → LabelledTree a → LabelledTree a → LabelledTree a
insertTree pos tree tree' = tree
--insertTree pos subtree tree = case insert' pos tree of
--	Left pos' → tree
--	Right res → res
--	where
--	insert' 0 t = Right subtree
--	insert' p t = case t of
--		Leaf l x → Left (p+1)
--		Branch l [] → Left p
--		Branch l ts → case muh ts (Left p) of
--			Left p' → Left p'
--			Right ts' → Right $ Branch l ts'
--			where
--			muh ∷ [LabelledTree a] → Either Int [LabelledTree a] → Either Int [LabelledTree a]
--			muh [] (Left p) = Left p
--			muh (t:ts) (Left p) = case insert' p t of
--				Left p' → 
--				Right t' → Right $ t'
--			muh t (Left p) = insert' p t

-- 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' ∷ (Set Match, Graph n) → (Int, Rule n) → ((Set Match, Graph n), (Int, Rule n))
applyLeafRules' (matches, g) (n, r) = let
		ms = runPattern r' g
		r' = restrictOverlap (\past future → future `elem` matches) r
	in if null ms
		then ((matches, g), (n, r))
		else let
				(match, rewrite) = head ms
				g' = execGraph rewrite g
			in applyLeafRules' (Set.delete match matches, g') (n+1, r)

--applyLeafRules' idx ms gvs (l@(Leaf n r c):rs) = do
--	applyLeafRule idx ms gvs l
--	applyLeafRules' (idx+1) ms gvs rs
--applyLeafRules' idx ms gvs (b@(Branch n c rss):rs) = do
--	selIdx ← applyLeafRules' (idx+1) ms gvs rss -- get the last index in a subtree
--	applyLeafRules' selIdx ms gvs rs
--applyLeafRules' idx ms gvs [] = return idx

-- | Flattens the LabelledTree into a list of its nodes, where the branch nodes have
-- empty lists attached to them
--flattenedLT ∷ LabelledTree a → [LabelledTree a]
--flattenedLT l@(Leaf n r c)  = [l]
--flattenedLT (Branch n c rs) = Branch n c [] : concatMap flattenedLT rs

--branchSums ∷ LabelledTree a → LabelledTree a
--branchSums l@(Leaf n r c)  = l
--branchSums (Branch n c rs) = Branch n (sum $ childCounters rs) (Prelude.map branchSums rs)

--childCounters ∷ [LabelledTree a] → [Int]
--childCounters [] = []
--childCounters ((Leaf n r c):rs)     = c : childCounters rs
--childCounters ((Branch n c rss):rs) = sum (childCounters rss) : childCounters rs

-- | Looks up the index of a given leaf rule in the rule tree.
--getRuleIndex ∷ GlobalVars n → Rule n → LabelledTree (Rule n) → IO (Maybe Int)
--getRuleIndex gvs rl l = getRuleIndex' 0 gvs rl l

--getRuleIndex' ∷ Int → GlobalVars n → Rule n → LabelledTree (Rule n) → IO (Maybe Int)
--getRuleIndex' idx gvs rl (Leaf n r c)     = do
--	let rlMatches = getMatches rl gvs
--	    rMatches  = getMatches r gvs
--	if Prelude.null rlMatches
--		then return Nothing
--		else if head rlMatches `elem` rMatches
--				then return (Just idx)
--				else return Nothing
--getRuleIndex' idx gvs rl (Branch n c rs) = do
--	selIdx ← getRuleIndex'' (idx+1) gvs rl rs
--	case selIdx of
--		Left _  → return Nothing
--		Right i → return (Just i)

--getRuleIndex'' ∷ Int → GlobalVars n → Rule n → [LabelledTree (Rule n)] → IO (Either Int Int)
--getRuleIndex'' idx gvs rl [] = return (Left idx)
--getRuleIndex'' idx gvs rl ((Leaf n r c):rs)     = do
--	let rlMatches = getMatches rl gvs
--	    rMatches  = getMatches r gvs
--	if Prelude.null rlMatches
--		then return (Left idx)
--		else if head rlMatches `elem` rMatches
--				then return (Right idx)
--				else getRuleIndex'' (idx+1) gvs rl rs
--getRuleIndex'' idx gvs rl ((Branch n c rss):rs) = do
--	selIdx ← getRuleIndex'' (idx+1) gvs rl rss
--	case selIdx of
--		Left i  → getRuleIndex'' i gvs rl rs
--		Right i → return (Right i)
--
--getMatches ∷ Rule n → GlobalVars n → [Match]
--getMatches r gvs = Prelude.map fst $ snd $ head $ runPattern (amnesia $ match r) (graph gvs)