diff --git a/gloss-examples.cabal b/gloss-examples.cabal --- a/gloss-examples.cabal +++ b/gloss-examples.cabal @@ -1,5 +1,5 @@ Name: gloss-examples -Version: 1.8.0.1 +Version: 1.8.0.2 License: MIT License-file: LICENSE Author: Ben Lippmeier diff --git a/picture/Graph/Main.hs b/picture/Graph/Main.hs --- a/picture/Graph/Main.hs +++ b/picture/Graph/Main.hs @@ -1,222 +1,287 @@ --- 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) + +-- See for a lengthy +-- explanation about this code. +import Data.Map.Strict (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 +import qualified Data.Map.Strict as Map +import System.Random -type Vertex = Int -type Edge = (Vertex, Vertex) +import Graphics.Gloss +import Graphics.Gloss.Data.Vector +import Graphics.Gloss.Data.ViewState +import Graphics.Gloss.Interface.Pure.Game -data Graph = Graph - { grVertices :: Set Vertex - , grNeighs :: Map Vertex (Set Vertex) - } +type Vertex = Int +type Edge = (Vertex, Vertex) + +-- Graph ---------------------------------------------------------------------- +-- 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)} + +-- | An empty graph, with no edges or vertexes. emptyGraph :: Graph -emptyGraph = Graph{grVertices = Set.empty, grNeighs = Map.empty} +emptyGraph = Graph Map.empty + +-- | Add a new vertex to the graph. 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 - } +addVertex v (Graph neighs) + = Graph + $ case Map.lookup v neighs of + Nothing -> Map.insert v Set.empty neighs + Just _ -> neighs +-- | Add a new edge to the graph. 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' +addEdge (v1, v2) gr + = Graph 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' + +-- | Yield the neighbours of a vertex. vertexNeighs :: Vertex -> Graph -> Set Vertex -vertexNeighs v Graph{grNeighs = neighs} = neighs Map.! v +vertexNeighs v (Graph neighs) = neighs Map.! v + +-- | Get the set of edges in a graoh. 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) +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 -data Scene = Scene - { scGraph :: Graph - , scPoints :: Map Vertex Point - , scSelected :: Maybe Vertex - , scViewState :: ViewState - } + order (v1, v2) + = if v1 > v2 then (v1, v2) else (v2, v1) + +-- Scene ---------------------------------------------------------------------- +-- 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 } + + +-- | An empty scene. emptyScene :: Scene -emptyScene = - Scene{ scGraph = emptyGraph - , scPoints = Map.empty - , scSelected = Nothing - , scViewState = viewStateInit } +emptyScene + = Scene + { scGraph = emptyGraph + , scPoints = Map.empty + , scSelected = Nothing + , scViewState = viewStateInit } + +-- | Add a vertex to a scene. 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} + +-- | Add an edge to a scene. 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!" +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 "scAddEdge: non existant point!" + +-- | Randomize the endpoints of some edges, and pack them into a Scene. +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]) + 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) + + +-- Drawing -------------------------------------------------------------------- vertexPos :: Vertex -> Scene -> Point -vertexPos v Scene{scPoints = pts} = pts Map.! v +vertexPos v Scene{scPoints = pts} + = pts Map.! v + vertexRadius :: Float -vertexRadius = 6 +vertexRadius = 6 + vertexColor :: Color -vertexColor = makeColor 1 0 0 1 -- Red +vertexColor = makeColor 1 0 0 1 -- Red + edgeColor :: Color -edgeColor = makeColor 1 1 1 0.8 -- Whiteish +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 + where (x, y) = vertexPos v sc + drawEdge :: Edge -> Scene -> Picture -drawEdge (v1, v2) sc = Line [vertexPos v1 sc, vertexPos v2 sc] +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]) +drawScene :: Scene -> Picture +drawScene sc@Scene{scGraph = gr, scViewState = ViewState{viewStateViewPort = port}} + = applyViewPortToPicture port + $ Pictures [Color edgeColor edges, Color vertexColor vertices] + where + vertices = Pictures [drawVertex n sc | n <- Map.keys (grNeighs gr) ] + edges = Pictures [drawEdge e sc | e <- Set.toList (graphEdges gr)] - -- `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)] +-- Graph Layout --------------------------------------------------------------- +charge :: Float +charge = 100000 -fps :: Int -fps = 30 +pushForce + :: Point -- Vertex we're calculating the force for + -> Point -- Vertex pushing the other away + -> Vector -adjust :: Float -> Float -> Float -adjust dt x = x * dt * fromIntegral fps +pushForce v1 v2 + = -- If we are analysing the same vertex, l = 0 + if l > 0 then (charge / l) `mulSV` normaliseV d + else 0 + where d = v1 - v2 + l = magV d ** 2 -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) +stiffness :: Float +stiffness = 1 / 2 -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) +pullForce :: Point -> Point -> Vector +pullForce v1 v2 + = stiffness `mulSV` (v2 - v1) -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') +-- | Apply forces to update the position of a single point. +updatePosition + :: Float -- Time since the last update + -> Vertex -- Vertex we are analysing + -> Scene + -> Point -- New position - 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] +updatePosition dt v1 sc@Scene{scPoints = pts, scGraph = gr} + = v1pos + pull + push + where + v1pos = vertexPos v1 sc + -- Gets a velocity by multiplying the time by the force (we assume + -- a mass of 1). + getVel f v2pos = dt `mulSV` f v1pos v2pos + + -- Sum all the pushing and pulling. All the other vertices push, + -- the connected vertices pull. + push = Map.foldr' (\v2pos -> (getVel pushForce v2pos +)) 0 pts + pull = foldr (\v2pos -> (getVel pullForce v2pos +)) 0 + [vertexPos v2 sc | v2 <- Set.toList (vertexNeighs v1 gr)] + + +-- | Apply forces to update the position of all the points. 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' +updatePositions dt sc@Scene{scSelected = sel, scGraph = Graph neighs} + = foldr 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' -inCircle :: Point -> Float -> Point -> Bool -inCircle p sca center = magV (local center p) <= vertexRadius * sca +-- | Check if a point is in the given circle. +inCircle :: Point -- Where the user has clicked + -> Float -- The scaling factor in the ViewPort + -> Point -- The position of the vertex + -> Bool +inCircle p sca v + = magV (v - 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 +findVertex p1 sca Scene{scPoints = pts} = Map.foldrWithKey' f Nothing pts + where + f _ _ (Just v) = Just v + f v p2 Nothing = if inCircle p1 sca p2 then Just v else Nothing + +-- Events --------------------------------------------------------------------- handleEvent :: Event -> Scene -> Scene -handleEvent (EventKey (MouseButton MiddleButton) Down _ pos) sc = - case findVertex (invertViewPort port pos) (viewPortScale port) sc of +handleEvent (EventKey (MouseButton LeftButton) Down Modifiers{shift = Down} pos) sc + = case findVertex (invertViewPort port pos) (viewPortScale port) sc of Nothing -> sc Just v -> sc{scSelected = Just v} - where viewState = scViewState sc + 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 +handleEvent (EventKey (MouseButton LeftButton) Up _ _) + sc@Scene{scSelected = Just _} + = 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)} + + +-- Sample Graph --------------------------------------------------------------- +-- 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), + [(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), + (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) + (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) ] + +-- Main ----------------------------------------------------------------------- +windowSize :: (Int, Int) +windowSize = (800, 600) + + sceneWindow :: Scene -> IO () -sceneWindow sc = - play (InWindow "Graph Drawing - middle mouse button to drag" (640, 480) (10, 10)) - black 30 sc drawScene handleEvent updatePositions +sceneWindow sc + = play (InWindow "Graph Drawing - ctrl + left mouse button to drag" windowSize (10, 10)) + black 30 sc drawScene handleEvent updatePositions + main :: IO () -main = - do gen <- getStdGen - sceneWindow (fromEdges gen sampleGraph) +main + = do gen <- getStdGen + sceneWindow (fromEdges gen sampleGraph)