A while ago, me and some friends wrote a C++
tool to generate and visualise
graphs, and I was surprised at how easy it is to “balance” graph
vertices so that they are laid out in a nice way. This tutorial
reproduces a version of the algorithm in Haskell, using the
`gloss`

library to get the
graph on the screen. Apart from `gloss`

nothing outside the Haskell
Platform is needed.^{1}

This tutorial is aimed at beginners, and only a basic knowledge of Haskell is required—we disregard performance in favour of simple code. Here is a preview of the result:

We import the libraries we need, qualifying `Map`

and `Set`

avoiding
clashes with the `Prelude`

.

```
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import System.Random
import Graphics.Gloss
import Graphics.Gloss.Data.Vector
import Graphics.Gloss.Data.ViewState
import Graphics.Gloss.Interface.Pure.Game
```

First, let’s frame the problem we want to solve. We have an undirected graph, and we want to position its vertices on a surface so that the result is pleasant to look at. “Pleasant to look at” is still a very vague requirement depending on fuzzy things like human taste, and in fact there are many ways to go at this problem.

We will gain inspiration from physics, and take vertices to be like
charged particles repelling each other, and edges to be like elastic
bands pulling the vertices together.^{2} We will calculate the
forces and update the positions in rounds, and hopefully after some time
our graph will stabilise. With the right numbers, this gives
surprisingly good results: clusters of vertices are held together by the
numerous edges between them, while sparsely connected vertices remain
distant, reducing clutter.

`Graph`

#We need some kind of identifier for our vertices, we will simply go for
`Int`

. An `Edge`

is a pair of `Vertex`

s.

```
type Vertex = Int
type Edge = (Vertex, Vertex)
```

We want to store our graph so that the operations we need to execute are
as natural as possible. Given the algorithm outline given above, we
need to do two things well: iterating through all the vertices, and
iterating through the neighbours of a given vertex. With that in mind,
the simplest thing to do is simply store the graph as the set of
neighbouring nodes for each `Vertex`

:

```
-- INVARIANT Every `Vertex` present in a set of neighbours is
-- present as a key in the `Map`.
newtype Graph = Graph {grNeighs :: Map Vertex (Set Vertex)}
emptyGraph :: Graph
= Graph Map.empty emptyGraph
```

When we add a vertex, we make sure that a set of neighbours exist for that vertex. In this way adding existing vertices will not modify the graph.

```
addVertex :: Vertex -> Graph -> Graph
Graph neighs) =
addVertex v (Graph $ case Map.lookup v neighs of
Nothing -> Map.insert v Set.empty neighs
Just _ -> neighs
```

When we add an `Edge`

, we first make sure that the vertices provided are
present in the graph by adding them, and then add each vertex to the
other vertex’s neighbours.

```
addEdge :: Edge -> Graph -> Graph
= Graph neighs
addEdge (v1, v2) gr where
= addVertex v1 (addVertex v2 gr)
gr' = Map.insert v1 (Set.insert v2 (vertexNeighs v1 gr')) $
neighs $
Map.insert v2 (Set.insert v1 (vertexNeighs v2 gr')) grNeighs gr'
```

`vertexNeighs`

unsafely gets the neighbours of a given `Vertex`

: the
precondition is that the `Vertex`

provided is in the graph.

```
vertexNeighs :: Vertex -> Graph -> Set Vertex
Graph neighs) = neighs Map.! v vertexNeighs v (
```

This is all we need to implement the algorithm. It is also useful to
have a function returning all the edges in the `Graph`

so that we can
draw them. `Set.foldr`

and `Map.foldrWithKey`

are equivalent to the
usual `foldr`

for lists, with the twist that with a `Map`

we fold over
the key and value at the same time. Since the graph is undirected, we
“order” each edge so that the the vertex with the lower id appears
first: in this way we will avoid duplicates like `(1, 2)`

and `(2, 1)`

.

```
graphEdges :: Graph -> Set Edge
= Map.foldrWithKey' foldNeighs Set.empty . grNeighs
graphEdges where
-- For each vertex `v1`, insert an edge for each neighbour `v2`.
=
foldNeighs v1 ns es -> Set.insert (order (v1, v2))) es ns
Set.foldr' (\v2 = if v1 > v2 then (v1, v2) else (v2, v1) order (v1, v2)
```

`Scene`

#Now that we have our graph, we need a data structure recording the
position of each point. We also want to be able to “grab” points to
move them around, so we add a field recording whether we have a `Vertex`

grabbed or not. We also make use of `gloss`

`ViewState`

, which will let
us implement panning, rotating, and zooming in an easy way.

