Grid Layout
====

We implement a simple and robust layout algorithm for drawing interaction nets.
We guarantee a minimum distance between any two nodes, and dynamic addition and
deletion of nodes should bring minimal changes to existing layout. All nodes
and lines are aligned to grids.

Layout computation is encapsulated in a monad transformer, and thus is easy
to compose with other parts of the program.

> {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, 
>              StandaloneDeriving, GeneralizedNewtypeDeriving, TupleSections #-}
> module Grid 
>   ( GridT
>   , GridMap
>   , Pos
>   , Radius
>   , evalGridT
>   , evalGridT_
>   , getGrid
>   , setGrid
>   , modifyGrid
>   , clearGrid
>   , getNodes
>   , lookupNode
>   , locateNode
>   , modifyNodeVal
>   , modifyNodePos
>   , newNode
>   , removeNode
>   ) where

> import qualified Data.IntMap as M
> import Data.Complex
> import Control.Arrow (first, second, (***))
> import Control.Monad.State 
> import Data.List (sortBy)

> type Uid  = M.Key
> type Radius = Float
> type Pos  = (Float, Float)
> type GridMap v = M.IntMap ((Pos, Radius), v)

> data S a = S { spacing :: Float, grid :: a }
> 
> newtype GridT v m a 
>   = GridT (StateT (S (GridMap v)) m a)
>   deriving (Functor, Monad, MonadTrans) 
>
> deriving instance Monad m => MonadState (S (GridMap v)) (GridT v m)
> deriving instance MonadIO m => MonadIO (GridT v m)

> clearGrid :: Monad m => GridT v m ()
> clearGrid = modify $ \s -> s { grid = M.empty }

> getGrid :: Monad m => GridT v m (GridMap v)
> getGrid = get >>= return . grid
> modifyGrid f  = modify $ \s -> s { grid = f (grid s) }
> modifyGrid' f = modify $ \s -> s { grid = f (spacing s) (grid s) }
> setGrid :: Monad m => GridMap v -> GridT v m ()
> setGrid = modifyGrid . const

> evalGridT :: Monad m => GridT v m a -> Float -> GridMap v -> m a
> evalGridT (GridT m) space grid = evalStateT m $ S space grid

> evalGridT_ :: Monad m => GridT v m a -> Float -> m a
> evalGridT_ m space = evalGridT m space M.empty 

> getNodes :: Monad m => GridT v m [(Uid, ((Pos, Radius), v))]
> getNodes = getGrid >>= return . M.toList 

> lookupNode :: Monad m => Uid -> GridT v m (Maybe ((Pos, Radius), v))
> lookupNode uid = getGrid >>= return . M.lookup uid 

> locateNode :: Monad m => Pos -> GridT v m [Uid]
> locateNode (x0, y0) = getGrid >>= return . M.keys . M.filter (inside . fst)
>   where 
>     inside ((x, y), r) = sqrt (dx * dx + dy * dy) < r
>       where 
>         dx = x - x0 
>         dy = y - y0

> modifyNodeVal :: Monad m => Uid -> (v -> v) -> GridT v m ()
> modifyNodeVal uid f = modifyGrid (M.alter (fmap (second f)) uid)

> modifyNodePos :: Monad m => Uid -> ((Pos, Radius) -> (Pos, Radius)) -> GridT v m Bool
> modifyNodePos uid f = do
>   modifyGrid (M.alter (fmap (first f)) uid)
>   m <- getGrid
>   maybe (return False) (\n -> modifyGrid' (`adjust` (fst n)) >> return True)
>         (M.lookup uid m)
>   where
>     adjust spacing ((x0, y0), r0) = 
>       M.fromList . map (fromPolar x0 y0) . 
>       balanceList spacing . sortByDistance . 
>       map (toPolar x0 y0) . M.toList 

> newNode :: Monad m => Uid -> Pos -> Radius -> v -> GridT v m ()
> newNode uid (x0, y0) rad v = modifyGrid' insert
>   where
>     newNode = (uid, (((0, 0), rad), v))
>     insert spacing = M.fromList . map (fromPolar x0 y0) . 
>       foldl (balance spacing) [newNode] . sortByDistance . 
>       map (toPolar x0 y0) . M.toList 

> removeNode :: Monad m => Uid -> GridT v m Bool
> removeNode uid = getGrid >>=
>   maybe (return False) (\_ -> modifyGrid (M.delete uid) >> return True) 
>   -- maybe (return False) (\n -> modifyGrid' (`delete` (fst n)) >> return True) 
>   . M.lookup uid 
>   where
>     delete spacing ((x0, y0), r0) = M.fromList . map (fromPolar x0 y0) . 
>       balanceList spacing . tail . sortByDistance .  
>       map (shorten . toPolar x0 y0) . M.toList
>       where 
>         shorten = modPos $ \d -> d - r0 - spacing / 2

> modPos = second . first . first . first

> balanceList spacing (x:xs) = foldl (balance spacing) [x] xs
> balanceList spacing [] = []

> balance spacing l p = foldl improve p l : l
>   where 
>     improve u@(i, (((r, a), r0), _)) v@(_, (((r', a'), r1), _)) = 
>       if d > minD then u else modPos (const r'') u
>       where 
>         d = r' * sin (a' - a)
>         s = sqrt (minD * minD - d * d)
>         t = r' * cos (a' - a)
>         st = s + t 
>         r'' = if st > r then st else r
>         minD = spacing + r0 + r1
>
> sortByDistance = sortBy $ \u v -> compare (p u) (p v)
>   where p = fst . fst . fst . snd

> toPolar x0 y0 = second $ first $ first (polar . toC (x0, y0))
> toC (x0, y0) (x, y) = (x - x0) :+ (y - y0)

> fromPolar x0 y0 = second $ first $ first (fromC (x0, y0) . uncurry mkPolar)
> fromC (x0, y0) c = (x0 + realPart c, y0 + imagPart c)