diff --git a/Data/Graph/Analysis.hs b/Data/Graph/Analysis.hs --- a/Data/Graph/Analysis.hs +++ b/Data/Graph/Analysis.hs @@ -1,7 +1,7 @@ {- | Module : Data.Graph.Analysis Description : A Graph-Theoretic Analysis Library. - Copyright : (c) Ivan Lazar Miljenovic 2008 + Copyright : (c) Ivan Lazar Miljenovic 2009 License : 2-Clause BSD Maintainer : Ivan.Miljenovic@gmail.com @@ -9,7 +9,8 @@ provide a way of analysing the relationships inherent in discrete data as a graph. - This was written as part of my mathematics honours thesis, + The original version of this library was written as part of my + mathematics honours thesis, /Graph-Theoretic Analysis of the Relationships in Discrete Data/. -} module Data.Graph.Analysis @@ -23,17 +24,15 @@ module Data.Graph.Inductive.Graph, -- * Importing data ImportParams(..), - defaultParams, importData, - manipulateNodes, -- * Result analysis -- $analfuncts lengthAnalysis, classifyRoots, - interiorChains, - applyAlg + interiorChains ) where +import Data.Graph.Analysis.Internal import Data.Graph.Analysis.Utils import Data.Graph.Analysis.Types import Data.Graph.Analysis.Algorithms @@ -41,86 +40,68 @@ import Data.Graph.Analysis.Reporting import Data.Graph.Inductive.Graph -import Data.List -import Data.Maybe + +import Data.Maybe(mapMaybe) import qualified Data.Map as M -import Control.Arrow(second) +import qualified Data.Set as S +import Data.Version(showVersion) +import qualified Paths_Graphalyze as Paths(version) + -- ----------------------------------------------------------------------------- -- | The library version. version :: String -version = "0.5" +version = showVersion Paths.version {- | This represents the information that's being passed in that we want to analyse. If the graph is undirected, it is better to list each edge once rather than both directions. -} -data ImportParams a = Params { -- | The discrete points. - dataPoints :: [a], - -- | The relationships between the points. - relationships :: [(a,a)], - -- | The expected roots of the graph. - -- If @'directed' = 'False'@, then this is ignored. - roots :: [a], - -- | 'False' if relationships are symmetric - -- (i.e. an undirected graph). - directed :: Bool - } - --- | Default values for 'ImportParams', with no roots and a directed graph. -defaultParams :: ImportParams a -defaultParams = Params { dataPoints = [], - relationships = [], - roots = [], - directed = True - } +data ImportParams n e = Params { -- | The discrete points. + dataPoints :: [n], + -- | The relationships between the points. + relationships :: [Rel n e], + -- | The expected roots of the graph. + -- If @'directed' = 'False'@, then this is ignored. + roots :: [n], + -- | 'False' if relationships are symmetric + -- (i.e. an undirected graph). + directed :: Bool + } {- | Import data into a format suitable for analysis. This function is /edge-safe/: if any datums are listed in the edges of 'ImportParams' that aren't listed in the data points, then those edges are ignored. Thus, no sanitation of the 'relationships' in - @ImportParams@ is necessary. + @ImportParams@ is necessary. The unused relations are stored in + 'unusedRelationships'. Note that it is assumed that all datums in + 'roots' are also contained within 'dataPoints'. -} -importData :: (Ord a) => ImportParams a -> GraphData a -importData params = GraphData { graph = dGraph, wantedRoots = rootNodes } +importData :: (Ord n, Ord e) => ImportParams n e -> GraphData n e +importData params = GraphData { graph = dGraph + , wantedRootNodes = rootNodes + , directedData = isDir + , unusedRelationships = unRs + } where + isDir = directed params -- Adding Node values to each of the data points. lNodes = zip [1..] (dataPoints params) + -- The valid edges in the graph along with the unused relationships. + (unRs, graphEdges) = relsToEs isDir lNodes (relationships params) -- Creating a lookup map from the label to the @Node@ value. - nodeMap = M.fromList $ map (uncurry (flip (,))) lNodes - -- Find the Node value for the given data point. - findNode n = M.lookup n nodeMap - -- Validate a edge after looking its values up. - validEdge (v1,v2) = case (findNode v1, findNode v2) of - (Just x, Just y) -> Just $ addLabel (x,y) - _ -> Nothing - -- Add an empty edge label. - addLabel (x,y) = (x,y,()) - -- The valid edges in the graph. - graphEdges = catMaybes $ map validEdge (relationships params) + nodeMap = mkNodeMap lNodes -- Validate a node - validNode l = case (findNode l) of - (Just n) -> Just (n,l) - _ -> Nothing + validNode l = M.lookup l nodeMap -- Construct the root nodes - rootNodes = if (directed params) - then catMaybes $ map validNode (roots params) + rootNodes = if isDir + then mapMaybe validNode (roots params) else [] - -- Make the graph undirected if necessary. - setDirection = if (directed params) then id else undir -- Construct the graph. - dGraph = setDirection $ mkGraph lNodes graphEdges - --- | Apply a function to the nodes after processing. --- This might be useful in circumstances where you want to --- reduce the data type used to a simpler one, etc. -manipulateNodes :: (a -> b) -> GraphData a -> GraphData b -manipulateNodes f gd = gd { graph = nmap f (graph gd) - , wantedRoots = map (second f) (wantedRoots gd) - } + dGraph = mkGraph lNodes graphEdges -- ----------------------------------------------------------------------------- @@ -152,24 +133,21 @@ * Unexpected roots (i.e. those roots that aren't present in 'wantedRoots'). -} -classifyRoots :: (Eq a) => GraphData a -> ([LNode a], [LNode a], [LNode a]) +classifyRoots :: (Ord n) => GraphData n e -> ([LNode n], [LNode n], [LNode n]) classifyRoots gd = (areWanted, notRoots, notWanted) where - wntd = wantedRoots gd - rts = applyAlg rootsOf gd - areWanted = intersect wntd rts - notRoots = wntd \\ rts - notWanted = rts \\ wntd + wntd = S.fromList $ wantedRoots gd + rts = S.fromList $ applyAlg rootsOf gd + areWanted = S.toList $ S.intersection wntd rts + notRoots = S.toList $ S.difference wntd rts + notWanted = S.toList $ S.difference rts wntd -- | Only return those chains (see 'chainsIn') where the non-initial -- nodes are /not/ expected roots. -interiorChains :: (Eq a) => GraphData a -> [LNGroup a] +interiorChains :: (Eq n, Eq e) => GraphData n e -> [LNGroup n] interiorChains gd = filter (not . interiorRoot) chains where chains = applyAlg chainsIn gd rts = wantedRoots gd interiorRoot = any (`elem` rts) . tail --- | Apply an algorithm to the data to be analysed. -applyAlg :: (AGr a -> b) -> GraphData a -> b -applyAlg f = f . graph diff --git a/Data/Graph/Analysis/Algorithms.hs b/Data/Graph/Analysis/Algorithms.hs --- a/Data/Graph/Analysis/Algorithms.hs +++ b/Data/Graph/Analysis/Algorithms.hs @@ -1,7 +1,7 @@ {- | Module : Data.Graph.Analysis.Algorithms Description : Graph analysis algorithms - Copyright : (c) Ivan Lazar Miljenovic 2008 + Copyright : (c) Ivan Lazar Miljenovic 2009 License : 2-Clause BSD Maintainer : Ivan.Miljenovic@gmail.com @@ -16,6 +16,9 @@ module Data.Graph.Analysis.Algorithms.Clustering ) where +-- For haddock purposes. +import Data.Graph.Inductive.Graph(Node) + import Data.Graph.Analysis.Algorithms.Common import Data.Graph.Analysis.Algorithms.Directed import Data.Graph.Analysis.Algorithms.Clustering @@ -24,5 +27,5 @@ For algorithms that return a group of nodes, there are typically two different forms: the standard form (e.g. 'cliquesIn') will return a list of @LNode@s, whilst the primed version - (e.g. `cliquesIn'') will return a list of @Node@s. + (e.g. `cliquesIn'') will return a list of 'Node's. -} diff --git a/Data/Graph/Analysis/Algorithms/Clustering.hs b/Data/Graph/Analysis/Algorithms/Clustering.hs --- a/Data/Graph/Analysis/Algorithms/Clustering.hs +++ b/Data/Graph/Analysis/Algorithms/Clustering.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - {- | Module : Data.Graph.Analysis.Algorithms.Clustering Description : Clustering and grouping algorithms. - Copyright : (c) Ivan Lazar Miljenovic 2008 + Copyright : (c) Ivan Lazar Miljenovic 2009 License : 2-Clause BSD Maintainer : Ivan.Miljenovic@gmail.com @@ -20,26 +18,26 @@ relativeNeighbourhood, -- * Graph Collapsing -- $collapsing - CNodes(..), + CNodes, collapseGraph, + collapseGraphBy, + collapseGraphBy', trivialCollapse, - cNodes ) where +import Data.Graph.Analysis.Internal import Data.Graph.Analysis.Types import Data.Graph.Analysis.Utils -import Data.Graph.Analysis.Visualisation(showNodes) import Data.Graph.Analysis.Algorithms.Common import Data.Graph.Inductive.Graph -import Data.List -import Data.Maybe -import Data.Function +import Data.List(foldl', tails, delete, intersect) +import Data.Function(on) import qualified Data.Set.BKTree as BK import Data.Set.BKTree(BKTree, Metric(..)) -import Control.Arrow -import System.Random +import Control.Arrow(first, second) +import System.Random(RandomGen, randomR) -- ----------------------------------------------------------------------------- @@ -187,15 +185,15 @@ -- | The renamed CLUSTER algorithm. Attempts to cluster a graph by using -- the spatial locations used by Graphviz. -relativeNeighbourhood :: (DynGraph gr, Eq a, Ord b) => gr a b - -> gr (GenCluster a) b -relativeNeighbourhood g = setCluster cMap g +relativeNeighbourhood :: (DynGraph gr, Eq a, Ord b) => Bool -> gr a b + -> gr (GenCluster a) b +relativeNeighbourhood dir g = setCluster cMap g where cMap = createLookup $ rn g rn g' = nbrCluster rng where - rng :: Gr () Int - rng = makeRNG $ getPositions g' + rng :: AGr () Int + rng = makeRNG $ getPositions dir g' -- | We take the ceiling of the Euclidian distance function to use as our -- metric function. @@ -205,9 +203,9 @@ -- | The Euclidian distance function. euclidian :: PosLabel a -> PosLabel a -> Double -euclidian n1 n2 = sqrt . fI $ (posBy xPos) + (posBy yPos) +euclidian n1 n2 = sqrt . fI $ posBy xPos + posBy yPos where - posBy p = sq $ (p n1) - (p n2) + posBy p = sq $ p n1 - p n2 -- | Converts the positional labels into an RNG. makeRNG :: (Eq a, Graph gr) => [PosLabel a] -> gr () Int @@ -258,7 +256,7 @@ (_,dfMin,dfMax) = sortMinMax $ map sub es' -- We are going to do >= tests on t, but using Int values, so -- take the ceiling. - t = ceiling $ (((fI dfMin) + (fI dfMax))/2 :: Double) + t = ceiling ((fI dfMin + fI dfMax)/2 :: Double) -- Edges that meet the threshold criteria. thrs = filter (\ejs@(ej,_) -> (ej >= 2*eMin) && (sub ejs >= t)) es' -- Take the first edges that meets the threshold criteria. @@ -273,81 +271,106 @@ -- ----------------------------------------------------------------------------- {- $collapsing - Collapse the /interesting/ parts of a graph down to try and show a - compressed overview of the whole graph. Note that this doesn't - work too well on undirected graphs, since every pair of nodes forms - a K_2 subgraph. + Collapse the parts of a graph down to try and show a compressed + overview of the whole graph. It may be possible to extend this to a clustering algorithm by collapsing low density regions into high density regions. -} -- | A collapsed node contains a list of nodes that it represents. -data CNodes a = CN [LNode a] +type CNodes a = [a] --- | The 'LNode's stored in a 'CNodes'. -cNodes :: CNodes a -> [LNode a] -cNodes (CN lns) = lns +-- | Collapse the cliques, cycles and chains in the graph down. Note +-- that this doesn't work too well on undirected graphs, since every +-- pair of nodes forms a K_2 subgraph. +collapseGraph :: (DynGraph gr, Eq b) => gr a b -> gr (CNodes a) b +collapseGraph = collapseGraphBy interestingParts + where + interestingParts = [cliquesIn', cyclesIn', chainsIn'] --- | This definition of 'show' is written so as to make the shapes of the --- nodes in Graphviz roughly circular, rather than one long ellipse. -instance (Show a) => Show (CNodes a) where - -- Print the labels in a roughly square shape. - show (CN lns) = showNodes lns +-- | Use the given functions to determine which nodes to collapse. +collapseGraphBy :: (DynGraph gr) => [gr (CNodes a) b -> [NGroup]] + -> gr a b -> gr (CNodes a) b +collapseGraphBy fs = collapseGr fs' + where + fs' = map (map (flip (,) Nothing) .) fs -collapseGraph :: (DynGraph gr, Eq b) => gr a b -> gr (CNodes a) b -collapseGraph g = foldl' (flip collapseAllBy) cg interestingParts +-- | Use the given functions to determine which nodes to collapse, +-- with a new label to represent the collapsed nodes. +collapseGraphBy' :: (DynGraph gr) => [gr a b -> [(NGroup, a)]] + -> gr a b -> gr a b +collapseGraphBy' fs = unCollapse . collapseGr fs' where - cg = makeCollapsible g - interestingParts = [cliquesIn', cyclesIn', chainsIn'] + -- convert gr a b -> [(NGroup a)] to + -- gr (CNodes a) b -> [(NGroup, Maybe a)] + fs' = map ((.nmap head) . (map (second Just) .)) fs +-- | Collapse the graph. +collapseGr :: (DynGraph gr) => [gr (CNodes a) b -> [(NGroup, Maybe a)]] + -> gr a b -> gr (CNodes a) b +collapseGr fs g = foldl' collapseAllBy (makeCollapsible g) fs + -- | Return @'True'@ if the collapsed graph is either a singleton node -- or else isomorphic to the original graph (i.e. not collapsed at all). trivialCollapse :: (Graph gr) => gr (CNodes a) b -> Bool trivialCollapse cg = allCollapsed || notCollapsed where - allCollapsed = (single lns) || (null lns) - notCollapsed = all (single . cNodes) lns + allCollapsed = single lns || null lns + notCollapsed = all single lns lns = labels cg -- | Allow the graph to be collapsed. makeCollapsible :: (DynGraph gr) => gr a b -> gr (CNodes a) b -makeCollapsible = nlmap (CN . return) +makeCollapsible = nmap return +unCollapse :: (DynGraph gr) => gr (CNodes a) b -> gr a b +unCollapse = nmap head + -- | Collapse the two given nodes into one node. collapse :: (DynGraph gr) => gr (CNodes a) b -> Node -> Node -> gr (CNodes a) b -collapse g n1 n2 = if (n1 == n2) +collapse g n1 n2 = if n1 == n2 then g else c' & g'' where (Just c1, g') = match n1 g (Just c2, g'') = match n2 g' -- The new edges. - nbrBy f = map (\(a,b) -> (b,a)) + nbrBy f = map swap . filter (\(n,_) -> notElem n [n1,n2]) $ (f c1 ++ f c2) p = nbrBy lpre' s = nbrBy lsuc' - (CN l1) = lab' c1 - (CN l2) = lab' c2 - c' = (p,n1,CN (l1++l2),s) + l1 = lab' c1 + l2 = lab' c2 + c' = (p,n1,l1++l2,s) -- | Collapse the list of nodes down to one node. -collapseAll :: (DynGraph gr) => gr (CNodes a) b -> [Node] - -> gr (CNodes a) b -collapseAll g [] = g -collapseAll g [_] = g -collapseAll g (n:ns) = foldl' collapser g ns +collapseAll :: (DynGraph gr) => gr (CNodes a) b + -> (NGroup, Maybe a) + -> gr (CNodes a) b +collapseAll g ([],_) = g -- These two cases +collapseAll g ([_],_) = g -- shouldn't occur. +collapseAll g ((n:ns),ma) = adj $ foldl' collapser g ns where + adj = maybe id (adjustLabel n) ma collapser g' = collapse g' n +adjustLabel :: (DynGraph gr) => Node -> a + -> gr (CNodes a) b -> gr (CNodes a) b +adjustLabel n a g = c & g' + where + (Just (p,_,_,s), g') = match n g + c = (p,n,[a],s) + -- | Collapse all results of the given function. -collapseAllBy :: (DynGraph gr) => (gr (CNodes a) b -> [[Node]]) - -> gr (CNodes a) b -> gr (CNodes a) b -collapseAllBy f g = case (filter (not . single) $ f g) of +collapseAllBy :: (DynGraph gr) => gr (CNodes a) b + -> (gr (CNodes a) b -> [(NGroup, Maybe a)]) + -> gr (CNodes a) b +collapseAllBy g f = case (filter (not . single . fst) $ f g) of [] -> g -- We re-evaluate the function in case -- the original results used nodes that -- have been collapsed down. - (ns:_) -> collapseAllBy f (collapseAll g ns) + (nsr:_) -> collapseAllBy (collapseAll g nsr) f diff --git a/Data/Graph/Analysis/Algorithms/Common.hs b/Data/Graph/Analysis/Algorithms/Common.hs --- a/Data/Graph/Analysis/Algorithms/Common.hs +++ b/Data/Graph/Analysis/Algorithms/Common.hs @@ -1,7 +1,7 @@ {- | Module : Data.Graph.Analysis.Algorithms.Common Description : Algorithms for all graph types. - Copyright : (c) Ivan Lazar Miljenovic 2008 + Copyright : (c) Ivan Lazar Miljenovic 2009 License : 2-Clause BSD Maintainer : Ivan.Miljenovic@gmail.com @@ -35,11 +35,12 @@ import Data.Graph.Analysis.Utils import Data.Graph.Inductive.Graph + -- For linking purposes. This will throw a warning. import Data.Graph.Inductive.Query.DFS(components) -import Data.List -import Data.Maybe -import Control.Arrow +import Data.List(unfoldr, foldl', foldl1', intersect, (\\), delete, tails, nub) +import Data.Maybe(isJust) +import Control.Arrow(first) -- ----------------------------------------------------------------------------- @@ -163,7 +164,7 @@ alsoRegular :: (Graph g) => g a b -> [Node] -> [[Node]] alsoRegular _ [] = [] alsoRegular _ [n] = [[n]] -alsoRegular g (n:ns) = [n] : rs ++ (alsoRegular g ns) +alsoRegular g (n:ns) = [n] : rs ++ alsoRegular g ns where rs = map (n:) (alsoRegular g $ intersect crn ns) crn = twoCycle g n @@ -180,7 +181,7 @@ -- Node + Rest of list split = zip ns tns' tns' = tail $ tails ns - allTwoCycle (n,rs) = null $ rs \\ (twoCycle g n) + allTwoCycle (n,rs) = null $ rs \\ twoCycle g n -- ----------------------------------------------------------------------------- {- $cycles @@ -219,7 +220,7 @@ pathTree . first Just where - isCycle p = (not $ single p) && ((head p) == (last p)) + isCycle p = not (single p) && (head p == last p) -- ----------------------------------------------------------------------------- @@ -250,7 +251,7 @@ -- | Find the chain starting with the given 'Node'. getChain :: (Graph g) => g a b -> Node -> NGroup -getChain g n = n : (unfoldr (chainLink g) (chainNext g n)) +getChain g n = n : unfoldr (chainLink g) (chainNext g n) -- | Find the next link in the chain. chainLink :: (Graph g) => g a b -> Maybe Node @@ -263,7 +264,7 @@ -- | Determines if the given node is the start of a chain. isChainStart :: (Graph g) => g a b -> Node -> Bool -isChainStart g n = (hasNext g n) +isChainStart g n = hasNext g n && case (pre g n \\ [n]) of [n'] -> not $ isChainStart g n' _ -> True @@ -272,7 +273,7 @@ -- direction, and if so what the next node in that direction is. chainFind :: (Graph g) => (g a b -> Node -> NGroup) -> g a b -> Node -> Maybe Node -chainFind f g n = case ((nub $ f g n) \\ [n]) of +chainFind f g n = case (nub (f g n) \\ [n]) of [n'] -> Just n' _ -> Nothing diff --git a/Data/Graph/Analysis/Algorithms/Directed.hs b/Data/Graph/Analysis/Algorithms/Directed.hs --- a/Data/Graph/Analysis/Algorithms/Directed.hs +++ b/Data/Graph/Analysis/Algorithms/Directed.hs @@ -1,11 +1,11 @@ {- | Module : Data.Graph.Analysis.Algorithms.Directed Description : Algorithms for directed graphs. - Copyright : (c) Ivan Lazar Miljenovic 2008 + Copyright : (c) Ivan Lazar Miljenovic 2009 License : 2-Clause BSD Maintainer : Ivan.Miljenovic@gmail.com - Defines algorithms that work on both directed graphs. + Defines algorithms that work on directed graphs. -} module Data.Graph.Analysis.Algorithms.Directed ( -- * Ending nodes @@ -23,13 +23,24 @@ isSingleton, isSingleton', -- * Subgraphs coreOf, + -- * Clustering + levelGraph, + -- * Other + leafMinPaths ) where import Data.Graph.Analysis.Types import Data.Graph.Analysis.Utils import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Query.BFS(esp) +import Data.List(minimumBy, unfoldr) +import Data.Function(on) +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Set(Set) + -- ----------------------------------------------------------------------------- {- $ends Find starting/ending nodes. @@ -44,8 +55,9 @@ -} -- | Determine if this 'LNode' is an ending node. -endNode :: (Graph g) => (g a b -> Node -> NGroup) -> g a b -> LNode a -> Bool -endNode f g ln = endNode' f g (node ln) +endNode :: (Graph g) => (g a b -> Node -> NGroup) + -> g a b -> LNode a -> Bool +endNode f g = endNode' f g . node -- | Determine if this 'Node' is an ending node. endNode' :: (Graph g) => (g a b -> Node -> NGroup) -> g a b -> Node @@ -57,12 +69,12 @@ _ -> False -- | Find all 'LNode's that meet the ending criteria. -endBy :: (Graph g) => (g a b -> Node -> NGroup) -> g a b -> LNGroup a -endBy f = filterNodes (endNode f) +endBy :: (Graph g) => (g a b -> Node -> NGroup) -> g a b -> LNGroup a +endBy = filterNodes . endNode -- | Find all 'Node's that match the ending criteria. -endBy' :: (Graph g) => (g a b -> Node -> NGroup) -> g a b -> NGroup -endBy' f = filterNodes' (endNode' f) +endBy' :: (Graph g) => (g a b -> Node -> NGroup) -> g a b -> NGroup +endBy' = filterNodes' . endNode' -- ----------------------------------------------------------------------------- @@ -144,3 +156,63 @@ where roots = rootsOf' gr' leaves = leavesOf' gr' + +-- ----------------------------------------------------------------------------- + +{- | + Cluster the nodes in the graph based upon how far away they are + from a root node. Root nodes are in the cluster labelled "0", + nodes in level "n" are at least /n/ edges away from a root node. +-} +levelGraph :: (Ord a) => (DynGraph g) => g a b -> g (GenCluster a) b +levelGraph g = gmap addLbl g + where + lvls = zip [0..] . map S.toList $ graphLevels g + lvMap = M.fromList + $ concatMap (\(l,ns) -> map (flip (,) l) ns) lvls + mkLbl n l = GC { clust = lvMap M.! n + , nLbl = l + } + + addLbl (p,n,l,s) = (p, n, mkLbl n l, s) + +type NSet = Set Node + +-- | Obtain the levels in the graph. +graphLevels :: (DynGraph g) => g a b -> [NSet] +graphLevels g = unfoldr getNextLevel + (S.fromList $ rootsOf' g, g) + +getNextLevel :: (DynGraph g) => (NSet, g a b) + -> Maybe (NSet, (NSet, g a b)) +getNextLevel (ns,g) + | S.null ns = Nothing + | otherwise = Just (ns, (ns', g')) + where + g' = delNodes (S.toList ns) g + ns' = flip S.difference ns + . S.unions . S.toList + $ S.map getSuc ns + getSuc = S.fromList . suc g + +-- ----------------------------------------------------------------------------- + +{- | + The shortest paths to each of the leaves in the graph (excluding + singletons). This can be used to obtain an indication of the + overall height/depth of the graph. + -} +leafMinPaths :: (Graph g) => g a b -> [LNGroup a] +leafMinPaths g = map (lfMinPth g rs) ls + where + rs = rootsOf' g + ls = leavesOf' g + +-- | Given the list of roots in this graph, find the shortest path to +-- this leaf node. +lfMinPth :: (Graph g) => g a b -> [Node] -> Node -> LNGroup a +lfMinPth g rs l = addLabels g + . snd + . minimumBy (compare `on` fst) + . addLengths + $ map (\ r -> esp r l g) rs diff --git a/Data/Graph/Analysis/Internal.hs b/Data/Graph/Analysis/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Analysis/Internal.hs @@ -0,0 +1,89 @@ +{-# OPTIONS_HADDOCK hide #-} + +{- | + Module : Data.Graph.Analysis.Internal + Description : Internal definitions + Copyright : (c) Ivan Lazar Miljenovic 2009 + License : 2-Clause BSD + Maintainer : Ivan.Miljenovic@gmail.com + + This module defines various internal definitions utilised by other + modules of the Graphalyze library. + -} +module Data.Graph.Analysis.Internal where + +import Data.Graph.Inductive.Graph + +import Data.Either(partitionEithers) +import qualified Data.Map as M +import Data.Map(Map) +import Data.Maybe(fromJust) +import Control.Arrow((***)) +import Control.Monad(ap) + +-- ----------------------------------------------------------------------------- + +-- | Squaring a number. +sq :: (Num a) => a -> a +sq x = x * x + +-- | Shorthand for 'fromIntegral' +fI :: (Num a) => Int -> a +fI = fromIntegral + +-- | Flip a pair. +swap :: (a,b) -> (b,a) +swap (a,b) = (b,a) + +-- | Apply the same function to both elements of a pair. +applyBoth :: (a -> b) -> (a,a) -> (b,b) +applyBoth f = f *** f + +mkNodeMap :: (Ord a) => [LNode a] -> Map a Node +mkNodeMap = M.fromList . map swap + +-- ----------------------------------------------------------------------------- + +-- | A relationship between two nodes with a label. +type Rel n e = (n, n, e) + +applyNodes :: (a -> b) -> Rel a e -> Rel b e +applyNodes f (n1, n2, e) = (f n1, f n2, e) + +fromNode :: Rel n e -> n +fromNode (n1, _, _) = n1 + +toNode :: Rel n e -> n +toNode (_, n2, _) = n2 + +relLabel :: Rel n e -> e +relLabel (_, _, e) = e + + +relsToEs :: (Ord a) => Bool -> [LNode a] -> [Rel a e] + -> ([Rel a e], [LEdge e]) +relsToEs isDir lns rs = (unRs, graphEdges) + where + -- Creating a lookup map from the label to the @Node@ value. + nodeMap = mkNodeMap lns + findNode v = M.lookup v nodeMap + -- Validate a edge after looking its values up. + validEdge e = case applyNodes findNode e of + (Just x, Just y, l) -> Right (x,y,l) + _ -> Left e + -- The valid edges in the graph. + (unRs, gEdges) = partitionEithers $ map validEdge rs + dupSwap' = if isDir + then id + else concatMap dupSwap + dupSwap e@(x,y,l) | x == y = [e] + | otherwise = [e, (y,x,l)] + graphEdges = dupSwap' gEdges + +-- This is needed by Types, so it's defined here and then exported by +-- Utils to avoid cyclic problems. + +-- | Obtain the labels for a list of 'Node's. +-- It is assumed that each 'Node' is indeed present in the given graph. +addLabels :: (Graph g) => g a b -> [Node] -> [LNode a] +addLabels gr = map (ap (,) (fromJust . lab gr)) diff --git a/Data/Graph/Analysis/Reporting.hs b/Data/Graph/Analysis/Reporting.hs --- a/Data/Graph/Analysis/Reporting.hs +++ b/Data/Graph/Analysis/Reporting.hs @@ -1,7 +1,7 @@ {- | Module : Data.Graph.Analysis.Reporting Description : Graphalyze Types and Classes - Copyright : (c) Ivan Lazar Miljenovic 2008 + Copyright : (c) Ivan Lazar Miljenovic 2009 License : 2-Clause BSD Maintainer : Ivan.Miljenovic@gmail.com @@ -15,6 +15,7 @@ Location(..), DocElement(..), DocInline(..), + GraphSize(..), DocGraph, -- * Helper functions -- $utilities @@ -25,16 +26,15 @@ unDotPath ) where +import Data.Graph.Inductive(Node) import Data.GraphViz -import Data.GraphViz.Attributes -import Data.Graph.Analysis.Visualisation -import Data.Maybe -import Data.Time -import Control.Exception -import System.Directory -import System.FilePath -import System.Locale +import Data.Maybe(isJust, fromJust) +import Data.Time(getZonedTime, zonedTimeToLocalTime, formatTime) +import Control.Exception.Extensible(SomeException(..), tryJust) +import System.Directory(createDirectoryIfMissing) +import System.FilePath((), (<.>)) +import System.Locale(defaultTimeLocale) -- ----------------------------------------------------------------------------- @@ -74,10 +74,10 @@ docExtension :: dg -> String -- | Representation of a location, either on the internet or locally. -data Location = URL String | File FilePath +data Location = Web String | File FilePath instance Show Location where - show (URL url) = url + show (Web url) = url show (File fp) = fp -- | Elements of a document. @@ -97,10 +97,10 @@ | DocLink DocInline Location | DocImage DocInline Location --- | Let the 'DocumentGenerator' instance apply extra settings, such as size. -type AttrsToGraph = [Attribute] -> DotGraph - -type DocGraph = (FilePath,DocInline,AttrsToGraph) +-- | Specify the 'DotGraph' to turn into an image, its filename (sans +-- extension) and its caption. The 'DotGraph' should not have a +-- 'Size' set. +type DocGraph = (FilePath, DocInline, DotGraph Node) -- ----------------------------------------------------------------------------- @@ -123,7 +123,8 @@ -- if successful (or if the directory already exists), @False@ -- if an error occurred. tryCreateDirectory :: FilePath -> IO Bool -tryCreateDirectory fp = do r <- try $ mkDir fp +tryCreateDirectory fp = do r <- tryJust (\(SomeException _) -> return ()) + $ mkDir fp return (isRight r) where mkDir = createDirectoryIfMissing True @@ -135,48 +136,62 @@ -- If the second set of attributes is not 'Nothing', then the first -- image links to the second. The whole result is wrapped in a -- 'Paragraph'. -createGraph :: FilePath -> FilePath -> [Attribute] -> Maybe [Attribute] +createGraph :: FilePath -> FilePath -> GraphSize -> Maybe GraphSize -> DocGraph -> IO (Maybe DocElement) -createGraph fp gfp as mas (fn,inl,ag) - = do eImg <- gI as DocImage fn inl Nothing - if (isJust eImg) - then case mas of +createGraph fp gfp s ms (fn,inl,ag) + = do eImg <- gI s Png "png" DocImage fn inl Nothing + if isJust eImg + then case ms of Nothing -> rt eImg - (Just as') -> do rt =<< gI as' DocLink fn' (toImg eImg) eImg + (Just s') -> rt =<< gI s' Svg "svg" DocLink fn' (toImg eImg) eImg else return Nothing where fn' = fn ++ "-large" i2e i = Just (i,Paragraph [i]) rt = return . fmap snd + -- This is safe because of the isJust above. toImg = fst . fromJust - gI a ln nm lb fl = do mImg <- graphImage fp gfp a ln (nm,lb,ag) - case mImg of - Nothing -> return fl - (Just img) -> return $ i2e img + gI a o e ln nm lb fl = do mImg <- graphImage fp gfp a o e ln (nm,lb,ag) + case mImg of + Nothing -> return fl + (Just img) -> return $ i2e img -- | Create the inline image/link from the given DocGraph. -graphImage :: FilePath -> FilePath -> [Attribute] +graphImage :: FilePath -> FilePath -> GraphSize + -> GraphvizOutput -> FilePath -> (DocInline -> Location -> DocInline) -> DocGraph -> IO (Maybe DocInline) -graphImage fp gfp as link (fn,inl,ag) - = do created <- runGraphviz dg output filename' +graphImage fp gfp s output ext link (fn,inl,dg) + = do created <- runGraphviz dg' output filename' if created then return (Just img) else return Nothing where - dg = ag as + dg' = setSize s dg fn' = unDotPath fn - ext = "png" - output = Png filename = gfp fn' <.> ext filename' = fp filename loc = File filename img = link inl loc --- | Create the "Data.GraphViz" 'Size' 'Attribute' using the given width --- and a 6:4 width:height ratio. -createSize :: Double -> Attribute -createSize w = Size w (w*4/6) +-- | Specify the size the 'DotGraph' should be at. +data GraphSize = GivenSize Point -- ^ Specify the size to use. + | DefaultSize -- ^ Let GraphViz choose an appropriate size. + +-- | Add a 'GlobalAttribute' to the 'DotGraph' specifying the given size. +setSize :: GraphSize -> DotGraph a -> DotGraph a +setSize DefaultSize g = g +setSize (GivenSize p) g = g { graphStatements = stmts' } + where + stmts = graphStatements g + stmts' = stmts { attrStmts = a : (attrStmts stmts) } + a = GraphAttrs [s] + s = Size p + +-- | Using a 6:4 ratio, create the given 'Point' representing +-- width,height from the width. +createSize :: Double -> GraphSize +createSize w = GivenSize $ PointD w (w*4/6) -- | Replace all @.@ with @-@ in the given 'FilePath', since some output -- formats (e.g. LaTeX) don't like extraneous @.@'s in the filename. diff --git a/Data/Graph/Analysis/Reporting/Pandoc.hs b/Data/Graph/Analysis/Reporting/Pandoc.hs --- a/Data/Graph/Analysis/Reporting/Pandoc.hs +++ b/Data/Graph/Analysis/Reporting/Pandoc.hs @@ -1,7 +1,7 @@ {- | Module : Data.Graph.Analysis.Reporting.Pandoc Description : Graphalyze Types and Classes - Copyright : (c) Ivan Lazar Miljenovic 2008 + Copyright : (c) Ivan Lazar Miljenovic 2009 License : 2-Clause BSD Maintainer : Ivan.Miljenovic@gmail.com @@ -27,16 +27,15 @@ -- TODO : the ability to create multiple files. import Data.Graph.Analysis.Reporting -import Data.GraphViz.Attributes(Attribute) -import Data.List -import Data.Maybe import Text.Pandoc -import Control.Monad -import Control.Exception -import System.Directory -import System.FilePath +import Data.List(intersperse) +import Data.Maybe(isNothing, fromJust) +import Control.Exception.Extensible(SomeException, try) +import System.Directory(removeDirectoryRecursive) +import System.FilePath((), (<.>)) + -- ----------------------------------------------------------------------------- {- $writers @@ -47,7 +46,7 @@ pandocHtml = pd { writer = writeHtmlString , extension = "html" , header = "" -- Header will be included - , extGraphSize = Just $ defaultWidth * 10 + , extGraphSize = Just DefaultSize } pandocLaTeX :: PandocDocument @@ -55,7 +54,7 @@ , extension = "tex" , header = defaultLaTeXHeader -- 4.5" should be less than \textwidth in LaTeX. - , graphSize = 4.5 + , graphSize = createSize 4.5 } pandocRtf :: PandocDocument @@ -84,10 +83,10 @@ extension :: FilePath, -- | The Pandoc header to use header :: String, - -- | Maximum width of graphs to be produced. - graphSize :: Double, - -- | Optional maximum width of external linked graph. - extGraphSize :: Maybe Double + -- | Size of graphs to be produced. + graphSize :: GraphSize, + -- | Optional size of external linked graphs. + extGraphSize :: Maybe GraphSize } -- | Some default sizes. Note that all other fields of 'PandocDocument' @@ -96,13 +95,16 @@ pd = PD { writer = undefined, extension = undefined, header = undefined, - graphSize = defaultWidth, + graphSize = defaultSize, extGraphSize = Nothing } defaultWidth :: Double defaultWidth = 10 +defaultSize :: GraphSize +defaultSize = createSize defaultWidth + instance DocumentGenerator PandocDocument where createDocument = createPandoc docExtension = extension @@ -118,8 +120,8 @@ data PandocProcess = PP { secLevel :: Int , filedir :: FilePath , graphdir :: FilePath - , grSize :: [Attribute] - , eGSize :: Maybe [Attribute] + , grSize :: GraphSize + , eGSize :: Maybe GraphSize } -- | Start with a level 1 heading. @@ -136,7 +138,7 @@ createPandoc p d = do created <- tryCreateDirectory dir -- If the first one fails, so will this one. tryCreateDirectory $ dir gdir - if (not created) + if not created then failDoc else do elems <- multiElems pp (content d) case elems of @@ -156,15 +158,15 @@ meta = makeMeta (title d) auth dt -- Html output doesn't show date and auth anywhere by default. htmlAuthDt = htmlInfo auth dt - createSize' = return . createSize pp = defaultProcess { filedir = dir , graphdir = gdir - , grSize = createSize' (graphSize p) - , eGSize = fmap createSize' (extGraphSize p) + , grSize = graphSize p + , eGSize = extGraphSize p } opts = writerOptions { writerHeader = (header p) } - convert = (writer p) opts - file = dir (fileFront d) <.> (extension p) + convert = writer p opts + file = dir fileFront d <.> extension p + tryWrite :: String -> IO (Either SomeException ()) tryWrite = try . writeFile file success = return (Just file) failDoc = removeDirectoryRecursive dir >> return Nothing @@ -176,8 +178,8 @@ -} -- | The meta information -makeMeta :: DocInline -> String -> String -> Meta -makeMeta t a d = Meta (inlines t) [a] d +makeMeta :: DocInline -> String -> String -> Meta +makeMeta t a = Meta (inlines t) [a] -- | Html output doesn't show the author and date; use this to print it. htmlInfo :: String -> String -> Block @@ -189,7 +191,7 @@ -- | Link conversion loc2target :: Location -> Target -loc2target (URL url) = (url,"") +loc2target (Web url) = (url,"") loc2target (File file) = (file,"") -- | Conversion of simple inline elements. @@ -247,13 +249,13 @@ -- | Concatenate the result of multiple calls to 'elements'. multiElems :: PandocProcess -> [DocElement] -> IO (Maybe [Block]) multiElems p elems = do elems' <- mapM (elements p) elems - if (any isNothing elems') + if any isNothing elems' then return Nothing else return (Just $ concatMap fromJust elems') -- | As for 'multiElems', but don't @concat@ the resulting 'Block's. multiElems' :: PandocProcess -> [DocElement] -> IO (Maybe [[Block]]) multiElems' p elems = do elems' <- mapM (elements p) elems - if (any isNothing elems') + if any isNothing elems' then return Nothing else return (Just $ map fromJust elems') diff --git a/Data/Graph/Analysis/Types.hs b/Data/Graph/Analysis/Types.hs --- a/Data/Graph/Analysis/Types.hs +++ b/Data/Graph/Analysis/Types.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE MultiParamTypeClasses - , FunctionalDependencies +{-# LANGUAGE TypeFamilies + , FlexibleContexts + , TypeSynonymInstances #-} {- | Module : Data.Graph.Analysis.Types Description : Graphalyze Types and Classes - Copyright : (c) Ivan Lazar Miljenovic 2008 + Copyright : (c) Ivan Lazar Miljenovic 2009 License : 2-Clause BSD Maintainer : Ivan.Miljenovic@gmail.com @@ -13,40 +14,158 @@ by the Graphalyze library. -} module Data.Graph.Analysis.Types - ( -- * Graph specialization + ( -- * Graph specialization. GraphData(..), - Gr, AGr, + Rel, NGroup, LNGroup, - -- * Graph Label classes + -- * Functions on @GraphData@. + wantedRoots, + applyAlg, + applyDirAlg, + mergeUnused, + removeUnused, + updateGraph, + updateGraph', + mapAllNodes, + mapNodeType, + -- * Clustering graphs based on their node labels. ClusterLabel(..), + ClusterType(..), + GraphID(..), + -- * Graph label types. GenCluster(..), PosLabel(..) ) where +import Data.Graph.Analysis.Internal + import Data.Graph.Inductive.Graph -import Data.Graph.Inductive.Tree +import Data.Graph.Inductive.PatriciaTree --- ----------------------------------------------------------------------------- +import Data.GraphViz.Types(GraphID(..)) -{- | - By default, the Graphalyze library works on graphs with no edge labels. - As such, these types provide useful aliases for the default FGL types. - Most of the algorithms, however, work on arbitrary graph types. - -} +import qualified Data.Set as S +import Data.Set(Set) +-- ----------------------------------------------------------------------------- + -- | Represents information about the graph being analysed. -data GraphData a = GraphData { -- | We use a graph type with no edge labels. - graph :: AGr a, - -- | The expected roots in the graph. - wantedRoots :: LNGroup a - } - deriving (Show) +data GraphData n e = GraphData { -- | We use a graph type with no edge labels. + graph :: AGr n e, + -- | The expected root nodes in the graph. + wantedRootNodes :: NGroup, + -- | Is the data this graph represents + -- directed in nature? + directedData :: Bool, + -- | Unused relationships (i.e. not in + -- the actual graph). These are the + -- edges containing nodes not in the + -- graph. + unusedRelationships :: [Rel n e] + } --- | We use a basic tree-based graph by default. -type AGr a = Gr a () +-- | The expected roots in the data to be analysed. +wantedRoots :: GraphData n e -> LNGroup n +wantedRoots gd = addLabels g rs' + where + g = graph gd + gns = S.fromList $ nodes g + rs = S.fromList $ wantedRootNodes gd + rs' = S.toList $ gns `S.intersection` rs +-- | Apply an algorithm to the data to be analysed. +applyAlg :: (AGr n e -> a) -> GraphData n e -> a +applyAlg f = f . graph + +-- | Apply an algorithm that requires knowledge about whether the +-- graph is directed ('True') or undirected ('False') to the data to +-- be analysed. +applyDirAlg :: (Bool -> AGr n e -> a) -> GraphData n e -> a +applyDirAlg f g = f (directedData g) (graph g) + +-- | Apply a function to all the data points. +-- This might be useful in circumstances where you want to reduce +-- the data type used to a simpler one, etc. The function is also +-- applied to the datums in 'unusedRelationships'. +mapAllNodes :: (Ord a, Ord e, Ord b) => (a -> b) + -> GraphData a e -> GraphData b e +mapAllNodes f gd = gd { graph = nmap f $ graph gd + , unusedRelationships = map (applyNodes f) + $ unusedRelationships gd + } + +-- | Apply the first function to nodes in the graph, and the second +-- function to those unknown datums in 'unusedRelationships'. +-- As a sample reason for this function, it can be used to apply a +-- two-part constructor (e.g. 'Left' and 'Right' from 'Either') to +-- the nodes such that the wanted and unwanted datums can be +-- differentiated before calling 'mergeUnused'. +mapNodeType :: (Ord a, Ord b, Ord e) => (a -> b) -> (a -> b) + -> GraphData a e -> GraphData b e +mapNodeType fk fu gd = gd { graph = nmap fk $ graph gd + , unusedRelationships = map (applyNodes f) + $ unusedRelationships gd + } + where + knownNs = knownNodes gd + f n = if S.member n knownNs + then fk n + else fu n + +-- | Merge the 'unusedRelationships' into the graph by adding the +-- appropriate nodes. +mergeUnused :: (Ord n, Ord e) => GraphData n e -> GraphData n e +mergeUnused gd = gd { graph = insEdges es' gr' + , unusedRelationships = [] + } + where + gr = graph gd + unRs = unusedRelationships gd + mkS f = S.fromList $ map f unRs + unNs = S.toList + . flip S.difference (knownNodes gd) + $ S.union (mkS fromNode) (mkS toNode) + ns' = newNodes (length unNs) gr + gr' = flip insNodes gr $ zip ns' unNs + -- Should no longer contain any unused rels. + es' = snd $ relsToEs (directedData gd) + (labNodes gr) + unRs + +knownNodes :: (Ord n) => GraphData n e -> Set n +knownNodes = S.fromList . map snd . labNodes . graph + +-- | Used to set @'unusedRelationships' = []@. This is of use when +-- they are unneeded or because there is no sensible mapping +-- function to use when applying a mapping function to the nodes in +-- the graph. +removeUnused :: GraphData n e -> GraphData n e +removeUnused g = g { unusedRelationships = [] } + +-- | Replace the current graph by applying a function to it. To +-- ensure type safety, 'removeUnused' is applied. +updateGraph :: (AGr a b -> AGr c d) + -> GraphData a b -> GraphData c d +updateGraph f g = g { graph = applyAlg f g + , unusedRelationships = [] + } + +-- | Replace the current graph by applying a function to it, where the +-- function depends on whether the graph is directed ('True') or +-- undirected ('False'). To ensure type safety, 'removeUnused' is +-- applied. +updateGraph' :: (Bool -> AGr a b -> AGr c d) + -> GraphData a b -> GraphData c d +updateGraph' f g = g { graph = applyDirAlg f g + , unusedRelationships = [] + } + + +-- | An alias for the type of graph being used by default. +type AGr n e = Gr n e + -- | A grouping of 'Node's. type NGroup = [Node] @@ -57,30 +176,49 @@ -- | These types and classes represent useful label types. --- | The class of outputs of a clustering algorithm. --- This class is mainly used for visualization purposes, --- with the 'Ord' instance required for grouping. --- Instances of this class are intended for use as --- the label type of graphs. -class (Ord c) => ClusterLabel a c | a -> c where +-- | The class of outputs of a clustering algorithm. This class is +-- mainly used for visualization purposes, with the 'Ord' instance +-- required for grouping. Instances of this class are intended for +-- use as the label type of graphs. +class (ClusterType (Cluster cl)) => ClusterLabel cl where + type Cluster cl + type NodeLabel cl + -- | The cluster the node label belongs in. - cluster :: a -> c - -- | The printed form of the actual label. - nodelabel :: a -> String + cluster :: cl -> Cluster cl + -- | The actual label. + nodeLabel :: cl -> NodeLabel cl + +-- | A class used to define which types are valid for clusters. +class (Ord c) => ClusterType c where + -- | Create a label for visualisation purposes with the GraphViz + -- library. Default is @'const' 'Nothing'@. + clusterID :: c -> Maybe GraphID + clusterID = const Nothing + +instance ClusterType Int where + clusterID = Just . Int + +instance ClusterType String where + clusterID = Just . Str + -- | A generic cluster-label type. data GenCluster a = GC { clust :: Int , nLbl :: a } deriving (Eq,Show) -instance (Show a) => ClusterLabel (GenCluster a) Int where - cluster (GC c _) = c - nodelabel (GC _ l) = show l +instance ClusterLabel (GenCluster a) where + type Cluster (GenCluster a) = Int + type NodeLabel (GenCluster a) = a --- | Label type for storing node positions. Note that this isn't an instance of --- 'ClusterLabel' since there's no clear indication on which cluster a node --- belongs to at this stage. + cluster = clust + nodeLabel = nLbl + +-- | Label type for storing node positions. Note that this isn't an +-- instance of 'ClusterLabel' since there's no clear indication on +-- which cluster a node belongs to at this stage. data PosLabel a = PLabel { xPos :: Int , yPos :: Int , pnode :: Node diff --git a/Data/Graph/Analysis/Utils.hs b/Data/Graph/Analysis/Utils.hs --- a/Data/Graph/Analysis/Utils.hs +++ b/Data/Graph/Analysis/Utils.hs @@ -1,13 +1,7 @@ -{-# LANGUAGE OverlappingInstances - , UndecidableInstances - , TypeSynonymInstances - , FlexibleInstances - #-} - {- | Module : Data.Graph.Analysis.Utils Description : Utility functions - Copyright : (c) Ivan Lazar Miljenovic 2008 + Copyright : (c) Ivan Lazar Miljenovic 2009 License : 2-Clause BSD Maintainer : Ivan.Miljenovic@gmail.com @@ -22,7 +16,7 @@ labels, edge, eLabel, - addLabels, + addLabels, -- Re-exported from Internal filterNodes, filterNodes', pathValues, @@ -30,20 +24,19 @@ undir, oneWay, mkSimple, + compact, + compact', + compactSame, nlmap, + delLNodes, -- ** Graph layout -- $spatial - -- These next two are re-exported from "Data.GraphViz" - AttributeNode, - AttributeEdge, - dotizeGraph, toPosGraph, getPositions, -- ** Cluster functions -- $cluster createLookup, setCluster, - assignCluster, reCluster, reClusterBy, clusterCount, @@ -56,12 +49,6 @@ lengthSort, groupElems, sortMinMax, - blockPrint, - blockPrint', - blockPrintList, - blockPrintList', - blockPrintWith, - blockPrintWith', shuffle, -- * Statistics functions mean, @@ -70,26 +57,26 @@ -- * Other functions fixPoint, fixPointGraphs, - fixPointBy, - sq, - fI + fixPointBy ) where +import Data.Graph.Analysis.Internal import Data.Graph.Analysis.Types import Data.Graph.Inductive.Graph -import Data.GraphViz +import Data.GraphViz( dotizeGraph + , Attribute(..) + , Pos(..) + , Point(..)) -import Data.List -import Data.Maybe -import Data.Function +import Data.List(nub, nubBy, (\\), find, sort, sortBy, group, groupBy) +import Data.Maybe(fromJust) +import Data.Function(on) import qualified Data.Set as Set import qualified Data.IntMap as IMap import Data.IntMap(IntMap) -import Control.Monad -import Control.Arrow -import System.Random -import System.IO.Unsafe(unsafePerformIO) +import Control.Arrow(first, second) +import System.Random(RandomGen, randomR) -- ----------------------------------------------------------------------------- @@ -115,11 +102,6 @@ eLabel :: LEdge b -> b eLabel (_,_,b) = b --- | Obtain the labels for a list of 'Node's. --- It is assumed that each 'Node' is indeed present in the given graph. -addLabels :: (Graph g) => g a b -> [Node] -> [LNode a] -addLabels gr = map (ap (,) (fromJust . lab gr)) - -- | Find all the labelled nodes in the graph that match the given predicate. filterNodes :: (Graph g) => (g a b -> LNode a -> Bool) -> g a b -> [LNode a] filterNodes p g = filter (p g) (labNodes g) @@ -175,41 +157,54 @@ p' = simpleEdges n p s' = simpleEdges n s +-- | Adjoin duplicate edges by grouping the labels together. +compact :: (DynGraph gr) => gr a b -> gr a [b] +compact = gmap cmpct + where + cEs = map (swap . second (map fst)) + . groupElems snd + cmpct (p,n,l,s) = (cEs p, n, l, cEs s) + +-- | Compact the graph by counting how many multiple edges there are +-- (considering only the two nodes and not the labels). +compact' :: (DynGraph gr) => gr a b -> gr a Int +compact' = emap length . compact + +-- | Compact the graph by adjoining identical duplicate edges. +compactSame :: (Ord b) => (DynGraph gr) => gr a b -> gr a (Int,b) +compactSame = gmap cmpct + where + cEs = map toAdj . group . sort + toAdj as = let (l,n) = head as in ((length as,l),n) + cmpct (p,n,l,s) = (cEs p, n, l, cEs s) + -- | Map over the labels on the nodes, using the node values as well. nlmap :: (DynGraph gr) => (LNode a -> c) -> gr a b -> gr c b nlmap f = gmap f' where f' (p,n,l,s) = (p,n,f (n,l),s) +-- | Delete these labelled nodes from the graph. +delLNodes :: (DynGraph gr) => LNGroup a -> gr a b -> gr a b +delLNodes = delNodes . map fst + -- ----------------------------------------------------------------------------- {- $spatial - Spatial positioning of graphs. Use the 'graphToGraph' function in + Spatial positioning of graphs. Use the 'dotizeGraph' function in "Data.GraphViz" to determine potential graph layouts. - - Note that for convenience sake, 'AttributeNode' and 'AttributeEdge' - from "Data.GraphViz" have been re-exported. -} --- | Pass the plain graph through 'graphToGraph'. This is an IO action, --- however since the state doesn't change it's safe to use 'unsafePerformIO' --- to convert this to a normal function. -dotizeGraph :: (DynGraph gr, Ord b) => gr a b - -> gr (AttributeNode a) (AttributeEdge b) -dotizeGraph g = unsafePerformIO - $ graphToGraph g gAttrs noAttrs noAttrs - where - gAttrs = [] - noAttrs = const [] - --- | Convert the graph into one with positions stored in the node labels. -toPosGraph :: (DynGraph gr, Ord b) => gr a b -> gr (PosLabel a) b -toPosGraph = nlmap getPos . emap rmAttrs . dotizeGraph +-- | Convert the graph into one with positions stored in the node +-- labels. The 'Bool' parameter denotes if the graph is directed or +-- not. +toPosGraph :: (DynGraph gr, Ord b) => Bool -> gr a b -> gr (PosLabel a) b +toPosGraph dir = nlmap getPos . emap rmAttrs . dotizeGraph dir where rmAttrs = snd isPoint attr = case attr of - (Pos _) -> True - _ -> False + Pos{} -> True + _ -> False getPos (n,(as,l)) = PLabel { xPos = x , yPos = y , pnode = n @@ -217,11 +212,15 @@ } where -- Assume that positions can't be doubles. - (Pos (PointList ((Point x y):_))) = fromJust $ find isPoint as + -- Also assuming that we're not dealing with a + -- spline-type point. + (Pos (PointPos (Point x y))) = fromJust $ find isPoint as --- | Returns the positions of the nodes in the graph, as found using Graphviz. -getPositions :: (DynGraph gr, Ord b) => gr a b -> [PosLabel a] -getPositions = map label . labNodes . toPosGraph +-- | Returns the positions of the nodes in the graph, as found using +-- Graphviz. The 'Bool' parameter denotes if the graph is directed +-- or not. +getPositions :: (DynGraph gr, Ord b) => Bool -> gr a b -> [PosLabel a] +getPositions dir = map label . labNodes . toPosGraph dir -- ----------------------------------------------------------------------------- @@ -239,11 +238,6 @@ where assClust (n,l) = GC (m IMap.! n) l --- | A function to convert an 'LNode' to the required 'NodeCluster' --- for use with the 'Graphviz' library. -assignCluster :: (ClusterLabel a c) => LNode a -> NodeCluster c a -assignCluster nl@(_,a) = C (cluster a) (N nl) - -- | Change the cluster values in the graph by having the largest cluster -- have the smallest cluster label. reCluster :: (DynGraph g) => g (GenCluster a) b -> g (GenCluster a) b @@ -258,7 +252,7 @@ -> g (GenCluster a) b reClusterBy m = nmap newClust where - newClust c = c { clust = m IMap.! (clust c) } + newClust c = c { clust = m IMap.! clust c } -- | Create an 'IntMap' of the size of each cluster. clusterCount :: (Graph g) => g (GenCluster a) b -> IntMap Int @@ -314,80 +308,7 @@ aMin = Set.findMin aSet aMax = Set.findMax aSet --- | Attempt to convert the @String@ form of a list into --- as much of a square shape as possible, using a single --- space as a separation string. -blockPrint :: (Show a) => [a] -> String -blockPrint = blockPrintWith " " --- | Attempt to convert a list of @String@s into a single @String@ --- that is roughly a square shape, with a single space as a row --- separator. -blockPrint' :: [String] -> String -blockPrint' = blockPrintWith' " " - --- | Attempt to convert the @String@ form of a list into --- as much of a square shape as possible, separating values --- with commas. -blockPrintList :: (Show a) => [a] -> String -blockPrintList = blockPrintWith ", " - --- | Attempt to combine a list of @String@s into as much of a --- square shape as possible, separating values with commas. -blockPrintList' :: [String] -> String -blockPrintList' = blockPrintWith' ", " - --- | Attempt to convert the @String@ form of a list into --- as much of a square shape as possible, using the given --- separation string between elements in the same row. -blockPrintWith :: (Show a) => String -> [a] -> String -blockPrintWith str = blockPrintWith' str . map show - --- | Attempt to convert the combined form of a list of @String@s --- into as much of a square shape as possible, using the given --- separation string between elements in the same row. -blockPrintWith' :: String -> [String] -> String -blockPrintWith' sep as = init -- Remove the final '\n' on the end. - . unlines $ map unwords' lns - where - lsep = length sep - las = addLengths as - -- Scale this, to take into account the height:width ratio. - sidelen :: Double -- Suppress defaulting messages - sidelen = (1.75*) . sqrt . fromIntegral . sum $ map fst las - slen = round sidelen - serr = round $ sidelen/10 - lns = unfoldr (takeLen slen serr lsep) las - unwords' = concat . intersperse sep - --- | Using the given line length and allowed error, take the elements of --- the next line. -takeLen :: Int -> Int -> Int -> [(Int,String)] - -> Maybe ([String],[(Int,String)]) -takeLen _ _ _ [] = Nothing -takeLen len err lsep ((l,a):als) = Just lr - where - lmax = len + err - lr = if l > len - then ([a],als) -- Overflow line of single item - else (a:as,als') - -- We subtract lsep here to take into account the spacer. - (as,als') = takeLine (lmax - l - lsep) lsep als - --- | Recursively build the rest of the line with given maximum length. -takeLine :: Int -> Int -> [(Int,String)] -> ([String],[(Int,String)]) -takeLine len lsep als - | null als = ([],als) - | len <= 0 = ([],als) -- This should be covered by the next guard, - -- but just in case... - | l > len = ([],als) - | otherwise = (a:as,als'') - where - ((l,a):als') = als - -- We subtract lsep here to take into account the spacer. - len' = len - l - lsep - (as,als'') = takeLine len' lsep als' - {- | Shuffle a list of elements. This isn't the most efficient version, but should serve for small lists. @@ -466,25 +387,17 @@ -- Other utility functions. -- | Find the fixed point of a function with the given initial value. -fixPoint :: (Eq a) => (a -> a) -> a -> a -fixPoint f = fixPointBy (==) f +fixPoint :: (Eq a) => (a -> a) -> a -> a +fixPoint = fixPointBy (==) -- | Find the fixed point of a function with the given initial value, -- using the given equality function. fixPointBy :: (a -> a -> Bool) -> (a -> a) -> a -> a -fixPointBy eq f x = if (eq x x') +fixPointBy eq f x = if eq x x' then x' else fixPointBy eq f x' where x' = f x -- | Find the fixed point of a graph transformation function. -fixPointGraphs :: (Eq a, Eq b, Graph g) => (g a b -> g a b) -> g a b -> g a b -fixPointGraphs f = fixPointBy equal f - --- | Squaring a number. -sq :: (Num a) => a -> a -sq x = x * x - --- | Shorthand for 'fromIntegral' -fI :: (Num a) => Int -> a -fI = fromIntegral +fixPointGraphs :: (Eq a, Eq b, Graph g) => (g a b -> g a b) -> g a b -> g a b +fixPointGraphs = fixPointBy equal diff --git a/Data/Graph/Analysis/Visualisation.hs b/Data/Graph/Analysis/Visualisation.hs --- a/Data/Graph/Analysis/Visualisation.hs +++ b/Data/Graph/Analysis/Visualisation.hs @@ -1,293 +1,204 @@ {- | Module : Data.Graph.Analysis.Visualisation Description : Graphviz wrapper functions - Copyright : (c) Ivan Lazar Miljenovic 2008 + Copyright : (c) Ivan Lazar Miljenovic 2009 License : 2-Clause BSD Maintainer : Ivan.Miljenovic@gmail.com Functions to assist in visualising graphs and components of graphs. - This module uses code licensed under the 3-Clause BSD license from - the /mohws/ project: - -} module Data.Graph.Analysis.Visualisation - ( -- * Graph visualisation + ( -- * Graph visualisation. -- $graphviz - -- ** Producing 'DotGraph's graphviz, graphvizClusters, - -- ** Creating images - GraphvizOutput(..), - GraphvizCommand(..), - runGraphviz, - runGraphvizCommand, - -- * Showing node groupings + graphvizClusters', + assignCluster, + noAttributes, + -- * Showing node groupings. -- $other showPath, + showPath', showCycle, - showNodes + showCycle', + showNodes, + showNodes', + -- * Various printing functions. + blockPrint, + blockPrint', + blockPrintList, + blockPrintList', + blockPrintWith, + blockPrintWith', ) where -import Prelude - import Data.Graph.Analysis.Types import Data.Graph.Analysis.Utils import Data.Graph.Inductive.Graph import Data.GraphViz -import System.IO -import System.Exit -import System.Process -import Data.Array.IO -import Control.Concurrent -import Control.Exception - --- Import this when the parsing stuff is finished --- import Text.ParserCombinators.PolyLazy +import Data.List(intersperse, unfoldr) -- ----------------------------------------------------------------------------- {- $graphviz - Simple wrappers around the Haskell "Data.GraphViz" library to - turn 'Graph's into basic 'DotGraph's for processing by the Graphviz - application. + Simple wrappers around the Haskell "Data.GraphViz" library to turn + 'GraphData's into basic 'DotGraph's for processing by the GraphViz + suite of applications. -} --- | Turns the graph into 'DotGraph' format with the given title and graph --- attributes. Nodes are labelled, edges aren't. -graphviz :: (Graph g, Show a, Ord b) => String -> g a b -> [Attribute] - -> DotGraph -graphviz t g as = graphToDot g attrs nattrs eattrs - where - attrs = Label t : as - nattrs (_,a) = [Label (show a)] - eattrs _ = [] - --- | Turns the graph into 'DotGraph' format with the given title and graph --- attributes. Cluster the nodes based upon their 'ClusterLabel' clusters. --- Nodes and clusters are labelled, edges aren't. -graphvizClusters :: (Graph g, Show c, ClusterLabel a c, Ord b) => - String -> g a b -> [Attribute] -> DotGraph -graphvizClusters t g as = clusterGraphToDot g atts assignCluster cas nas eas - where - atts = Label t : as - cas c = [Label (show c)] - nas (_,a) = [Label (nodelabel a)] - eas _ = [] +-- | Convert the 'GraphData' into 'DotGraph' format with the given +-- 'Attribute's. +graphviz :: GraphData n e -> [GlobalAttributes] + -> (LNode n -> Attributes) + -> (LEdge e -> Attributes) -> DotGraph Node +graphviz = applyDirAlg graphToDot --- | The possible Graphviz outputs, obtained by running /dot -Txxx/. --- Note that it is not possible to choose between output variants, --- and that not all of these may be available on your system. -data GraphvizOutput = Canon - | Cmap - | Cmapx - | Cmapx_np - | Dia - | DotOutput - | Eps - | Fig - | Gd - | Gd2 - | Gif - | Gtk - | Hpgl - | Imap - | Imap_np - | Ismap - | Jpe - | Jpeg - | Jpg - | Mif - | Mp - | Pcl - | Pdf - | Pic - | Plain - | PlainExt - | Png - | Ps - | Ps2 - | Svg - | Svgz - | Tk - | Vml - | Vmlz - | Vrml - | Vtx - | Wbmp - | Xdot - | Xlib +-- | Convert the clustered 'GraphData' into 'DotGraph' format with the +-- given 'Attribute's. Cluster the nodes based upon their +-- 'ClusterLabel' clusters. +graphvizClusters :: (ClusterLabel cl) => GraphData cl e -> [GlobalAttributes] + -> (Cluster cl -> [GlobalAttributes]) + -> (LNode (NodeLabel cl) -> Attributes) + -> (LEdge e -> Attributes) -> DotGraph Node +graphvizClusters g gas = graphvizClusters' g gas assignCluster clusterID -instance Show GraphvizOutput where - show Canon = "canon" - show Cmap = "cmap" - show Cmapx = "cmapx" - show Cmapx_np = "cmapx_np" - show Dia = "dia" - show DotOutput = "dot" - show Eps = "eps" - show Fig = "fig" - show Gd = "gd" - show Gd2 = "gd2" - show Gif = "gif" - show Gtk = "gtk" - show Hpgl = "hpgl" - show Imap = "imap" - show Imap_np = "imap_np" - show Ismap = "ismap" - show Jpe = "jpe" - show Jpeg = "jpeg" - show Jpg = "jpg" - show Mif = "mif" - show Mp = "mp" - show Pcl = "pcl" - show Pdf = "pdf" - show Pic = "pic" - show Plain = "plain" - show PlainExt = "plain-ext" - show Png = "png" - show Ps = "ps" - show Ps2 = "ps2" - show Svg = "svg" - show Svgz = "svgz" - show Tk = "tk" - show Vml = "vml" - show Vmlz = "vmlz" - show Vrml = "vrml" - show Vtx = "vtx" - show Wbmp = "wbmp" - show Xdot = "xdot" - show Xlib = "xlib" +-- | Convert the 'GraphData' into a clustered 'DotGraph' format using +-- the given clustering function and with the given 'Attribute's. +graphvizClusters' :: (Ord c) => GraphData n e -> [GlobalAttributes] + -> (LNode n -> NodeCluster c l) + -> (c -> Maybe GraphID) + -> (c -> [GlobalAttributes]) -> (LNode l -> Attributes) + -> (LEdge e -> Attributes) -> DotGraph Node +graphvizClusters' = applyDirAlg clusterGraphToDot --- | The available Graphviz commands. -data GraphvizCommand = DotCmd | Neato | TwoPi | Circo | Fdp +-- | A function to convert an 'LNode' to the required 'NodeCluster' +-- for use with the GraphViz library. +assignCluster :: (ClusterLabel cl) => LNode cl + -> NodeCluster (Cluster cl) (NodeLabel cl) +assignCluster (n,a) = C (cluster a) $ N (n, nodeLabel a) -instance Show GraphvizCommand where - show DotCmd = "dot" - show Neato = "neato" - show TwoPi = "twopi" - show Circo = "circo" - show Fdp = "fdp" +-- | Used to state that GraphViz should use the default 'Attribute's +-- for the given value. +noAttributes :: a -> Attributes +noAttributes = const [] --- | Run the recommended Graphviz command on this graph, saving the result --- to the file provided (note: file extensions are /not/ checked). -runGraphviz :: DotGraph -> GraphvizOutput -> FilePath -> IO Bool -runGraphviz gr t fp = runGraphvizInternal (commandFor gr) gr t fp +-- ----------------------------------------------------------------------------- --- | Run the chosen Graphviz command on this graph, saving the result --- to the file provided (note: file extensions are /not/ checked). -runGraphvizCommand :: GraphvizCommand -> DotGraph -> GraphvizOutput - -> FilePath -> IO Bool -runGraphvizCommand cmd gr t fp = runGraphvizInternal (show cmd) gr t fp +{- $other + Printing different lists of labels. + -} --- | This command should /not/ be available outside this module, as --- it isn't safe: running an arbitrary command will crash the programme. -runGraphvizInternal :: String -> DotGraph -> GraphvizOutput -> FilePath - -> IO Bool -runGraphvizInternal cmd gr t fp - = do pipe <- try $ openFile fp WriteMode - case pipe of - (Left _) -> return False - (Right f) -> do file <- graphvizWithHandle cmd gr t (flip squirt f) - hClose f - case file of - (Just _) -> return True - _ -> return False +-- | Print a path, with \"->\" between each element. +showPath :: (Show a) => [a] -> String +showPath = showPath' show -{- | - This function is taken from the /mohws/ project, available under a - 3-Clause BSD license. The actual function is taken from: - - It provides an efficient way of transferring data from one 'Handle' - to another. - -} -squirt :: Handle -> Handle -> IO () -squirt rd wr = do - arr <- newArray_ (0, bufsize-1) - let loop = do - r <- hGetArray rd arr bufsize - if (r == 0) - then return () - else if (r < bufsize) - then hPutArray wr arr r - else hPutArray wr arr bufsize >> loop - loop +-- | Print a path, with \"->\" between each element. +showPath' :: (a -> String) -> [a] -> String +showPath' _ [] = "" +showPath' f ls = blockPrint' (l:ls'') where - -- This was originally separate - bufsize :: Int - bufsize = 4 * 1024 + -- Can't use blockPrintWith above, as it only takes a per-row spacer. + (l:ls') = map f ls + ls'' = map ("-> "++) ls' -{- +-- | Print a cycle: copies the first node to the end of the list, +-- and then calls 'showPath'. +showCycle :: (Show a) => [a] -> String +showCycle = showCycle' show --- Parsing to get graph size... do this later. +-- | Print a cycle: copies the first node to the end of the list, +-- and then calls 'showPath''. +showCycle' :: (a -> String) -> [a] -> String +showCycle' _ [] = "" +showCycle' f ls@(l:_) = showPath' f (ls ++ [l]) -parseGraphviz :: DotGraph -> IO (Maybe DotGraph) -parseGraphviz gr = parseGraphvizInternal (commandFor gr) gr +-- | Show a group of nodes, with no implicit ordering. +showNodes :: (Show a) => [a] -> String +showNodes = showNodes' show -graphvizSizeInternal :: String -> DotGraph -> Maybe (Int,Int) -graphvizSizeInternal cmd gr = +-- | Show a group of nodes, with no implicit ordering. +showNodes' :: (a -> String) -> [a] -> String +showNodes' _ [] = "" +showNodes' f ls = blockPrint' . addCommas + $ map f ls where - parsed = parseGraphvizInternal cmd gr - getBB = maybe Nothing (find - bb2Rect (Bb r) = r - rectToSize (Rect _ (Point x y)) = (x,y) + addCommas [] = [] + addCommas [l] = [l] + addCommas (l:ls') = (l ++ ", ") : addCommas ls' --- | Internal parsing command. -parseGraphvizInternal :: String -> DotGraph -> IO (Maybe DotGraph) -parseGraphvizInternal cmd gr = graphvizWithHandle cmd gr DotOutput parse - where - parse h = do res <- hGetContents h - let gr' = fst $ runParser readDotGraph res - return gr' +-- ----------------------------------------------------------------------------- --} +-- | Attempt to convert the @String@ form of a list into +-- as much of a square shape as possible, using a single +-- space as a separation string. +blockPrint :: (Show a) => [a] -> String +blockPrint = blockPrintWith " " --- | Internal command to run Graphviz and process the output. --- This is /not/ to be made available outside this module. -graphvizWithHandle :: (Show a) => String -> DotGraph -> GraphvizOutput -> (Handle -> IO a) - -> IO (Maybe a) -graphvizWithHandle cmd gr t f - = do (inp, outp, errp, proc) <- runInteractiveCommand command - forkIO $ hPrint inp gr >> hClose inp - forkIO $ (hGetContents errp >>= hPutStr stderr >> hClose errp) - a <- f outp - -- Don't close outp until f finishes. - a `seq` hClose outp - exitCode <- waitForProcess proc - case exitCode of - ExitSuccess -> return (Just a) - _ -> return Nothing - where - command = cmd ++ " -T" ++ (show t) +-- | Attempt to convert a list of @String@s into a single @String@ +-- that is roughly a square shape, with a single space as a row +-- separator. +blockPrint' :: [String] -> String +blockPrint' = blockPrintWith' " " --- ----------------------------------------------------------------------------- +-- | Attempt to convert the @String@ form of a list into +-- as much of a square shape as possible, separating values +-- with commas. +blockPrintList :: (Show a) => [a] -> String +blockPrintList = blockPrintWith ", " -{- $other - Other visualisations. These are mainly replacements for - the @show@ function. - -} +-- | Attempt to combine a list of @String@s into as much of a +-- square shape as possible, separating values with commas. +blockPrintList' :: [String] -> String +blockPrintList' = blockPrintWith' ", " --- | Print a path, with \"->\" between each element. -showPath :: (Show a) => LNGroup a -> String -showPath [] = "" -showPath lns = blockPrint' (l:ls') +-- | Attempt to convert the @String@ form of a list into +-- as much of a square shape as possible, using the given +-- separation string between elements in the same row. +blockPrintWith :: (Show a) => String -> [a] -> String +blockPrintWith str = blockPrintWith' str . map show + +-- | Attempt to convert the combined form of a list of @String@s +-- into as much of a square shape as possible, using the given +-- separation string between elements in the same row. +blockPrintWith' :: String -> [String] -> String +blockPrintWith' sep as = init -- Remove the final '\n' on the end. + . unlines $ map unwords' lns where - -- Can't use blockPrintWith above, as it only takes a per-row spacer. - (l:ls) = map (show . label) lns - ls' = map ("-> "++) ls + lsep = length sep + las = addLengths as + -- Scale this, to take into account the height:width ratio. + sidelen :: Double -- Suppress defaulting messages + sidelen = (1.75*) . sqrt . fromIntegral . sum $ map fst las + slen = round sidelen + serr = round $ sidelen/10 + lns = unfoldr (takeLen slen serr lsep) las + unwords' = concat . intersperse sep --- | Print a cycle: copies the first node to the end of the list, --- and then calls 'showPath'. -showCycle ::(Show a) => LNGroup a -> String -showCycle [] = "" -showCycle lns@(ln:_) = showPath (lns ++ [ln]) +-- | Using the given line length and allowed error, take the elements of +-- the next line. +takeLen :: Int -> Int -> Int -> [(Int,String)] + -> Maybe ([String],[(Int,String)]) +takeLen _ _ _ [] = Nothing +takeLen len err lsep ((l,a):als) = Just lr + where + lmax = len + err + lr = if l > len + then ([a],als) -- Overflow line of single item + else (a:as,als') + -- We subtract lsep here to take into account the spacer. + (as,als') = takeLine (lmax - l - lsep) lsep als --- | Show a group of nodes, with no implicit ordering. -showNodes :: (Show a) => LNGroup a -> String -showNodes [] = "" -showNodes lns = blockPrint' . addCommas - $ map (show . label) lns +-- | Recursively build the rest of the line with given maximum length. +takeLine :: Int -> Int -> [(Int,String)] -> ([String],[(Int,String)]) +takeLine len lsep als + | null als = ([],als) + | len <= 0 = ([],als) -- This should be covered by the next guard, + -- but just in case... + | l > len = ([],als) + | otherwise = (a:as,als'') where - addCommas [] = [] - addCommas [l] = [l] - addCommas (l:ls) = (l ++ ", ") : addCommas ls + ((l,a):als') = als + -- We subtract lsep here to take into account the spacer. + len' = len - l - lsep + (as,als'') = takeLine len' lsep als' diff --git a/Graphalyze.cabal b/Graphalyze.cabal --- a/Graphalyze.cabal +++ b/Graphalyze.cabal @@ -1,5 +1,5 @@ Name: Graphalyze -Version: 0.5 +Version: 0.7.0.0 Synopsis: Graph-Theoretic Analysis library. Description: A library to use graph theory to analyse the relationships inherent in discrete data. @@ -10,21 +10,29 @@ Author: Ivan Lazar Miljenovic Maintainer: Ivan.Miljenovic@gmail.com Extra-Source-Files: TODO -Cabal-Version: >= 1.2 +Cabal-Version: >= 1.6 Build-Type: Simple -Tested-With: GHC==6.8.3 -flag small_base - description: Choose the new smaller, split-up base package. +Source-Repository head + Type: darcs + Location: http://code.haskell.org/Graphalyze -Library { - if flag(small_base) - Build-Depends: base >= 3, array, containers, directory, filepath, - old-locale, process, random, time - else - Build-Depends: base < 3 - Build-Depends: bktrees, fgl, graphviz >= 2008.9.20, pandoc +Library { + Build-Depends: base >= 3 && < 5, + extensible-exceptions, + array, + containers, + directory, + filepath, + old-locale, + process, + random, + time, + bktrees >= 0.2, + fgl >= 5.4.2.2, + graphviz >= 2999.6.0.0 && < 2999.7.0.0, + pandoc Exposed-Modules: Data.Graph.Analysis Data.Graph.Analysis.Types @@ -37,7 +45,9 @@ Data.Graph.Analysis.Reporting Data.Graph.Analysis.Reporting.Pandoc - Ghc-Options: -Wall - Ghc-Prof-Options: -auto-all + Other-Modules: Data.Graph.Analysis.Internal, + Paths_Graphalyze + Ghc-Options: -Wall + Ghc-Prof-Options: -prof -auto-all }