```
-- INVARIANT The keys in `scGraph` are the same as the keys
-- in `scPoints`.
data Scene =
Scene { scGraph :: Graph
scPoints :: Map Vertex Point
, scSelected :: Maybe Vertex
, scViewState :: ViewState }
,
emptyScene :: Scene
=
emptyScene Scene{ scGraph = emptyGraph
= Map.empty
, scPoints = Nothing
, scSelected = viewStateInit } , scViewState
```

Then two predictable operations: one that adds a `Vertex`

, with its
initial position on the scene, and one that adds an `Edge`

. When adding
the `Edge`

, we *need* both points to be already present—see the
invariant for `Scene`

. We cannot simply add the vertices like we do in
`addEdge`

because we need their positions.

```
scAddVertex :: Vertex -> Point -> Scene -> Scene
@Scene{scGraph = gr, scPoints = pts} =
scAddVertex v pt sc= addVertex v gr, scPoints = Map.insert v pt pts}
sc{scGraph
scAddEdge :: Edge -> Scene -> Scene
@(v1, v2) sc@Scene{scGraph = gr, scPoints = pts} =
scAddEdge eif Map.member v1 pts && Map.member v2 pts
then sc{scGraph = addEdge e gr}
else error "scAddEdge: non existant point!"
```

It is also useful to have an helper to get the position of a `Vertex`

.

```
vertexPos :: Vertex -> Scene -> Point
Scene{scPoints = pts} = pts Map.! v vertexPos v
```

Now we can write the functions to convert the `Scene`

to a `Picture`

.
Thanks to `gloss`

, this is *extremely* easy: we are offered a simple
data type that `gloss`

will use to get things on the screen.

Some constants:

```
vertexRadius :: Float
= 6
vertexRadius
vertexColor :: Color
= makeColor 1 0 0 1 -- Red
vertexColor
edgeColor :: Color
= makeColor 1 1 1 0.8 -- Whiteish edgeColor
```

Drawing a `Vertex`

is simply drawing a circle. We use `ThickCircle`

to
get the circle to be filled instead of just an outline.

```
drawVertex :: Vertex -> Scene -> Picture
=
drawVertex v sc Translate x y (ThickCircle (vertexRadius / 2) vertexRadius)
where (x, y) = vertexPos v sc
```

Drawing an `Edge`

is drawing a `Line`

.

```
drawEdge :: Edge -> Scene -> Picture
= Line [vertexPos v1 sc, vertexPos v2 sc] drawEdge (v1, v2) sc
```

Bringing everything together, we generate `Picture`

s for all the
vertices and all the edges, and then combine those with the appropriate
colours. Moreover we get the `ViewPort`

in the `ViewState`

—which
stores the current translation, rotation, and scaling—and apply it to
the picture.

```
drawScene :: Scene -> Picture
@Scene{scGraph = gr, scViewState = ViewState{viewStateViewPort = port}} =
drawScene sc$
applyViewPortToPicture port Pictures [Color edgeColor edges, Color vertexColor vertices]
where
= Pictures [drawVertex n sc | n <- Map.keys (grNeighs gr) ]
vertices = Pictures [drawEdge e sc | e <- Set.toList (graphEdges gr)] edges
```

Now to the interesting part, the code necessary to balance the graph. As mentioned, we have two contrasting forces. Each vertex “pushes” all the others away, and each edge “pulls” together the connected vertices.

First we define a function for the “pushing” force, resulting from the
charge of the vertices.
Predictably, the force
will be inversely proportional to the square of the distance of the two
vertices. `Graphics.Gloss.Data.Vector`

defines

`type Vector = (Float, Float)`

and also a `Num`

instance for `Vector`

, which means that we can take
advantage of vector subtraction to easily get the distance and the
direction of the force.

The charge of each particle has been determined empirically to give good
results—increasing it will lead to a more “spaced out” graph,
decreasing it a more crowded one. `mulSV`

lets us multiply `Vector`

s by
scalars, `magV`

lets us get the magnitude of a vector (in this case
the distance). Varying the charge will determine how far apart the
vertices will be.

```
charge :: Float
= 100000
charge
pushForce :: Point -- Vertex we're calculating the force for
-> Point -- Vertex pushing the other away
-> Vector
=
pushForce v1 v2 -- If we are analysing the same vertex, l = 0
if l > 0 then (charge / l) `mulSV` normaliseV d else 0
where
= v1 - v2
d = magV d ** 2 l
```

For what concerns the force that pulls connected vertices together, it will be proportional to the distance of the two vertices, so we can take the distance vector directly and multiply it by the stiffness, although this time ve have the vector point in the other direction, since this force brings the vertices together.

```
stiffness :: Float
= 1 / 2
stiffness
pullForce :: Point -> Point -> Vector
= stiffness `mulSV` (v2 - v1) pullForce v1 v2
```

We can then write a function to get the velocity of a `Vertex`

