{-# 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 :: forall n n'.
(View Position n, Render n', View Rotation n', View Position n') =>
(Graph n -> Graph n')
-> (Edge -> [n'] -> [(Vector2, Vector2)])
-> IORef (GlobalVars n)
-> IO Window
setupCanvas Graph n -> Graph n'
project Edge -> [n'] -> [(Vector2, Vector2)]
hyperEdgeToLines IORef (GlobalVars n)
globalVars = do
	Window
canvas ← String -> IO Window
forall (m :: * -> *). MonadIO m => String -> m Window
GL.createWindow String
"Graph"
	StateVar (Color4 GLfloat)
GL.clearColor StateVar (Color4 GLfloat) -> Color4 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Color4 GLfloat) -> Color4 GLfloat -> m ()
$= (GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
forall a. a -> a -> a -> a -> Color4 a
GL.Color4 GLfloat
1 GLfloat
1 GLfloat
1 GLfloat
0 ∷ GL.Color4 GL.GLclampf)
	StateVar GLfloat
GL.lineWidth StateVar GLfloat -> GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar GLfloat -> GLfloat -> m ()
$= GLfloat
2
	IORef GLdouble
aspect ← GLdouble -> IO (IORef GLdouble)
forall a. a -> IO (IORef a)
newIORef GLdouble
1
	IORef (Vector3 GLdouble)
focus  ← Vector3 GLdouble -> IO (IORef (Vector3 GLdouble))
forall a. a -> IO (IORef a)
newIORef (Vector3 GLdouble -> IO (IORef (Vector3 GLdouble)))
-> Vector3 GLdouble -> IO (IORef (Vector3 GLdouble))
forall a b. (a -> b) -> a -> b
$ GLdouble -> GLdouble -> GLdouble -> Vector3 GLdouble
forall a. a -> a -> a -> Vector3 a
GL.Vector3 GLdouble
0 GLdouble
0 GLdouble
0
	IORef GLdouble
zoom   ← GLdouble -> IO (IORef GLdouble)
forall a. a -> IO (IORef a)
newIORef (GLdouble
1 ∷ GL.GLdouble)
	Node -> Rewrite n ()
origLayoutStep ← GlobalVars n -> Node -> Rewrite n ()
forall n. GlobalVars n -> Node -> Rewrite n ()
layoutStep (GlobalVars n -> Node -> Rewrite n ())
-> IO (GlobalVars n) -> IO (Node -> Rewrite n ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
	(Node -> Rewrite n ())
-> IORef GLdouble
-> IORef (Vector3 GLdouble)
-> IORef GLdouble
-> (Graph n -> Graph n')
-> (Edge -> [n'] -> [(Vector2, Vector2)])
-> IORef (GlobalVars n)
-> IO ()
forall {n} {n}.
(Render n, View Rotation n, View Position n, View Position n) =>
(Node -> Rewrite n ())
-> IORef GLdouble
-> IORef (Vector3 GLdouble)
-> IORef GLdouble
-> (Graph n -> Graph n)
-> (Edge -> [n] -> [(Vector2, Vector2)])
-> IORef (GlobalVars n)
-> IO ()
registerCallbacks Node -> Rewrite n ()
origLayoutStep IORef GLdouble
aspect IORef (Vector3 GLdouble)
focus IORef GLdouble
zoom Graph n -> Graph n'
project Edge -> [n'] -> [(Vector2, Vector2)]
hyperEdgeToLines IORef (GlobalVars n)
globalVars
	StateVar Cursor
GL.cursor StateVar Cursor -> Cursor -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Cursor -> Cursor -> m ()
$= Cursor
GL.LeftArrow
	Window -> IO Window
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Window
canvas

registerCallbacks :: (Node -> Rewrite n ())
-> IORef GLdouble
-> IORef (Vector3 GLdouble)
-> IORef GLdouble
-> (Graph n -> Graph n)
-> (Edge -> [n] -> [(Vector2, Vector2)])
-> IORef (GlobalVars n)
-> IO ()
registerCallbacks Node -> Rewrite n ()
origLayoutStep IORef GLdouble
aspect IORef (Vector3 GLdouble)
focus IORef GLdouble
zoom Graph n -> Graph n
project Edge -> [n] -> [(Vector2, Vector2)]
hyperEdgeToLines IORef (GlobalVars n)
globalVars = do
	IO ()
autozoom
	SettableStateVar (IO ())
GL.displayCallback SettableStateVar (IO ()) -> IO () -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (IO ()) -> IO () -> m ()
$= IO ()
display
	SettableStateVar (Maybe ReshapeCallback)
GL.reshapeCallback SettableStateVar (Maybe ReshapeCallback)
-> Maybe ReshapeCallback -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe ReshapeCallback)
-> Maybe ReshapeCallback -> m ()
$= ReshapeCallback -> Maybe ReshapeCallback
forall a. a -> Maybe a
Just ReshapeCallback
reshape
	SettableStateVar (Maybe KeyboardMouseCallback)
GL.keyboardMouseCallback SettableStateVar (Maybe KeyboardMouseCallback)
-> Maybe KeyboardMouseCallback -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe KeyboardMouseCallback)
-> Maybe KeyboardMouseCallback -> m ()
$= KeyboardMouseCallback -> Maybe KeyboardMouseCallback
forall a. a -> Maybe a
Just KeyboardMouseCallback
forall {p}. Key -> KeyState -> p -> Position -> IO ()
inputCallback

	where

	zoomBy :: GLdouble -> IO ()
zoomBy GLdouble
factor = IORef GLdouble -> (GLdouble -> GLdouble) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef GLdouble
zoom (GLdouble -> GLdouble -> GLdouble
forall a. Num a => a -> a -> a
* GLdouble
factor) IO () -> IO (GlobalVars n) -> IO (GlobalVars n)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars IO (GlobalVars n) -> (GlobalVars n -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Window -> IO ()
redisplay (Window -> IO ())
-> (GlobalVars n -> Window) -> GlobalVars n -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalVars n -> Window
forall n. GlobalVars n -> Window
canvas

	inputCallback :: Key -> KeyState -> p -> Position -> IO ()
inputCallback (GL.MouseButton MouseButton
GL.WheelUp)   KeyState
_ p
_ Position
_ = GLdouble -> IO ()
zoomBy GLdouble
1.1
	inputCallback (GL.MouseButton MouseButton
GL.WheelDown) KeyState
_ p
_ Position
_ = GLdouble -> IO ()
zoomBy GLdouble
0.9

	inputCallback (GL.MouseButton MouseButton
GL.RightButton) KeyState
GL.Down p
mod Position
pos = do
		IORef (GlobalVars n) -> IO ()
forall {n}. IORef (GlobalVars n) -> IO ()
pause IORef (GlobalVars n)
globalVars
		Maybe Node
node ← Position -> IO (Maybe Node)
nodeAt Position
pos
		case Maybe Node
node of
			Maybe Node
Nothing → () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
			Just Node
n  → do
				()
_ ← (\Int
idx → (Rule n -> Rule n) -> Int -> IORef (GlobalVars n) -> IO ()
forall n.
(Rule n -> Rule n) -> Int -> IORef (GlobalVars n) -> IO ()
applyLeafRules (Node -> Rule n -> Rule n
forall (m :: * -> *) n a.
Monad m =>
Node -> PatternT n m a -> PatternT n m a
nextIs Node
n) Int
idx IORef (GlobalVars n)
globalVars) (Int -> IO ()) -> (GlobalVars n -> Int) -> GlobalVars n -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalVars n -> Int
forall n. GlobalVars n -> Int
selectedRule (GlobalVars n -> IO ()) -> IO (GlobalVars n) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
				IORef (GlobalVars n) -> IO ()
forall {n}. IORef (GlobalVars n) -> IO ()
highlight IORef (GlobalVars n)
globalVars

	inputCallback (GL.MouseButton MouseButton
GL.RightButton) KeyState
GL.Up p
mod (GL.Position GLsizei
x GLsizei
y) = IORef (GlobalVars n) -> IO ()
forall {n}. View Position n => IORef (GlobalVars n) -> IO ()
resume IORef (GlobalVars n)
globalVars

	inputCallback (GL.MouseButton MouseButton
GL.LeftButton) KeyState
GL.Up p
mod Position
pos = do
		IORef (GlobalVars n) -> (GlobalVars n -> GlobalVars n) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (GlobalVars n)
globalVars ((GlobalVars n -> GlobalVars n) -> IO ())
-> (GlobalVars n -> GlobalVars n) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GlobalVars n
v → GlobalVars n
v {layoutStep = origLayoutStep}
		Int -> IO () -> IO ()
GL.addTimerCallback Int
50 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SettableStateVar (Maybe (Position -> IO ()))
GL.motionCallback SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> m ()
$= Maybe (Position -> IO ())
forall a. Maybe a
Nothing
	inputCallback (GL.MouseButton MouseButton
GL.LeftButton) KeyState
GL.Down p
mod Position
from = do
		Maybe Node
node ← Position -> IO (Maybe Node)
nodeAt Position
from
		case Maybe Node
node of
			Maybe Node
Nothing → SettableStateVar (Maybe (Position -> IO ()))
GL.motionCallback SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> m ()
$= (Position -> IO ()) -> Maybe (Position -> IO ())
forall a. a -> Maybe a
Just (Position -> Position -> IO ()
scrollCallback Position
from)
			Just Node
n  → do
				let fixN :: Node -> Rewrite n ()
fixN Node
node = if Node
n Node -> Node -> Bool
forall α. Eq α => α -> α -> Bool
≡ Node
node
					then do
						Vector2
pos ← (Position -> Vector2) -> Node -> Rewrite n Vector2
forall v n (m :: * -> *) a.
(View v n, MonadReader (Graph n) m, MonadFail m) =>
(v -> a) -> Node -> m a
examineNode Position -> Vector2
position Node
node
						Node -> Rewrite n ()
origLayoutStep Node
node
						Node -> Position -> Rewrite n ()
forall v n. View v n => Node -> v -> Rewrite n ()
Unsafe.updateNode Node
node (Vector2 -> Position
Position Vector2
pos)
					else Node -> Rewrite n ()
origLayoutStep Node
node
				IORef (GlobalVars n) -> (GlobalVars n -> GlobalVars n) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (GlobalVars n)
globalVars ((GlobalVars n -> GlobalVars n) -> IO ())
-> (GlobalVars n -> GlobalVars n) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GlobalVars n
v → GlobalVars n
v {layoutStep = fixN}
				SettableStateVar (Maybe (Position -> IO ()))
GL.motionCallback SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> m ()
$= (Position -> IO ()) -> Maybe (Position -> IO ())
forall a. a -> Maybe a
Just (Node -> Position -> IO ()
dragCallback Node
n)
		where
		dragCallback :: Node -> Position -> IO ()
dragCallback Node
n Position
to = do
			SettableStateVar (Maybe (Position -> IO ()))
GL.motionCallback SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> m ()
$= Maybe (Position -> IO ())
forall a. Maybe a
Nothing
			GL.Vertex3 GLdouble
tx GLdouble
ty GLdouble
_ ← Position -> IO (Vertex3 GLdouble)
unproject Position
to
			let v :: Vector2
v = GLdouble -> GLdouble -> Vector2
Vector2 (GLdouble -> GLdouble
convertGLdouble GLdouble
tx) (GLdouble -> GLdouble
convertGLdouble GLdouble
ty)
			(Graph n -> Graph n) -> IORef (GlobalVars n) -> IO ()
forall {n}. (Graph n -> Graph n) -> IORef (GlobalVars n) -> IO ()
modifyGraph (Rewrite n () -> Graph n -> Graph n
forall n a. Rewrite n a -> Graph n -> Graph n
execGraph (Rewrite n () -> Graph n -> Graph n)
-> Rewrite n () -> Graph n -> Graph n
forall a b. (a -> b) -> a -> b
$ Node -> Position -> Rewrite n ()
forall v n. View v n => Node -> v -> Rewrite n ()
Unsafe.updateNode Node
n (Vector2 -> Position
Position Vector2
v)) IORef (GlobalVars n)
globalVars
			Int -> IO () -> IO ()
GL.addTimerCallback Int
40 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SettableStateVar (Maybe (Position -> IO ()))
GL.motionCallback SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> m ()
$= (Position -> IO ()) -> Maybe (Position -> IO ())
forall a. a -> Maybe a
Just (Node -> Position -> IO ()
dragCallback Node
n)

		scrollCallback :: Position -> Position -> IO ()
scrollCallback Position
from Position
to = do
			SettableStateVar (Maybe (Position -> IO ()))
GL.motionCallback SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> m ()
$= Maybe (Position -> IO ())
forall a. Maybe a
Nothing
			GL.Vertex3 GLdouble
fx GLdouble
fy GLdouble
_ ← Position -> IO (Vertex3 GLdouble)
unproject Position
from
			GL.Vertex3 GLdouble
tx GLdouble
ty GLdouble
_ ← Position -> IO (Vertex3 GLdouble)
unproject Position
to
			IORef (Vector3 GLdouble)
-> (Vector3 GLdouble -> Vector3 GLdouble) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (Vector3 GLdouble)
focus ((Vector3 GLdouble -> Vector3 GLdouble) -> IO ())
-> (Vector3 GLdouble -> Vector3 GLdouble) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(GL.Vector3 GLdouble
x GLdouble
y GLdouble
_) → GLdouble -> GLdouble -> GLdouble -> Vector3 GLdouble
forall a. a -> a -> a -> Vector3 a
GL.Vector3 (GLdouble
x GLdouble -> GLdouble -> GLdouble
forall a. Num a => a -> a -> a
+ GLdouble
tx GLdouble -> GLdouble -> GLdouble
forall a. Num a => a -> a -> a
- GLdouble
fx) (GLdouble
y GLdouble -> GLdouble -> GLdouble
forall a. Num a => a -> a -> a
+ GLdouble
ty GLdouble -> GLdouble -> GLdouble
forall a. Num a => a -> a -> a
- GLdouble
fy) GLdouble
0
			Window -> IO ()
redisplay (Window -> IO ())
-> (GlobalVars n -> Window) -> GlobalVars n -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalVars n -> Window
forall n. GlobalVars n -> Window
canvas (GlobalVars n -> IO ()) -> IO (GlobalVars n) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
			Int -> IO () -> IO ()
GL.addTimerCallback Int
40 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SettableStateVar (Maybe (Position -> IO ()))
GL.motionCallback SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> m ()
$= (Position -> IO ()) -> Maybe (Position -> IO ())
forall a. a -> Maybe a
Just (Position -> Position -> IO ()
scrollCallback Position
to)

	inputCallback (GL.Char Char
'z') KeyState
GL.Up p
_ Position
_ = IO ()
autozoom
	inputCallback (GL.Char Char
' ') KeyState
GL.Up p
_ Position
_ = do
		Bool
isPaused ← GlobalVars n -> Bool
forall n. GlobalVars n -> Bool
paused (GlobalVars n -> Bool) -> IO (GlobalVars n) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
		if Bool
isPaused then IORef (GlobalVars n) -> IO ()
forall {n}. View Position n => IORef (GlobalVars n) -> IO ()
resume IORef (GlobalVars n)
globalVars else IORef (GlobalVars n) -> IO ()
forall {n}. IORef (GlobalVars n) -> IO ()
pause IORef (GlobalVars n)
globalVars
	inputCallback Key
_ KeyState
_ p
_ Position
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

	autozoom :: IO ()
autozoom = let margin :: GLdouble
margin = GLdouble
2 in do
		[n]
ns ← Graph n -> [n]
forall n. Graph n -> [n]
nodes (Graph n -> [n])
-> (GlobalVars n -> Graph n) -> GlobalVars n -> [n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalVars n -> Graph n
forall n. GlobalVars n -> Graph n
graph (GlobalVars n -> [n]) -> IO (GlobalVars n) -> IO [n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
		let maxDist :: GLdouble
maxDist = [GLdouble] -> GLdouble
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([GLdouble] -> GLdouble) -> [GLdouble] -> GLdouble
forall a b. (a -> b) -> a -> b
$ (GLdouble -> GLdouble) -> [GLdouble] -> [GLdouble]
forall a b. (a -> b) -> [a] -> [b]
map GLdouble -> GLdouble
forall a. Num a => a -> a
abs ([GLdouble] -> [GLdouble]) -> [GLdouble] -> [GLdouble]
forall a b. (a -> b) -> a -> b
$ [[GLdouble]] -> [GLdouble]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Vector2 -> GLdouble
v2x Vector2
p, Vector2 -> GLdouble
v2y Vector2
p] | Vector2
p ← (Position -> Vector2) -> n -> Vector2
forall v n field. View v n => (v -> field) -> n -> field
examine Position -> Vector2
position (n -> Vector2) -> [n] -> [Vector2]
forall a b. (a -> b) -> [a] -> [b]
`map` [n]
ns]
		IORef (Vector3 GLdouble) -> Vector3 GLdouble -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Vector3 GLdouble)
focus (Vector3 GLdouble -> IO ()) -> Vector3 GLdouble -> IO ()
forall a b. (a -> b) -> a -> b
$ GLdouble -> GLdouble -> GLdouble -> Vector3 GLdouble
forall a. a -> a -> a -> Vector3 a
GL.Vector3 GLdouble
0 GLdouble
0 GLdouble
0
		IORef GLdouble -> GLdouble -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef GLdouble
zoom (GLdouble -> IO ()) -> GLdouble -> IO ()
forall a b. (a -> b) -> a -> b
$ GLdouble
1 GLdouble -> GLdouble -> GLdouble
forall a. Fractional a => a -> a -> a
/ (GLdouble -> GLdouble
convertDouble GLdouble
maxDist GLdouble -> GLdouble -> GLdouble
forall a. Num a => a -> a -> a
+ GLdouble
margin)

	display :: IO ()
display = do
		[ClearBuffer] -> IO ()
GL.clear [ClearBuffer
GL.ColorBuffer]
		IO ()
GL.loadIdentity
		GLdouble
a ← IORef GLdouble -> IO GLdouble
forall a. IORef a -> IO a
readIORef IORef GLdouble
aspect
		if GLdouble
a GLdouble -> GLdouble -> Bool
forall a. Ord a => a -> a -> Bool
< GLdouble
1 then GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO ()
GL.ortho2D (-GLdouble
1) GLdouble
1 (-GLdouble
1GLdouble -> GLdouble -> GLdouble
forall a. Fractional a => a -> a -> a
/GLdouble
a) (GLdouble
1GLdouble -> GLdouble -> GLdouble
forall a. Fractional a => a -> a -> a
/GLdouble
a) else GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO ()
GL.ortho2D (-GLdouble
1GLdouble -> GLdouble -> GLdouble
forall a. Num a => a -> a -> a
*GLdouble
a) (GLdouble
1GLdouble -> GLdouble -> GLdouble
forall a. Num a => a -> a -> a
*GLdouble
a) (-GLdouble
1) GLdouble
1
		GLdouble
z ← IORef GLdouble -> IO GLdouble
forall a. IORef a -> IO a
readIORef IORef GLdouble
zoom
		GLdouble -> GLdouble -> GLdouble -> IO ()
forall c. MatrixComponent c => c -> c -> c -> IO ()
GL.scale GLdouble
z GLdouble
z GLdouble
1
		Vector3 GLdouble -> IO ()
forall c. MatrixComponent c => Vector3 c -> IO ()
GL.translate (Vector3 GLdouble -> IO ()) -> IO (Vector3 GLdouble) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Vector3 GLdouble) -> IO (Vector3 GLdouble)
forall a. IORef a -> IO a
readIORef IORef (Vector3 GLdouble)
focus

		Color3 GLfloat -> IO ()
forall a. Color a => a -> IO ()
GL.color (GLfloat -> GLfloat -> GLfloat -> Color3 GLfloat
forall a. a -> a -> a -> Color3 a
GL.Color3 GLfloat
0 GLfloat
0 GLfloat
0 ∷ GL.Color3 GL.GLfloat)
		Graph n
g ← Graph n -> Graph n
project (Graph n -> Graph n)
-> (GlobalVars n -> Graph n) -> GlobalVars n -> Graph n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalVars n -> Graph n
forall n. GlobalVars n -> Graph n
graph (GlobalVars n -> Graph n) -> IO (GlobalVars n) -> IO (Graph n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
		((Vector2, Vector2) -> IO ()) -> [(Vector2, Vector2)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Vector2 -> Vector2 -> IO ()) -> (Vector2, Vector2) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Vector2 -> Vector2 -> IO ()
renderLine) (((Edge, [n]) -> [(Vector2, Vector2)])
-> [(Edge, [n])] -> [(Vector2, Vector2)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Edge -> [n] -> [(Vector2, Vector2)])
-> (Edge, [n]) -> [(Vector2, Vector2)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Edge -> [n] -> [(Vector2, Vector2)]
hyperEdgeToLines) (Graph n -> [(Edge, [n])]
forall n. Graph n -> [(Edge, [n])]
edges Graph n
g))
		Set Node
hl ← GlobalVars n -> Set Node
forall n. GlobalVars n -> Set Node
highlighted (GlobalVars n -> Set Node) -> IO (GlobalVars n) -> IO (Set Node)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
		((Node, n) -> IO ()) -> [(Node, n)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Set Node -> (Node, n) -> IO ()
forall n.
(Render n, View Position n, View Rotation n) =>
Set Node -> (Node, n) -> IO ()
renderNode Set Node
hl) (Rewrite n [Node] -> Graph n -> [Node]
forall n a. Rewrite n a -> Graph n -> a
evalGraph Rewrite n [Node]
forall n (m :: * -> *). MonadReader (Graph n) m => m [Node]
readNodeList Graph n
g [Node] -> [n] -> [(Node, n)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` Graph n -> [n]
forall n. Graph n -> [n]
nodes Graph n
g)
		Window
w ← GlobalVars n -> Window
forall n. GlobalVars n -> Window
menu (GlobalVars n -> Window) -> IO (GlobalVars n) -> IO Window
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
		Window -> IO ()
redisplay Window
w -- redisplay the menu subwindow

		IO ()
forall (m :: * -> *). MonadIO m => m ()
GL.swapBuffers

	nodeAt ∷ GL.Position → IO (Maybe Node)
	nodeAt :: Position -> IO (Maybe Node)
nodeAt Position
glPos = do
		GL.Vertex3 GLdouble
x GLdouble
y GLdouble
_ ← Position -> IO (Vertex3 GLdouble)
unproject Position
glPos
		let pos :: Vector2
pos = GLdouble -> GLdouble -> Vector2
Vector2 (GLdouble -> GLdouble
convertGLdouble GLdouble
x) (GLdouble -> GLdouble
convertGLdouble GLdouble
y)
		Graph n
g ← Graph n -> Graph n
project (Graph n -> Graph n)
-> (GlobalVars n -> Graph n) -> GlobalVars n -> Graph n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalVars n -> Graph n
forall n. GlobalVars n -> Graph n
graph (GlobalVars n -> Graph n) -> IO (GlobalVars n) -> IO (Graph n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (GlobalVars n) -> IO (GlobalVars n)
forall a. IORef a -> IO a
readIORef IORef (GlobalVars n)
globalVars
		Maybe Node -> IO (Maybe Node)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Node -> IO (Maybe Node)) -> Maybe Node -> IO (Maybe Node)
forall a b. (a -> b) -> a -> b
$ [Node] -> Maybe Node
forall a. [a] -> Maybe a
listToMaybe ([Node] -> Maybe Node) -> [Node] -> Maybe Node
forall a b. (a -> b) -> a -> b
$ [Maybe Node] -> [Node]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Node] -> [Node]) -> [Maybe Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ Rewrite n [Maybe Node] -> Graph n -> [Maybe Node]
forall n a. Rewrite n a -> Graph n -> a
evalGraph (Reader (Graph n) [Maybe Node] -> Rewrite n [Maybe Node]
forall n (m :: * -> *) a.
MonadReader (Graph n) m =>
Reader (Graph n) a -> m a
readOnly (Reader (Graph n) [Maybe Node] -> Rewrite n [Maybe Node])
-> Reader (Graph n) [Maybe Node] -> Rewrite n [Maybe Node]
forall a b. (a -> b) -> a -> b
$ (Node -> ReaderT (Graph n) Identity (Maybe Node))
-> Reader (Graph n) [Maybe Node]
forall n (m :: * -> *) a.
MonadReader (Graph n) m =>
(Node -> m a) -> m [a]
withNodes ((Node -> ReaderT (Graph n) Identity (Maybe Node))
 -> Reader (Graph n) [Maybe Node])
-> (Node -> ReaderT (Graph n) Identity (Maybe Node))
-> Reader (Graph n) [Maybe Node]
forall a b. (a -> b) -> a -> b
$ Vector2 -> Node -> ReaderT (Graph n) Identity (Maybe Node)
forall {m :: * -> *} {n}.
(View Position n, MonadReader (Graph n) m, MonadFail m) =>
Vector2 -> Node -> m (Maybe Node)
checkPos Vector2
pos) Graph n
g
		where checkPos :: Vector2 -> Node -> m (Maybe Node)
checkPos Vector2
pos Node
n = do
			Vector2
npos ← (Position -> Vector2) -> Node -> m Vector2
forall v n (m :: * -> *) a.
(View v n, MonadReader (Graph n) m, MonadFail m) =>
(v -> a) -> Node -> m a
examineNode Position -> Vector2
position Node
n
			Maybe Node -> m (Maybe Node)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Node -> m (Maybe Node)) -> Maybe Node -> m (Maybe Node)
forall a b. (a -> b) -> a -> b
$ if Vector2 -> GLdouble
forall v. Vector v => v -> GLdouble
vmag (Vector2
pos Vector2 -> Vector2 -> Vector2
forall a. Num a => a -> a -> a
- Vector2
npos) GLdouble -> GLdouble -> Bool
forall a. Ord a => a -> a -> Bool
< GLdouble
1 then Node -> Maybe Node
forall a. a -> Maybe a
Just Node
n else Maybe Node
forall a. Maybe a
Nothing

	reshape :: ReshapeCallback
reshape s :: Size
s@(GL.Size GLsizei
w GLsizei
h) = do
		IORef GLdouble -> GLdouble -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef GLdouble
aspect GLdouble
newAspect
		StateVar (Position, Size)
GL.viewport StateVar (Position, Size) -> (Position, Size) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Position, Size) -> (Position, Size) -> m ()
$= (GLsizei -> GLsizei -> Position
GL.Position GLsizei
0 GLsizei
0, Size
s)
		StateVar MatrixMode
GL.matrixMode StateVar MatrixMode -> MatrixMode -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar MatrixMode -> MatrixMode -> m ()
$= MatrixMode
GL.Projection
		IO ()
GL.loadIdentity
		GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO ()
GL.perspective GLdouble
0 GLdouble
newAspect (-GLdouble
1) GLdouble
1
		StateVar MatrixMode
GL.matrixMode StateVar MatrixMode -> MatrixMode -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar MatrixMode -> MatrixMode -> m ()
$= GLsizei -> MatrixMode
GL.Modelview GLsizei
0
		where newAspect :: GLdouble
newAspect = GLsizei -> GLdouble
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
w GLdouble -> GLdouble -> GLdouble
forall a. Fractional a => a -> a -> a
/ GLsizei -> GLdouble
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GLsizei -> GLsizei -> GLsizei
forall a. Ord a => a -> a -> a
max GLsizei
1 GLsizei
h)

unproject ∷ GL.Position → IO (GL.Vertex3 GL.GLdouble)
unproject :: Position -> IO (Vertex3 GLdouble)
unproject (GL.Position GLsizei
x GLsizei
y) = do
	GL.Size GLsizei
winWidth GLsizei
winHeight ← StateVar Size -> IO Size
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *). MonadIO m => StateVar Size -> m Size
GL.get StateVar Size
GL.windowSize
	let pos :: Vertex3 GLdouble
pos = GLdouble -> GLdouble -> GLdouble -> Vertex3 GLdouble
forall a. a -> a -> a -> Vertex3 a
GL.Vertex3 (GLsizei -> GLdouble
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
x) (GLsizei -> GLdouble
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GLsizei -> GLdouble) -> GLsizei -> GLdouble
forall a b. (a -> b) -> a -> b
$ GLsizei -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
winHeight GLsizei -> GLsizei -> GLsizei
forall a. Num a => a -> a -> a
- GLsizei
y) GLdouble
0
	GLmatrix GLdouble
modelview  ← MatrixMode -> IO (GLmatrix GLdouble)
getMatrix (GLsizei -> MatrixMode
GL.Modelview GLsizei
1)
	GLmatrix GLdouble
projection ← MatrixMode -> IO (GLmatrix GLdouble)
getMatrix MatrixMode
GL.Projection
	(Position, Size)
viewport   ← StateVar (Position, Size) -> IO (Position, Size)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *).
MonadIO m =>
StateVar (Position, Size) -> m (Position, Size)
GL.get StateVar (Position, Size)
GL.viewport
	Vertex3 GLdouble
-> GLmatrix GLdouble
-> GLmatrix GLdouble
-> (Position, Size)
-> IO (Vertex3 GLdouble)
forall (m :: * -> *).
Matrix m =>
Vertex3 GLdouble
-> m GLdouble
-> m GLdouble
-> (Position, Size)
-> IO (Vertex3 GLdouble)
GL.unProject Vertex3 GLdouble
pos GLmatrix GLdouble
modelview GLmatrix GLdouble
projection (Position, Size)
viewport

getMatrix ∷ GL.MatrixMode → IO (GL.GLmatrix GL.GLdouble)
getMatrix :: MatrixMode -> IO (GLmatrix GLdouble)
getMatrix = StateVar (GLmatrix GLdouble) -> IO (GLmatrix GLdouble)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *).
MonadIO m =>
StateVar (GLmatrix GLdouble) -> m (GLmatrix GLdouble)
GL.get (StateVar (GLmatrix GLdouble) -> IO (GLmatrix GLdouble))
-> (MatrixMode -> StateVar (GLmatrix GLdouble))
-> MatrixMode
-> IO (GLmatrix GLdouble)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe MatrixMode -> StateVar (GLmatrix GLdouble)
forall (m :: * -> *) c.
(Matrix m, MatrixComponent c) =>
Maybe MatrixMode -> StateVar (m c)
GL.matrix (Maybe MatrixMode -> StateVar (GLmatrix GLdouble))
-> (MatrixMode -> Maybe MatrixMode)
-> MatrixMode
-> StateVar (GLmatrix GLdouble)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatrixMode -> Maybe MatrixMode
forall a. a -> Maybe a
Just

renderNode ∷ (Render n, View Position n, View Rotation n) ⇒ Set.Set Node → (Node,n) → IO ()
renderNode :: forall n.
(Render n, View Position n, View Rotation n) =>
Set Node -> (Node, n) -> IO ()
renderNode Set Node
highlighted (Node
ref,n
n) = IO () -> IO ()
forall a. IO a -> IO a
GL.preservingMatrix (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
	Vector3 GLdouble -> IO ()
forall c. MatrixComponent c => Vector3 c -> IO ()
GL.translate (Vector2 -> Vector3 GLdouble
vector (Vector2 -> Vector3 GLdouble) -> Vector2 -> Vector3 GLdouble
forall a b. (a -> b) -> a -> b
$ (Position -> Vector2) -> n -> Vector2
forall v n field. View v n => (v -> field) -> n -> field
examine Position -> Vector2
position n
n)
	GLdouble -> Vector3 GLdouble -> IO ()
forall c. MatrixComponent c => c -> Vector3 c -> IO ()
GL.rotate (GLdouble -> GLdouble
convertDouble (GLdouble -> GLdouble) -> GLdouble -> GLdouble
forall a b. (a -> b) -> a -> b
$ (Rotation -> GLdouble) -> n -> GLdouble
forall v n field. View v n => (v -> field) -> n -> field
examine Rotation -> GLdouble
rotation n
n GLdouble -> GLdouble -> GLdouble
forall a. Num a => a -> a -> a
* GLdouble
180 GLdouble -> GLdouble -> GLdouble
forall a. Fractional a => a -> a -> a
/ GLdouble
forall a. Floating a => a
pi) (GLdouble -> GLdouble -> GLdouble -> Vector3 GLdouble
forall a. a -> a -> a -> Vector3 a
GL.Vector3 GLdouble
0 GLdouble
0 GLdouble
1 ∷ GL.Vector3 GL.GLdouble)
	if Node
ref Node -> Set Node -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Node
highlighted
		then Color3 GLfloat -> IO ()
forall a. Color a => a -> IO ()
GL.color (GLfloat -> GLfloat -> GLfloat -> Color3 GLfloat
forall a. a -> a -> a -> Color3 a
GL.Color3 GLfloat
1 GLfloat
0 GLfloat
0 ∷ GL.Color3 GL.GLfloat)
		else Color3 GLfloat -> IO ()
forall a. Color a => a -> IO ()
GL.color (GLfloat -> GLfloat -> GLfloat -> Color3 GLfloat
forall a. a -> a -> a -> Color3 a
GL.Color3 GLfloat
0 GLfloat
0 GLfloat
0 ∷ GL.Color3 GL.GLfloat)
	n -> IO ()
forall a. Render a => a -> IO ()
render n
n

renderLine ∷ Vector2 → Vector2 → IO ()
renderLine :: Vector2 -> Vector2 -> IO ()
renderLine Vector2
p1 Vector2
p2 = PrimitiveMode -> IO () -> IO ()
forall a. PrimitiveMode -> IO a -> IO a
GL.renderPrimitive PrimitiveMode
GL.Lines (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Vector2 -> IO ()
vertex Vector2
p1 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Vector2 -> IO ()
vertex Vector2
p2