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

import Prelude.Unicode
import Graphics.UI.GLUT as GLUT
import qualified Graphics.Rendering.OpenGL as GL
import GraphRewriting.GL.Global
import Data.IORef
import Control.Monad
import Data.Functor ()
import Control.Applicative ()


menuItemHeight :: Int
menuItemHeight = Int
20
font :: BitmapFont
font = BitmapFont
Fixed9By15

setupMenu ∷ IORef (GlobalVars n) → IO ()
setupMenu :: forall n. IORef (GlobalVars n) -> IO ()
setupMenu IORef (GlobalVars n)
globalVars = do
	Window
c ← GlobalVars n -> Window
forall n. GlobalVars n -> Window
canvas (GlobalVars n -> Window) -> IO (GlobalVars n) -> IO Window
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
	RuleTree n
ruleTree ← 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)
globalVars
	GLint
charWidth ← BitmapFont -> String -> IO GLint
forall a (m :: * -> *).
(Font a, MonadIO m) =>
a -> String -> m GLint
forall (m :: * -> *). MonadIO m => BitmapFont -> String -> m GLint
stringWidth BitmapFont
font String
"0"
	let cols :: GLint
cols = Int -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLint) -> Int -> GLint
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> [Int]) -> [String] -> [Int]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ RuleTree n -> String
forall n. RuleTree n -> String
showRuleTree RuleTree n
ruleTree
	let winWidth :: GLint
winWidth = (GLint
cols GLint -> GLint -> GLint
forall a. Num a => a -> a -> a
+ GLint
1) GLint -> GLint -> GLint
forall a. Num a => a -> a -> a
* GLint -> GLint -> GLint
forall a. Ord a => a -> a -> a
min GLint
10 GLint
charWidth
	let ruleListLength :: Int
ruleListLength = RuleTree n -> Int
forall a. LabelledTree a -> Int
numNodes RuleTree n
ruleTree
	let winSize :: Size
winSize = GLint -> GLint -> Size
Size GLint
winWidth (Int -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLint) -> Int -> GLint
forall a b. (a -> b) -> a -> b
$ Int
menuItemHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ruleListLength)
	Window
menu ← Window -> Position -> Size -> IO Window
forall (m :: * -> *).
MonadIO m =>
Window -> Position -> Size -> m Window
createSubWindow Window
c (GLint -> GLint -> Position
GL.Position GLint
0 GLint
0) Size
winSize
	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
x -> GlobalVars n
x {menu=menu} -- set the menu subwindow
	StateVar (Color4 GLfloat)
clearColor StateVar (Color4 GLfloat) -> Color4 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Color4 GLfloat) -> Color4 GLfloat -> m ()
$= (GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
forall a. a -> a -> a -> a -> Color4 a
Color4 GLfloat
1 GLfloat
1 GLfloat
1 GLfloat
0 ∷ Color4 GLclampf)

	StateVar Cursor
GLUT.cursor StateVar Cursor -> Cursor -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Cursor -> Cursor -> m ()
$= Cursor
GLUT.LeftArrow
	Int -> IORef (GlobalVars n) -> IO ()
forall {n}. Int -> IORef (GlobalVars n) -> IO ()
selectRule Int
0 IORef (GlobalVars n)
globalVars
	SettableStateVar (IO ())
displayCallback SettableStateVar (IO ()) -> IO () -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (IO ()) -> IO () -> m ()
$= IORef (GlobalVars n) -> IO ()
forall n. IORef (GlobalVars n) -> IO ()
displayMenu IORef (GlobalVars n)
globalVars
	SettableStateVar (Maybe KeyboardMouseCallback)
keyboardMouseCallback SettableStateVar (Maybe KeyboardMouseCallback)
-> Maybe KeyboardMouseCallback -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe KeyboardMouseCallback)
-> Maybe KeyboardMouseCallback -> m ()
$= KeyboardMouseCallback -> Maybe KeyboardMouseCallback
forall a. a -> Maybe a
Just ((MouseButton -> Int -> IO ()) -> KeyboardMouseCallback
forall {m :: * -> *} {p}.
Monad m =>
(MouseButton -> Int -> m ())
-> Key -> KeyState -> p -> Position -> m ()
inputCallback ((MouseButton -> Int -> IO ()) -> KeyboardMouseCallback)
-> (MouseButton -> Int -> IO ()) -> KeyboardMouseCallback
forall a b. (a -> b) -> a -> b
$ Window -> IORef (GlobalVars n) -> MouseButton -> Int -> IO ()
forall {n}.
Window -> IORef (GlobalVars n) -> MouseButton -> Int -> IO ()
menuClick Window
menu IORef (GlobalVars n)
globalVars)
	where

	displayMenu :: IORef (GlobalVars n) -> IO ()
