diff --git a/Data/Graph/Analysis.hs b/Data/Graph/Analysis.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Analysis.hs @@ -0,0 +1,98 @@ +{- | + Module : Data.Graph.Analysis + Description : A Graph-Theoretic Analysis Library. + Copyright : (c) Ivan Lazar Miljenovic 2008 + License : 2-Clause BSD + Maintainer : Ivan.Miljenovic@gmail.com + + This is the root module of the /Graphalyze/ library, which aims to + provide a way of analysing the relationships inherent in discrete + data as a graph. + + This was written as part of my mathematics honours thesis, + /Graph-Theoretic Analysis of the Relationships in Discrete Data/. + -} +module Data.Graph.Analysis + ( -- * Re-exporting other modules + module Data.Graph.Analysis.Types, + module Data.Graph.Analysis.Utils, + module Data.Graph.Analysis.Algorithms, + module Data.Graph.Inductive.Graph, + -- * Importing data + ImportParams(..), + defaultParams, + importData + ) where + +import Data.Graph.Analysis.Utils +import Data.Graph.Analysis.Types +import Data.Graph.Analysis.Algorithms + +import Data.Graph.Inductive.Graph +import Data.List +import Data.Maybe +import qualified Data.Map as M + +-- ----------------------------------------------------------------------------- + +{- | + 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 + } + +{- | + 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. + -} +importData :: (Ord a) => ImportParams a -> GraphData a +importData params = GraphData { graph = dGraph, wantedRoots = rootNodes } + where + -- Adding Node values to each of the data points. + lNodes = zip [1..] (dataPoints 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) + -- Validate an edge + validNode l = case (findNode l) of + (Just n) -> Just (n,l) + _ -> Nothing + -- Construct the root nodes + rootNodes = if (directed params) + then catMaybes $ map 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 diff --git a/Data/Graph/Analysis/Algorithms.hs b/Data/Graph/Analysis/Algorithms.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Analysis/Algorithms.hs @@ -0,0 +1,35 @@ +{- | + Module : Data.Graph.Analysis.Algorithms + Description : Graph analysis algorithms + Copyright : (c) Ivan Lazar Miljenovic 2008 + License : 2-Clause BSD + Maintainer : Ivan.Miljenovic@gmail.com + + This module exports all the algorithms found in the + @Data.Graph.Analysis.Algorithms.*@ modules. + -} +module Data.Graph.Analysis.Algorithms + ( -- * Graph Algorithms + -- $algorithms + module Data.Graph.Analysis.Algorithms.Common, + module Data.Graph.Analysis.Algorithms.Directed, + module Data.Graph.Analysis.Algorithms.Clustering, + applyAlg + ) where + +import Data.Graph.Analysis.Types +import Data.Graph.Analysis.Algorithms.Common +import Data.Graph.Analysis.Algorithms.Directed +import Data.Graph.Analysis.Algorithms.Clustering + +{- $algorithms + 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. + -} + +-- | 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/Clustering.hs b/Data/Graph/Analysis/Algorithms/Clustering.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Analysis/Algorithms/Clustering.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +{- | + Module : Data.Graph.Analysis.Algorithms.Clustering + Description : Clustering and grouping algorithms. + Copyright : (c) Ivan Lazar Miljenovic 2008 + License : 2-Clause BSD + Maintainer : Ivan.Miljenovic@gmail.com + + Clustering and grouping algorithms that are graph-invariant and require + no user intervention. + -} +module Data.Graph.Analysis.Algorithms.Clustering + ( -- * Clustering Algorithms + -- ** Non-deterministic algorithms + -- $chinesewhispers + Whispering, + chineseWhispers, + -- ** Spatial Algorithms + -- $relneighbours + relativeNeighbourhood, + -- * Graph Collapsing + -- $collapsing + CNodes(..), + collapseGraph + ) where + +import Data.Graph.Analysis.Types +import Data.Graph.Analysis.Utils +import Data.Graph.Analysis.Algorithms.Common +import Data.Graph.Analysis.Algorithms.Directed(rootsOf') + +import Data.Graph.Inductive.Graph + +import Data.List +import Data.Maybe +import Data.Function +import qualified Data.Set as Set +import qualified Data.Set.BKTree as BK +import Data.Set.BKTree(BKTree, Metric(..)) +import Control.Arrow +import System.Random + +-- ----------------------------------------------------------------------------- + +{- $chinesewhispers + The Chinese Whispering Algorithm. + This is an adaptation of the algorithm described in: + + Biemann, C. (2006): Chinese Whispers - an Efficient Graph Clustering + Algorithm and its Application to Natural Language Processing Problems. + Proceedings of the HLT-NAACL-06 Workshops on Textgraphs-06, New York, USA + + + The adaptations to this algorithm are as follows: + + * Ignore any edge weightings that may exist, as we can't depend on them + (also, we want the algorithm to be dependent solely upon the + /structure/ of the graph, not what it contains). + + * Increase the weighting of those nodes present in interesting structures, + such as loops and root nodes. This is to try and ensure that these nodes + end up in the same cluster. + + + Simplistically, the way it works is this: + + 1. Every node is assigned into its own unique cluster. + + 2. For each iteration, sort the nodes into each order. For each node, + it joins the most popular cluster in its neighbourhood + (where popularity is defined by the sum of the weightings). + + 3. Repeat step 2. until a fixed point is reached. + + Note that this algorithm is non-deterministic, and that for some graphs + no fixed point may be reached (and the algorithm may oscillate between + a few different graph clusterings). +-} + +-- | An instance of 'ClusterLabel' used for the Chinese Whispers algorithm. +data Whispering a = W { name :: a -- ^ The original label. + , whisp :: Int -- ^ The current cluster this node is in. + , coeff :: Double -- ^ The node's weighting. + } deriving (Show,Eq) + +instance (Show a) => ClusterLabel (Whispering a) Int where + cluster = whisp + nodelabel = show . name + +-- | The actual Chinese Whispers algorithm. +chineseWhispers :: (RandomGen g, Eq a, Eq b, DynGraph gr) => g -> gr a b + -> gr (Whispering a) b +chineseWhispers g gr = fst $ fixPointBy eq whispering (gr',g) + where + eq = equal `on` fst + ns = nodes gr + whispering (gr'',g') = foldl' whisperNode (gr'',g'') ns' + where + -- Shuffle the nodes to ensure the order of choosing a new + -- cluster is random. + (ns',g'') = shuffle g' ns + gr' = addWhispers gr + +-- | Choose a new cluster for the given 'Node'. Note that this updates +-- the graph each time a new cluster value is chosen. +whisperNode :: (RandomGen g, DynGraph gr) => (gr (Whispering a) b,g) + -> Node -> (gr (Whispering a) b,g) +whisperNode (gr,g) n = (c' & gr',g') + where + (Just c,gr') = match n gr + (g',c') = whisper gr g c + +-- | Choose a new cluster for the given @Context@. +whisper :: (RandomGen g, Graph gr) => gr (Whispering a) b -> g + -> Context (Whispering a) b -> (g,Context (Whispering a) b) +whisper gr g (p,n,al,s) = (g',(p,n,al {whisp = w'},s)) + where + (w',g') = case (neighbors gr n) of + [] -> (whisp al,g) + -- Add this current node to the list of neighbours to add + -- extra weighting, as it seems to give better results. + ns -> chooseWhisper g (addLabels gr (n:ns)) + +-- | Choose which cluster to pick by taking the one with maximum sum of +-- weightings. If more than one has the same maximum, choose one +-- randomly. +chooseWhisper :: (RandomGen g) => g -> [LNode (Whispering a)] + -> (Int,g) +chooseWhisper g lns = pick maxWspWgts + where + -- This isn't the most efficient method of choosing a random list element, + -- but the graph is assumed to be relatively sparse and thus ns should + -- be relatively short. + pick ns = first (ns!!) $ randomR (0,length ns - 1) g + whispWgts = map (second sumWgts) . groupElems whisp $ map label lns + maxWspWgts = map fst . snd . head $ groupElems (negate . snd) whispWgts + sumWgts = sum . map coeff + +-- | Convert the graph into a form suitable for the Chinese Whispers algorithm. +addWhispers :: (DynGraph gr) => gr a b -> gr (Whispering a) b +addWhispers g = gmap augment g + where + augment (p,n,l,s) = (p,n,W { name = l + , whisp = n + , coeff = coefFor n + },s) + -- Note that cliques are also cycles... + -- cliques = Set.fromList . concat $ cliquesIn' g + cycles = Set.fromList . concat $ cyclesIn' g + roots = Set.fromList $ rootsOf' g + -- Give more emphasis to interesting parts of the graph. + coefFor n + | Set.member n roots = 3 + | Set.member n cycles = 2 + | otherwise = 1 + + +{- + +Originally used for the clustering coefficient, didn't seem to give good +results. +http://en.wikipedia.org/wiki/Clustering_coefficient + +clusteringCoef :: (Graph gr) => gr a b -> Node -> Double +clusteringCoef g n = if (liftM2 (||) isNaN isInfinite $ coef) + then 0 + else coef + where + d = fromIntegral $ deg g n + coef = (fromIntegral nes) / (k*(k - 1)) + ns = (neighbors g n) + k = fromIntegral $ length ns + nes = length $ concatMap (union ns . neighbors g) ns +-} + +-- ----------------------------------------------------------------------------- + +{- $relneighbours + This implements the algorithm called CLUSTER, from the paper: + + Bandyopadhyay, S. (2003): An automatic shape independent clustering + technique. Pattern Recognition, vol. 37, pp. 33-45. + + Simplistically, it defines clusters as groups of nodes that are + spatially located closer to each other than to nodes in + other clusters. It utilises the concept of a /Relative + Neighbour Graph/ [RNG] to determine the spatial structure of a set + of two-dimensional data points. + + The adaptations to this algorithm are as follows: + + * Due to the limitations of the BKTree data structure, we utilise a + /fuzzy/ distance function defined as the ceiling of the standard + Euclidian distance. + + * We utilise 'toPosGraph' to get the spatial locations. As such, + these locations may not be optimal, especially for smaller + graphs. + + * The actual algorithm is applied to each connected component of + the graph. The actual paper is unclear what to do in this + scenario, but Graphviz may locate nodes from separate + components together, despite them not being related. + + + The algorithm is renamed 'relativeNeighbourhood'. Experimentally, it + seems to work better with larger graphs (i.e. more nodes), since + then Graphviz makes the apparent clusters more obvious. +-} + +-- | 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 + where + cMap = createLookup . concatMap rn $ componentsOf g + rn g' = nbrCluster rng + where + rng :: Gr () Int + rng = makeRNG $ getPositions g' + +-- | We take the ceiling of the Euclidian distance function to use as our +-- metric function. +instance (Eq a) => Metric (PosLabel a) where + distance = (ceiling . ) . euclidian +-- Note that this throws an orphan instance warning. + +-- | The Euclidian distance function. +euclidian :: PosLabel a -> PosLabel a -> Double +euclidian n1 n2 = sqrt . fI $ (posBy xPos) + (posBy yPos) + where + posBy p = sq $ (p n1) - (p n2) + +-- | Converts the positional labels into an RNG. +makeRNG :: (Eq a, Graph gr) => [PosLabel a] -> gr () Int +makeRNG ls = mkGraph ns es + where + ns = map (\l -> (pnode l,())) ls + tree = BK.fromList ls + tls = tails ls + es = [ (pnode l1,pnode l2,distance l1 l2) + | (l1:ls') <- tls + , l2 <- ls' + , areRelative tree l1 l2 ] + +-- | Determines if the two given nodes should be connected in the RNG. +-- Nodes are connected if there is no node that is closer to both of them. +areRelative :: (Metric a) => BKTree a -> a -> a -> Bool +areRelative t l1 l2 = null lune + where + d = distance l1 l2 + -- Find all nodes distance <= d away from the given node. + -- Note that n is distance 0 <= d away from n, so we need to + -- remove it from the list of results. + rgnFor l = delete l $ BK.elemsDistance d l t + -- The nodes that are between the two given nodes. + lune = intersect (rgnFor l1) (rgnFor l2) + +-- | Performs the actual clustering algorithm on the RNG. +nbrCluster :: (DynGraph gr) => gr a Int -> [[Node]] +nbrCluster g + | numNodes == 1 = [ns] -- Can't split up a single node. + | eMax < 2*eMin = [ns] -- The inter-cluster relative neighbours + -- are too close too each other. + | null thrs = [ns] -- No threshold value available. + | single cg' = [ns] -- No edges meet the threshold deletion + -- criteria. + | nCgs > sNum = [ns] -- Over-fragmentation of the graph. + | otherwise = concatMap nbrCluster cg' + where + ns = nodes g + numNodes = noNodes g + sNum = floor (sqrt $ fI numNodes :: Double) + les = labEdges g + (es,eMin,eMax) = sortMinMax $ map eLabel les + es' = zip es (tail es) + sub = uncurry subtract + -- First order differences. + -- We don't care about the list, just what the min and max diffs are. + (_,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) + -- 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. + thresh = fst $ head thrs + -- Edges that meet the threshold deletion criteria. + rEs = map edge $ filter ((>= thresh) . eLabel) les + g' = delEdges rEs g + -- Each of these will also be an RNG + cg' = componentsOf g' + nCgs = length cg' + +-- ----------------------------------------------------------------------------- + +{- $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. + + 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] + +-- | 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) = blockPrint $ map label lns + +collapseGraph :: (DynGraph gr, Eq b) => gr a b -> gr (CNodes a) b +collapseGraph g = foldl' (flip collapseAllBy) cg interestingParts + where + cg = makeCollapsible g + interestingParts = [cliquesIn', cyclesIn', chainsIn'] + +-- | Allow the graph to be collapsed. +makeCollapsible :: (DynGraph gr) => gr a b -> gr (CNodes a) b +makeCollapsible = nlmap (CN . return) + +-- | 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) + 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)) + -- not sure if this should be included: . nub + . 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) + +-- | 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 + where + collapser g' = collapse g' n + +-- | 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 + [] -> g + -- We re-evaluate the function in case + -- the original results used nodes that + -- have been collapsed down. + (ns:_) -> collapseAllBy f (collapseAll g ns) diff --git a/Data/Graph/Analysis/Algorithms/Common.hs b/Data/Graph/Analysis/Algorithms/Common.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Analysis/Algorithms/Common.hs @@ -0,0 +1,288 @@ +{- | + Module : Data.Graph.Analysis.Algorithms.Common + Description : Algorithms for all graph types. + Copyright : (c) Ivan Lazar Miljenovic 2008 + License : 2-Clause BSD + Maintainer : Ivan.Miljenovic@gmail.com + + Defines algorithms that work on both undirected and + directed graphs. + -} +module Data.Graph.Analysis.Algorithms.Common + ( -- * Graph decomposition + -- $connected + componentsOf, + pathTree, + -- * Clique Detection + -- $cliques + cliquesIn, + cliquesIn', + findRegular, + isRegular, + -- * Cycle Detection + -- $cycles + cyclesIn, + cyclesIn', + uniqueCycles, + uniqueCycles', + -- * Chain detection + -- $chains + chainsIn, + chainsIn' + ) where + +import Data.Graph.Analysis.Types +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 + +-- ----------------------------------------------------------------------------- + +{- $connected + Finding connected components. + + Whilst the FGL library does indeed have a function 'components' + that returns the connected components of a graph, it returns each + component as a list of 'Node's. This implementation instead + returns each component as a /graph/, which is much more useful. + + Connected components are found by choosing a random node, then + recursively extracting all neighbours of that node until no more + nodes can be removed. + + Note that for directed graphs, these are known as the /weakly/ + connected components. +-} + +-- | Find all connected components of a graph. +componentsOf :: (DynGraph g) => g a b -> [g a b] +componentsOf = unfoldr splitComponent + +-- | Find the next component and split it off from the graph. +splitComponent :: (DynGraph g) => g a b -> Maybe (g a b, g a b) +splitComponent g + | isEmpty g = Nothing + | otherwise = Just . -- Get the type right + first buildGr . -- Create the subgraph + extractNode . -- Extract components of subgraph + first Just . -- Getting the types right + matchAny $ g -- Choose an arbitrary node to begin with + +-- | Extract the given node and all nodes it is transitively +-- connected to from the graph. +extractNode :: (DynGraph g) => Decomp g a b -> ([Context a b], g a b) +extractNode (Nothing,gr) = ([],gr) +extractNode (Just ctxt, gr) + | isEmpty gr = ([ctxt], empty) + | otherwise = first (ctxt:) $ foldl' nodeExtractor ([],gr) nbrs + where + nbrs = neighbors' ctxt + +-- | Helper function for 'extractNode' above. +nodeExtractor :: (DynGraph g) => ([Context a b], g a b) -> Node + -> ([Context a b], g a b) +nodeExtractor cg@(cs,g) n + | gelem n g = first (++ cs) . extractNode $ match n g + | otherwise = cg + +-- ----------------------------------------------------------------------------- + +-- | Find all possible paths from this given node, avoiding loops, +-- cycles, etc. +pathTree :: (DynGraph g) => Decomp g a b -> [NGroup] +pathTree (Nothing,_) = [] +pathTree (Just ct,g) + | isEmpty g = [] + | null sucs = [[n]] + | otherwise = (:) [n] . map (n:) . concatMap (subPathTree g') $ sucs + where + n = node' ct + sucs = suc' ct + -- Avoid infinite loops by not letting it continue any further + ct' = makeLeaf ct + g' = ct' & g + subPathTree gr n' = pathTree $ match n' gr + +-- | Remove all outgoing edges +makeLeaf :: Context a b -> Context a b +makeLeaf (p,n,a,_) = (p', n, a, []) + where + -- Ensure there isn't an edge (n,n) + p' = filter (\(_,n') -> n' /= n) p + +-- ----------------------------------------------------------------------------- +{- $cliques + Clique detection routines. Find cliques by taking out a node, and + seeing which other nodes are all common neighbours (by both 'pre' + and 'suc'). + -} + +-- | Finds all cliques (i.e. maximal complete subgraphs) in the given graph. +cliquesIn :: (Graph g) => g a b -> [[LNode a]] +cliquesIn gr = map (addLabels gr) (cliquesIn' gr) + +-- | Finds all cliques in the graph, without including labels. +cliquesIn' :: (Graph g) => g a b -> [NGroup] +cliquesIn' gr = filter (isClique gr) (findRegular gr) + +-- | Determine if the given list of nodes is indeed a clique, +-- and not a smaller subgraph of a clique. +isClique :: (Graph g) => g a b -> NGroup -> Bool +isClique _ [] = False +isClique gr ns = null . + foldl1' intersect . + map ((\\ ns) . corecursive gr) $ ns + +-- | Find all regular subgraphs of the given graph. +findRegular :: (Graph g) => g a b -> [[Node]] +findRegular = concat . unfoldr findRegularOf + +-- | Extract the next regular subgraph of a graph. +findRegularOf :: (Graph g) => g a b -> Maybe ([[Node]], g a b) +findRegularOf g + | isEmpty g = Nothing + | otherwise = Just . + first (regularOf g . node') . + matchAny $ g + +-- | Returns all regular subgraphs that include the given node. +regularOf :: (Graph g) => g a b -> Node -> [[Node]] +regularOf gr n = map (n:) (alsoRegular gr crs) + where + crs = corecursive gr n + +-- | Recursively find all regular subgraphs only containing nodes +-- in the given list. +alsoRegular :: (Graph g) => g a b -> [Node] -> [[Node]] +alsoRegular _ [] = [] +alsoRegular _ [n] = [[n]] +alsoRegular g (n:ns) = [n] : rs ++ (alsoRegular g ns) + where + rs = map (n:) (alsoRegular g $ intersect crn ns) + crn = corecursive g n + +-- | Return all nodes that are co-recursive with the given node +-- (i.e. for n, find all n' such that n->n' and n'->n). +corecursive :: (Graph g) => g a b -> Node -> [Node] +corecursive gr n = filter (elem n . suc gr) (delete n $ suc gr n) + +-- | Determines if the list of nodes represents a regular subgraph. +isRegular :: (Graph g) => g a b -> NGroup -> Bool +isRegular g ns = all allCorecursive split + where + -- Node + Rest of list + split = zip ns tns' + tns' = tail $ tails ns + allCorecursive (n,rs) = null $ rs \\ (corecursive g n) + +-- ----------------------------------------------------------------------------- +{- $cycles + Cycle detection. Find cycles by finding all paths from a given + node, and seeing if it reaches itself again. + -} + +-- | Find all cycles in the given graph. +cyclesIn :: (DynGraph g) => g a b -> [LNGroup a] +cyclesIn g = map (addLabels g) (cyclesIn' g) + +-- | Find all cycles in the given graph, returning just the nodes. +cyclesIn' :: (DynGraph g) => g a b -> [NGroup] +cyclesIn' = filter (not . single) -- Exclude trivial cycles, i.e. loops + . concat . unfoldr findCycles + +-- | Find all cycles in the given graph, excluding those that are also cliques. +uniqueCycles :: (DynGraph g) => g a b -> [LNGroup a] +uniqueCycles g = map (addLabels g) (uniqueCycles' g) + +-- | Find all cycles in the given graph, excluding those that are also cliques. +uniqueCycles' :: (DynGraph g) => g a b -> [NGroup] +uniqueCycles' g = filter (not . isRegular g) (cyclesIn' g) + +-- | Find all cycles containing a chosen node. +findCycles :: (DynGraph g) => g a b -> Maybe ([NGroup], g a b) +findCycles g + | isEmpty g = Nothing + | otherwise = Just . getCycles . matchAny $ g + where + getCycles (ctx,g') = (cyclesFor (ctx, g'), g') + +-- | Find all cycles for the given node. +cyclesFor :: (DynGraph g) => GDecomp g a b -> [NGroup] +cyclesFor = map init . + filter isCycle . + pathTree . + first Just + where + isCycle p = (not $ single p) && ((head p) == (last p)) + +-- ----------------------------------------------------------------------------- + +{- $chains + A chain is a path in a graph where for each interior node, there is + exactly one predecessor and one successor node, i.e. that part of + the graph forms a \"straight line\". Furthermore, the initial node + should have only one successor, and the final node should have only + one predecessor. Chains are found by recursively finding the next + successor in the chain, until either a leaf node is reached or no + more nodes match the criteria. +-} + +-- | Find all chains in the given graph. +chainsIn :: (DynGraph g, Eq b) => g a b -> [LNGroup a] +chainsIn g = map (addLabels g) + $ chainsIn' g + +-- | Find all chains in the given graph. +chainsIn' :: (DynGraph g, Eq b) => g a b -> [NGroup] +chainsIn' g = filter (not . single) -- Remove trivial chains + . map (getChain g') + $ filterNodes' isChainStart g' + where + -- Try to make this work on two-element cycles, undirected + -- graphs, etc. + g' = oneWay g + +-- | 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)) + +-- | Find the next link in the chain. +chainLink :: (Graph g) => g a b -> Maybe Node + -> Maybe (Node, Maybe Node) +chainLink _ Nothing = Nothing +chainLink g (Just n) + | isEmpty g = Nothing + | not $ hasPrev g n = Nothing + | otherwise = Just (n, chainNext g n) + +-- | 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) + && case (pre g n \\ [n]) of + [n'] -> not $ isChainStart g n' + _ -> True + +-- | Determine if the given node matches the chain criteria in the given +-- 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 + [n'] -> Just n' + _ -> Nothing + +-- | Find the next node in the chain. +chainNext :: (Graph g) => g a b -> Node -> Maybe Node +chainNext = chainFind suc + +-- | Determines if this node matches the successor criteria for chains. +hasNext :: (Graph g) => g a b -> Node -> Bool +hasNext g = isJust . chainNext g + +-- | Determines if this node matches the predecessor criteria for chains. +hasPrev :: (Graph g) => g a b -> Node -> Bool +hasPrev g = isJust . chainFind pre g diff --git a/Data/Graph/Analysis/Algorithms/Directed.hs b/Data/Graph/Analysis/Algorithms/Directed.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Analysis/Algorithms/Directed.hs @@ -0,0 +1,160 @@ +{- | + Module : Data.Graph.Analysis.Algorithms.Directed + Description : Algorithms for directed graphs. + Copyright : (c) Ivan Lazar Miljenovic 2008 + License : 2-Clause BSD + Maintainer : Ivan.Miljenovic@gmail.com + + Defines algorithms that work on both directed graphs. + -} +module Data.Graph.Analysis.Algorithms.Directed + ( -- * Ending nodes + -- $ends + endNode, endNode', + endBy, endBy', + -- ** Root nodes + rootsOf, rootsOf', + isRoot, isRoot', + -- ** Leaf nodes + leavesOf, leavesOf', + isLeaf, isLeaf', + -- ** Singleton nodes + singletonsOf, singletonsOf', + isSingleton, isSingleton', + -- * Subgraphs + coreOf, + ) where + +import Data.Graph.Analysis.Types +import Data.Graph.Analysis.Utils +import Data.Graph.Analysis.Algorithms.Common + +import Data.Graph.Inductive.Graph + +-- ----------------------------------------------------------------------------- +{- $ends + Find starting/ending nodes. + + We define an ending node as one where, given a function: + + @ + f :: (Graph g) => g a b -> Node -> [Node] + @ + + the only allowed result is that node itself (to allow for loops). + -} + +-- | 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) + +-- | Determine if this 'Node' is an ending node. +endNode' :: (Graph g) => (g a b -> Node -> NGroup) -> g a b -> Node + -> Bool +endNode' f g n = case (f g n) of + [] -> True + -- Allow loops + [n'] -> n' == n + _ -> 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) + +-- | 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) + +-- ----------------------------------------------------------------------------- + +{- + Root detection. + -} + +-- | Find all roots of the graph. +rootsOf :: (Graph g) => g a b -> LNGroup a +rootsOf = endBy pre + +-- | Find all roots of the graph. +rootsOf' :: (Graph g) => g a b -> NGroup +rootsOf' = endBy' pre + +-- | Returns @True@ if this 'LNode' is a root. +isRoot :: (Graph g) => g a b -> LNode a -> Bool +isRoot = endNode pre + +-- | Returns @True@ if this 'Node' is a root. +isRoot' :: (Graph g) => g a b -> Node -> Bool +isRoot' = endNode' pre + +{- +classifyRoots :: (Eq a) => GraphData a -> (Maybe (LNode a), LNGroup a) +classifyRoots gr = first listToMaybe $ partition isWanted roots + where + roots = findRoots gr + theRoot = wantedRoot gr + isWanted = maybe (const False) (==) theRoot + +wantedRootExists :: (Eq a) => GraphData a -> Bool +wantedRootExists = isJust . fst . classifyRoots +-} + + +-- ----------------------------------------------------------------------------- + +{- + Leaf detection. + -} + +-- | Find all leaves of the graph. +leavesOf :: (Graph g) => g a b -> LNGroup a +leavesOf = endBy pre + +-- | Find all leaves of the graph. +leavesOf' :: (Graph g) => g a b -> NGroup +leavesOf' = endBy' pre + +-- | Returns @True@ if this 'LNode' is a leaf. +isLeaf :: (Graph g) => g a b -> LNode a -> Bool +isLeaf = endNode pre + +-- | Returns @True@ if this 'Node' is a leaf. +isLeaf' :: (Graph g) => g a b -> Node -> Bool +isLeaf' = endNode' pre + +-- ----------------------------------------------------------------------------- + +{- + Singleton detection. + -} + +-- | Find all singletons of the graph. +singletonsOf :: (Graph g) => g a b -> LNGroup a +singletonsOf = endBy pre + +-- | Find all singletons of the graph. +singletonsOf' :: (Graph g) => g a b -> NGroup +singletonsOf' = endBy' pre + +-- | Returns @True@ if this 'LNode' is a singleton. +isSingleton :: (Graph g) => g a b -> LNode a -> Bool +isSingleton = endNode pre + +-- | Returns @True@ if this 'Node' is a singleton. +isSingleton' :: (Graph g) => g a b -> Node -> Bool +isSingleton' = endNode' pre + +-- ----------------------------------------------------------------------------- + +{- | + The /core/ of the graph is the part of the graph containing all the + cycles, etc. Depending on the context, it could be interpreted as + the part of the graph where all the "work" is done. + -} +coreOf :: (DynGraph g, Eq a, Eq b) => g a b -> [g a b] +coreOf = componentsOf . fixPointGraphs stripEnds + where + stripEnds gr' = delNodes roots . delNodes leaves $ gr' + where + roots = rootsOf' gr' + leaves = leavesOf' gr' diff --git a/Data/Graph/Analysis/Types.hs b/Data/Graph/Analysis/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Analysis/Types.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE MultiParamTypeClasses + , FunctionalDependencies + #-} + +{- | + Module : Data.Graph.Analysis.Types + Description : Graphalyze Types and Classes + Copyright : (c) Ivan Lazar Miljenovic 2008 + License : 2-Clause BSD + Maintainer : Ivan.Miljenovic@gmail.com + + This module defines the various types and classes utilised + by the Graphalyze library. + -} +module Data.Graph.Analysis.Types + ( -- * Graph specialization + GraphData(..), + Gr, + AGr, + NGroup, + LNGroup, + -- * Graph Label classes + ClusterLabel(..), + GenCluster(..), + PosLabel(..) + ) where + +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Tree + +-- ----------------------------------------------------------------------------- + +{- | + 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. + -} + +-- | 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) + +-- | We use a basic tree-based graph by default. +type AGr a = Gr a () + +-- | A grouping of 'Node's. +type NGroup = [Node] + +-- | A grouping of 'LNode's. +type LNGroup a = [LNode a] + +-- ----------------------------------------------------------------------------- + +-- | 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 cluster the node label belongs in. + cluster :: a -> c + -- | The printed form of the actual label. + nodelabel :: a -> String + +-- | A generic cluster-label type. +data GenCluster a = GC Int a + +instance (Show a) => ClusterLabel (GenCluster a) Int where + cluster (GC c _) = c + nodelabel (GC _ l) = show l + +-- | 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 + , plabel :: a + } + deriving (Eq, Show) diff --git a/Data/Graph/Analysis/Utils.hs b/Data/Graph/Analysis/Utils.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Analysis/Utils.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE OverlappingInstances + , UndecidableInstances + , TypeSynonymInstances + , FlexibleInstances + #-} + +{- | + Module : Data.Graph.Analysis.Utils + Description : Utility functions + Copyright : (c) Ivan Lazar Miljenovic 2008 + License : 2-Clause BSD + Maintainer : Ivan.Miljenovic@gmail.com + + This module defines various utility functions used throughout. + -} +module Data.Graph.Analysis.Utils + ( -- * Graph functions + -- ** Data extraction + node, + label, + edge, + eLabel, + addLabels, + filterNodes, + filterNodes', + -- ** Graph manipulation + pathValues, + undir, + oneWay, + nlmap, + -- ** Graph layout + -- | These next two are re-exported from "Data.GraphViz" + AttributeNode, + AttributeEdge, + dotizeGraph, + toPosGraph, + getPositions, + -- ** Cluster functions + createLookup, + setCluster, + assignCluster, + -- * List functions + single, + longerThan, + longest, + groupElems, + sortMinMax, + blockPrint, + shuffle, + -- * Statistics functions + mean, + statistics, + statistics', + -- * Other functions + fixPoint, + fixPointGraphs, + fixPointBy, + sq, + fI + ) where + +import Data.Graph.Analysis.Types + +import Data.Graph.Inductive.Graph +import Data.GraphViz + +import Data.List +import Data.Maybe +import Data.Function +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) + +-- ----------------------------------------------------------------------------- + +-- | Extracting data from graphs. + +-- | The node number of an 'LNode'. +node :: LNode a -> Node +node = fst + +-- | The label of an 'LNode' +label :: LNode a -> a +label = snd + +-- | Extract the 'Edge' from the 'LEdge'. +edge :: LEdge b -> Edge +edge (n1,n2,_) = (n1,n2) + +-- | The label of an 'LEdge' +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) + +-- | Find all the nodes in the graph that match the given predicate. +filterNodes' :: (Graph g) => (g a b -> Node -> Bool) -> g a b -> [Node] +filterNodes' p g = filter (p g) (nodes g) + +-- ----------------------------------------------------------------------------- + +-- | Manipulating graphs. + +-- | Extract the actual 'LNode's from an 'LPath'. +pathValues :: LPath a -> [LNode a] +pathValues (LP lns) = lns + +{- | + Make the graph undirected, i.e. for every edge from A to B, there + exists an edge from B to A. The provided function + 'Data.Graph.Inductive.Basic.undir' duplicates loops as well, which + isn't wanted. It is assumed that no edges are already duplicates + [i.e. if there exists an edge (n1,n2), then there doesn't exist + (n2,n1)]. This function also preserves edge labels: if two edges + exist between two nodes with different edge labels, then both edges + will be duplicated. +-} +undir :: (Eq b, DynGraph gr) => gr a b -> gr a b +undir = gmap dupEdges + where + dupEdges (p,n,l,s) = (ps',n,l,ps) + where + ps = nub $ p ++ s + ps' = snd $ partition isLoop ps + isLoop (_,n') = n == n' + +-- | This is a pseudo-inverse of 'undir': any edges that are both successor +-- and predecessor become successor edges only. +oneWay :: (DynGraph g, Eq b) => g a b -> g a b +oneWay = gmap rmPre + where + rmPre (p,n,l,s) = (p \\ s,n,l,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) + +-- ----------------------------------------------------------------------------- + +{- | + Spatial positioning of graphs. Use the 'graphToGraph' function in + "Data.GraphViz" to determine potential graph layouts. +-} + +-- | 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 + where + rmAttrs = snd + isPoint attr = case attr of + (Pos _) -> True + _ -> False + getPos (n,(as,l)) = PLabel { xPos = x + , yPos = y + , pnode = n + , plabel = l + } + where + -- Assume that positions can't be doubles. + (Pos (PointList ((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 + +-- ----------------------------------------------------------------------------- + +-- | Cluster utility functions. + +-- | Create a cluster-lookup 'IntMap'. +createLookup :: [[Node]] -> IntMap Int +createLookup = IMap.fromList . concatMap addCluster . zip [1..] + where + addCluster (k,ns) = map (flip (,) k) ns + +-- | Used when the clusters are assigned in a lookup 'IntMap' instance. +setCluster :: (DynGraph gr) => IntMap Int -> gr a b -> gr (GenCluster a) b +setCluster m = nlmap assClust + 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) + +-- ----------------------------------------------------------------------------- + +-- | List utility functions. + +-- | Return true if and only if the list contains a single element. +single :: [a] -> Bool +single [_] = True +single _ = False + +-- | If we need to only tell if the list contains more than @n@ elements, +-- there's no need to find its length. +longerThan :: Int -> [a] -> Bool +longerThan n = not . null . drop n + +-- | Returns the longest list in a list of lists. +longest :: [[a]] -> [a] +longest = snd . maximumBy (compare `on` fst) + . map addLength + where + addLength xs = (length xs,xs) + +-- | Group elements by the given grouping function. +groupElems :: (Ord b) => (a -> b) -> [a] -> [(b,[a])] +groupElems f = map createGroup + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . map addOrd + where + addOrd a = (f a, a) + createGroup bas@((b,_):_) = (b, map snd bas) + -- This shouldn't ever happen, but let's suppress the -Wall warning. + createGroup [] = error "Grouping resulted in an empty list!" + +-- | Returns the unique elements of the list in ascending order, +-- as well as the minimum and maximum elements. +sortMinMax :: (Ord a) => [a] -> ([a],a,a) +sortMinMax as = (as',aMin,aMax) + where + aSet = Set.fromList as + as' = Set.toAscList aSet + aMin = Set.findMin aSet + aMax = Set.findMax aSet + +-- | Attempt to convert a list of elements into a square format +-- in as much of a square shape as possible. +blockPrint :: (Show a) => [a] -> String +blockPrint as = init -- Remove the final '\n' on the end. + . unlines $ map unwords lns + where + showl a = let sa = show a in (sa, length sa) + las = map showl as + -- Scale this, to take into account the height:width ratio. + sidelen :: Double -- Suppress defaulting messages + sidelen = (1.75*) . sqrt . fromIntegral . sum $ map snd las + slen = round sidelen + serr = round $ sidelen/10 + lns = unfoldr (takeLen slen serr) las + +-- | Using the given line length and allowed error, take the elements of +-- the next line. +takeLen :: Int -> Int -> [(String,Int)] -> Maybe ([String],[(String,Int)]) +takeLen _ _ [] = Nothing +takeLen len err ((a,l):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 one here to take into account the space. + (as,als') = takeLine (lmax - l - 1) als + +-- | Recursively build the rest of the line with given maximum length. +takeLine :: Int -> [(String,Int)] -> ([String],[(String,Int)]) +takeLine len 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 + ((a,l):als') = als + len' = len - l - 1 -- Subtract 1 to account for the space + (as,als'') = takeLine len' als' + +{- | + Shuffle a list of elements. + This isn't the most efficient version, but should serve for small lists. + Adapted from: + + The adaptation mainly involved altering the code so that the new + random seed is also returned. + -} +shuffle :: (RandomGen g) => g -> [a] -> ([a],g) +shuffle g [] = ([],g) +shuffle g [x] = ([x],g) +shuffle g xs = randomMerge g'' ((shYs,yn),(shZs,zn)) + where + ((ys, yn), (zs, zn)) = splitAndCount xs (([], 0), ([], 0)) + (shYs,g') = shuffle g ys + (shZs,g'') = shuffle g' zs + +splitAndCount :: [a] -> (([a], Int), ([a], Int)) -> (([a], Int), ([a], Int)) +splitAndCount [] result = result +splitAndCount (x : xs) ((ys, yn), (zs, zn)) = + splitAndCount xs ((x : zs, zn + 1), (ys, yn)) + +{- + Taken from the original site: + + The idea is to merge two shuffled lists which come with given sizes. + If the lists X and Y have sizes n and m, we should pick the first element + of X with probability n / n + m and the first element of Y with probability + m / n + m. As X and Y are shuffled, picking the first element is random + among their original elements, and thus this constitutes a random choice + of first element from the original set. + -} +randomMerge :: (RandomGen g) => g -> (([a], Int), ([a], Int)) -> ([a],g) +randomMerge g (([],_),(ys,_)) = (ys,g) +randomMerge g ((xs,_),([],_)) = (xs,g) +randomMerge g ((x:xs,xn),(y:ys,yn)) = if n <= xn + then first (x:) xg + else first (y:) yg + where + xg = randomMerge g' ((xs, xn - 1), (y : ys, yn)) + yg = randomMerge g' ((x : xs, xn), (ys, yn - 1)) + (n, g') = randomR (1, xn + yn) g + +-- ----------------------------------------------------------------------------- + +-- | Statistics functions. + +-- | An efficient mean function by Don Stewart, available from: +-- +mean :: [Double] -> Double +mean = go 0 0 + where + go :: Double -> Int -> [Double] -> Double + go s l [] = s / fromIntegral l + go s l (x:xs) = go (s+x) (l+1) xs + +-- | Calculate the mean and standard deviation of a list of elements. +statistics :: [Double] + -> (Double,Double) -- ^ (Mean, Standard Deviation) +statistics as = (av,stdDev) + where + av = mean as + stdDev = sqrt . mean $ map (sq . subtract av) as + +-- | Calculate the mean and standard deviation of a list of 'Int' values. +statistics' :: [Int] + -> (Int,Int) -- ^ (Mean, Standard Deviation) +statistics' as = (av', stdDev') + where + (av,stdDev) = statistics $ map fromIntegral as + av' = round av + stdDev' = round stdDev + +-- ----------------------------------------------------------------------------- + +-- | 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 + +-- | 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') + 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 diff --git a/Data/Graph/Analysis/Visualisation.hs b/Data/Graph/Analysis/Visualisation.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Analysis/Visualisation.hs @@ -0,0 +1,38 @@ +{- | + Module : Data.Graph.Analysis.Visualisation + Description : Graphviz wrapper functions + Copyright : (c) Ivan Lazar Miljenovic 2008 + License : 2-Clause BSD + Maintainer : Ivan.Miljenovic@gmail.com + + A wrapper module around the Haskell "Data.GraphViz" library to + turn Graphs into basic graphs for processing by the Graphviz + application. + -} +module Data.Graph.Analysis.Visualisation where + +import Data.Graph.Analysis.Types +import Data.Graph.Analysis.Utils +import Data.Graph.Inductive.Graph +import Data.GraphViz + +-- | Turns the graph into 'DotGraph' format with the given title. +-- Nodes are labelled, edges aren't. +graphviz :: (Graph g, Show a, Ord b) => String -> g a b -> DotGraph +graphviz t g = graphToDot g attrs nattrs eattrs + where + attrs = [Label t] + nattrs (_,a) = [Label (show a)] + eattrs _ = [] + +-- | Turns the graph into 'DotGraph' format with the given title. +-- 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 -> DotGraph +graphvizClusters t g = clusterGraphToDot g atts assignCluster catts natts eatts + where + atts = [Label t] + catts c = [Label (show c)] + natts (_,a) = [Label (nodelabel a)] + eatts _ = [] diff --git a/Graphalyze.cabal b/Graphalyze.cabal new file mode 100644 --- /dev/null +++ b/Graphalyze.cabal @@ -0,0 +1,34 @@ +Name: Graphalyze +Version: 0.1 +Synopsis: Graph-Theoretic Analysis library. +Description: A library to use graph theory to analyse the relationships + inherent in discrete data. +Category: Algorithms +License: OtherLicense +License-File: LICENSE +Copyright: (c) Ivan Lazar Miljenovic +Author: Ivan Lazar Miljenovic +Maintainer: Ivan.Miljenovic@gmail.com +Cabal-Version: >= 1.2 +Build-Type: Simple +Tested-With: GHC==6.8.3 + +flag small_base + description: Choose the new smaller, split-up base package. + +Library { + if flag(small_base) + Build-Depends: base >= 3, containers, random, fgl, graphviz >= 2008.9.20, bktrees + else + Build-Depends: base < 3, fgl, graphviz >= 2008.9.20, bktrees + Exposed-Modules: Data.Graph.Analysis + Data.Graph.Analysis.Types + Data.Graph.Analysis.Utils + Data.Graph.Analysis.Visualisation + Data.Graph.Analysis.Algorithms + Data.Graph.Analysis.Algorithms.Common + Data.Graph.Analysis.Algorithms.Directed + Data.Graph.Analysis.Algorithms.Clustering + Ghc-Options: -Wall + Ghc-Prof-Options: -auto-all + } diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +Copyright (c) 2008, Ivan Lazar Miljenovic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain