gloss-examples 1.8.0.1 → 1.8.0.2
raw patch · 2 files changed
+221/−156 lines, 2 files
Files
- gloss-examples.cabal +1/−1
- picture/Graph/Main.hs +220/−155
gloss-examples.cabal view
@@ -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
picture/Graph/Main.hs view
@@ -1,222 +1,287 @@--- See <http://mazzo.li/posts/graph-drawing.html>, 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 <http://mazzo.li/posts/graph-drawing.html> 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 <http://www.graphviz.org/Gallery/undirected/transparency.gv.txt>+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 <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),+ [(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)