{-# LANGUAGE FlexibleContexts #-}
module GraphRewriting.Layout.SpringEmbedder where

import GraphRewriting.Graph
import GraphRewriting.Graph.Read
import GraphRewriting.Layout.Position
import GraphRewriting.Layout.PortSpec
import GraphRewriting.Layout.Rotation
import GraphRewriting.Layout.RotPortSpec
import GraphRewriting.Layout.Force
import Control.Monad
import Data.Vector.Class


springForce ∷ (View [Port] n, View Position n, View Rotation n, PortSpec n) ⇒ Double → Node → WithGraph n Force
springForce :: forall n.
(View [Port] n, View Position n, View Rotation n, PortSpec n) =>
Double -> Node -> WithGraph n Force
springForce Double
springLength Node
n = ([Force] -> Force)
-> ReaderT (Graph n) Identity [Force]
-> ReaderT (Graph n) Identity Force
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Force] -> Force
fsum (ReaderT (Graph n) Identity [Force]
 -> ReaderT (Graph n) Identity Force)
-> ReaderT (Graph n) Identity [Force]
-> ReaderT (Graph n) Identity Force
forall a b. (a -> b) -> a -> b
$ (Port -> ReaderT (Graph n) Identity Force)
-> [Port] -> ReaderT (Graph n) Identity [Force]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Port -> ReaderT (Graph n) Identity Force
forall {m :: * -> *} {a1}.
(MonadFail m, PortSpec a1, View [Port] a1, View Position a1,
 View Rotation a1, MonadReader (Graph a1) m) =>
Port -> m Force
edgeForce ([Port] -> ReaderT (Graph n) Identity [Force])
-> ReaderT (Graph n) Identity [Port]
-> ReaderT (Graph n) Identity [Force]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node -> ReaderT (Graph n) Identity [Port]
forall n (m :: * -> *).
(View [Port] n, MonadReader (Graph n) m, MonadFail m) =>
Node -> m [Port]
attachedEdges Node
n where
	
	edgeForce :: Port -> m Force
edgeForce Port
e = do
		[Node]
ns ← Node -> Port -> m [Node]
forall n (m :: * -> *).
(MonadReader (Graph n) m, MonadFail m) =>
Node -> Port -> m [Node]
adverseNodes Node
n Port
e
		[Vector2]
nTs ← Port -> Node -> m [Vector2]
forall {m :: * -> *} {a1}.
(PortSpec a1, View [Port] a1, View Position a1, View Rotation a1,
 MonadReader (Graph a1) m, MonadFail m) =>
Port -> Node -> m [Vector2]
springTargets Port
e Node
n
		[Vector2]
nsTs ← ([[Vector2]] -> [Vector2]) -> m [[Vector2]] -> m [Vector2]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Vector2]] -> [Vector2]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[Vector2]] -> m [Vector2]) -> m [[Vector2]] -> m [Vector2]
forall a b. (a -> b) -> a -> b
$ (Node -> m [Vector2]) -> [Node] -> m [[Vector2]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Port -> Node -> m [Vector2]
forall {m :: * -> *} {a1}.
(PortSpec a1, View [Port] a1, View Position a1, View Rotation a1,
 MonadReader (Graph a1) m, MonadFail m) =>
Port -> Node -> m [Vector2]
springTargets Port
e) [Node]
ns
		Force -> m Force
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Force -> m Force) -> Force -> m Force
forall a b. (a -> b) -> a -> b
$ [Force] -> Force
fsum [Vector2 -> Vector2 -> Force
attraction Vector2
nsT Vector2
nT | Vector2
nsT ← [Vector2]
nsTs, Vector2
nT ← [Vector2]
nTs]
	
	springTargets :: Port -> Node -> m [Vector2]
springTargets Port
e Node
node = do
		[(Vector2, Vector2)]
ps ← (a1 -> [(Vector2, Vector2)]) -> m a1 -> m [(Vector2, Vector2)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((a1 -> [(Vector2, Vector2)]) -> Port -> a1 -> [(Vector2, Vector2)]
forall n a. View [Port] n => (n -> [a]) -> Port -> n -> [a]
propOfPort a1 -> [(Vector2, Vector2)]
forall n.
(PortSpec n, View Position n, View Rotation n) =>
n -> [(Vector2, Vector2)]
absRotPortSpec Port
e) (Node -> m a1
forall n (m :: * -> *).
(MonadReader (Graph n) m, MonadFail m) =>
Node -> m n
readNode Node
node)
		[Vector2] -> m [Vector2]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Vector2] -> m [Vector2]) -> [Vector2] -> m [Vector2]
forall a b. (a -> b) -> a -> b
$ ((Vector2, Vector2) -> Vector2)
-> [(Vector2, Vector2)] -> [Vector2]
forall a b. (a -> b) -> [a] -> [b]
map (\(Vector2
p,Vector2
dir) → Vector2
p Vector2 -> Vector2 -> Vector2
forall a. Num a => a -> a -> a
+ Vector2 -> Vector2
forall v. Vector v => v -> v
vnormalise Vector2
dir Vector2 -> Double -> Vector2
forall v. Vector v => v -> Double -> v
|* Double
springLength) [(Vector2, Vector2)]
ps