prolog-graph-lib 0.1 → 0.2.1.1
raw patch · 2 files changed
Files
- GraphViz.hs +118/−49
- prolog-graph-lib.cabal +7/−8
GraphViz.hs view
@@ -1,90 +1,159 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleContexts #-} module GraphViz where -import Control.Applicative ((<$>), Applicative(..))+import Control.Applicative ((<$>), Applicative(..), Alternative(..)) import Control.Monad import Control.Monad.State import Control.Monad.Error-import Data.List (intercalate, intersperse)+import Control.Concurrent (forkIO)+import Data.List (intercalate, intersperse, nub)+import Data.Char (ord) import qualified Data.Graph.Inductive as Graph-import Data.HashTable (hashString)+-- import Data.HashTable (hashString) -import Data.GraphViz (preview, runGraphviz, setDirectedness, graphToDot, GraphvizOutput(Png), toLabel, nonClusteredParams, GraphvizParams(..))-import Data.GraphViz.Attributes.Colors (Color(X11Color), X11Color(..))+import Data.GraphViz (runGraphvizCommand, runGraphvizCanvas', GraphvizCanvas(Xlib), graphElemsToDot, GraphvizOutput(..), toLabel, nonClusteredParams, GraphvizParams(..), GlobalAttributes(GraphAttrs), GraphvizCommand(Dot))+import Data.GraphViz.Attributes.Colors (Color(X11Color), WeightedColor(..))+import Data.GraphViz.Attributes.Colors.X11 (X11Color(..)) import Data.GraphViz.Attributes.HTML+import Data.GraphViz.Attributes.Complete (Attribute(Ordering,Label,Shape,Color,Width,Regular), Shape(BoxShape), Label(HtmlLabel), Order(OutEdges)) import qualified Data.Text.Lazy import Language.Prolog -htmlStr = HtmlStr . Data.Text.Lazy.pack-+htmlStr = Str . Data.Text.Lazy.pack -- Graphical output of derivation tree resolveTree p q = preview =<< execGraphGenT (resolve_ p q) resolveTreeToFile path p q = do graph <- execGraphGenT (resolve_ p q)- runGraphviz (setDirectedness graphToDot params graph) Png path- where- params = nonClusteredParams { fmtNode = \ (_,l) -> [toLabel l]- , fmtEdge = \ (_, _, l) -> [toLabel l]+ runGraphvizCommand Dot (toDot [] graph) Png path++preview g = ign $ forkIO (ign $ runGraphvizCanvas' (toDot [] g) Xlib)+ where+ ign = (>> return ())++toDot attrs g = graphElemsToDot params (labNodes g) (labEdges g)+ where+ params = nonClusteredParams { fmtNode = \ (_,l) -> formatNode l+ , fmtEdge = \ (_, _, l) -> formatEdge l+ , globalAttributes = [GraphAttrs (Ordering OutEdges : attrs)] -- child nodes are drawn in edge-order+ , isDirected = True } +type Graph = Gr NodeLabel EdgeLabel+type NodeLabel = ((ProtoBranch, Branch), [Branch], CutFlag)+type EdgeLabel = (ProtoBranch, Branch)+type Branch = (Path, [(VariableName, Term)], [Term])+type Path = [Integer]+type ProtoBranch = Branch -type Graph = Graph.Gr HtmlText HtmlText -newtype GraphGenT m a = GraphGenT (StateT Graph m a) deriving (Monad, Functor, MonadFix, MonadPlus, Applicative, MonadError e, MonadState Graph, MonadTrans)-runGraphGenT (GraphGenT st) = runStateT st Graph.empty-execGraphGenT (GraphGenT st) = execStateT st Graph.empty+data Gr a b = Gr [(Int,a)] [(Int, Int, b)] deriving Show +empty = Gr [] []+insEdge edge (Gr ns es) = Gr ns (es ++ [edge])+insNode node (Gr ns es) = Gr (ns ++ [node]) es+gelem n (Gr ns es) = n `elem` map fst ns+relabelNode f node (Gr ns es) = Gr (map (\(n,l) -> (n,if n == node then f l else l)) ns) es+labNodes (Gr ns _) = ns+labEdges (Gr _ es) = es ++newtype GraphGenT m a = GraphGenT (StateT Graph m a) deriving (Monad, Functor, MonadFix, MonadPlus, Applicative, MonadError e, MonadState Graph, MonadTrans, Alternative)+runGraphGenT (GraphGenT st) = runStateT st GraphViz.empty+execGraphGenT (GraphGenT st) = execStateT st GraphViz.empty++ instance Monad m => MonadGraphGen (GraphGenT m) where - createConnections usf gs branches = do- let current = hash (usf, gs)- let label = makeNodeLabel usf gs- ensureNode current label- forM_ branches $ \x@(u',gs') -> do- connect current u' gs'- when (null branches) $ do- modifyLabel current (colorize Red)+ createConnections currentBranch@(path,_,_) protoBranches branches = do+ let current = hash path+ -- Ensure node is present (FIXME Why do we do this?)+ let protoBranch = error "Unknown protobranch accessed during graph generation"+ let label = ((protoBranch, currentBranch), branches, WasNotCut)+ modify $ \graph ->+ if gelem current graph+ then relabelNode (const label) current graph+ else insNode (current, label) graph+ -- Create nodes and edges to them+ forM_ (zip protoBranches branches) $ \x@(_,(pathOfTarget,_,_))-> do+ let new = hash pathOfTarget+ modify $ insNode (new, (x, [], WasNotCut))+ modify $ insEdge (current, new, x) markSolution usf = do- let current = hash (usf,[])- modifyLabel current (colorize Green)+ return () markCutBranches stackPrefix = do- forM_ stackPrefix $ \(u_,gs_,alts_) -> do- forM_ alts_ $ \x -> do- let child = hash x- modifyLabel child (colorize Gray)+ forM_ stackPrefix $ \((path_,u_,gs_),alts_) -> do+ forM_ alts_ $ \(pathOfChild,_,_) -> do+ let child = hash pathOfChild+ modifyLabel child $ \(t,b,_) -> (t,b,WasCut) +data CutFlag = WasNotCut | WasCut -ensureNode node label =- modify $ \graph ->- if Graph.gelem node graph- then graph- else Graph.insNode (node, label) graph -makeNodeLabel _ [] = [htmlStr "[]"]-makeNodeLabel _ gs = [htmlStr $ intercalate "," $ map show gs] -makeEdgeLabel [] _ = [HtmlFont [HtmlPointSize 8] [htmlStr "{}"]]-makeEdgeLabel u _ = [HtmlFont [HtmlPointSize 8] $ intersperse (HtmlNewline []) [htmlStr $ show v ++ " = " ++ show t | (v,t) <- u]]+formatNode :: NodeLabel -> [Data.GraphViz.Attributes.Complete.Attribute]+formatNode ((_,(_,u',[])), _, WasNotCut) = -- Success+ Shape BoxShape :+ case filterOriginal u' of+ [] -> [ toLabel ("" :: String)+ , Data.GraphViz.Attributes.Complete.Width 0.2+ , Regular True+ , Data.GraphViz.Attributes.Complete.Color [(WC (X11Color Green) Nothing)]+ ]+ uf -> [ toLabel $ colorize Green $ htmlUnifier uf+ , Data.GraphViz.Attributes.Complete.Color [(WC (X11Color Green) Nothing)]+ ]+formatNode ((_,(_,_,gs')), [], WasNotCut) = -- Failure+ [ toLabel $ colorize Red [htmlGoals gs'] + , Data.GraphViz.Attributes.Complete.Color [(WC (X11Color Red) Nothing)]+ ]+formatNode ((_,(_,_,gs')), _, WasNotCut) =+ [ toLabel [htmlGoals gs'] ]+formatNode ((_,(_,u',[])), _, WasCut) = -- Cut with Succees+ Shape BoxShape :+ case filterOriginal u' of+ [] -> [ toLabel ("" :: String)+ , Data.GraphViz.Attributes.Complete.Width 0.2+ , Regular True+ , Data.GraphViz.Attributes.Complete.Color [(WC (X11Color Gray) Nothing)]+ ]+ uf -> [ toLabel $ colorize Gray $ htmlUnifier uf+ , Data.GraphViz.Attributes.Complete.Color [(WC (X11Color Gray) Nothing)]+ ]+formatNode ((_,(_,_,gs')), _, WasCut) = -- Cut+ [ toLabel $ colorize Gray [htmlGoals gs']+ , Data.GraphViz.Attributes.Complete.Color [(WC (X11Color Gray) Nothing)]+ ] -modifyLabel node f = do- modify $ Graph.gmap $ \cxt@(in_,node',label,out) ->- if node == node'- then (in_, node', f label, out)- else cxt -colorize color label = [HtmlFont [HtmlColor (X11Color color)] label]+formatEdge :: EdgeLabel -> [Data.GraphViz.Attributes.Complete.Attribute]+formatEdge ((_,u ,_),_) =+ [ toLabel [Font [PointSize 8] $ htmlUnifier $ simplify u] ] -connect current u gs = do- let new = hash (u, gs)- modify $ Graph.insNode (new, makeNodeLabel u gs)- modify $ Graph.insEdge (current, new, makeEdgeLabel u gs)+simplify = ([] +++) +htmlGoals = htmlStr . intercalate "," . map show++htmlUnifier [] = [htmlStr " "]+htmlUnifier u = intersperse (Newline []) [ htmlStr $ show v ++ " = " ++ show t | (v,t) <- u ]++modifyLabel node f =+ modify $ relabelNode f node++colorize color label = [Font [Data.GraphViz.Attributes.HTML.Color (X11Color color)] label]++hash :: Path -> Int+-- TODO This is a complicated way to hash a list of integers.+-- Also, a unique hash value would be nice to avoid collisions. hash = fromEnum . hashString . show++filterOriginal = filter $ \(VariableName n _, _) -> n == 0++hashString = fromIntegral . foldr f 0+ where f c m = ord c + (m * 128) `rem` 1500007
prolog-graph-lib.cabal view
@@ -1,26 +1,25 @@ Name: prolog-graph-lib-Version: 0.1+Version: 0.2.1.1 Synopsis: Generating images of resolution trees for Prolog queries. Description: This is the library part (See <http://hackage.haskell.org/package/prolog-graph> for the command line tool). License: PublicDomain Author: Matthias Bartsch-Maintainer: bartsch@cs.uni-bonn.de-Homepage: https://github.com/Erdwolf/prolog+Maintainer: Marcel Fourné (haskell@marcelfourne.de) Category: Language Build-type: Simple Cabal-version: >=1.6 -Source-repository head- type: git- location: git://github.com/Erdwolf/prolog.git- Library Exposed-Modules: Language.Prolog.GraphViz Other-Modules: GraphViz Build-depends:- prolog == 0.1.*,+ prolog >= 0.2.1, base >=4 && <5, fgl >= 5.4.2.4, mtl >= 2.0.1.0, text >= 0.11.1.5, graphviz >= 2999.12.0.3++source-repository head+ type: git+ location: https://github.com/mfourne/prolog-graph-lib