-- See , at some point I will
-- complete the prose that goes with the code
import Control.Monad (mplus)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Graphics.Gloss
import Graphics.Gloss.Data.Vector
import Graphics.Gloss.Interface.Pure.Game
import Graphics.Gloss.Data.ViewState
import System.Random
type Vertex = Int
type Edge = (Vertex, Vertex)
data Graph = Graph
{ grVertices :: Set Vertex
, grNeighs :: Map Vertex (Set Vertex)
}
emptyGraph :: Graph
emptyGraph = Graph{grVertices = Set.empty, grNeighs = Map.empty}
addVertex :: Vertex -> Graph -> Graph
addVertex v gr@Graph{grVertices = vs, grNeighs = neighs} =
gr{ grVertices = Set.insert v vs
, grNeighs = case Map.lookup v neighs of
Nothing -> Map.insert v Set.empty neighs
Just _ -> neighs
}
addEdge :: Edge -> Graph -> Graph
addEdge (v1, v2) gr = gr'{grNeighs = neighs}
where
gr' = addVertex v1 (addVertex v2 gr)
neighs = Map.insert v1 (Set.insert v2 (vertexNeighs v1 gr')) $
Map.insert v2 (Set.insert v1 (vertexNeighs v2 gr')) $
grNeighs gr'
vertexNeighs :: Vertex -> Graph -> Set Vertex
vertexNeighs v Graph{grNeighs = neighs} = neighs Map.! v
graphEdges :: Graph -> Set Edge
graphEdges = Map.foldrWithKey' foldNeighs Set.empty . grNeighs
where
-- For each vertex `v1', insert an edge for each neighbour `v2'.
foldNeighs v1 ns es =
Set.foldr' (\v2 -> Set.insert (order (v1, v2))) es ns
order (v1, v2) = if v1 > v2 then (v1, v2) else (v2, v1)
data Scene = Scene
{ scGraph :: Graph
, scPoints :: Map Vertex Point
, scSelected :: Maybe Vertex
, scViewState :: ViewState
}
emptyScene :: Scene
emptyScene =
Scene{ scGraph = emptyGraph
, scPoints = Map.empty
, scSelected = Nothing
, scViewState = viewStateInit }
scAddVertex :: Vertex -> Point -> Scene -> Scene
scAddVertex v pt sc@Scene{scGraph = gr, scPoints = pts} =
sc{scGraph = addVertex v gr, scPoints = Map.insert v pt pts}
scAddEdge :: Edge -> Scene -> Scene
scAddEdge e@(v1, v2) sc@Scene{scGraph = gr, scPoints = pts} =
if Map.member v1 pts && Map.member v2 pts
then sc{scGraph = addEdge e gr}
else error "non existant point!"
vertexPos :: Vertex -> Scene -> Point
vertexPos v Scene{scPoints = pts} = pts Map.! v
vertexRadius :: Float
vertexRadius = 6
vertexColor :: Color
vertexColor = makeColor 1 0 0 1 -- Red
edgeColor :: Color
edgeColor = makeColor 1 1 1 0.8 -- Whiteish
drawVertex :: Vertex -> Scene -> Picture
drawVertex v sc = Translate x y (ThickCircle (vertexRadius / 2) vertexRadius)
where (x, y) = vertexPos v sc
drawEdge :: Edge -> Scene -> Picture
drawEdge (v1, v2) sc = Line [vertexPos v1 sc, vertexPos v2 sc]
windowSize :: (Int, Int)
windowSize = (640, 480)
fromEdges :: StdGen -> [Edge] -> Scene
fromEdges gen es =
foldr scAddEdge (fst (Set.foldr' addv (emptyScene, gen) vs)) es
where
vs = Set.fromList (concat [[v1, v2] | (v1, v2) <- es])
-- `fromIntegral' is needed to convert from `Int' to `Float'.
halfWidth = fromIntegral (fst windowSize) / 2
halfHeight = fromIntegral (snd windowSize) / 2
addv v (sc, gen1) =
let (x, gen2) = randomR (-halfWidth, halfWidth) gen1
(y, gen3) = randomR (-halfHeight, halfHeight) gen2
in (scAddVertex v (x, y) sc, gen3)
drawScene :: Scene -> Picture
drawScene sc@Scene{scGraph = gr, scViewState = ViewState{viewStateViewPort = port}} =
applyViewPortToPicture port $
Pictures [Color vertexColor vertices, Color edgeColor edges]
where
vertices = Pictures [drawVertex n sc | n <- Set.toList (grVertices gr)]
edges = Pictures [drawEdge e sc | e <- Set.toList (graphEdges gr)]
fps :: Int
fps = 30
adjust :: Float -> Float -> Float
adjust dt x = x * dt * fromIntegral fps
local :: Point -> Point -> Vector
local (x1, y1) (x2, y2) = (x1 - x2, y1 - y2)
pushVelocity :: Float -> Point -> Point -> Vector
pushVelocity dt v1 v2 =
if l > 0 -- If we are analysing the same vertex, l = 0
then (dx * weight / l, dy * weight / l)
else (0, 0)
where
weight = adjust dt 120
(dx, dy) = local v1 v2
l = 2 * (dx * dx + dy * dy)
pullVelocity :: Int -> Float -> Point -> Point -> Vector
pullVelocity nedges dt v1 v2 =
(-(dx / weight), -(dy / weight))
where
(dx, dy) = local v1 v2
weight = adjust dt (fromIntegral (nedges + 1) * 10)
updatePosition :: Float -> Vertex -> Scene -> Point
updatePosition dt v1 sc@Scene{scPoints = pts, scGraph = gr} =
addVel v1pos (pull (push (0, 0)))
where
v1pos = vertexPos v1 sc
neighs = vertexNeighs v1 gr
addVel (x, y) (x', y') = (x + x', y + y')
push vel =
Map.foldr' (\v2pos -> addVel (pushVelocity dt v1pos v2pos))
vel pts
pull vel =
foldr (addVel . pullVelocity (Set.size neighs) dt v1pos)
vel [vertexPos v2 sc | v2 <- Set.toList neighs]
updatePositions :: Float -> Scene -> Scene
updatePositions dt sc@Scene{scSelected = sel, scGraph = gr} =
foldr uppt sc . Set.toList . grVertices $ gr
where
uppt n sc' =
let pt = if Just n == sel then vertexPos n sc
else updatePosition dt n sc'
in scAddVertex n pt sc'
inCircle :: Point -> Float -> Point -> Bool
inCircle p sca center = magV (local center p) <= vertexRadius * sca
findVertex :: Point -> Float -> Scene -> Maybe Vertex
findVertex p1 sca Scene{scPoints = pts} =
Map.foldrWithKey'
(\v p2 m -> m `mplus` if inCircle p1 sca p2 then Just v else Nothing)
Nothing pts
handleEvent :: Event -> Scene -> Scene
handleEvent (EventKey (MouseButton MiddleButton) Down _ pos) sc =
case findVertex (invertViewPort port pos) (viewPortScale port) sc of
Nothing -> sc
Just v -> sc{scSelected = Just v}
where viewState = scViewState sc
port = viewStateViewPort viewState
handleEvent (EventKey (MouseButton MiddleButton) Up _ _) sc =
sc{scSelected = Nothing}
handleEvent (EventMotion pos) sc@Scene{scPoints = pts, scSelected = Just v} =
sc{scPoints = Map.insert v (invertViewPort port pos) pts}
where port = viewStateViewPort (scViewState sc)
handleEvent ev sc = sc{scViewState = updateViewStateWithEvent ev (scViewState sc)}
-- Taken from
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)
]
sceneWindow :: Scene -> IO ()
sceneWindow sc =
play (InWindow "Graph Drawing - middle mouse button to drag" (640, 480) (10, 10))
black 30 sc drawScene handleEvent updatePositions
main :: IO ()
main =
do gen <- getStdGen
sceneWindow (fromEdges gen sampleGraph)