{-# LANGUAGE UnicodeSyntax, FlexibleContexts #-}
module GraphRewriting.GL.Canvas (setupCanvas) where
import Prelude.Unicode
import qualified Graphics.UI.GLUT as GL
import Graphics.Rendering.OpenGL (($=))
import GraphRewriting.Graph
import GraphRewriting.Graph.Read
import GraphRewriting.Pattern
import qualified GraphRewriting.Graph.Write.Unsafe as Unsafe
import GraphRewriting.GL.Render
import GraphRewriting.GL.Global
import Data.IORef
import GraphRewriting.Layout.Rotation
import GraphRewriting.Layout.Position
import qualified Data.Set as Set
import Data.Functor ()
import Data.Maybe (catMaybes, listToMaybe)
import Data.Vector.Class
setupCanvas ∷ (View Position n, Render n', View Rotation n', View Position n')
⇒ (Graph n → Graph n') → (Edge → [n'] → [(Vector2, Vector2)]) → IORef (GlobalVars n) → IO GL.Window
setupCanvas project hyperEdgeToLines globalVars = do
canvas ← GL.createWindow "Graph"
GL.clearColor $= (GL.Color4 1 1 1 0 ∷ GL.Color4 GL.GLclampf)
GL.lineWidth $= 2
aspect ← newIORef 1
focus ← newIORef $ GL.Vector3 0 0 0
zoom ← newIORef (1 ∷ GL.GLdouble)
origLayoutStep ← layoutStep <$> readIORef globalVars
registerCallbacks origLayoutStep aspect focus zoom project hyperEdgeToLines globalVars
GL.cursor $= GL.LeftArrow
return canvas
registerCallbacks origLayoutStep aspect focus zoom project hyperEdgeToLines globalVars = do
autozoom
GL.displayCallback $= display
GL.reshapeCallback $= Just reshape
GL.keyboardMouseCallback $= Just inputCallback
where
zoomBy factor = modifyIORef zoom (* factor) >> readIORef globalVars >>= redisplay . canvas
inputCallback (GL.MouseButton GL.WheelUp) _ _ _ = zoomBy 1.1
inputCallback (GL.MouseButton GL.WheelDown) _ _ _ = zoomBy 0.9
inputCallback (GL.MouseButton GL.RightButton) GL.Down mod pos = do
pause globalVars
node ← nodeAt pos
case node of
Nothing → return ()
Just n → do
_ ← (\idx → applyLeafRules (nextIs n) idx globalVars) . selectedRule =<< readIORef globalVars
highlight globalVars
inputCallback (GL.MouseButton GL.RightButton) GL.Up mod (GL.Position x y) = resume globalVars
inputCallback (GL.MouseButton GL.LeftButton) GL.Up mod pos = do
modifyIORef globalVars $ \v → v {layoutStep = origLayoutStep}
GL.addTimerCallback 50 $ GL.motionCallback $= Nothing
inputCallback (GL.MouseButton GL.LeftButton) GL.Down mod from = do
node ← nodeAt from
case node of
Nothing → GL.motionCallback $= Just (scrollCallback from)
Just n → do
let fixN node = if n ≡ node
then do
pos ← examineNode position node
origLayoutStep node
Unsafe.updateNode node (Position pos)
else origLayoutStep node
modifyIORef globalVars $ \v → v {layoutStep = fixN}
GL.motionCallback $= Just (dragCallback n)
where
dragCallback n to = do
GL.motionCallback $= Nothing
GL.Vertex3 tx ty _ ← unproject to
let v = Vector2 (convertGLdouble tx) (convertGLdouble ty)
modifyGraph (execGraph $ Unsafe.updateNode n (Position v)) globalVars
GL.addTimerCallback 40 $ GL.motionCallback $= Just (dragCallback n)
scrollCallback from to = do
GL.motionCallback $= Nothing
GL.Vertex3 fx fy _ ← unproject from
GL.Vertex3 tx ty _ ← unproject to
modifyIORef focus $ \(GL.Vector3 x y _) → GL.Vector3 (x + tx - fx) (y + ty - fy) 0
redisplay . canvas =<< readIORef globalVars
GL.addTimerCallback 40 $ GL.motionCallback $= Just (scrollCallback to)
inputCallback (GL.Char 'z') GL.Up _ _ = autozoom
inputCallback (GL.Char ' ') GL.Up _ _ = do
isPaused ← paused <$> readIORef globalVars
if isPaused then resume globalVars else pause globalVars
inputCallback _ _ _ _ = return ()
autozoom = let margin = 2 in do
ns ← nodes . graph <$> readIORef globalVars
let maxDist = maximum $ map abs $ concat [[v2x p, v2y p] | p ← examine position `map` ns]
writeIORef focus $ GL.Vector3 0 0 0
writeIORef zoom $ 1 / (convertDouble maxDist + margin)
display = do
GL.clear [GL.ColorBuffer]
GL.loadIdentity
a ← readIORef aspect
if a < 1 then GL.ortho2D (-1) 1 (-1/a) (1/a) else GL.ortho2D (-1*a) (1*a) (-1) 1
z ← readIORef zoom
GL.scale z z 1
GL.translate =<< readIORef focus
GL.color (GL.Color3 0 0 0 ∷ GL.Color3 GL.GLfloat)
g ← project . graph <$> readIORef globalVars
mapM_ (uncurry renderLine) (concatMap (uncurry hyperEdgeToLines) (edges g))
hl ← highlighted <$> readIORef globalVars
mapM_ (renderNode hl) (evalGraph readNodeList g `zip` nodes g)
w ← menu <$> readIORef globalVars
redisplay w -- redisplay the menu subwindow
GL.swapBuffers
nodeAt ∷ GL.Position → IO (Maybe Node)
nodeAt glPos = do
GL.Vertex3 x y _ ← unproject glPos
let pos = Vector2 (convertGLdouble x) (convertGLdouble y)
g ← project . graph <$> readIORef globalVars
return $ listToMaybe $ catMaybes $ evalGraph (readOnly $ withNodes $ checkPos pos) g
where checkPos pos n = do
npos ← examineNode position n
return $ if vmag (pos - npos) < 1 then Just n else Nothing
reshape s@(GL.Size w h) = do
writeIORef aspect newAspect
GL.viewport $= (GL.Position 0 0, s)
GL.matrixMode $= GL.Projection
GL.loadIdentity
GL.perspective 0 newAspect (-1) 1
GL.matrixMode $= GL.Modelview 0
where newAspect = fromIntegral w / fromIntegral (max 1 h)
unproject ∷ GL.Position → IO (GL.Vertex3 GL.GLdouble)
unproject (GL.Position x y) = do
GL.Size winWidth winHeight ← GL.get GL.windowSize
let pos = GL.Vertex3 (fromIntegral x) (fromIntegral $ fromIntegral winHeight - y) 0
modelview ← getMatrix (GL.Modelview 1)
projection ← getMatrix GL.Projection
viewport ← GL.get GL.viewport
GL.unProject pos modelview projection viewport
getMatrix ∷ GL.MatrixMode → IO (GL.GLmatrix GL.GLdouble)
getMatrix = GL.get . GL.matrix . Just
renderNode ∷ (Render n, View Position n, View Rotation n) ⇒ Set.Set Node → (Node,n) → IO ()
renderNode highlighted (ref,n) = GL.preservingMatrix $ do
GL.translate (vector $ examine position n)
GL.rotate (convertDouble $ examine rotation n * 180 / pi) (GL.Vector3 0 0 1 ∷ GL.Vector3 GL.GLdouble)
if ref `Set.member` highlighted
then GL.color (GL.Color3 1 0 0 ∷ GL.Color3 GL.GLfloat)
else GL.color (GL.Color3 0 0 0 ∷ GL.Color3 GL.GLfloat)
render n
renderLine ∷ Vector2 → Vector2 → IO ()
renderLine p1 p2 = GL.renderPrimitive GL.Lines $ vertex p1 >> vertex p2