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.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 =
		applyRule (everywhere $ ruleList !! idx) globalVars
	menuClick _ _ _ _  = return ()