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.Graph.Write.Unsafe as Unsafe
import GraphRewriting.Pattern
import GraphRewriting.Rule
import GraphRewriting.GL.Render
import GraphRewriting.GL.Global
import Data.IORef
import GraphRewriting.Layout.Rotation
import GraphRewriting.Layout.Position
import GraphRewriting.Layout.PortSpec
import qualified Data.Set as Set
import Control.Monad (liftM, replicateM_)
import Data.Maybe (catMaybes, listToMaybe)


setupCanvas ∷ (View [Port] n, Render n, View Position n, PortSpec n, View Rotation 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 ← liftM 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
		rule ← liftM selectedRule $ readIORef globalVars
		node ← nodeAt pos
		case node of
			Nothing → return ()
			Just n  → do
				(newNodes, g) ← liftM (runGraph $ apply $ nextIs n rule) (readGraph globalVars)
				writeGraph (execGraph (replicateM_ 5 $ mapM origLayoutStep newNodes) g) 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 return ()
					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 (Position v) n) 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 =<< liftM 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 ← liftM paused $ readIORef globalVars
		if isPaused then resume globalVars else pause globalVars
	inputCallback _ _ _ _ = return ()

	autozoom = let margin = 2 in do
		ns ← liftM (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 ← liftM (project . graph) (readIORef globalVars)
		mapM_ (uncurry renderLine) (concatMap (uncurry hyperEdgeToLines) (edges g))
		hl ← liftM highlighted (readIORef globalVars)
		mapM_ (renderNode hl) (evalGraph readNodeList g `zip` nodes g)

		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 ← liftM (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