displayMenu IORef (GlobalVars n)
globalVars = do
		GlobalVars n
gv <- IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
		[ClearBuffer] -> IO ()
clear [ClearBuffer
ColorBuffer]
		Color3 GLfloat -> IO ()
forall a. Color a => a -> IO ()
color (GLfloat -> GLfloat -> GLfloat -> Color3 GLfloat
forall a. a -> a -> a -> Color3 a
Color3 GLfloat
0 GLfloat
0 GLfloat
0 ∷ Color3 GLfloat)
		RuleTree n
ruleTree ← 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)
globalVars
		let ruleListLength :: Int
ruleListLength = RuleTree n -> Int
forall a. LabelledTree a -> Int
numNodes RuleTree n
ruleTree
		let displayLine :: String -> Int -> IO ()
displayLine String
line Int
i = do  -- display one line of the menu
			GlobalVars n
gv <- IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
			if Int
i Int -> Int -> Bool
forall α. Eq α => α -> α -> Bool
≡ GlobalVars n -> Int
forall n. GlobalVars n -> Int
selectedRule GlobalVars n
gv
				then Color3 GLfloat -> IO ()
forall a. Color a => a -> IO ()
GL.color (GLfloat -> GLfloat -> GLfloat -> Color3 GLfloat
forall a. a -> a -> a -> Color3 a
GL.Color3 GLfloat
1 GLfloat
0 GLfloat
0 ∷ GL.Color3 GL.GLfloat)
				else Color3 GLfloat -> IO ()
forall a. Color a => a -> IO ()
GL.color (GLfloat -> GLfloat -> GLfloat -> Color3 GLfloat
forall a. a -> a -> a -> Color3 a
GL.Color3 GLfloat
0 GLfloat
0 GLfloat
0 ∷ GL.Color3 GL.GLfloat)
			Vertex2 GLint -> IO ()
forall a. WindowPos a => a -> IO ()
windowPos (GLint -> GLint -> Vertex2 GLint
forall a. a -> a -> Vertex2 a
Vertex2 GLint
0 (Int -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLint) -> Int -> GLint
forall a b. (a -> b) -> a -> b
$ (Int
ruleListLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
menuItemHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5) ∷ Vertex2 GLint)
			BitmapFont -> String -> IO ()
forall a (m :: * -> *). (Font a, MonadIO m) => a -> String -> m ()
forall (m :: * -> *). MonadIO m => BitmapFont -> String -> m ()
renderString BitmapFont
font String
line
		(String -> Int -> IO ()) -> [String] -> [Int] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ String -> Int -> IO ()
displayLine (String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ RuleTree n -> String
forall n. RuleTree n -> String
showRuleTree RuleTree n
ruleTree) [Int
0..]
		IO ()
forall (m :: * -> *). MonadIO m => m ()
swapBuffers

	inputCallback :: (MouseButton -> Int -> m ())
-> Key -> KeyState -> p -> Position -> m ()
inputCallback MouseButton -> Int -> m ()
handler (MouseButton MouseButton
button) KeyState
Up p
modifiers (Position GLint
x GLint
y) = do
		let idx :: Int
idx = GLint -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
menuItemHeight
		MouseButton -> Int -> m ()
handler MouseButton
button Int
idx
	inputCallback MouseButton -> Int -> m ()
_ Key
_ KeyState
_ p
_ Position
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

	menuClick :: Window -> IORef (GlobalVars n) -> MouseButton -> Int -> IO ()
menuClick Window
menu IORef (GlobalVars n)
globalVars MouseButton
LeftButton Int
idx = 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
x -> GlobalVars n
x {selectedRule = idx}
		GlobalVars n
gv <- IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
		Int -> IORef (GlobalVars n) -> IO ()
forall {n}. Int -> IORef (GlobalVars n) -> IO ()
selectRule Int
idx IORef (GlobalVars n)
globalVars
		Window -> IO ()
redisplay Window
menu
	menuClick Window
menu IORef (GlobalVars n)
globalVars MouseButton
RightButton Int
idx = do
		GlobalVars n
gv <- IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
		()
_ ← (Rule n -> Rule n) -> Int -> IORef (GlobalVars n) -> IO ()
forall n.
(Rule n -> Rule n) -> Int -> IORef (GlobalVars n) -> IO ()
applyLeafRules Rule n -> Rule n
forall a. a -> a
id Int
idx IORef (GlobalVars n)
globalVars
		IORef (GlobalVars n) -> IO ()
forall n. IORef (GlobalVars n) -> IO ()
highlight IORef (GlobalVars n)
globalVars
	menuClick Window
_ IORef (GlobalVars n)
_ MouseButton
_ Int
_  = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()