in each
round:

```
updatePosition :: Float -- Time since the last update
-> Vertex -- Vertex we are analysing
-> Scene
-> Point -- New position
@Scene{scPoints = pts, scGraph = gr} =
updatePosition dt v1 sc+ pull + push
v1pos where
= vertexPos v1 sc
v1pos
-- Gets a velocity by multiplying the time by the force (we take
-- the mass to be 1).
= dt `mulSV` f v1pos v2pos
getVel f v2pos
-- Sum all the pushing and pulling. All the other vertices push,
-- the connected vertices pull.
= Map.foldr' (\v2pos -> (getVel pushForce v2pos +)) 0 pts
push = foldr (\v2pos -> (getVel pullForce v2pos +)) 0
pull | v2 <- Set.toList (vertexNeighs v1 gr)] [vertexPos v2 sc
```

We bring everything together by calculating the new position for each vertex. We do not move the vertex that is currently selected by the user, if there is one.

```
updatePositions :: Float -> Scene -> Scene
@Scene{scSelected = sel, scGraph = Graph neighs} =
updatePositions dt scfoldr f sc (Map.keys neighs)
where
=
f n sc' let pt = if Just n == sel
then vertexPos n sc else updatePosition dt n sc'
in scAddVertex n pt sc'
```

When a user clicks to grab a point, we need to check if she has caught
something. Thus we define `inCircle`

to check if the a point is inside
the drawn version of a vertex.

```
inCircle :: Point -- Where the user has clicked
-> Float -- The scaling factor in the ViewPort
-> Point -- The position of the vertex
-> Bool
= magV (v - p) <= vertexRadius * sca inCircle p sca v
```

`findVertex`

iterates through all the vertices and returns one if the
position where the user has clicked is in it.

```
findVertex :: Point -> Float -> Scene -> Maybe Vertex
Scene{scPoints = pts} =
findVertex p1 sca Nothing pts
Map.foldrWithKey' f where
Just v) = Just v
f _ _ (Nothing = if inCircle p1 sca p2 then Just v else Nothing f v p2
```

User input will come in the form of `Event`

s, a `gloss`

data type that
represents key or mouse button presses, and mouse motion. Thus we
define `handleEvent`

to process an `Event`

and a `Scene`

producing a new
`Scene`

:

`handleEvent :: Event -> Scene -> Scene`

We want the user to be able to grab vertices. Since the default
configuration for the `ViewState`

—which we are using—already uses
the left and right mouse button for its actions, we require the user to
press `Ctrl`

and click:

```
EventKey (MouseButton LeftButton) Down Modifiers{ctrl = Down} pos) sc =
handleEvent (case findVertex (invertViewPort port pos) (viewPortScale port) sc of
Nothing -> sc
Just v -> sc{scSelected = Just v}
where
= scViewState sc
viewState = viewStateViewPort viewState port
```

`invertViewPort`

“undoes” the rotation, translation and scaling applied
by the `ViewPort`

to the picture, so that we can map user input to the
coordinates that `scPoints`

refers to.

When the user releases the left mouse button and a vertex is selected, we deselect it:

```
EventKey (MouseButton LeftButton) Up _ _) sc@Scene{scSelected = Just _} =
handleEvent (= Nothing} sc{scSelected
```

When the user moves the mouse and a vertex is selected, we move the vertex where the cursor is:

```
EventMotion pos) sc@Scene{scPoints = pts, scSelected = Just v} =
handleEvent (= Map.insert v (invertViewPort port pos) pts}
sc{scPoints where
= viewStateViewPort (scViewState sc) port
```

When none of the above apply, we pass the event to the `ViewState`

,
which will handle the panning, rotating, and zooming.

```
=
handleEvent ev sc = updateViewStateWithEvent ev (scViewState sc)} sc{scViewState
```

Finally, we put the code above to good use. We will use a sample graph to draw:

```
-- Taken from <http://www.graphviz.org/Gallery/undirected/transparency.gv.txt>.
sampleGraph :: [Edge]
=
sampleGraph 1, 30), (1, 40), (8, 46), (8, 16), (10, 25), (10, 19), (10, 33),
[(12, 8 ), (12, 36), (12, 17), (13, 38), (13, 24), (24, 49), (24, 13),
(24, 47), (24, 12), (25, 27), (25, 12), (27, 12), (27, 14), (29, 10),
(29, 8 ), (30, 24), (30, 44), (38, 29), (38, 35), (2, 42), (2, 35),
(2, 11), (14, 18), (14, 24), (14, 38), (18, 49), (18, 47), (26, 41),
(26, 42), (31, 39), (31, 47), (31, 25), (37, 26), (37, 16), (39, 50),
(39, 14), (39, 18), (39, 47), (41, 31), (41, 8 ), (42, 44), (42, 29),
(44, 37), (44, 32), (3, 20), (3, 28), (6, 45), (6, 28), (9, 6 ),
(9, 16), (15, 16), (15, 48), (16, 50), (16, 32), (16, 39), (20, 33),
(33, 9 ), (33, 46), (33, 48), (45, 15), (4, 17), (4, 15), (4, 12),
(17, 21), (19, 35), (19, 15), (19, 43), (21, 19), (21, 50), (23, 36),
(34, 23), (34, 24), (35, 34), (35, 16), (35, 18), (36, 46), (5, 7 ),
(5, 36), (7, 32), (7, 11), (7, 14), (11, 40), (11, 50), (22, 46),
(28, 43), (28, 8 ), (32, 28), (32, 39), (32, 42), (40, 22), (40, 47),
(43, 11), (43, 17)
( ]
```

