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 ()