diff --git a/Data/Graph/Analysis.hs b/Data/Graph/Analysis.hs --- a/Data/Graph/Analysis.hs +++ b/Data/Graph/Analysis.hs @@ -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 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 @@ -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 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 @@ -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 --} - - -- ----------------------------------------------------------------------------- {- diff --git a/Data/Graph/Analysis/Reporting.hs b/Data/Graph/Analysis/Reporting.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Analysis/Reporting.hs @@ -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 + diff --git a/Data/Graph/Analysis/Reporting/Pandoc.hs b/Data/Graph/Analysis/Reporting/Pandoc.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Analysis/Reporting/Pandoc.hs @@ -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: + + + Note that Pandoc is released under GPL-2 or later, however + according to the Free Software Foundation, I am indeed allowed to + use it: + + since the 2-Clause BSD license that I'm using is GPL-compatible: + + (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 = "

Document Information

" + html = unlines [heading,htmlize auth, htmlize dt] + htmlize str = "

" ++ str ++ "

" + +-- | 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') 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 @@ -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) 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 @@ -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. 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 @@ -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: + -} -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: + + 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 diff --git a/Graphalyze.cabal b/Graphalyze.cabal --- a/Graphalyze.cabal +++ b/Graphalyze.cabal @@ -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 + }