content: {-# 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
  