module GraphRewriting.GL.Menu (LabeledTree (..), setupMenu) where

import Prelude.Unicode
import Graphics.UI.GLUT as GLUT
import qualified Graphics.Rendering.OpenGL as GL
import GraphRewriting.GL.Global
import GraphRewriting.Graph
import GraphRewriting.Rule
import Data.IORef
import GraphRewriting.Pattern
import Control.Monad


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

flattenLT ∷ String → ([a] → a) → LabeledTree 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

menuItemHeight = 20
font = Fixed9By15

setupMenu ∷ LabeledTree (Rule n) → IORef (GlobalVars n) → IO ()
setupMenu rules globalVars = do
	c ← liftM canvas $ readIORef globalVars
	winWidth ← liftM (fromIntegral . maximum) (mapM (stringWidth font) ruleNames)
	let winSize = Size winWidth (fromIntegral $ menuItemHeight * n)
	menu ← createSubWindow c (GL.Position 0 0) winSize
	clearColor $= (Color4 1 1 1 0 ∷ Color4 GLclampf)

	GLUT.cursor $= GLUT.LeftArrow
	selectedIndex ← newIORef (0 ∷ Int)
	selectRule (ruleList !! 0) globalVars
	displayCallback $= (displayMenu =<< readIORef selectedIndex)
	keyboardMouseCallback $= Just (inputCallback $ menuClick menu selectedIndex)
	where

	(ruleNames, ruleList) = unzip $ snd $ flattenLT "   " anyOf rules
	n = length ruleNames

	displayMenu selectedIndex = do
		clear [ColorBuffer]
		color (Color3 0 0 0 ∷ Color3 GLfloat)
		zipWithM_ displayLine ruleNames [0..]
		swapBuffers
		where displayLine name i = do
			if i ≡ selectedIndex
				then GL.color (GL.Color3 1 0 0 ∷ GL.Color3 GL.GLfloat)
				else GL.color (GL.Color3 0 0 0 ∷ GL.Color3 GL.GLfloat)
			windowPos (Vertex2 0 (fromIntegral $ (n - i - 1) * menuItemHeight + 5) ∷ Vertex2 GLint)
			renderString font name

	inputCallback handler (MouseButton button) Up modifiers (Position x y) = do
		let idx = fromIntegral y `div` menuItemHeight
		when (0 <= idx ∧ idx < n) (handler button idx)
	inputCallback _ _ _ _ _ = return ()

	menuClick menu selectedIndex LeftButton idx = do
		writeIORef selectedIndex idx
		selectRule (ruleList !! idx) globalVars
		postRedisplay $ Just menu
	menuClick menu selectedIndex RightButton idx = do
		modifyGraph (execGraph $ apply $ everywhere $ ruleList !! idx) globalVars
	menuClick _ _ _ _  = return ()