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