Graphalyze 0.1 → 0.2
raw patch · 9 files changed
+738/−46 lines, 9 filesdep +arraydep +directorydep +filepath
Dependencies added: array, directory, filepath, old-locale, pandoc, process, time
Files
- Data/Graph/Analysis.hs +53/−2
- Data/Graph/Analysis/Algorithms/Clustering.hs +2/−1
- Data/Graph/Analysis/Algorithms/Directed.hs +0/−13
- Data/Graph/Analysis/Reporting.hs +136/−0
- Data/Graph/Analysis/Reporting/Pandoc.hs +220/−0
- Data/Graph/Analysis/Types.hs +1/−1
- Data/Graph/Analysis/Utils.hs +63/−22
- Data/Graph/Analysis/Visualisation.hs +252/−4
- Graphalyze.cabal +11/−3
Data/Graph/Analysis.hs view
@@ -13,20 +13,27 @@ /Graph-Theoretic Analysis of the Relationships in Discrete Data/. -} module Data.Graph.Analysis- ( -- * Re-exporting other modules+ ( version,+ -- * Re-exporting other modules module Data.Graph.Analysis.Types, module Data.Graph.Analysis.Utils, module Data.Graph.Analysis.Algorithms,+ module Data.Graph.Analysis.Reporting, module Data.Graph.Inductive.Graph, -- * Importing data ImportParams(..), defaultParams,- importData+ importData,+ -- * Result analysis+ -- $analfuncts+ lengthAnalysis,+ classifyRoots ) where import Data.Graph.Analysis.Utils import Data.Graph.Analysis.Types import Data.Graph.Analysis.Algorithms+import Data.Graph.Analysis.Reporting import Data.Graph.Inductive.Graph import Data.List@@ -35,6 +42,10 @@ -- ----------------------------------------------------------------------------- +-- | The library version.+version :: String+version = "0.2"+ {- | 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@@ -96,3 +107,43 @@ setDirection = if (directed params) then id else undir -- Construct the graph. dGraph = setDirection $ mkGraph lNodes graphEdges++-- -----------------------------------------------------------------------------++{- $analfuncts+ Extra functions for data analysis.+ -}++-- | Returns the mean and standard deviations of the lengths of the sublists,+-- as well all those lists more than one standard deviation longer than+-- the mean.+lengthAnalysis :: [[a]] -> (Int,Int,[(Int,[a])])+lengthAnalysis as = (av,stdDev,as'')+ where+ as' = addLengths as+ ls = map fst as'+ (av,stdDev) = statistics' ls+ as'' = filter (\(l,_) -> l > (av+stdDev)) as'++{- |+ Compare the actual roots in the graph with those that are expected+ (i.e. those in 'wantedRoots'). Returns (in order):++ * Those roots that are expected (i.e. elements of 'wantedRoots'+ that are roots).++ * Those roots that are expected but not present (i.e. elements of+ 'wantedRoots' that /aren't/ roots.++ * Unexpected roots (i.e. those roots that aren't present in+ 'wantedRoots').+ -}+classifyRoots :: (Eq a) => GraphData a -> ([LNode a], [LNode a], [LNode a])+classifyRoots gd = (areWanted, notRoots, notWanted)+ where+ g = graph gd+ wntd = wantedRoots gd+ rts = rootsOf g+ areWanted = intersect wntd rts+ notRoots = wntd \\ rts+ notWanted = rts \\ wntd
Data/Graph/Analysis/Algorithms/Clustering.hs view
@@ -27,6 +27,7 @@ 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.Analysis.Algorithms.Directed(rootsOf') @@ -313,7 +314,7 @@ -- 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+ show (CN lns) = showNodes lns collapseGraph :: (DynGraph gr, Eq b) => gr a b -> gr (CNodes a) b collapseGraph g = foldl' (flip collapseAllBy) cg interestingParts
Data/Graph/Analysis/Algorithms/Directed.hs view
@@ -87,19 +87,6 @@ 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--}-- -- ----------------------------------------------------------------------------- {-
+ Data/Graph/Analysis/Reporting.hs view
@@ -0,0 +1,136 @@+{- |+ Module : Data.Graph.Analysis.Reporting+ Description : Graphalyze Types and Classes+ Copyright : (c) Ivan Lazar Miljenovic 2008+ License : 2-Clause BSD+ Maintainer : Ivan.Miljenovic@gmail.com++ This module defines the report framework used.+ -}+module Data.Graph.Analysis.Reporting+ ( -- * Document representation+ -- $document+ Document(..),+ DocumentGenerator(..),+ Location(..),+ DocElement(..),+ DocInline(..),+ DocGraph,+ -- * Helper functions+ -- $utilities+ today,+ tryCreateDirectory,+ createGraph+ ) where++import Data.GraphViz+import Data.Graph.Analysis.Visualisation++import Data.Time+import Control.Exception+import System.Directory+import System.FilePath+import System.Locale++-- -----------------------------------------------------------------------------++{- $document+ 'Document' is the simplified representation of a document. Note+ that this just specifies a document layout, and not an+ implementation. To actually create a \"physical\" document,+ you must use an instance of 'DocumentGenerator'.+-}++{- | Representation of a document. The document is to be stored in+ the directory 'rootDirectory', and the main file is to have a+ filename of @'fileFront' '<.>' ('docExtension' dg)@, where @dg@ is an+ instance of 'DocumentGenerator'.+ -}+data Document = Doc { -- | Document location+ rootDirectory :: FilePath,+ fileFront :: String,+ -- | Pre-matter+ title :: DocInline,+ author :: String,+ date :: String,+ -- | Main-matter+ content :: [DocElement]+ }++-- | Represents the class of document generators.+class DocumentGenerator dg where+ -- | Convert idealised 'Document' values into actual documents,+ -- returning the document file created.+ createDocument :: dg -> Document -> IO (Maybe FilePath)+ -- | The extension of all document-style files created. Note that+ -- this doesn't preclude the creation of other files, e.g. images.+ docExtension :: dg -> String++-- | Representation of a location, either on the internet or locally.+data Location = URL String | File FilePath++instance Show Location where+ show (URL url) = url+ show (File fp) = fp++-- | Elements of a document.+data DocElement = Section DocInline [DocElement]+ | Paragraph [DocInline]+ | Enumeration [DocElement]+ | Itemized [DocElement]+ | Definition DocInline DocElement+ | DocImage DocInline Location+ | GraphImage DocGraph++data DocInline = Text String+ | BlankSpace+ | Grouping [DocInline]+ | Bold DocInline+ | Emphasis DocInline+ | DocLink DocInline Location++type DocGraph = (FilePath,DocInline,DotGraph)++-- -----------------------------------------------------------------------------++{- $utilities+ Utility functions to help with document creation.+ -}++-- | Return today's date as a string, e.g. \"Monday 1 January, 2000\".+-- This arbitrary format is chosen as there doesn't seem to be a way+-- of determining the correct format as per the user's locale settings.+today :: IO String+today = do zoneT <- getZonedTime+ let localT = zonedTimeToLocalTime zoneT+ return $ formatTime locale fmt localT+ where+ locale = defaultTimeLocale+ fmt = "%A %e %B, %Y"++-- | Attempts to create the specified directly, returning @True@+-- if successful (or if the directory already exists), @False@+-- if an error occurred.+tryCreateDirectory :: FilePath -> IO Bool+tryCreateDirectory fp = do r <- try $ mkDir fp+ return (isRight r)+ where+ mkDir = createDirectoryIfMissing True+ isRight (Right _) = True+ isRight _ = False++-- | Attempts to creates a png file (with the given filename in the+-- given directory) and - if successful - returns a 'DocImage' link.+createGraph :: FilePath -> DocGraph -> IO (Maybe DocElement)+createGraph fp (fn,inl,dg) = do created <- runGraphviz dg output filename'+ if created+ then return (Just img)+ else return Nothing+ where+ ext = "png"+ output = Png+ filename = fn <.> ext+ filename' = fp </> filename+ loc = File filename+ img = DocImage inl loc+
+ Data/Graph/Analysis/Reporting/Pandoc.hs view
@@ -0,0 +1,220 @@+{- |+ Module : Data.Graph.Analysis.Reporting.Pandoc+ Description : Graphalyze Types and Classes+ Copyright : (c) Ivan Lazar Miljenovic 2008+ License : 2-Clause BSD+ Maintainer : Ivan.Miljenovic@gmail.com++ This module uses /Pandoc/ to generate documents:+ <http://johnmacfarlane.net/pandoc/>++ Note that Pandoc is released under GPL-2 or later, however+ according to the Free Software Foundation, I am indeed allowed to+ use it:+ <http://www.fsf.org/licensing/licenses/gpl-faq.html#IfLibraryIsGPL>+ since the 2-Clause BSD license that I'm using is GPL-compatible:+ <http://www.fsf.org/licensing/licenses/index_html#GPLCompatibleLicenses>+ (search for /FreeBSD License/, which is another name for it).+ -}+module Data.Graph.Analysis.Reporting.Pandoc+ ( PandocDocument,+ pandocHtml,+ pandocLaTeX,+ pandocRtf,+ pandocMarkdown+ ) where++-- TODO : the ability to create multiple files.++import Data.Graph.Analysis.Reporting++import Data.List+import Data.Maybe+import Text.Pandoc+import Control.Monad+import Control.Exception+import System.Directory+import System.FilePath++-- -----------------------------------------------------------------------------++{- $writers+ The actual exported writers.+ -}++pandocHtml :: PandocDocument+pandocHtml = PD { writer = writeHtmlString+ , extension = "html"+ , header = "" -- Header will be included+ }++pandocLaTeX :: PandocDocument+pandocLaTeX = PD { writer = writeLaTeX+ , extension = "tex"+ , header = defaultLaTeXHeader+ }++pandocRtf :: PandocDocument+pandocRtf = PD { writer = writeRTF+ , extension = "rtf"+ , header = defaultRTFHeader+ }++pandocMarkdown :: PandocDocument+pandocMarkdown = PD { writer = writeMarkdown+ , extension = "text"+ , header = ""+ }++-- -----------------------------------------------------------------------------++{- $defs+ Pandoc definition.+ -}++data PandocDocument = PD { writer :: WriterOptions -> Pandoc -> String+ , extension :: FilePath+ , header :: String+ }++instance DocumentGenerator PandocDocument where+ createDocument = createPandoc+ docExtension = extension++-- | Define the 'WriterOptions' used.+writerOptions :: WriterOptions+writerOptions = defaultWriterOptions { writerStandalone = True+ , writerTableOfContents = True+ , writerNumberSections = True+ }++-- | Used when traversing the document structure.+data PandocProcess = PP { secLevel :: Int+ , filedir :: FilePath+ }++-- | Start with a level 1 heading.+defaultProcess :: PandocProcess+defaultProcess = PP { secLevel = 1+ , filedir = ""+ }++-- | Create the document.+createPandoc :: PandocDocument -> Document -> IO (Maybe FilePath)+createPandoc p d = do created <- tryCreateDirectory dir+ if (not created)+ then failDoc+ else do elems <- multiElems pp (content d)+ case elems of+ Just es -> do let es' = htmlAuthDt : es+ pd = Pandoc meta es'+ doc = convert pd+ wr <- tryWrite doc+ case wr of+ (Right _) -> success+ (Left _) -> failDoc+ Nothing -> failDoc+ where+ dir = rootDirectory d+ auth = author d+ dt = date d+ meta = makeMeta (title d) auth dt+ -- Html output doesn't show date and auth anywhere by default.+ htmlAuthDt = htmlInfo auth dt+ pp = defaultProcess { filedir = dir }+ opts = writerOptions { writerHeader = (header p) }+ convert = (writer p) opts+ file = dir </> (fileFront d) <.> (extension p)+ tryWrite = try . writeFile file+ success = return (Just file)+ failDoc = removeDirectoryRecursive dir >> return Nothing++-- -----------------------------------------------------------------------------++{- $conv+ Converting individual elements to their corresponding Pandoc types.+ -}++-- | The meta information+makeMeta :: DocInline -> String -> String -> Meta+makeMeta t a d = Meta (inlines t) [a] d++-- | Html output doesn't show the author and date; use this to print it.+htmlInfo :: String -> String -> Block+htmlInfo auth dt = RawHtml html+ where+ heading = "<h1>Document Information</h1>"+ html = unlines [heading,htmlize auth, htmlize dt]+ htmlize str = "<blockquote><p><em>" ++ str ++ "</em></p></blockquote>"++-- | Link conversion+loc2target :: Location -> Target+loc2target (URL url) = (url,"")+loc2target (File file) = (file,"")++-- | Conversion of simple inline elements.+inlines :: DocInline -> [Inline]+inlines (Text str) = intersperse Space $ map Str (words str)+inlines BlankSpace = [Space]+inlines (Grouping grp) = concat . intersperse [Space] $ map inlines grp+inlines (Bold inl) = [Strong (inlines inl)]+inlines (Emphasis inl) = [Emph (inlines inl)]+inlines (DocLink inl loc) = [Link (inlines inl) (loc2target loc)]++{- |+ Conversion of complex elements. The only reason it's in the IO monad is+ for GraphImage, as it requires IO to create the image.++ If any one of the conversions fail (i.e. returns 'Nothing'), the entire+ process fails.++ In future, may extend this to creating multiple files for top-level+ sections, in which case the IO monad will be required for that as+ well.+-}+elements :: PandocProcess -> DocElement -> IO (Maybe [Block])++elements p (Section lbl elems) = do let n = secLevel p+ p' = p { secLevel = n + 1}+ sec = Header n (inlines lbl)+ elems' <- multiElems p' elems+ return (fmap (sec:) elems')++elements _ (Paragraph inls) = return $ Just [Para (concatMap inlines inls)]++elements p (Enumeration elems) = do elems' <- multiElems' p elems+ let attrs = (1,DefaultStyle,DefaultDelim)+ list = fmap (OrderedList attrs) elems'+ return (fmap return list)++elements p (Itemized elems) = do elems' <- multiElems' p elems+ return (fmap (return . BulletList) elems')++elements p (Definition x def) = do def' <- elements p def+ let x' = inlines x+ xdef = fmap (return . (,) x') def'+ return (fmap (return . DefinitionList) xdef)++elements _ (DocImage inl loc) = do let img = Image (inlines inl)+ (loc2target loc)+ return $ Just [Plain [img]]++elements p (GraphImage dg) = do el <- createGraph (filedir p) dg+ case el of+ Nothing -> return Nothing+ Just img -> elements p img++-- | 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')+ 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')+ then return Nothing+ else return (Just $ map fromJust elems')
Data/Graph/Analysis/Types.hs view
@@ -39,7 +39,7 @@ -- | 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.+ -- | The expected roots in the graph. wantedRoots :: LNGroup a } deriving (Show)
Data/Graph/Analysis/Utils.hs view
@@ -42,10 +42,16 @@ -- * List functions single, longerThan,+ addLengths, longest, groupElems, sortMinMax, blockPrint,+ blockPrint',+ blockPrintList,+ blockPrintList',+ blockPrintWith,+ blockPrintWith', shuffle, -- * Statistics functions mean,@@ -222,12 +228,14 @@ longerThan :: Int -> [a] -> Bool longerThan n = not . null . drop n +-- | Add the length of each sublist.+addLengths :: [[a]] -> [(Int,[a])]+addLengths = map ( \ as -> (length as, as))+ -- | 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)+ . addLengths -- | Group elements by the given grouping function. groupElems :: (Ord b) => (a -> b) -> [a] -> [(b,[a])]@@ -251,46 +259,79 @@ 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+-- | 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- showl a = let sa = show a in (sa, length sa)- las = map showl as+ 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 snd las+ sidelen = (1.75*) . sqrt . fromIntegral . sum $ map fst las slen = round sidelen serr = round $ sidelen/10- lns = unfoldr (takeLen slen serr) las+ 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 -> [(String,Int)] -> Maybe ([String],[(String,Int)])-takeLen _ _ [] = Nothing-takeLen len err ((a,l):als) = Just lr+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 one here to take into account the space.- (as,als') = takeLine (lmax - l - 1) 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 -> [(String,Int)] -> ([String],[(String,Int)])-takeLine len als+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- ((a,l):als') = als- len' = len - l - 1 -- Subtract 1 to account for the space- (as,als'') = takeLine len' als'+ ((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.
Data/Graph/Analysis/Visualisation.hs view
@@ -5,17 +5,54 @@ 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.+ 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:+ <http://code.haskell.org/mohws/src/Util.hs> -}-module Data.Graph.Analysis.Visualisation where+module Data.Graph.Analysis.Visualisation+ ( -- * Graph visualisation+ -- $graphviz+ -- ** Producing 'DotGraph's+ graphviz,+ graphvizClusters,+ -- ** Creating images+ GraphvizOutput(..),+ GraphvizCommand(..),+ runGraphviz,+ runGraphvizCommand,+ -- * Showing node groupings+ -- $other+ showPath,+ showCycle,+ showNodes+ ) 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++-- -----------------------------------------------------------------------------++{- $graphviz+ Simple wrappers around the Haskell "Data.GraphViz" library to+ turn 'Graph's into basic 'DotGraph's for processing by the Graphviz+ application.+-}+ -- | 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@@ -36,3 +73,214 @@ catts c = [Label (show c)] natts (_,a) = [Label (nodelabel a)] eatts _ = []++-- | 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++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"++-- | The available Graphviz commands.+data GraphvizCommand = DotCmd | Neato | TwoPi | Circo | Fdp++instance Show GraphvizCommand where+ show DotCmd = "dot"+ show Neato = "neato"+ show TwoPi = "twopi"+ show Circo = "circo"+ show Fdp = "fdp"++-- | 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++-- | This command should /not/ be available outside this module, as+-- it isn't safe: running an arbitrary command will crash the program.+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++{- |+ This function is taken from the /mohws/ project, available under a+ 3-Clause BSD license. The actual function is taken from:+ <http://code.haskell.org/mohws/src/Util.hs>+ 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+ where+ -- This was originally separate+ bufsize :: Int+ bufsize = 4 * 1024++{-++-- Parsing to get graph size... do this later.++parseGraphviz :: DotGraph -> IO (Maybe DotGraph)+parseGraphviz gr = parseGraphvizInternal (commandFor gr) gr++graphvizSizeInternal :: String -> DotGraph -> Maybe (Int,Int)+graphvizSizeInternal cmd gr =+ where+ parsed = parseGraphvizInternal cmd gr+ getBB = maybe Nothing (find+ bb2Rect (Bb r) = r+ rectToSize (Rect _ (Point x y)) = (x,y)++-- | 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'++-}++-- | 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)++-- -----------------------------------------------------------------------------++{- $other+ Other visualisations. These are mainly replacements for+ the @show@ function.+ -}++-- | Print a path, with \"->\" between each element.+showPath :: (Show a) => LNGroup a -> String+showPath [] = ""+showPath lns = blockPrint' (l:ls')+ where+ -- Can't use blockPrintWith above, as it only takes a per-row spacer.+ (l:ls) = map (show . label) lns+ ls' = map ("-> "++) ls++-- | 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])++-- | Show a group of nodes, with no implicit ordering.+showNodes :: (Show a) => LNGroup a -> String+showNodes = blockPrintList . map label
Graphalyze.cabal view
@@ -1,5 +1,5 @@ Name: Graphalyze-Version: 0.1+Version: 0.2 Synopsis: Graph-Theoretic Analysis library. Description: A library to use graph theory to analyse the relationships inherent in discrete data.@@ -18,9 +18,13 @@ Library { if flag(small_base)- Build-Depends: base >= 3, containers, random, fgl, graphviz >= 2008.9.20, bktrees+ Build-Depends: base >= 3, array, containers, directory, filepath,+ old-locale, process, random, time else- Build-Depends: base < 3, fgl, graphviz >= 2008.9.20, bktrees+ Build-Depends: base < 3++ Build-Depends: bktrees, fgl, graphviz >= 2008.9.20, pandoc+ Exposed-Modules: Data.Graph.Analysis Data.Graph.Analysis.Types Data.Graph.Analysis.Utils@@ -29,6 +33,10 @@ Data.Graph.Analysis.Algorithms.Common Data.Graph.Analysis.Algorithms.Directed Data.Graph.Analysis.Algorithms.Clustering+ Data.Graph.Analysis.Reporting+ Data.Graph.Analysis.Reporting.Pandoc+ Ghc-Options: -Wall Ghc-Prof-Options: -auto-all+ }