Then an utility function `fromEdges`

initialises a scene from a list of
edges randomising the positions of the vertices in the initial window
size:

```
windowSize :: (Int, Int)
= (640, 480)
windowSize
fromEdges :: StdGen -> [Edge] -> Scene
=
fromEdges gen es foldr scAddEdge (fst (Set.foldr' addv (emptyScene, gen) vs)) es
where
= Set.fromList (concat [[v1, v2] | (v1, v2) <- es])
vs
= fromIntegral (fst windowSize) / 2
halfWidth = fromIntegral (snd windowSize) / 2
halfHeight
=
addv v (sc, gen1) let (x, gen2) = randomR (-halfWidth, halfWidth ) gen1
= randomR (-halfHeight, halfHeight) gen2
(y, gen3) in (scAddVertex v (x, y) sc, gen3)
```

Finally, we use the `play`

function provided by `gloss`

to make
everything work. The important arguments in `play`

are the last two
functions, which update the state of the world after a user event and
after a time step, respectively. In our case `handleEvent`

and
`updatePositions`

will do the job, our world being a `Scene`

.

```
sceneWindow :: Scene -> IO ()
=
sceneWindow sc InWindow "Graph Drawing - ctrl + left mouse button to drag" windowSize (10, 10))
play (30 sc drawScene handleEvent updatePositions black
```

Then all its left to do is to initialise the `Scene`

and run
`sceneWindow`

.

```
main :: IO ()
=
main do gen <- getStdGen
sceneWindow (fromEdges gen sampleGraph)
```

The code provided is a good starting point for many improvements, here we give some suggestions.

**Performance**The code does not scale well for big graphs, for a number of reason.

*QuadTree/Voronoi diagram*: Currently our algorithm is cubic: for each vertex we go over all the other vertices for the push forces and over all the neighbours for the pull forces.It can be made much faster by approximating distant clusters of vertices to a single particle with higher charge. An easy way is to subdivide recursively the space into squares, a goal achievable by storing the graph in a

*QuadTree*.^{3}Then squares that are far enough are deemed as one entity.^{4}A more precise but also more expensive way is to subdivide the space in a more irregular way depending on the disposition of the vertices, for example in what is called a

*Voronoi diagram*.*Arrays*: Currently, once a graph is loaded, it stays the same forever. This considered, using`Map`

is quite a waste: we can utilise a structure with much better performance to store the graph, such as an`Array`

or a`Vector`

. The best option would probably be an unboxed`Vector`

.

**Functionality***Weighed edges*: We can easily adapt the algorithm to work with weighed edges by adjusting the stiffness of each edge depending on the weigh. For example if the weigh represents the distance between two connected nodes, the stiffness will be inversely proportional to the weigh, so that closer vertices will indeed end up being closer.*Generating graphs*: Generating realistic graphs is an interesting and useful challenge. It turns out that many real networks, such as friendships and the web, share certain characteristics. Such networks are known as*small-world networks*, and various algorithms to generate them are available.*3D*: The algorithm can be trivially extended to the 3rd dimension—in fact given the right`Num`

instances it will work in automatically, and with some type class trickery in any dimension.The hard part would be drawing the graph, since

`gloss`

does not go beyond 2 dimensions, and raw OpenGL is so much uglier.: The program could be enhanced with a parser for`dot`

files`dot`

or similar format, so that experiments could be ran on existing graphs.

If you implement any of the above in a nice way, let me know!

As usual, comments on Reddit.

Note that you need the very last version of

`gloss`

, 1.8.0.1, for this code to work. The author spent some time hacking on gloss to make this code simpler, and the changes have been merged recently.↩︎This class of algorithms is known as

*force-directed graph drawing*.↩︎`gloss`

provides a module to work with QuadTrees,`Graphics.Gloss.Data.QuadTree`

.↩︎This approach is known as

*Barnes-Hut simulation*.↩︎